File Coverage

blib/lib/Config/IOD/Document.pm

Criterion	Covered	Total	%
statement	405	454	89.2
branch	224	274	81.7
condition	41	63	65.0
subroutine	33	40	82.5
pod	17	17	100.0
total	720	848	84.9

package Config::IOD::Document;

our $DATE = '2021-06-21'; # DATE
our $VERSION = '0.351'; # VERSION

use 5.010;
use strict;
use warnings;
#use Carp; # avoided to shave a bit of startup time

use Config::IOD::Constants qw(:ALL);

sub new {
    my ($class, %attrs) = @_;

    if (!$attrs{_parsed}) {
        $attrs{_parsed} = [];
    }
    if (!$attrs{_parser}) {
        require Config::IOD;
        $attrs{_parser} = Config::IOD->new;
    }

    bless \%attrs, $class;
}

sub empty {
    my $self = shift;
    $self->_discard_cache;
    $self->{_parsed} = [];
}

# all _validate_*() methods return ($err_msg, $validated_val)

sub _validate_section {
    my ($self, $name) = @_;
    $name =~ s/\A\s+//;
    $name =~ s/\s+\z//;
    if (!length($name)) { return ("Section name must be non-zero string") }
    if ($name =~ /\R|\]/) { return ("Section name must not contain ] or newline") }
    return ("", $name);
}

sub _validate_key {
    my ($self, $name) = @_;
    $name =~ s/\A\s+//;
    $name =~ s/\s+\z//;
    if (!length($name)) { return ("Key name must be non-zero string") }
    if ($name =~ /\R|=/) { return ("Key name must not contain = or newline") }
    if ($name =~ /\A(?:;|#|\[)/) { return ("Key name must not start with ;, #, [") }
    return ("", $name);
}

sub _validate_value {
    my ($self, $value) = @_;
    $value =~ s/\s+\z//;
    if ($value =~ /\R/) { return ("Value must not contain newline") }
    return ("", $value);
}

sub _validate_comment {
    my ($self, $comment) = @_;
    if ($comment =~ /\R/) { return ("Comment must not contain newline") }
    return ("", $comment);
}

sub _validate_linum {
    my ($self, $value) = @_;
    if ($value < 1) { return ("linum must be at least 1") }
    if ($value > @{$self->{_parsed}}) { return ("linum must not be larger than number of document's lines") }
    return ("", $value);
}

sub _blank_line {
    ["B", "\n"];
}

# cache is used for get_value() and get_raw_value() to avoid re-scanning the
# files on every invocation. but whenever one of document-modifying methods is
# called, we discard the cache
sub _discard_cache {
    my $self = shift;
    delete $self->{_dump_cache};
}

sub dump {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my $parser = $self->{_parser};

    my $linum = 0;
    my $merge;
    my $cur_section = $parser->{default_section};
    my $res = {};
    my $arrayified = {};
    my $num_seen_section_lines = 0;

    my $_merge = sub {
        return if $cur_section eq $merge;
        die "IOD document:$linum: Can't merge section '$merge' to ".
            "'$cur_section': Section '$merge' not seen yet"
                unless exists $res->{$merge};
        for my $k (keys %{ $res->{$merge} }) {
            $res->{$cur_section}{$k} //= $res->{$merge}{$k};
        }
    };

    # TMP HACK. for _decode_expr, this is currently rather hackish because
    # Config::IOD::Base expects some state in $parser
    local $parser->{_res} = $res if $parser->{enable_expr};
    local $parser->{_cur_section} = $cur_section if $parser->{enable_expr};

    for my $line (@{ $self->{_parsed} }) {
        $linum++;
        next if defined($opts->{linum_start}) && $linum < $opts->{linum_start};
        next if defined($opts->{linum_end}  ) && $linum > $opts->{linum_end};

        my $type = $line->[COL_TYPE];
        if ($type eq 'D') {
            my $directive = $line->[COL_D_DIRECTIVE];
            if ($directive eq 'merge') {
                my $args = $parser->_parse_command_line(
                    $line->[COL_D_ARGS_RAW]);
                if (!defined($args)) {
                    die "IOD document:$linum: Invalid arguments syntax '".
                        $line->[COL_D_ARGS_RAW]."'";
                }
                $merge = @$args ? $args->[0] : undef;
            } # ignore the other directives
        } elsif ($type eq 'S') {
            $num_seen_section_lines++;
            # merge previous section
            $_merge->() if defined($merge) && $num_seen_section_lines > 1;
            $cur_section = $line->[COL_S_SECTION];
            $parser->{_cur_section} = $cur_section if $parser->{enable_expr}; #TMP HACK
            $res->{$cur_section} //= {};
        } elsif ($type eq 'K') {
            # the common case is that value are not decoded or
            # quoted/bracketed/braced, so we avoid calling _parse_raw_value here
            # to avoid overhead
            my $key = $line->[COL_K_KEY];
            my $val = $line->[COL_K_VALUE_RAW];
            if ($val =~ /\A["!\\[\{]/) {
                my ($err, $parse_res, $decoded_val) =
                    $parser->_parse_raw_value($val);
                die "IOD document:$linum: Invalid value: $err" if $err;
                $val = $decoded_val;
            } else {
                $val =~ s/\s*[#;].*//; # strip comment
            }

            if (exists $res->{$cur_section}{$key}) {
                if (!$parser->{allow_duplicate_key}) {
                    die "IOD document:$linum: Duplicate key: $key ".
                        "(section $cur_section)";
                } elsif ($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;
            }
        } # ignore the other line types
    }

    $_merge->() if defined($merge) && $num_seen_section_lines > 1;;

    $res;
}

sub each_key {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($code) = @_;

    my $parser = $self->{_parser};

    my $linum = 0;
    my $cur_section = $parser->{default_section};

    my $skip_section;
    my %seen_sections;
    my %seen_keys;
    for my $line (@{ $self->{_parsed} }) {
        $linum++;
        next if defined($opts->{linum_start}) && $linum < $opts->{linum_start};
        next if defined($opts->{linum_end}  ) && $linum > $opts->{linum_end};

        my $type = $line->[COL_TYPE];
        if ($type eq 'S') {
            $cur_section = $line->[COL_S_SECTION];
            %seen_keys = ();
            $skip_section = $opts->{unique_section} &&
                $seen_sections{$cur_section}++;
        } elsif ($type eq 'K') {
            next if $skip_section;
            my $key = $line->[COL_K_KEY];
            next if $opts->{unique_key} && $seen_keys{$key}++;
            my $res = $code->(
                $self,
                linum     => $linum,
                section   => $cur_section,
                key       => $key,
                raw_value => $line->[COL_K_VALUE_RAW],
            );
            return if $opts->{early_exit} && !$res;
        }
    }
}

sub get_value {
    my ($self, $section, $key) = @_;
    $self->{_dump_cache} = $self->dump unless $self->{_dump_cache};
    $self->{_dump_cache}{$section}{$key};
}

sub get_directive_before_key {
    my ($self, $section, $key) = @_;

    my $found;
    $self->each_key(
        sub {
            my ($self, %args) = @_;
            return if $found;
            return unless $args{linum} > 1;
            return unless $args{section} eq $section;
            return unless $args{key} eq $key;
            my $l = $self->{_parsed}[ $args{linum}-1-1 ];
            return unless $l->[COL_TYPE] eq 'D';
            my $p = $self->{_parser};
            $found = [
                $l->[COL_D_DIRECTIVE],
                @{ $p->_parse_command_line($l->[COL_D_ARGS_RAW]) // [] },
            ];
        },
    );
    $found;
}

sub list_keys {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($section) = @_;

    my @res;
    my %mem;
    $self->each_key(
        sub {
            my ($self, %args) = @_;
            return unless $args{section} eq $section;
            return if $opts->{unique} && $mem{$args{key}}++;
            push @res, $args{key};
        },
    );
    @res;
}

sub key_exists {
    my $self = shift;
    my ($section, $key) = @_;

    my $found;
    $self->each_key(
        {early_exit=>1},
        sub {
            my ($self, %args) = @_;
            return 1 unless $args{section} eq $section;
            return 1 unless $args{key} eq $key;
            $found++;
            return 0;
        },
    );
    $found;
}

sub _find_section {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($name) = @_;

    my @res;

    my $linum = 0;
    for my $line (@{ $self->{_parsed} }) {
        $linum++;
        next unless $line->[COL_TYPE] eq 'S';
        if (defined $name) {
            next unless $line->[COL_S_SECTION] eq $name;
        }
        return $linum unless $opts->{all};
        push @res, $linum;
    }
    return undef unless $opts->{all};
    return @res;
}

sub each_section {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($code) = @_;

    my $parsed = $self->{_parsed};
    my @linums = $self->_find_section({all=>1});
    my %seen;
    for my $linum (@linums) {
        my $section = $parsed->[$linum-1][COL_S_SECTION];
        next if $opts->{unique} && $seen{$section}++;

        my $linum_end = $linum;
        while (1) {
            last if $linum_end >= @$parsed;
            last if $parsed->[$linum_end][COL_TYPE] eq 'S';
            $linum_end++;
        }

        my $res = $code->(
            $self,
            linum       => $linum,
            linum_start => $linum,
            linum_end   => $linum_end,
            parsed      => $parsed->[$linum-1],
            section     => $section,
        );
        return if $opts->{early_exit} && !$res;
    }
}

sub list_sections {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my @res;
    $self->each_section(
        $opts,
        sub {
            my ($self, %args) = @_;
            push @res, $args{section};
        }
    );
    @res;
}

sub section_exists {
    my $self = shift;
    my ($section) = @_;

    my $found;
    $self->each_section(
        {early_exit=>1},
        sub {
            my ($self, %args) = @_;
            return 1 unless $args{section} eq $section;
            $found++;
            return 0;
        },
    );
    $found;
}

sub _get_section_line_range {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($name) = @_;

    my @res;

    my $linum = 0;
    my $cur_section = $self->{_parser}{default_section};
    my $prev_section;
    my $start;
    for my $line (@{ $self->{_parsed} }) {
        $linum++;
        if ($line->[COL_TYPE] eq 'S') {
            $cur_section = $line->[COL_S_SECTION];
            if ($cur_section eq $name) {
                $start = $linum+1;
                $res[-1][1] = $linum if @res && !defined $res[-1][1];
                push @res, [$start, undef];
            } else {
                $res[-1][1] = $linum if @res;
                last if @res && !$opts->{all};
            }
        }
    }
    $res[-1][1] = $linum+1 if @res && !defined($res[-1][1]);

  L1:
    if ($opts->{all}) { return @res } else { return $res[0] }
}

sub _find_key {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($section, $name) = @_;

    my @res;

    my $linum = 0;
    my $cur_section = $self->{_parser}{default_section};
    for my $line (@{ $self->{_parsed} }) {
        $linum++;
        if ($line->[COL_TYPE] eq 'S') {
            $cur_section = $line->[COL_S_SECTION];
            next;
        }
        next unless $line->[COL_TYPE] eq 'K';
        next unless $cur_section eq $section;
        next unless $line->[COL_K_KEY] eq $name;
        return $linum unless $opts->{all};
        push @res, $linum;
    }
    return undef unless $opts->{all};
    return @res;
}

sub _line_in_section {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    my ($asked_linum, $asked_section) = @_;

    my @res;

    my $linum = 0;
    my $cur_section = $self->{_parser}{default_section};
    for my $line (@{ $self->{_parsed} }) {
        $linum++;
        if ($linum == $asked_linum) {
            return $asked_section eq $cur_section;
        }
        if ($line->[COL_TYPE] eq 'S') {
            $cur_section = $line->[COL_S_SECTION];
        }
    }
    return 0;
}

sub insert_section {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my ($err, $name) = $self->_validate_section($_[0]);
    die $err if $err;

    my $p = $self->{_parsed};

    if (defined $opts->{comment}) {
        ($err, $opts->{comment}) = $self->_validate_comment($opts->{comment});
        die $err if $err;
    }

    if ($self->_find_section($name)) {
        if ($opts->{ignore}) {
            return undef;
        } else {
            die "Can't insert section '$name': already exists";
        }
    }

    my $linum;
    if (defined $opts->{linum}) {
        ($err, $opts->{linum}) = $self->_validate_linum($opts->{linum});
        die $err if $err;
        $linum = $opts->{linum};
    } elsif ($opts->{top}) {
        $linum = $self->_find_section;
        $linum //= 1;
    } else {
        $linum = @$p + 1;
    }

    splice @$p, $linum-1, 0, [
        'S',
        '', # COL_S_WS1
        '', # COL_S_WS2
        $name, # COL_S_SECTION
        '', # COL_S_WS3
        defined($opts->{comment}) ? ' ' : undef, # COL_S_WS4
        defined($opts->{comment}) ? ';' : undef, # COL_S_COMMENT_CHAR
        $opts->{comment}, # COL_S_COMMENT
        "\n", # COL_S_NL
    ];

    $self->_discard_cache;
    $linum;
}

sub insert_key {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my $err;
    my ($err_section, $section) = $self->_validate_section($_[0]);
    die $err_section if $err_section;
    my ($err_name, $name)       = $self->_validate_key($_[1]);
    die $err_name if $err_name;
    my ($err_value, $value)     = $self->_validate_value($_[2]);
    die $err_value if $err_value;

    my $p = $self->{_parsed};

    my $linum;

    if ($opts->{replace}) {
        $self->delete_key({all=>1}, $section, $name);
    }

    # find section
    my $line_range = $self->_get_section_line_range($section);
    if (!$line_range) {
        if ($opts->{create_section}) {
            $linum = $self->insert_section($section) + 1;
            $line_range = [$linum, $linum];
        } else {
            die "Can't insert key '$name': unknown section '$section'";
        }
    }

    unless (defined $linum) {
        $linum = $self->_find_key($section, $name);
        if ($linum) {
            if ($opts->{ignore}) {
                return undef;
            } elsif ($opts->{add}) {
                #
            } elsif ($opts->{replace}) {
                # delete already done above
            } else {
                die "Can't insert key '$name': already exists";
            }
        }

        if ($opts->{linum}) {
            ($err, $opts->{linum}) = $self->_validate_linum($opts->{linum});
            die $err if $err;
            $self->_line_in_section($opts->{linum}, $section)
                or die "Invalid linum $opts->{linum}: not inside section '$section'";
            $linum = $opts->{linum};
        } else {
            if ($opts->{top}) {
                $linum = $line_range->[0];
            } else {
                $linum = $line_range->[1];
                if ($p->[$linum-1]) {
                    if ($p->[$linum-1][COL_TYPE] eq 'S') {
                    } else {
                        $linum++;
                    }
                }
            }
        }
    }

    #XXX implement option: replace

    splice @$p, $linum-1, 0, [
        'K',
        '', # COL_K_WS1
        $name, # COL_K_KEY
        '', # COL_K_WS2
        '', # COL_K_WS3
        $value, # COL_K_VALUE_RAW
        "\n", # COL_K_NL
    ];
    $self->_discard_cache;
    $linum;
}

sub delete_section {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my ($err, $section) = $self->_validate_section($_[0]);
    die $err if $err;

    my $p = $self->{_parsed};

    my @line_ranges;
    if ($opts->{all}) {
        @line_ranges = $self->_get_section_line_range({all=>1}, $section);
    } else {
        @line_ranges = ($self->_get_section_line_range($section));
        @line_ranges = () if !defined($line_ranges[0]);
    }

    if ($opts->{cond}) {
        @line_ranges = grep {
            $opts->{cond}->(
                $self,
                linum_start => $_->[0],
                linum_end   => $_->[1],
            );
        } @line_ranges;
    }

    my $num_deleted = 0;
    for my $line_range (reverse @line_ranges) {
        next unless defined $line_range;
        my $line1 = $line_range->[0] - 1; $line1 = 1 if $line1 < 1;
        my $line2 = $line_range->[1] - 1;
        splice @$p, $line1-1, ($line2-$line1+1);
        $num_deleted++;
    }
    $self->_discard_cache if $num_deleted;
    $num_deleted;
}

sub delete_key {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my ($err_section, $section) = $self->_validate_section($_[0]);
    die $err_section if $err_section;
    my ($err_name, $name) = $self->_validate_key($_[1]);
    die $err_name if $err_name;

    my $p = $self->{_parsed};

    my @linums;
    if ($opts->{all}) {
        @linums = $self->_find_key({all=>1}, $section, $name);
    } else {
        @linums = ($self->_find_key($section, $name));
        @linums = () if !defined($linums[0]);
    }

    if ($opts->{cond}) {
        @linums = grep {
            my $line = $self->{_parsed}[$_-1];
            $opts->{cond}->(
                $self,
                linum     => $_,
                parsed    => $line,
                key       => $line->[COL_K_KEY],
                raw_value => $line->[COL_K_VALUE_RAW],
                # XXX value
            );
        } @linums;
    }

    my $num_deleted = 0;
    for my $linum (reverse @linums) {
        splice @$p, $linum-1, 1;
        $num_deleted++;
    }

    $self->_discard_cache if $num_deleted;
    $num_deleted;
}

sub set_value {
    my $self = shift;
    my $opts;
    if (ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }

    my $section = $_[0];
    my $key     = $_[1];
    my ($err_value, $value) = $self->_validate_value($_[2]);
    die $err_value if $err_value;

    my $found;
    $self->each_key(
        sub {
            my ($self, %args) = @_;
            return if $found && !$opts->{all};
            return unless $args{section} eq $section;
            return unless $args{key} eq $key;
            $found++;
            my $l = $self->{_parsed}[ $args{linum}-1 ];
            $l->[COL_K_VALUE_RAW] = $value;
        },
    );
}

sub as_string {
    my $self = shift;

    my $abo = $self->{_parser}{allow_bang_only};

    my @str;
    my $linum = 0;
    for my $line (@{$self->{_parsed}}) {
        $linum++;
        my $type = $line->[COL_TYPE];
        if ($type eq 'B') {
            push @str, $line->[COL_B_RAW];
        } elsif ($type eq 'D') {
            push @str, join(
                "",
                ($abo ? $line->[COL_D_COMMENT_CHAR] : ";"),
                $line->[COL_D_WS1], "!",
                $line->[COL_D_WS2],
                $line->[COL_D_DIRECTIVE],
                $line->[COL_D_WS3],
                $line->[COL_D_ARGS_RAW],
                $line->[COL_D_NL],
            );
        } elsif ($type eq 'C') {
            push @str, join(
                "",
                $line->[COL_C_WS1],
                $line->[COL_C_COMMENT_CHAR],
                $line->[COL_C_COMMENT],
                $line->[COL_C_NL],
            );
        } elsif ($type eq 'S') {
            push @str, join(
                "",
                $line->[COL_S_WS1], "[",
                $line->[COL_S_WS2],
                $line->[COL_S_SECTION],
                $line->[COL_S_WS3], "]",
                $line->[COL_S_WS4] // '',
                $line->[COL_S_COMMENT_CHAR] // '',
                $line->[COL_S_COMMENT] // '',
                $line->[COL_S_NL],
            );
        } elsif ($type eq 'K') {
            push @str, join(
                "",
                $line->[COL_K_WS1],
                $line->[COL_K_KEY],
                $line->[COL_K_WS2], "=",
                $line->[COL_K_WS3],
                $line->[COL_K_VALUE_RAW],
                $line->[COL_K_NL],
            );
        } else {
            die "BUG: Unknown type '$type' in line $linum";
        }
    }

    join "", @str;
}

use overload '""' => \&as_string;

1;
# ABSTRACT: Represent IOD document

__END__