File Coverage

blib/lib/AI/MicroStructure/MultiList.pm

Criterion	Covered	Total	%
statement	110	124	88.7
branch	20	22	90.9
condition	13	21	61.9
subroutine	20	23	86.9
pod	7	7	100.0
total	170	197	86.2

package AI::MicroStructure::MultiList;
use strict;
use AI::MicroStructure ();    # do not export metaname and friends
use AI::MicroStructure::RemoteList;
use List::Util qw( shuffle );
use Carp;

our @ISA = qw( AI::MicroStructure::RemoteList );
our $VERSION = '0.20';

sub init {
    my ($self, $data) = @_;
    my $class = caller(0);

    $data ||= AI::MicroStructure->load_data($class);
    no strict 'refs';

    # note: variables mentioned twice to avoid a warning

    my $sep = ${"$class\::Separator"} = ${"$class\::Separator"} ||= '/';
    my $tail = qr/$sep?[^$sep]*$/;

    # compute all categories
    my @categories = ( [ $data->{names}, '' ] );
    while ( my ( $h, $k ) = @{ shift @categories or []} ) {
        if ( ref $h eq 'HASH' ) {
            push @categories,
                map { [ $h->{$_}, ( $k ? "$k$sep$_" : $_ ) ] } keys %$h;
        }
        else {    # leaf
            my @items = split /\s+/, $h;
            while ($k) {
                push @{ ${"$class\::MultiList"}{$k} }, @items;
                $k =~ s!$tail!!;
            }
        }
    }

    ${"$class\::Default"} = ${"$class\::Default"} = $data->{default} || ':all';
    ${"$class\::Theme"} = ${"$class\::Theme"} = ( split /::/, $class )[-1];

    *{"$class\::import"} = sub {
        my $callpkg = caller(0);
        my $structure   = ${"$class\::Theme"};
        my $meta    = $class->new;
        *{"$callpkg\::meta$structure"} = sub { $meta->name(@_) };
    };

    ${"$class\::meta"} = ${"$class\::meta"} = $class->new();
}

sub name {
    my ( $self, $count ) = @_;
    my $class = ref $self;

    if ( !$class ) {    # called as a class method!
        $class = $self;
        no strict 'refs';
        $self = ${"$class\::meta"};
    }

    if ( defined $count && $count == 0 ) {
        no strict 'refs';
        return wantarray
            ? shuffle @{ $self->{base} }
            : scalar @{ $self->{base} };
    }

    $count ||= 1;
    my $list = $self->{cache};
    if ( @{ $self->{base} } ) {
        push @$list, shuffle @{ $self->{base} } while @$list < $count;
    }
    splice( @$list, 0, $count );
}

sub new {
    my $class = shift;

    no strict 'refs';
    my $self = bless { @_, cache => [] }, $class;

    # compute some defaults
    $self->{category} ||= ${"$class\::Default"};

    # fall back to last resort (FIXME should we carp()?)
    $self->{category} = ${"$class\::Default"}
        if $self->{category} ne ':all'
        && !exists ${"$class\::MultiList"}{ $self->{category} };

    $self->_compute_base();
    return $self;
}

sub _compute_base {
    my ($self) = @_;
    my $class = ref $self;

    # compute the base list for this category
    no strict 'refs';
    my %seen;
    $self->{base} = [
        grep { !$seen{$_}++ }
            map { @{ ${"$class\::MultiList"}{$_} } }
            $self->{category} eq ':all'
        ? ( keys %{"$class\::MultiList"} )
        : ( $self->{category} )
    ];
    return;
}

sub category { $_[0]->{category} }

sub categories {
    my $class = shift;
    $class = ref $class if ref $class;

    no strict 'refs';
    return keys %{"$class\::MultiList"};
}

sub has_category {
    my ($class, $category) = @_;
    $class = ref $class if ref $class;

    no strict 'refs';
    return exists ${"$class\::MultiList"}{$category};
}

sub structure {
    my $class = ref $_[0] || $_[0];
    no strict 'refs';
    return ${"$class\::Theme"};
}

1;

__END__

=head1 NAME

AI::MicroStructure::MultiList - Base class for structures with multiple lists

=head1 SYNOPSIS

    package AI::MicroStructure::digits;
    use AI::MicroStructure::MultiList;
    our @ISA = ( AI::MicroStructure::MultiList );
    __PACKAGE__->init();
    1;

    =head1 NAME

    AI::MicroStructure::digits - The numbers structure

    =head1 DESCRIPTION

    You can count on this module. Almost.

    =cut

    __DATA__
    # default
    :all
    # names primes even
    two
    # names primes odd
    three five seven
    # names composites even
    four six eight
    # names composites odd
    nine
    # names other
    zero one

=head1 DESCRIPTION

C<AI::MicroStructure::MultiList> is the base class for all structures
that are meant to return a random excerpt from a predefined list
I<divided in categories>.

The category is selected at construction time from:

=over 4

=item 1.

the given C<category> parameter,

=item 2.

the default category for the selected structure.

=back

Categories and sub-categories are separated by a C</> character.

=head1 METHODS

AI::MicroStructure::MultiList offers several methods, so that the subclasses
are easy to write (see full example in L<SYNOPSIS>):

=over 4

=item new( category => $category )

The constructor of a single instance. An instance will not repeat items
until the list is exhausted.

    $meta = AI::MicroStructure::digits->new( category => 'primes' );
    $meta = AI::MicroStructure::digits->new( category => 'primes/odd' );

The special category C<:all> will use all the items in all categories.

    $meta = AI::MicroStructure::digits->new( category => ':all' );

If no C<category> parameter is given, C<AI::MicroStructure::MultiList>
will use the class default. If the class doesn't define a default,
then C<:all> is used.

=item init()

init() must be called when the subclass is loaded, so as to read the
__DATA__ section and fully initialise it.

=item name( $count )

Return $count names (default: C<1>).

Using C<0> will return the whole list in list context, and the size of the
list in scalar context (according to the C<category> parameter passed to the
constructor).

=item category()

Return the selected category for this instance.

=item categories()

Return the categories supported by the structure (except C<:all>).

=item has_category( $category )

Return a boolean value indicating if the structure contains the given category.

=item structure()

Return the structure name.

=back

=head1 AUTHOR

Philippe 'BooK' Bruhat, C<< <[e-mail]> >>

=head1 COPYRIGHT & LICENSE

Copyright 2006 Philippe 'BooK' Bruhat, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut