File Coverage

blib/lib/Hash/DefHash.pm

Criterion	Covered	Total	%
statement	202	221	91.4
branch	107	130	82.3
condition	49	69	71.0
subroutine	29	37	78.3
pod	31	31	100.0
total	418	488	85.6

## no critic: Modules::ProhibitAutomaticExportation

package Hash::DefHash;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-01-04'; # DATE
our $DIST = 'Hash-DefHash'; # DIST
our $VERSION = '0.071'; # VERSION

use 5.010001;
use strict;
use warnings;

use Scalar::Util qw(blessed);
use String::Trim::More qw(trim_blank_lines);

use Exporter qw(import);
our @EXPORT = qw(defhash);

our $re_prop = qr/\A[A-Za-z_][A-Za-z0-9_]*\z/;
our $re_attr = qr/\A[A-Za-z_][A-Za-z0-9_]*(?:\.[A-Za-z_][A-Za-z0-9_]*)*\z/;
our $re_key  = qr/
    \A(?:
        # 1 = property
        ([A-Za-z_][A-Za-z0-9_]*)
        (?:
            (?:
                # 2 = attr
                \. ([A-Za-z_][A-Za-z0-9_]*(?:\.[A-Za-z_][A-Za-z0-9_]*)*)
            ) |
            (?:
                # 3 = (LANG) shortcut
                \(([A-Za-z]{2}(?:_[A-Za-z]{2})?)\)
            )
        )?
    |
        # 4 = attr without property
        \.([A-Za-z_][A-Za-z0-9_]*(?:\.[A-Za-z_][A-Za-z0-9_]*)*)
    )\z/x;

sub defhash {
    # avoid wrapping twice if already a defhash
    return $_[0] if blessed($_[0]) && $_[0]->isa(__PACKAGE__);

    __PACKAGE__->new(@_);
}

sub new {
    my $class = shift;

    my ($hash, %opts) = @_;
    $hash //= {};

    my $self = bless {hash=>$hash, parent=>$opts{parent}}, $class;
    if ($opts{check} // 1) {
        $self->check;
    }
    $self;
}

sub hash {
    my $self = shift;

    $self->{hash};
}

sub check {
    my $self = shift;
    my $h = $self->{hash};

    for my $k (keys %$h) {
        next if $k =~ $re_key;
        die "Invalid hash key '$k'";
    }
    1;
}

sub contents {
    my $self = shift;
    my $h = $self->{hash};

    my %props;
    for my $k (keys %$h) {
        my ($p_prop, $p_attr, $p_lang, $p_attr_wo_prop) = $k =~ $re_key
            or die "Invalid hash key '$k'";
        my $v = $h->{$k};
        if (defined $p_prop) {
            next if $p_prop =~ /\A_/;
            $props{$p_prop} //= {};
            if (defined $p_attr) {
                next if $p_attr =~ /(?:\A|\.)_/;
                $props{$p_prop}{$p_attr} = $v;
            } elsif (defined $p_lang) {
                $props{$p_prop}{"alt.lang.$p_lang"} = $v;
            } else {
                $props{$p_prop}{""} = $v;
            }
        } else {
            next if $p_attr_wo_prop =~ /(?:\A|\.)_/;
            $props{""} //= {};
            $props{""}{$p_attr_wo_prop} = $v;
        }
    }
    %props;
}

sub props {
    my $self = shift;
    my $h = $self->{hash};

    my %props;
    for my $k (keys %$h) {
        my ($p_prop, $p_attr, $p_lang, $p_attr_wo_prop) = $k =~ $re_key
            or die "Invalid hash key '$k'";
        next if defined $p_attr || $p_lang || defined $p_attr_wo_prop;
        next if $p_prop =~ /\A_/;
        $props{$p_prop}++;
    }
    sort keys %props;
}

sub prop {
    my ($self, $prop) = @_;
    my $h = $self->{hash};

    die "Property '$prop' not found" unless exists $h->{$prop};
    $h->{$prop};
}

sub get_prop {
    my ($self, $prop) = @_;
    my $h = $self->{hash};

    $h->{$prop};
}

sub prop_exists {
    my ($self, $prop) = @_;
    my $h = $self->{hash};

    exists $h->{$prop};
}

sub add_prop {
    my ($self, $prop, $val) = @_;
    my $h = $self->{hash};

    die "Invalid property name '$prop'" unless $prop =~ $re_prop;
    die "Property '$prop' already exists" if exists $h->{$prop};
    $h->{$prop} = $val;
}

sub set_prop {
    my ($self, $prop, $val) = @_;
    my $h = $self->{hash};

    die "Invalid property name '$prop'" unless $prop =~ $re_prop;
    if (exists $h->{$prop}) {
        my $old = $h->{$prop};
        $h->{$prop} = $val;
        return $old;
    } else {
        $h->{$prop} = $val;
        return undef;
    }
}

sub del_prop {
    my ($self, $prop, $val) = @_;
    my $h = $self->{hash};

    die "Invalid property name '$prop'" unless $prop =~ $re_prop;
    if (exists $h->{$prop}) {
        return delete $h->{$prop};
    } else {
        return undef;
    }
}

sub del_all_props {
    my ($self, $delattrs) = @_;
    my $h = $self->{hash};

    for my $k (keys %$h) {
        my ($p_prop, $p_attr, $p_lang, $p_attr_wo_prop) = $k =~ $re_key
            or die "Invalid hash key '$k'";
        next if defined $p_prop && $p_prop =~ /\A_/;
        next if defined $p_attr && $p_attr =~ /(?:\A|\.)_/;
        next if defined $p_attr_wo_prop && $p_attr_wo_prop =~ /(?:\A|\.)_/;
        if (defined $p_attr || defined $p_lang || defined $p_attr_wo_prop) {
            delete $h->{$k} if $delattrs;
        } else {
            delete $h->{$k};
        }
    }
}

sub attrs {
    my ($self, $prop) = @_;
    $prop //= "";
    my $h = $self->{hash};

    unless ($prop eq '') {
        die "Invalid property name '$prop'" unless $prop =~ $re_prop;
    }

    my %attrs;
    for my $k (keys %$h) {
        my ($p_prop, $p_attr, $p_lang, $p_attr_wo_prop) = $k =~ $re_key
            or die "Invalid hash key '$k'";
        $p_prop //= '';
        my $v = $h->{$k};
        if (defined $p_attr) {
            next unless $prop eq $p_prop;
            next if $p_attr =~ /(?:\A|\.)_/;
            $attrs{$p_attr} = $v;
        } elsif (defined $p_lang) {
            next unless $prop eq $p_prop;
            $attrs{"alt.lang.$p_lang"} = $v;
        } elsif (defined $p_attr_wo_prop) {
            next unless $prop eq '';
            next if $p_attr_wo_prop =~ /(?:\A|\.)_/;
            $attrs{$p_attr_wo_prop} = $v;
        }
    }
    %attrs;
}

sub attr {
    my ($self, $prop, $attr) = @_;
    $prop //= "";
    my $h = $self->{hash};

    my $k = "$prop.$attr";
    die "Attribute '$attr' for property '$prop' not found" if !exists($h->{$k});
    $h->{$k};
}

sub get_attr {
    my ($self, $prop, $attr) = @_;
    $prop //= "";
    my $h = $self->{hash};

    my $k = "$prop.$attr";
    $h->{$k};
}

sub attr_exists {
    my ($self, $prop, $attr) = @_;
    $prop //= "";
    my $h = $self->{hash};

    my $k = "$prop.$attr";
    exists $h->{$k};
}

sub add_attr {
    my ($self, $prop, $attr, $val) = @_;
    $prop //= "";
    my $h = $self->{hash};

    if ($prop ne '') {
        die "Invalid property name '$prop'"  unless $prop =~ $re_prop;
    }
    die "Invalid attribute name '$attr'" unless $attr =~ $re_attr;
    my $k = "$prop.$attr";
    die "Attribute '$attr' for property '$prop' already exists"
        if exists($h->{$k});
    $h->{$k} = $val;
}

sub set_attr {
    my ($self, $prop, $attr, $val) = @_;
    $prop //= "";
    my $h = $self->{hash};

    if ($prop ne '') {
        die "Invalid property name '$prop'"  unless $prop =~ $re_prop;
    }
    die "Invalid attribute name '$attr'" unless $attr =~ $re_attr;
    my $k = "$prop.$attr";
    if (exists($h->{$k})) {
        my $old = $h->{$k};
        $h->{$k} = $val;
        return $old;
    } else {
        $h->{$k} = $val;
        return undef;
    }
}

sub del_attr {
    my ($self, $prop, $attr) = @_;
    $prop //= "";
    my $h = $self->{hash};

    if ($prop ne '') {
        die "Invalid property name '$prop'"  unless $prop =~ $re_prop;
    }
    die "Invalid attribute name '$attr'" unless $attr =~ $re_attr;
    my $k = "$prop.$attr";
    if (exists($h->{$k})) {
        return delete $h->{$k};
    } else {
        return undef;
    }
}

sub del_all_attrs {
    my ($self, $prop) = @_;
    $prop //= "";
    my $h = $self->{hash};

    for my $k (keys %$h) {
        my ($p_prop, $p_attr, $p_lang, $p_attr_wo_prop) = $k =~ $re_key
            or die "Invalid hash key '$k'";
        if (defined $p_attr) {
            next unless $prop eq $p_prop;
            next if $p_attr =~ /(?:\A|\.)_/;
        } elsif ($p_lang) {
            next unless $prop eq $p_prop;
        } elsif (defined $p_attr_wo_prop) {
            next unless $prop eq '';
            next if $p_attr_wo_prop =~ /(?:\A|\.)_/;
        } else {
            next;
        }
        delete $h->{$k};
    }
}

sub defhash_v {
    my ($self) = @_;
    $self->get_prop('defhash_v') // 1;
}

sub v {
    my ($self) = @_;
    $self->get_prop('v') // 1;
}

sub default_lang {
    my ($self) = @_;
    my $par;
    if ($self->{parent}) {
        $par = $self->{parent}->default_lang;
    }
    my $res = $self->get_prop('default_lang') // $par // $ENV{LANG} // "en_US";
    $res = "en_US" if $res eq "C";
    $res;
}

sub name {
    my ($self) = @_;
    $self->get_prop('name');
}

sub summary {
    my ($self) = @_;
    $self->get_prop('summary');
}

sub description {
    my ($self) = @_;
    $self->get_prop('description');
}

sub tags {
    my ($self) = @_;
    $self->get_prop('tags');
}

sub get_prop_lang {
    my ($self, $prop, $lang, $opts) = @_;
    my $h = $self->{hash};
    $opts //= {};

    my $deflang = $self->default_lang;
    $lang     //= $deflang;
    my $mark    = $opts->{mark_different_lang} // 1;
    #print "deflang=$deflang, lang=$lang, mark_different_lang=$mark\n";

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

    for my $k (@k) {
        #print "k=".join(", ", @$k)."\n";
        my $v = $h->{$k->[1]};
        if (defined $v) {
            if ($k->[2]) {
                my $has_nl = $v =~ s/\R\z//;
                $v = "{$k->[0] $v}" . ($has_nl ? "\n" : "");
            }
            return trim_blank_lines($v);
        }
    }
    return undef;
}

sub get_prop_all_langs {
    die "Not yet implemented";
}

sub set_prop_lang {
    die "Not yet implemented";
}

1;
# ABSTRACT: Manipulate defhash

__END__