File Coverage

blib/lib/Games/Word/Wordlist.pm

Criterion	Covered	Total	%
statement	78	121	64.4
branch	16	50	32.0
condition	0	6	0.0
subroutine	19	22	86.3
pod	10	10	100.0
total	123	209	58.8

package Games::Word::Wordlist;
BEGIN {
  $Games::Word::Wordlist::AUTHORITY = 'cpan:DOY';
}
{
  $Games::Word::Wordlist::VERSION = '0.06';
}
use strict;
use warnings;
use Games::Word qw/all_permutations all_subpermutations/;
use List::MoreUtils qw/uniq/;
# ABSTRACT: manages a list of words



sub new {
    my $class = shift;
    my $word_list = shift;
    my $self = {
        cache => 1,
        @_,

        file => $word_list,
        word_list => [],
        word_hash => {},
    };

    if (ref($word_list) eq 'ARRAY') {
        $self->{cache} = 1;
        $self->{file} = '';
        $self->{word_list} = $word_list;
        $self->{word_hash}{$_} = 1 for @$word_list;
    }
    else {
        die "Can't read word list: $word_list" unless -r $word_list;
        if ($self->{cache} && -s $word_list) {
            open my $fh, '<', $word_list or die "Opening $word_list failed";
            while (<$fh>) {
                chomp;
                $self->{word_hash}{$_} = 1;
            }
            $self->{word_list} = [keys %{$self->{word_hash}}];
        }
    }

    bless $self, $class;
    return $self;
}


sub add_words {
    my $self = shift;
    my $word_list = shift;

    die "Can't add words to a non-cached word list" unless $self->{cache};

    if (ref($word_list) eq 'ARRAY') {
        $self->{word_hash}{$_} = 1 for @$word_list;
    }
    else {
        open my $fh, '<', $word_list or die "Opening $word_list failed";
        $self->{word_hash}{$_} = 1 for <$fh>;
    }
    $self->{word_list} = [keys %{$self->{word_hash}}];

    return;
}


sub remove_words {
    my $self = shift;

    die "Can't remove words from a non-cached word list" unless $self->{cache};

    delete $self->{word_hash}{$_} for (@_);
    $self->{word_list} = [keys %{$self->{word_hash}}];

    return;
}


sub words {
    my $self = shift;

    return @{$self->{word_list}} if $self->{cache};
    open my $fh, '<', $self->{file} or die "Opening $self->{file} failed";
    while (<$fh>) {}

    return $.;
}

sub _random_word_cache {
    my $self = shift;
    my $length = shift;

    my @word_list;
    if (defined $length) {
        @word_list = $self->words_like(qr/^\w{$length}$/);
        return unless @word_list;
    }
    else {
        @word_list = @{$self->{word_list}};
        return unless @word_list;
    }

    return $word_list[int rand @word_list];
}

sub _random_word_nocache {
    my $self = shift;
    my $length = shift;

    open my $fh, '<', $self->{file} or die "Opening $self->{file} failed";
    return unless -s $self->{file};
    my $word;
    my $lineno = 0;
    while (<$fh>) {
        next unless !defined $length || /^\w{$length}$/;
        $lineno++;
        $word = $_ if int(rand $lineno) == 0;
    }
    return unless defined $word;
    chomp $word;

    return $word;
}


sub random_word {
    my $self = shift;

    return $self->_random_word_cache(@_) if $self->{cache};
    return $self->_random_word_nocache(@_);
}

sub _is_word_cache {
    my $self = shift;
    my $word = shift;

    return $self->{word_hash}{$word};
}

sub _is_word_nocache {
    my $self = shift;
    my $word = shift;

    open my $fh, '<', $self->{file} or die "Opening $self->{file} failed";
    while (<$fh>) {
        chomp;
        return 1 if $_ eq $word;
    }

    return 0;
}


sub is_word {
    my $self = shift;

    return $self->_is_word_cache(@_) if $self->{cache};
    return $self->_is_word_nocache(@_);
}

sub _each_word_cache {
    my $self = shift;
    my $code = shift;

    &$code($_) for @{$self->{word_list}};

    return;
}

sub _each_word_nocache {
    my $self = shift;
    my $code = shift;

    open my $fh, '<', $self->{file} or die "Opening $self->{file} failed";
    while (<$fh>) {
        chomp;
        &$code($_);
    }

    return;
}


sub each_word {
    my $self = shift;

    return $self->_each_word_cache(@_) if $self->{cache};
    return $self->_each_word_nocache(@_);
}


sub anagrams {
    my $self = shift;
    my $word = shift;

    return grep {$self->is_word($_)} all_permutations($word);
}


sub words_like {
    my $self = shift;
    my $re = shift;

    my @words = ();
    $self->each_word(sub { push @words, $_[0] if $_[0] =~ $re });

    return @words;
}


sub subwords_of {
    my $self = shift;
    my $string = shift;

    return grep {$self->is_word($_)} all_subpermutations($string);
}


1;

__END__