File Coverage

blib/lib/Lingua/SoundChange.pm

Criterion	Covered	Total	%
statement	95	104	91.3
branch	32	48	66.6
condition	11	16	68.7
subroutine	12	15	80.0
pod	3	8	37.5
total	153	191	80.1

package Lingua::SoundChange;

use 5.005_03;
use strict;
use Carp;
# use warnings;

# for debugging:
use constant PRINT_RULES => $ENV{LINGUA_SOUNDCHANGE_PRINTRULES} || 0;
use constant DEBUG => 0;
use vars qw($VERSION);

$VERSION = '0.05';

sub compile_rules($$$$);
sub compile_vars($$);

sub new {
    my($class, $vars, $rules, $opts) = @_;

    $opts ||= { };

    croak '$vars must be a hash reference!' unless ref $vars eq 'HASH';
    croak '$rules must be an array reference!' unless ref $rules eq 'ARRAY';

    my $obj = {
        raw_vars  => $vars,
        raw_rules => $rules,
        opts      => $opts,
    };

    $obj->{vars}     = compile_vars($vars, $opts);
    if($opts->{longVars}) {
        $obj->{raw_vars}->{"\Q<$_>\E"} = $vars->{$_} for keys %$vars;
    }
    ( $obj->{rules},
      $obj->{code} ) = compile_rules($rules, $obj->{vars}, $obj->{raw_vars}, $opts);

    bless $obj, $class;
}

sub change {
    my($self, $words) = @_;

    $words = [] unless defined $words;

    croak("change needs an array reference") unless ref($words) eq 'ARRAY';

    foreach my $word (@$words) {
        my $origword = $word;
        my @rules;
        my $ruleout;
        foreach my $rule (@{$self->rules}) {
            ($word, $ruleout) = $rule->($word);
            push @rules, $ruleout if defined $ruleout;
        }

        $word = { orig => $origword, word => $word, rules => \@rules };
    }

    $words;
}


# Private methods

sub compile_rules ($$$$) {
    my($rules, $vars, $varstring, $opt) = @_;

    croak "rules not an array reference" unless ref $rules eq 'ARRAY';
    croak "vars not a hash reference" unless ref $vars eq 'HASH';
    croak "varstring not a hash reference" unless ref $varstring eq 'HASH';
    croak "opt not a hash reference" unless ref $opt eq 'HASH';

    my @compiledrules;
    my %code;

    # Rules: change from a sound (one or more letters) or a category
    # to another sound or category, in a certain environment.
    # Categories may only be one letter long and are usually uppercase.
    # Environments must contain a _ symbol to show where the replacement
    # takes place; it may also contain letters, categories, and the special
    # symbols ( ) (to enclose optional parts) and # (beginning or end of
    # word).
    # Rules can only change sounds to sounds, and categories to categories.
    # If a category is to be changed to another category, they should be
    # the same length. Otherwise the second category will have its laster
    # letter repeated until it has the same length as the first (if it is
    # shorter), or characters in the second category that don't match
    # characters in the first will not be produced by such a range. Note
    # that this is an artefact of the use of tr/// and is not guaranteed
    # behaviour.
    # Don't use regex metacharacters (except for the parentheses which
    # show optional elements) in the environment or in names of categories
    # or sounds.
    # These include: . * + ? ^ $ [ ]

    foreach my $rule (@$rules) {
        if( $rule =~ m{
                ^
                ( [^/]+ )   # "change from" to $1
                /           # slash
                ( [^/]* )   # "change to" to $2 (may be blank)
                /           # slash
                ( .+ )      # "environment" to $3 (may not be blank)
                $
              }x )
        {
            my($from, $to, $env) = ($1, $2, $3);
            my($subfrom, $subto) = ('', '');

            my $option = sub {
                my $word = shift;

                # Change parentheses round one element to a question
                # mark following it, ...
                $word =~ s{
                    \(  # open parenthesis
                    (.) # one character, to $1
                    \)  # close parenthesis
                }{
                    $1 . '?'
                }gex;

                # ... and parentheses around multiple elements by
                # non-capturing parentheses followed by a question mark
                # (but nested parentheses are not allowed!)
                $word =~ s{
                    \(          # open parenthesis
                    ( [^()]+ )  # one or more non-parenthesis characters,
                                # to $1
                    \)          # close parenthesis
                }{
                    '(?:' . $1 . ')?'
                }gex;

                $word;
            };

            # Escape dollar signs and at signs in $env, which would
            # otherwise try to interpolate a variable into the regular
            # expression
            $env =~ s/([\$\@])/\\$1/g;

            # Get the bits before and after the underscore
            # and put them in capturing parentheses in $subfrom
            if($env =~ /^(#?)([^_#]*)(_)([^_#]*)(#?)$/) {
                # leading #
                $subfrom .= '^' if defined $1 && length $1;

                # preceding stuff, so we don't need $`
                # non-greedy
                # If match anchored at beginning, don't add this
                if(defined $1 && length $1) {
                    $subfrom .= '()';
                } else {
                    $subfrom .= '(.*?)';
                }

                # pre-environment
                $subfrom .= '(' . $option->(quotemeta $2) . ')';

                # underscore
                $subfrom .= "(\Q$from\E)";

                # post-environment
                $subfrom .= '(' . $option->(quotemeta $4) . ')';

                # trailing #
                $subfrom .= '$' if defined $5 && length $5;
            }

            # Now expand categories
            if($opt->{longVars}) {
                $subfrom =~ s{(\\<[^>]+\\>)}{$vars->{$1} || $1}eg;
            } else {
                $subfrom =~ s{(\\?)(.)}{$vars->{$2} || $1 . $2}eg;
            }

            # Show where the rule matches
            $subto .= qq(\$rule = "\Q$from\E->\Q$to\E /\Q$env\E applies to \$word at " . (length(\$1)+1) . "\\n"; );

            $subto .= '$1 . $2 . ';
            $subto .= ($vars->{quotemeta $from}
                      ? "do { my \$char = \$3; \$char =~ tr{$varstring->{quotemeta $from}}{" . ($varstring->{quotemeta $to} || $to) . "}; \$char }"
                      : "q{" . $to . "}");
            $subto .= ' . $4';

            if(PRINT_RULES) {
                print "[", $#compiledrules + 1, "] $rule --> s{$subfrom}{$subto}eg\n";
            }

            my $code = <<"EOF";
sub {
    my \$word = shift;
    my \$rule;
    my \$orig;
    # print qq(Working on '\$word'; \Q$from\E->\Q$to\E /\Q$env\E; from is '\Q$subfrom\E and to is '\Q$subto\E'\\n);
    1 while ((\$orig = \$word) =~ s{$subfrom}{$subto}e) && (\$orig ne \$word) && (\$word = \$orig);
    return ( \$word, \$rule );
}
EOF

            push @compiledrules, eval $code;
            croak "Problem with '$code'" unless $compiledrules[-1];
            $code{$compiledrules[-1]} = $code;
        }
    }

    ( \@compiledrules, \%code );
}

sub compile_vars ($$) {
    my($vars, $opt) = @_;

    croak "\$vars is not a hash reference" unless ref $vars eq 'HASH';
    croak "\$opt is not a hash reference" unless ref $opt eq 'HASH';

    my %compiledvars;

    foreach my $var (keys %$vars) {
        my $list = $vars->{$var};
        # Escape at signs and dollars in the list
        $list =~ s/([\$\@])/\\$1/g;

        if($opt->{longVars}) {
            $compiledvars{"\Q<$var>\E"} = qr/[$list]/;
            print qq[($var => $list // $compiledvars{"\Q<$var>\E"})\n] if PRINT_RULES;
        } else {
            $compiledvars{$var} = qr/[$list]/;
            print "($var => $list // $compiledvars{$var})\n" if PRINT_RULES;
        }
    }

    \%compiledvars;
}

sub rules {
    my($self) = @_;

    $self->{rules};
}

sub vars {
    my($self) = @_;

    $self->{vars};
}

sub varstring {
    my($self) = @_;

    $self->{raw_vars};
}

sub code {
    my($self, $token, $code) = @_;

    $self->{code}->{$token} = $code if $code;

    $self->{code}->{$token};
}


1;
__END__