File Coverage

blib/lib/Lingua/Awkwords.pm

Criterion	Covered	Total	%
statement	72	73	98.6
branch	22	24	91.6
condition			n/a
subroutine	15	15	100.0
pod	7	7	100.0
total	116	119	97.4

# -*- Perl -*-
#
# randomly generates outputs from a given pattern

package Lingua::Awkwords;

use strict;
use warnings;

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw/&percentize &set_filter &weights2str &weights_from/;

use Carp qw(croak);
use Lingua::Awkwords::Parser;
use Moo;
use namespace::clean;

our $VERSION = '0.07';

has pattern => (
    is      => 'rw',
    trigger => sub {
        my ( $self, $pat ) = @_;
        $self->_set_tree( Lingua::Awkwords::Parser->new->from_string($pat) );
    },
);
has tree => ( is => 'rwp' );

########################################################################
#
# FUNCTIONS
#
# TODO these probably should go in a ::Util module?

# utility routine that makes percentages of the presumably numeric
# values of the given hash reference
sub percentize {
    my ($href) = @_;
    my $sum    = 0;
    my $min    = ~0;
    for my $v ( values %$href ) {
        $sum += $v;
        $min = $v if $v < $min;
    }
    croak "sum of values cannot be 0" if $sum == 0;
    for my $v ( values %$href ) {
        $v = $v / $sum * 100;
    }
}

# utility routine for use with ->walk
sub set_filter {
    my $filter = shift;
    return sub {
        my $self = shift;
        $self->filter_with($filter) if $self->can('filter_with');
    };
}

sub weights2str {
    my ($hr) = @_;
    return join '/',
      map { $hr->{$_} == 1 ? $_ : join( '*', $_, $hr->{$_} ) } sort keys %$hr;
}

sub weights_from {
    my ($input) = @_;

    my $type = ref $input;
    my $fh;

    if ( $type eq '' ) {
        open $fh, '<', \$input;
    } elsif ( $type eq 'GLOB' ) {
        $fh = $input;
    } else {
        croak "unknown input type";
    }

    my ( %first, %mid, %last, %all );

    while ( readline $fh ) {
        chomp;
      LOOP: {
            redo LOOP if /\G\s+/cg;
            # various \b{...} forms detailed in perlrebackslash may be
            # better for word boundaries though require perl 5.22 or up
            if (m/\G\b(.)/cg) {
                $first{$1}++;
                $all{$1}++;
                redo LOOP;
            }
            if (m/\G(.)\b/cg) {
                $last{$1}++;
                $all{$1}++;
                redo LOOP;
            }
            if (m/\G\B(.)/cg) {
                $mid{$1}++;
                $all{$1}++;
                redo LOOP;
            }
        }
    }

    return \%first, \%mid, \%last, \%all;
}

########################################################################
#
# METHODS

# avoids need to say
#   use Lingua::Awkwords::Parser;
#   ... = Lingua::Awkwords::Parser->new->from_string(q{ ...
# in the calling code
sub parse_string {
    my ( $self_or_class, $str ) = @_;
    return Lingua::Awkwords::Parser->new->from_string($str);
}

sub render {
    my ($self) = @_;
    my $tree = $self->tree;
    croak "no pattern supplied" if !defined $tree;
    return $tree->render;
}

sub walk {
    my ( $self, $callback ) = @_;
    my $tree = $self->tree;
    croak "no pattern supplied" if !defined $tree;
    $tree->walk($callback);
    return;
}

1;
__END__