File Coverage

blib/lib/Data/Transmute.pm

Criterion	Covered	Total	%
statement	180	181	99.4
branch	143	150	95.3
condition	28	37	75.6
subroutine	25	25	100.0
pod	2	2	100.0
total	378	395	95.7

package Data::Transmute;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-02-13'; # DATE
our $DIST = 'Data-Transmute'; # DIST
our $VERSION = '0.039'; # VERSION

use 5.010001;
use strict 'subs', 'vars';
use warnings;
use Log::ger;

use Ref::Util qw(is_hashref is_arrayref is_plain_hashref is_plain_arrayref);
use Scalar::Util qw(refaddr);

use Exporter qw(import);
our @EXPORT_OK = qw(transmute_data reverse_rules);

sub _rule_create_hash_key {
    my %args = @_;

    my $data = $args{data};
    return unless ($args{transmute_object} // 1) ? is_hashref($data) : is_plain_hashref($data);

    my $name = $args{name};
    die "Rule create_hash_key: Please specify 'name'" unless defined $name;

    if (exists $data->{$name}) {
        return if $args{ignore};
        die "Rule create_hash_key: Key '$name' already exists" unless $args{replace};
    }
    die "Rule create_hash_key: Please specify 'value' or 'value_code'"
        unless exists $args{value} || $args{value_code};
    $data->{$name} = $args{value_code} ? $args{value_code}->($data->{$name}) : $args{value};
}

sub _rulereverse_create_hash_key {
    my %args = @_;
    die "Cannot generate reverse rule create_hash_key with value_code" if $args{value_code};
    die "Cannot generate reverse rule create_hash_key with ignore=1"   if $args{ignore};
    die "Cannot generate reverse rule create_hash_key with replace=1"  if $args{replace};
    [delete_hash_key => {name=>$args{name}, transmute_object=>$args{transmute_object}}];
}

sub _rule_rename_hash_key {
    my %args = @_;

    my $data = $args{data};
    return unless ($args{transmute_object} // 1) ? is_hashref($data) : is_plain_hashref($data);

    my $from = $args{from};
    die "Rule rename_hash_key: Please specify 'from'" unless defined $from;
    my $to   = $args{to};
    die "Rule rename_hash_key: Please specify 'to'" unless defined $to;

    # noop
    return if $from eq $to;

    if (!exists($data->{$from})) {
        die "Rule rename_hash_key: Can't rename '$from' -> '$to': Old key '$from' doesn't exist" unless $args{ignore_missing_from};
        return;
    }
    if (exists $data->{$to}) {
        return if $args{ignore_existing_target};
        die "Rule rename_hash_key: Can't rename '$from' -> '$to': Target key '$from' already exists" unless $args{replace};
    }
    $data->{$to} = delete $data->{$from};
}

sub _rulereverse_rename_hash_key {
    my %args = @_;
    die "Cannot generate reverse rule rename_hash_key with ignore_missing_from=1"     if $args{ignore_missing_from};
    die "Cannot generate reverse rule rename_hash_key with ignore_existing_target=1"  if $args{ignore_existing_target};
    die "Cannot generate reverse rule rename_hash_key with replace=1"                 if $args{replace};
    [rename_hash_key => {
        from=>$args{to}, to=>$args{from},
        transmute_object=>$args{transmute_object},
    }];
}

sub _rule_modify_hash_value {
    require Data::Cmp;

    my %args = @_;

    my $data = $args{data};
    return unless ($args{transmute_object} // 1) ? is_hashref($data) : is_plain_hashref($data);

    my $name = $args{name};
    die "Rule modify_hash_value: Please specify 'name' (key)" unless defined $name;
    my $from = $args{from};
    my $from_exists = exists $args{from};
    my $to   = $args{to};
    die "Rule rename_hash_key: Please specify 'to' or 'to_code'"
        unless exists $args{to} || $args{to_code};

    my $errprefix = "Rule modify_hash_value: Can't modify key '$name'".
        ($from_exists ? " from '".($from // '') : "").
        ($args{to_code} ? "' using to_code" : "' to '".($to // '')."'");

    unless (exists $data->{$name}) {
        die "$errprefix: key does not exist";
    }

    my $cur = $data->{$name};

    $to = $args{to_code}->($cur) if $args{to_code};

    if ($from_exists) {
        # noop
        return unless Data::Cmp::cmp_data($from, $to);

        if (Data::Cmp::cmp_data($cur, $from)) {
            die "$errprefix: current value is not '".($cur // '')."'";
        }
    }

    $data->{$name} = $to;
}

sub _rulereverse_modify_hash_value {
    my %args = @_;
    die "Cannot generate reverse rule modify_hash_value without from" unless exists $args{from};
    die "Cannot generate reverse rule modify_hash_value with to_code" if $args{to_code};
    [modify_hash_value => {
        name => $args{name}, from => $args{to}, to => $args{from},
        transmute_object=>$args{transmute_object},
    }];
}

sub _rule_delete_hash_key {
    my %args = @_;

    my $data = $args{data};
    return unless ($args{transmute_object} // 1) ? is_hashref($data) : is_plain_hashref($data);

    my $name = $args{name};
    die "Rule delete_hash_key: Please specify 'name'" unless defined $name;

    delete $data->{$name};
}

sub _rulereverse_delete_hash_key {
    die "Can't create reverse rule for delete_hash_key";
}

sub _rule_transmute_array_elems {
    my %args = @_;

    my $data = $args{data};
    return unless ($args{transmute_object} //1) ? is_arrayref($data) : is_plain_arrayref($data);

    die "Rule transmute_array_elems: Please specify 'rules' or 'rules_module'"
        unless defined($args{rules}) || defined($args{rules_module});

    my $idx = -1;
  ELEM:
    for my $el (@$data) {
        $idx++;
        if (defined $args{index_is}) {
            next ELEM unless $idx == $args{index_is};
        }
        if (defined $args{index_in}) {
            next ELEM unless grep { $idx == $_ } @{ $args{index_in} };
        }
        if (defined $args{index_match}) {
            next ELEM unless $idx =~ $args{index_match};
        }
        if (defined $args{index_filter}) {
            next ELEM unless $args{index_filter}->(index=>$idx, array=>$data, rules=>$args{rules});
        }
        $el = transmute_data(
            data => $el,
            (rules        => $args{rules})        x !!(exists $args{rules}),
            (rules_module => $args{rules_module}) x !!(exists $args{rules_module}),
        );
    }
    $data;
}

sub _rulereverse_transmute_array_elems {
    my %args = @_;

    [transmute_array_elems => {
        rules => reverse_rules(
            (rules        => $args{rules})        x !!(exists $args{rules}),
            (rules_module => $args{rules_module}) x !!(exists $args{rules_module}),
        ),
        (index_is     => $args{index_is})     x !!(exists $args{index_is}),
        (index_in     => $args{index_in})     x !!(exists $args{index_in}),
        (index_match  => $args{index_match})  x !!(exists $args{index_match}),
        (index_filter => $args{index_filter}) x !!(exists $args{index_filter}),
        transmute_object=>$args{transmute_object},
    }];
}

sub _rule_transmute_hash_values {
    my %args = @_;

    my $data = $args{data};
    return unless ($args{transmute_object} //1) ? is_hashref($data) : is_plain_hashref($data);

    die "Rule transmute_hash_values: Please specify 'rules' or 'rules_module'"
        unless defined($args{rules}) || defined($args{rules_module});

  KEY:
    for my $key (keys %$data) {
        if (defined $args{key_is}) {
            next KEY unless $key eq $args{key_is};
        }
        if (defined $args{key_in}) {
            next KEY unless grep { $key eq $_ } @{ $args{key_in} };
        }
        if (defined $args{key_match}) {
            next KEY unless $key =~ $args{key_match};
        }
        if (defined $args{key_filter}) {
            next KEY unless $args{key_filter}->(key=>$key, hash=>$data, rules=>$args{rules});
        }
        $data->{$key} = transmute_data(
            data => $data->{$key},
            (rules        => $args{rules})        x !!(exists $args{rules}),
            (rules_module => $args{rules_module}) x !!(exists $args{rules_module}),
        );
    }
    $data;
}

sub _rulereverse_transmute_hash_values {
    my %args = @_;

    [transmute_hash_values => {
        rules => reverse_rules(
            (rules        => $args{rules})        x !!(exists $args{rules}),
            (rules_module => $args{rules_module}) x !!(exists $args{rules_module}),
        ),
        (key_is     => $args{key_is})     x !!(exists $args{key_is}),
        (key_in     => $args{key_in})     x !!(exists $args{key_in}),
        (key_match  => $args{key_match})  x !!(exists $args{key_match}),
        (key_filter => $args{key_filter}) x !!(exists $args{key_filter}),
        transmute_object=>$args{transmute_object},
    }];
}

sub _walk {
    my ($data, $rule_args, $seen) = @_;

    # transmute the node itself
    transmute_data(
        data => $data,
        (rules        => $rule_args->{rules})        x !!(exists $rule_args->{rules}),
        (rules_module => $rule_args->{rules_module}) x !!(exists $rule_args->{rules_module}),
    );
    my $refaddr = refaddr($data);
    return unless $refaddr;
    return if $seen->{$refaddr}++;

    if ($rule_args->{recurse_object} ?
            is_arrayref($data) : is_plain_arrayref($data)) {
        for my $elem (@$data) {
            _walk($elem, $rule_args, $seen);
        }
    } elsif ($rule_args->{recurse_object} ?
            is_hashref($data) : is_plain_hashref($data)) {
        for my $key (sort keys %$data) {
            _walk($data->{$key}, $rule_args, $seen);
        }
    }
}

sub _rule_transmute_nodes {
    my %args = @_;

    my $data = $args{data};

    die "Rule transmute_nodes: Please specify 'rules' or 'rules_module'"
        unless defined($args{rules}) || defined($args{rules_module});

    my $seen = {};
    _walk($data, \%args, $seen);
    $data;
}

sub _rulereverse_transmute_nodes {
    die "Rule transmute_nodes is not reversible";
}

sub _rules_or_rules_module {
    my $args = shift;

    my $rules = $args->{rules};
    if (!$rules) {
        if (defined $args->{rules_module}) {
            my $mod = "Data::Transmute::Rules::$args->{rules_module}";
            (my $mod_pm = "$mod.pm") =~ s!::!/!g;
            require $mod_pm;
            $rules = \@{"$mod\::RULES"};
        }
    }
    $rules or die "Please specify rules (or rules_module)";
    $rules;
}

sub transmute_data {
    my %args = @_;

    exists $args{data} or die "Please specify data";
    my $data  = $args{data};
    my $rules = _rules_or_rules_module(\%args);

    my $rulenum = 0;
    for my $rule (@$rules) {
        $rulenum++;
        if ($ENV{LOG_DATA_TRANSMUTE_STEP}) {
            log_trace "transmute_data #%d/%d: %s",
                $rulenum, scalar(@$rules), $rule;
        }
        my $funcname = "_rule_$rule->[0]";
        die "rule #$rulenum: Unknown function '$rule->[0]'"
            unless defined &{$funcname};
        my $func = \&{$funcname};
        $func->(
            %{$rule->[1] // {}},
            data => $data,
        );
    }
    $data;
}

sub reverse_rules {
    my %args = @_;

    my $rules = _rules_or_rules_module(\%args);

    my @rev_rules;
    for my $rule (@$rules) {
        my $funcname = "_rulereverse_$rule->[0]";
        my $func = \&{$funcname};
        unshift @rev_rules, $func->(
            %{$rule->[1] // {}},
        );
    }
    \@rev_rules;
}

1;
# ABSTRACT: Transmute (transform) data structure using rules data

__END__