File Coverage

blib/lib/Encode/Mapper.pm

Criterion	Covered	Total	%
statement	174	328	53.0
branch	85	186	45.7
condition	16	31	51.6
subroutine	13	18	72.2
pod	9	11	81.8
total	297	574	51.7

# ############################################################################ Otakar Smrz, 2003/01/23
#
# Mapper Engine Class ##################################################################### 2003/06/19

# $Id: Mapper.pm 663 2008-08-11 14:21:54Z smrz $

package Encode::Mapper;

use 5.008;

use strict;
use warnings;

use Carp;

our $VERSION = '1.6' || do { q $Revision: 663 $ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 };


use bytes;                  # ensures splitting into one-byte tokens .. lexically scoped


our %options;               # records of options per package .. global register
our %option;                # options of the caller package .. used with local


sub import {                # enforces setting of options
    my $cls = shift @_;
    $cls->options(@_) if @_;
}


sub whisper ($) {           # module's internal function

    carp shift unless $option{'silent'};
}


sub verify_rule ($$) {      # module's internal function

    unless (defined $_[0] and $_[0] ne '') {
        whisper "Rule's LHS is empty, rule ignored";
        return;
    }
    unless (defined $_[1]) {
        whisper "Rule's RHS is undefined, rule ignored";
        return;
    }

    if (UNIVERSAL::isa($_[1], 'ARRAY')) {
        unless (defined $_[1]->[0]) {
            whisper "Rule's RHS is undefined, rule ignored";
            return;
        }
        unless (ref \$_[1]->[0] eq 'SCALAR' or UNIVERSAL::isa($_[1]->[0], 'CODE')) {
            whisper "Rule's RHS is neither literal nor subroutine reference, rule ignored";
            return;
        }
        unless (defined $_[1]->[1] and length $_[1]->[1] < length $_[0]) {
            whisper "Rule type '\$A => [\$X, \$Y], length \$A > length \$Y' misused, considering it '\$A => \$X'";
            $_[1] = $_[1]->[0];
        }
    }
    elsif (ref \$_[1] ne 'SCALAR' and not UNIVERSAL::isa($_[1], 'CODE')) {
        whisper "Rule's RHS is neither literal nor subroutine reference, rule ignored";
        return;
    }

    return 1;
}


sub options ($%) {          # options for general compilation of Mappers
    my $cls = shift @_;
    my ($i, $opt, %opt);

    my $caller = caller 0; $caller = caller 1 if $caller eq __PACKAGE__;
    my @returns = exists $options{$caller} ? %{$options{$caller}} : ();

    while (@_) {
        $opt = lc shift @_;

        if ($opt =~ /^\:/) {
            $opt eq ':others' and $opt{'others'} = sub { shift } and next;
            $opt eq ':silent' and $opt{'silent'} = 1 and next;
            $opt eq ':join'   and $opt{'join'} = '';
        }
        else {
            $opt =~ /^\-*(.*)$/;
            $opt{$1} = shift @_;
        }
    }

    {
        local $option{'silent'} = exists $opt{'silent'} ? $opt{'silent'} : $options{$caller}{'silent'};

        if (defined $opt{'complement'} and UNIVERSAL::isa($opt{'complement'}, 'ARRAY')) {
            for ($i = 0; $i < @{$opt{'complement'}}; $i += 2) {
                verify_rule $opt{'complement'}->[$i], $opt{'complement'}->[$i + 1];
            }
        }

        if (defined $opt{'override'} and UNIVERSAL::isa($opt{'override'}, 'ARRAY')) {
            for ($i = 0; $i < @{$opt{'override'}}; $i += 2) {
                verify_rule $opt{'override'}->[$i], $opt{'override'}->[$i + 1];
            }
        }

        if (defined $opt{'others'} and not $option{'silent'}) {     # see whisper
            if (UNIVERSAL::isa($opt{'others'}, 'CODE')) {
                carp "The subroutine will be called with the 'other' LHS parameter to get the rule's RHS";
            }
            else {
                carp "The scalar value will become the RHS of each 'other' LHS";
            }
        }
    }

    return %opt unless defined $cls;

    $options{$caller}{$_} = $opt{$_} foreach keys %opt;

    return @returns;
}


*new = *compile{'CODE'};    # provides the 'new' constructor .. the 'compile' method
                            # *new = \&compile;     # might be known at compile-time


sub compile ($@) {          # returns Mapper .. modified Aho-Corasick and Boyer-Moore search engine
    my $cls = shift @_;
    my (@tree, @bell, @skip, @queue, %redef);
    my ($q, $r, $s, $t, $i, $token, $trick);

    my ($null_list, $null_hash) = ([], {});     # references to empties need not consume unique memory
    my ($no_code, $no_list) = (1, 1);           # optimization indicators

    local %option = exists $options{caller 0} ? %{$options{caller 0}} : ();
                                                # options be local due to verify_rule and whisper

    if (UNIVERSAL::isa($_[0], 'ARRAY')) {
        %option = (%option, options undef, @{shift @_});
    }
    elsif (UNIVERSAL::isa($_[0], 'HASH')) {
        %option = (%option, options undef, %{shift @_});
    }

    $skip[0] = undef;       # never ever used .. fix the number of list elements equal
    $bell[0] = $null_list;  # important .. depth-wise inheritation of the lists

    if (defined $option{'complement'}) {
        for ($i = 0; $i < @{$option{'complement'}}; $i += 2) {

            $q = 0;

            foreach $token (split //, $option{'complement'}->[$i]) {
                $tree[$q]->{$token} = ++$r unless defined $tree[$q]->{$token};  # increment $r ^^
                $q = $tree[$q]->{$token};
            }

            $tree[$q] = {} unless defined $tree[$q];    # define trees correctly, economize below

            whisper "Redefining the mapping for '" . $option{'complement'}->[$i] . "'" if defined $bell[$q];

            $bell[$q] = [ $option{'complement'}->[$i + 1] ];
        }
    }

    for ($i = 0; $i < @_; $i += 2) {    # generate $tree[$q] transition function and initial $bell[$q]

        next unless verify_rule $_[$i], $_[$i + 1];

        $q = 0;

        foreach $token (split //, $_[$i]) {
            $tree[$q]->{$token} = ++$r unless defined $tree[$q]->{$token};  # increment $r ^^
            $q = $tree[$q]->{$token};
        }

        $tree[$q] = {} unless defined $tree[$q];    # define trees correctly, economize below

        whisper "Redefining the mapping for '$_[$i]'" if $redef{$q}++;

        $bell[$q] = [ $_[$i + 1] ];
    }

    if (defined $option{'override'}) {
        for ($i = 0; $i < @{$option{'override'}}; $i += 2) {

            $q = 0;

            foreach $token (split //, $option{'override'}->[$i]) {
                $tree[$q]->{$token} = ++$r unless defined $tree[$q]->{$token};  # increment $r ^^
                $q = $tree[$q]->{$token};
            }

            $tree[$q] = {} unless defined $tree[$q];    # define trees correctly, economize below

            whisper "Redefining the mapping for '" . $option{'override'}->[$i] . "'" if $redef{$q}++;

            $bell[$q] = [ $option{'override'}->[$i + 1] ];
        }
    }

    foreach $token (map { chr } 0x00..0xFF) {
        unless (defined $tree[0]->{$token}) {
            unless (defined $option{'others'}) {
                $tree[0]->{$token} = 0;
            }
            else {
                $tree[0]->{$token} = ++$r;  # increment $r ^^
                $tree[$r] = {};             # define trees correctly
            }
        }

        $q = $tree[0]->{$token};    # including existing prefixes

        unless ($q == 0) {
            unless (defined $bell[$q]) {
                if (not defined $option{'others'}) {
                    $bell[$q] = $bell[0];
                }
                elsif (UNIVERSAL::isa($option{'others'}, 'CODE')) {
                    $bell[$q] = [ $option{'others'}->($token) ];
                }
                else {
                    $bell[$q] = [ $option{'others'} ];
                }
            }

            $skip[$q] = 0;

            push @queue, $q;
        }
    }

    while (@queue) {                # generate $skip[$q] backward function and complete $bell[$q]
        $q = shift @queue;

        foreach $token (keys %{$tree[$q]}) {
            $t = $tree[$q]->{$token};
            push @queue, $t;

            if (defined $bell[$t]) {
                $skip[$t] = 0;

                if (UNIVERSAL::isa($bell[$t]->[0], 'ARRAY')) {  # shortening property of the rules
                    $s = $skip[$t];

                    foreach $trick (split //, $bell[$t]->[0]->[1]) {
                        until (defined $tree[$s]->{$trick}) {   # loops only if not in the root ^^
                            push @{$bell[$t]}, @{$bell[$s]};
                            $s = $skip[$s];
                        }
                        $s = $tree[$s]->{$trick};
                    }

                    $skip[$t] = $s;
                    $bell[$t]->[0] = $bell[$t]->[0]->[0];
                }
            }
            else {
                $s = $skip[$q];
                $bell[$t] = [ @{$bell[$q]} ];   # unique reference quite important ^^

                until (defined $tree[$s]->{$token}) {   # extremely tricky ...
                    push @{$bell[$t]}, @{$bell[$s]};
                    $s = $skip[$s];
                }

                $skip[$t] = $tree[$s]->{$token};
            }
        }

        $tree[$q] = $null_hash unless keys %{$tree[$q]};    # economize with memory
    }

    for ($q = 1; $q < @bell; $q++) {    # optimize the bell function for $q > 0

        if (grep { UNIVERSAL::isa($_, 'CODE') } @{$bell[$q]}) {
            $no_code = 0;
        }
        elsif (defined $option{'join'}) {
            $bell[$q] = join $option{'join'}, @{$bell[$q]};
            next;
        }

        if (@{$bell[$q]} == 1) {
            $bell[$q] = $bell[$q]->[0];
        }
        else {
            $bell[$q] = $null_list if @{$bell[$q]} == 0;
            $no_list = 0;
        }
    }

    return bless {
                    'current' => 0,
                    'tree' => \@tree,
                    'bell' => \@bell,
                    'skip' => \@skip,
                    'null' => { 'list' => $null_list, 'hash' => $null_hash },
                    'join' => $option{'join'},
                    'no_code' => $no_code,
                    'no_list' => $no_list,
        }, $cls;
}


sub process ($@) {          # returns the list of search results performed by Mapper
    my $obj = shift @_;
    my (@returns, $phrase, $token, $q);

    $q = $obj->{'current'};

    if ($obj->{'no_list'}) {
        foreach $phrase (@_) {
            foreach $token (split //, $phrase) {
                until (defined $obj->{'tree'}[$q]->{$token}) {
                    push @returns, $obj->{'bell'}[$q];
                    $q = $obj->{'skip'}[$q];
                }
                $q = $obj->{'tree'}[$q]->{$token};
            }
        }
    }
    else {
        foreach $phrase (@_) {
            foreach $token (split //, $phrase) {
                until (defined $obj->{'tree'}[$q]->{$token}) {
                    push @returns, ref $obj->{'bell'}[$q] eq 'ARRAY' ?
                         @{$obj->{'bell'}[$q]} : $obj->{'bell'}[$q];
                    $q = $obj->{'skip'}[$q];
                }
                $q = $obj->{'tree'}[$q]->{$token};
            }
        }
    }

    $obj->{'current'} = $q;

    return @returns;
}


sub recover ($;$$) {        # returns the 'in-progress' search result and resets Mapper
    my ($obj, $r, $q) = @_;
    my (@returns);

    $q = $obj->{'current'} unless defined $q;

    if ($obj->{'no_list'}) {
        until ($q == 0) {
            push @returns, $obj->{'bell'}[$q];
            $q = $obj->{'skip'}[$q];
        }
    }
    else {
        until ($q == 0) {
            push @returns, ref $obj->{'bell'}[$q] eq 'ARRAY' ?
                 @{$obj->{'bell'}[$q]} : $obj->{'bell'}[$q];
            $q = $obj->{'skip'}[$q];
        }
    }

    $obj->{'current'} = defined $r ? $r : 0;

    return @returns;
}


sub compute ($@) {
    my $obj = shift @_;
    my (@returns, $phrase, $token, $q);

    $obj->recover();

    foreach $phrase (@_) {
        foreach $token (split //, $phrase) {
            push @returns, [$token, $obj->{'current'}];
            push @{$returns[-1]}, [$obj->process($token)];
            $q = $obj->{'current'};
            push @{$returns[-1]}, $q, $obj->{'bell'}[$q], $obj->{'skip'}[$q];
        }
    }

    push @returns, ['recover', $obj->{'current'}];
    push @{$returns[-1]}, [$obj->recover()];
    $q = $obj->{'current'};
    push @{$returns[-1]}, $q, $obj->{'bell'}[$q], ($q == 0 ? 'undef' : $obj->{'skip'}[$q]);

    return @returns;
}


sub dumper ($;$) {
    my ($obj, $ref) = @_;

    $ref = ['L', 'H', 'mapper'] unless defined $ref;

    require Data::Dumper;

    return Data::Dumper->new([$obj->{'null'}{'list'}, $obj->{'null'}{'hash'}, $obj], $ref);
}


sub describe ($;$) {
    my ($obj, $ref) = @_;
    my ($q, $nodes, $edges, $skips, $bells, $paths, $lists);

    $nodes = @{$obj->{'tree'}};
    $edges = [];
    $lists = [];

    if ($obj->{'no_list'}) {
        for ($q = 0; $q < @{$obj->{'tree'}}; $q++) {
            $lists->[$q * 3] = scalar %{$obj->{'tree'}[$q]};
            $lists->[$q * 3] =~ m{^([0-9]+)(?:/([0-9]+))?$};

            $edges->[0] += scalar keys %{$obj->{'tree'}[$q]};
            $lists->[$q * 3] .= " " . keys %{$obj->{'tree'}[$q]};

            if (defined $2) {
                $edges->[1] += $1;
                $edges->[2] += $2;
            }
            else {
                $paths++ unless $1;
            }

            $lists->[$q * 3 + 1] = $obj->{'bell'}[$q] eq "" ? 0 : 1;
            $bells += $lists->[$q * 3 + 1];

            next if $q == 0;

            $lists->[$obj->{'skip'}[$q] * 3 + 2]++;
            $skips++ unless $obj->{'skip'}[$q] == 0;
        }
    }
    else {
        for ($q = 0; $q < @{$obj->{'tree'}}; $q++) {
            $lists->[$q * 3] = scalar %{$obj->{'tree'}[$q]};
            $lists->[$q * 3] =~ m{^([0-9]+)(?:/([0-9]+))?$};

            $edges->[0] += scalar keys %{$obj->{'tree'}[$q]};
            $lists->[$q * 3] .= " " . keys %{$obj->{'tree'}[$q]};

            if (defined $2) {
                $edges->[1] += $1;
                $edges->[2] += $2;
            }
            else {
                $paths++ unless $1;
            }

            $lists->[$q * 3 + 1] = ref $obj->{'bell'}[$q] eq 'ARRAY' ? scalar @{$obj->{'bell'}[$q]} : 1;
            $bells += $lists->[$q * 3 + 1];

            next if $q == 0;

            $lists->[$obj->{'skip'}[$q] * 3 + 2]++;
            $skips++ unless $obj->{'skip'}[$q] == 0;
        }
    }

    my $return = {'nodes' => $nodes, 'edges' => $edges->[0], 'slots' => $edges->[1] . "/" . $edges->[2],
                  'skips' => $skips, 'bells' => $bells, 'paths' => $paths, 'lists' => $lists};

    if (defined $ref) {
        $ref = *STDERR if ref $ref ne 'GLOB';
        print $ref ( join ", ", map { ( defined $return->{$_} ? $return->{$_} : 'undef' ) . " " . $_ }
                                    grep { $_ ne 'lists' } keys %{$return} ) . "\n";
    }

    return $return;
}


sub encode ($$$;$) {
    my ($cls, $text, $encoder, $enc) = @_;
    my ($mapper, $join);

    local %option = exists $options{caller 0} ? %{$options{caller 0}} : ();
                                                # options be local due to whisper

    require Encode;

    unless (Encode::is_utf8($text)) {
        whisper "The input text is not in Perl's internal utf8 .. note only, might be fine";
    }

    if ($enc) {
        unless (Encode::resolve_alias($enc)) {
            carp "Cannot resolve the proposed '$enc' encoding";
            return undef;
        }

        $text = Encode::encode($enc, $text);
    }

    if (not UNIVERSAL::isa($encoder, 'ARRAY') or grep { defined $_ and not $_->isa($cls) } @{$encoder}) {
        carp "Expecting a reference to an array of '$cls' objects";
        return undef;
    }

    foreach $mapper (@{$encoder}) {
        last unless defined $mapper;

        $join = defined $mapper->{'join'} ? $mapper->{'join'} :
                defined $option{'join'} ? $option{'join'} : "";

        if ($mapper->{'no_code'}) {
            $text = join $join, $mapper->process($text), $mapper->recover();
        }
        else {
            $text = join $join, map {
                        UNIVERSAL::isa($_, 'CODE') ? $_->() : $_
                    } $mapper->process($text), $mapper->recover();
        }
    }

    return $text;
}


sub decode ($$$;$) {
    my ($cls, $text, $decoder, $enc) = @_;
    my ($mapper, $join);

    local %option = exists $options{caller 0} ? %{$options{caller 0}} : ();
                                                # options be local due to tradition ^^

    require Encode;

    $enc = 'utf8' unless $enc;

    unless (Encode::resolve_alias($enc)) {
        carp "Cannot resolve the proposed '$enc' encoding";
        return undef;
    }

    if (not UNIVERSAL::isa($decoder, 'ARRAY') or grep { defined $_ and not $_->isa($cls) } @{$decoder}) {
        carp "Expecting a reference to an array of $cls objects";
        return undef;
    }

    foreach $mapper (@{$decoder}) {
        last unless defined $mapper;

        $join = defined $mapper->{'join'} ? $mapper->{'join'} :
                defined $option{'join'} ? $option{'join'} : "";

        if ($mapper->{'no_code'}) {
            $text = join $join, $mapper->process($text), $mapper->recover();
        }
        else {
            $text = join $join, map {
                        UNIVERSAL::isa($_, 'CODE') ? $_->() : $_
                    } $mapper->process($text), $mapper->recover();
        }
    }

    return Encode::is_utf8($text) ? $text : Encode::decode($enc, $text);
}


1;

__END__