File Coverage

blib/lib/Perinci/Object/Metadata.pm

Criterion	Covered	Total	%
statement	78	79	98.7
branch	22	24	91.6
condition	21	23	91.3
subroutine	12	13	92.3
pod	9	9	100.0
total	142	148	95.9

package Perinci::Object::Metadata;

our $DATE = '2017-02-03'; # DATE
our $VERSION = '0.30'; # VERSION

use 5.010;
use strict;
use warnings;

# BEGIN COPY-PASTE FROM String::Trim::More
sub __trim_blank_lines {
    local $_ = shift;
    return $_ unless defined;
    s/\A(?:\n\s*)+//;
    s/(?:\n\s*){2,}\z/\n/;
    $_;
}
# END COPY-PASTE

sub new {
    my ($class, $meta) = @_;
    $meta //= {};
    my $obj = \$meta;
    bless $obj, $class;
}

sub v {
    my $self = shift;
    ${$self}->{v} // 1.0;
}

sub type {
    die "BUG: type() must be subclassed";
}

sub as_struct {
    my $self = shift;
    ${$self};
}

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

    my $deflang = ${$self}->{default_lang} // "en_US";
    my $olang   = $opts->{lang} || $ENV{LANGUAGE} || $ENV{LANG} || $deflang;
    $olang =~ s/\W.+//; # change "en_US.UTF-8" to "en_US"
    $olang = "en_US" if $olang eq 'C';
    (my $olang2 = $olang) =~ s/\A([a-z]{2})_[A-Z]{2}\z/$1/; # change "en_US" to "en"
    my $mark    = $opts->{mark_different_lang} // 1;
    #print "deflang=$deflang, olang=$olang, mark_different_lang=$mark\n";

    my @k;
    if ($olang eq $deflang) {
        @k = ([$olang, $prop, 0]);
    } else {
        @k = (
            [$olang, "$prop.alt.lang.$olang", 0],
            ([$olang2, "$prop.alt.lang.$olang2", 0]) x !!($olang2 ne $olang),
            [$deflang, $prop, $mark],
        );
    }

    my $v;
  GET:
    for my $k (@k) {
        #print "k=".join(", ", @$k)."\n";
        $v = ${$self}->{$k->[1]};
        if (defined $v) {
            if ($k->[2]) {
                my $has_nl = $v =~ s/\n\z//;
                $v = "{$olang|$k->[0] $v}" . ($has_nl ? "\n" : "");
            }
            $v = __trim_blank_lines($v);
            last GET;
        }
    }

    if (@_) {
        # set value
        ${$self}->{$k[0][1]} = $_[0];
    }

    $v;
}

sub name {
    my $self = shift;
    my $opts;
    if (@_ && ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    $self->langprop($opts, "name", @_);
}

sub caption {
    my $self = shift;
    my $opts;
    if (@_ && ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    $self->langprop($opts, "caption", @_);
}

sub summary {
    my $self = shift;
    my $opts;
    if (@_ && ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    $self->langprop($opts, "summary", @_);
}

sub description {
    my $self = shift;
    my $opts;
    if (@_ && ref($_[0]) eq 'HASH') {
        $opts = shift;
    } else {
        $opts = {};
    }
    $self->langprop($opts, "description", @_);
}

1;
# ABSTRACT: Base class for Perinci::Object metadata classes

__END__