File Coverage

blib/lib/Locale/TextDomain/OO/Extract/Process.pm

Criterion	Covered	Total	%
statement	33	136	24.2
branch	0	50	0.0
condition	0	7	0.0
subroutine	11	20	55.0
pod	7	7	100.0
total	51	220	23.1

package Locale::TextDomain::OO::Extract::Process; ## no critic (TidyCode)

use strict;
use warnings;
use Carp qw(confess);
use Clone qw(clone);
use Class::Load qw(load_class);
use Locale::TextDomain::OO::Util::JoinSplitLexiconKeys;
use Moo;
use MooX::StrictConstructor;
use MooX::Types::MooseLike::Base qw(HashRef Str);
use Set::Scalar;
use namespace::autoclean;

our $VERSION = '2.014';

has category => (
    is      => 'rw',
    isa     => Str,
    lazy    => 1,
    default => q{},
);

has domain => (
    is      => 'rw',
    isa     => Str,
    lazy    => 1,
    default => q{},
);

has language => (
    is      => 'rw',
    isa     => Str,
    lazy    => 1,
    default => 'i-default',
);

has project => (
    is  => 'rw',
    isa => sub {
        my $project = shift;
        defined $project
            or return;
        return Str->($project);
    },
);

has lexicon_ref => (
    is      => 'rw',
    isa     => HashRef,
    lazy    => 1,
    default => sub { {} },
);

has plugin_ref => (
    is      => 'rw',
    isa     => HashRef,
    lazy    => 1,
    default => sub { { po => 'PO' } },
);

has _plugin_object_ref => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { {} },
);

sub add_plugin {
    my ( $self, $plugin_alias, $plugin ) = @_;

    $plugin_alias
        or confess 'Plugin alias expected';
    $plugin
        or confess 'Plugin name expected';
    delete $self->_plugin_object_ref->{$plugin_alias};
    $self->plugin_ref->{$plugin_alias} = $plugin;

    return;
}

sub _plugin {
    my ( $self, $plugin_alias ) = @_;

    $plugin_alias
        or confess 'Undef is not a plugin alias';
    my $plugin_object_ref = $self->_plugin_object_ref;
    if ( exists $plugin_object_ref->{$plugin_alias} ) {
        my $object = $plugin_object_ref->{$plugin_alias};
        $object->clear;
        METHOD:
        for my $method ( qw( category domain language lexicon_ref project ) ) {
            my $value = $self->$method;
            defined $value
                or next METHOD;
            $object->$method($value);
        }
        return $object;
    }
    my $plugin = $self->plugin_ref->{$plugin_alias}
        or confess "Unknown plugin alias $plugin_alias";
    my $class = $plugin =~ s{ \A [+] }{}xms
        ? $plugin
        : "Locale::TextDomain::OO::Extract::Process::Plugin::$plugin";
    my $object = load_class($class)->new(
        map {
            defined $self->$_
                ? ( $_ => $self->$_ )
                : ();
        }
        qw( category domain language lexicon_ref project )
    );
    $plugin_object_ref->{$plugin_alias} = $object;

    return $object;
}

sub slurp {
    my ( $self, $plugin_alias, $filename ) = @_;

    $self->_plugin($plugin_alias)->slurp($filename);

    return;
}

sub spew {
    my ( $self, $plugin_alias, $filename ) = @_;

    $self->_plugin($plugin_alias)->spew($filename);

    return;
}

sub remove_all_reference {
    my $self = shift;

    my $lexicon_ref = $self->lexicon_ref;
    for my $message_ref ( values %{$lexicon_ref} ) {
        for my $value_ref ( values %{$message_ref} ) {
            delete $value_ref->{reference};
        }
    }

    return;
}

sub remove_all_automatic {
    my $self = shift;

    my $lexicon_ref = $self->lexicon_ref;
    for my $message_ref ( values %{$lexicon_ref} ) {
        for my $value_ref ( values %{$message_ref} ) {
            delete $value_ref->{automatic};
        }
    }

    return;
}

sub remove_all_non_referenced {
    my $self = shift;

    my $lexicon_ref = $self->lexicon_ref;
    for my $message_ref ( values %{$lexicon_ref} ) {
        MESSAGE_KEY:
        for my $message_key ( keys %{$message_ref} ) {
            length $message_key
                or next MESSAGE_KEY; # skip header
            my $has_reference
                = exists $message_ref->{$message_key}->{reference}
                && $message_ref->{$message_key}->{reference} =~ m{\S}xms;
            $has_reference
                or delete $message_ref->{$message_key};
        }
    }

    return;
}

sub merge_extract {
    my ( $self, $arg_ref ) = @_;

    my $extract_lexicon_ref = $arg_ref->{lexicon_ref}
        or confess 'Parameter lexicon_ref expected';
    ref $extract_lexicon_ref eq 'HASH'
        or confess 'Parameter lexicon_ref is not a hash reference';

    my $key_util = Locale::TextDomain::OO::Util::JoinSplitLexiconKeys->instance;
    # extracted to language i-default
    my $extract_lexicon_key = $key_util->join_lexicon_key({(
        map {
            $_ => $arg_ref->{$_};
        }
        qw( category domain project )
    )});
    # merged to real language
    my $lexicon_key = $key_util->join_lexicon_key({(
        map {
            $_ => $self->$_;
        }
        qw( category domain language project )
    )});

    my $message_ref  = $self->lexicon_ref->{$lexicon_key} ||= {};
    my $message_keys = Set::Scalar->new( keys %{$message_ref} );
    my $extract_message_ref  = $extract_lexicon_ref->{$extract_lexicon_key};
    my $extract_message_keys = Set::Scalar->new( keys %{$extract_message_ref} );
    my $skip_new_messages = $arg_ref->{skip_new_messages};
    my @new_message_keys
        = ref $skip_new_messages ne 'HASH'
        # simple
        ? (
            $skip_new_messages
            # bool parameter true
            ? ()
            : $extract_message_keys->difference($message_keys)->elements
        )
        # extended
        : ! $skip_new_messages->{on}
        # hash parameter false
        ? $extract_message_keys->difference($message_keys)->elements
        : do {
            my $to_regex = sub {
                my $any = shift;
                my @parts
                    = map { ref $_ eq 'Regex' ? $_ : qr{\Q$_\E}xmsi }
                    grep { defined && length }
                    ref $any eq 'ARRAY' ? @{$any} : $any;
                return @parts
                    ? do {
                        my $joined = join ' | ', @parts;
                        qr{ $joined }xms;
                    }
                    : qr{ (?!) }xms;
            };
            my $regex     = $to_regex->( $skip_new_messages->{no_skip_for} );
            my $not_regex = $to_regex->( $skip_new_messages->{but_skip_for} );

            grep { $_ =~ $regex && $_ !~ $not_regex }
            $extract_message_keys->difference($message_keys)->elements;
        };
    my @changed_message_keys = $extract_message_keys->intersection($message_keys)->elements;

    # merge header
    my $header_arg_ref = $arg_ref->{header_ref};
    if ($header_arg_ref) {
        # overwrite them
        if ( ref $arg_ref->{header_ref} eq 'HASH' ) {
            $message_ref->{ q{} } = clone($header_arg_ref);
        }
        # manipulate them
        elsif ( ref $header_arg_ref eq 'CODE' ) {
            local $_ = $message_ref->{ q{} } || {};
            $header_arg_ref->();
            $message_ref->{ q{} } = clone($_);
        }
    }

    MESSAGE_KEY:
    for my $message_key (@new_message_keys) {
        length $message_key
            or next MESSAGE_KEY;
        $message_ref->{$message_key}
            = clone( $extract_message_ref->{$message_key} );
    }
    MESSAGE_KEY:
    for my $message_key (@changed_message_keys) {
        length $message_key
            or next MESSAGE_KEY;
        my $extract_message_value_ref
            = clone( $extract_message_ref->{$message_key} );
        @{ $message_ref->{$message_key} }{ keys %{$extract_message_value_ref} }
            = values %{ $extract_message_value_ref };
    }

    return;
}

__PACKAGE__->meta->make_immutable;

1;

__END__