File Coverage

blib/lib/Pandoc/Metadata.pm

Criterion	Covered	Total	%
statement	107	112	95.5
branch	39	44	88.6
condition	20	33	60.6
subroutine	24	25	96.0
pod			n/a
total	190	214	88.7

package Pandoc::Metadata;
use strict;
use warnings;
use 5.010001;

use Pandoc::Elements;
use Scalar::Util qw(blessed reftype);
use JSON::PP;
use Carp;
# # For Pandoc::Metadata::Error
# use Carp qw(shortmess longmess);

# packages and methods

{
    # key-value map of metadata fields
    package Pandoc::Document::Metadata;

    {
        no warnings 'once';
        *to_json = \&Pandoc::Document::Element::to_json;
    }

    sub TO_JSON {
        return { %{ $_[0] } }
    }

    sub value {
        my $map = { c => shift };
        Pandoc::Document::MetaMap::value( $map, @_ )
    }
}

{
    # metadata element parent class
    package Pandoc::Document::Meta;
    our @ISA = ('Pandoc::Document::Element');
    sub is_meta { 1 }
    sub value { shift->value(@_) }
}

# # For Pandoc::Metadata::Error
# {
#     package Pandoc::Metadata::Error;
#     use overload q[""] => 'shortmess', q[%{}] => 'data', fallback => 1;
#     use constant { SHORTMESS => 0, LONGMESS => 1, DATA => 2 };
#     sub new {
#         my($class, @values) = @_;   # CLASS, (MESSAGE, {DATA})
#         bless \@values => $class;
#     }
#     sub shortmess { shift->[SHORTMESS] }
#     sub longmess { shift->[LONGMESS] }
#     sub data { shift->[DATA] }
#     sub rethrow { die shift }
#     sub throw { shift->new( @_ )->rethrow }
# }

# helpers

my @token_keys = qw(last_pointer ref_token plain_key key empty pointer);

sub _pointer_token {
    state $valid_pointer_re = qr{\A (?: [^/] .* | (?: / [^/]* )* ) \z}msx;
    state $token_re = qr{
        \A
        (?<_last_pointer>
            (?<_ref_token>
                (?<_plain_key>
                    (?<_key> [^/] .* \z )    # plain "key"
                )
            |   / (?<_key> [^/]* ) # "/key"
            |     (?<_empty> \z )  # "" -- return current element
            )
            (?<_pointer> / .* \z | )
        )
        \z
    }msx;
    # set non-participating keys to undef
    state $defaults = { map {; "_$_" => undef } @token_keys };
    my %opts = @_;
    $opts{_pointer} //= $opts{_full_pointer} //= $opts{pointer} //= "";
    $opts{_pointer} =~ $valid_pointer_re // _bad_pointer( %opts, _error => 'pointer' );
    $opts{_pointer} =~ $token_re; # guaranteed to match since validation matched!
    my %match = %+;
    unless ( grep { defined $_ } @match{qw(_plain_key _empty)} ) {
        $match{_key} =~ s!\~1!/!g;
        $match{_key} =~ s!\~0!~!g;
    }
    return (%opts, %$defaults, %match);
}

sub _bad_pointer {
    state $params_for = do {
        my %params_map = (
            default => {
                msg     => 'Invalid or unknown pointer reference "%s"',
                in      => 1,
                _keys    => ['_ref_token'],
                pointer => '_last_pointer'
            },
            pointer => { msg => 'Invalid', in => 0, _keys => [], pointer => '_last_pointer', },
            container => { msg => 'No list or mapping "%s"', },
            key       => { msg => 'Node "%s" doesn\'t correspond to any key', },
            range => { msg => 'List index %s out of range', _keys => ['_key'], },
            index => { msg => 'Node "%s" not a valid list index', },
        );
        for my $key ( keys %params_map ) {
            for my $params ( $params_map{$key} ) {
                $params = { %{ $params_map{default} }, %$params };
                $params->{msg} .= ( $params->{in} ? q[ in] : "" );
                $params->{keys}
                  = [ @{ $params->{_keys} }, $params->{pointer}, '_full_pointer' ];
            }
        }
        \%params_map;
    };
    # # For Pandoc::Metadata::Error
    # state $data_keys = {
    #     ( map { ; $_ => $_ } qw[element strict boolean] ),
    #     ( map { ; $_ => "_$_" } @token_keys, qw[error] ),
    #     ( pointer => '_full_pointer', next_pointer => '_pointer' ),
    # };
    my ( %opts ) = @_;
    return undef unless $opts{strict};
    $opts{_error} //= 'default';
    my $params = $params_for->{ $opts{_error} };
    if ( $opts{_error} eq 'container' ) {
        %opts = _pointer_token( %opts );
    }
    my $msg = sprintf $params->{msg} . q[ (sub)pointer "%s" in pointer "%s"], @opts{ @{ $params->{keys} } };
    # # For Pandoc::Metadata::Error
    # my %data;
    # @data{ keys %$data_keys } = @opts{ values %$data_keys };
    # Pandoc::Metadata::Error->throw( shortmess($msg), longmess($msg), \%data );
    croak $msg;
}

# methods

sub _value_args {
    my $content = shift->{c};
    my ($pointer, %opts) = @_ % 2 ? @_ : (undef, @_);

    $opts{_pointer} = $pointer // $opts{_pointer} // $opts{pointer} // '';
    $opts{_full_pointer} //= $opts{_pointer};

    return ($content, %opts);
}

sub Pandoc::Document::MetaString::value {
    my ($content, %opts) = _value_args(@_);

    if ($opts{_pointer} ne '') {
        _bad_pointer(%opts, _error => 'container');
    } else {
        $content;
    }
}

sub Pandoc::Document::MetaBool::set_content {
    $_[0]->{c} = $_[1] && $_[1] ne 'false' && $_[1] ne 'FALSE' ? 1 : 0;
}

sub Pandoc::Document::MetaBool::TO_JSON {
    return {
        t => 'MetaBool',
        c => $_[0]->{c} ? JSON::true() : JSON::false(),
    };
}

sub Pandoc::Document::MetaBool::value {
    my ($content, %opts) = _value_args(@_);

    if ($opts{_pointer} ne '') {
        _bad_pointer(%opts, _error => 'container');
    } elsif (($opts{boolean} // '') eq 'JSON::PP') {
        $content ? JSON::true() : JSON::false();
    } else {
        $content ? 1 : 0;
    }
}

sub Pandoc::Document::MetaMap::value {
    my ($map, %opts) = _value_args(@_);
    %opts = _pointer_token(%opts);

    if (defined $opts{_empty}) {
        return { map { $_ => $map->{$_}->value(%opts) } keys %$map };
    } elsif (exists($map->{$opts{_key}})) {
        return $map->{$opts{_key}}->value(%opts);
    } else {
        _bad_pointer( %opts, _error => 'key');
    }
}

sub Pandoc::Document::MetaList::value {
    my ($content, %opts) = _value_args(@_);
    %opts = _pointer_token(%opts);
    if ( defined $opts{_empty} ) {
        return [ map { $_->value(%opts) } @$content ]
    } elsif ($opts{_key} =~ /^[1-9][0-9]*$|^0$/) {
        if ( $opts{_key} > $#$content ) {
            return _bad_pointer( %opts, _error => 'range' );
        }
        my $value = $content->[$opts{_key}];
        return defined($value) ? $value->value(%opts) : undef;
    } else {
        return _bad_pointer( %opts, _error => 'index' );
    }
}

sub Pandoc::Document::MetaInlines::value {
    my ($content, %opts) = _value_args(@_);

    if ($opts{_pointer} ne '') {
        _bad_pointer(%opts, _error => 'container');
    } elsif ($opts{element} // '' eq 'keep') {
        $content;
    } else {
        join '', map { $_->string } @$content;
    }
}

sub Pandoc::Document::MetaBlocks::string {
    join "\n\n", map { $_->string } @{$_[0]->content};
}

sub Pandoc::Document::MetaBlocks::value {
    my ($content, %opts) = _value_args(@_);

    if ($opts{_pointer} ne '') {
        _bad_pointer(%opts);
    } elsif ($opts{element} // '' eq 'keep') {
        $content;
    } else {
        $_[0]->string;
    }
}

1;
__END__