File Coverage

blib/lib/Acme/MetaSyntactic/MultiList.pm
Criterion Covered Total %
statement 120 124 96.7
branch 20 22 90.9
condition 17 21 80.9
subroutine 23 23 100.0
pod 7 7 100.0
total 187 197 94.9


line stmt bran cond sub pod time code
1             package Acme::MetaSyntactic::MultiList;
2 11     11   13721 use strict;
  11         13  
  11         292  
3 11     11   349 use Acme::MetaSyntactic (); # do not export metaname and friends
  11         14  
  11         179  
4 11     11   2026 use Acme::MetaSyntactic::RemoteList;
  11         20  
  11         343  
5 11     11   47 use List::Util qw( shuffle );
  11         14  
  11         828  
6 11     11   49 use Carp;
  11         14  
  11         2178  
7              
8             our @ISA = qw( Acme::MetaSyntactic::RemoteList );
9             our $VERSION = '1.000';
10              
11             sub init {
12 10     10 1 74 my ($self, $data) = @_;
13 10         21 my $class = caller(0);
14              
15 10   66     101 $data ||= Acme::MetaSyntactic->load_data($class);
16 11     11   53 no strict 'refs';
  11         23  
  11         4973  
17              
18             # note: variables mentioned twice to avoid a warning
19              
20 10   100     14 my $sep = ${"$class\::Separator"} = ${"$class\::Separator"} ||= '/';
  10         33  
  10         70  
21 10         260 my $tail = qr/$sep?[^$sep]*$/;
22              
23             # compute all categories
24 10         73 my @categories = ( [ $data->{names}, '' ] );
25 10 100       18 while ( my ( $h, $k ) = @{ shift @categories or []} ) {
  65         260  
26 55 100       103 if ( ref $h eq 'HASH' ) {
27             push @categories,
28 15 100       42 map { [ $h->{$_}, ( $k ? "$k$sep$_" : $_ ) ] } keys %$h;
  45         138  
29             }
30             else { # leaf
31 40         252 my @items = split /\s+/, $h;
32 40         78 while ($k) {
33 50         37 push @{ ${"$class\::MultiList"}{$k} }, @items;
  50         39  
  50         258  
34 50         317 $k =~ s!$tail!!;
35             }
36             }
37             }
38              
39 10   50     55 ${"$class\::Default"} = ${"$class\::Default"} = $data->{default} || ':all';
  10         23  
  10         56  
40 10         34 ${"$class\::Theme"} = ${"$class\::Theme"} = ( split /::/, $class )[-1];
  10         23  
  10         43  
41              
42 10         46 *{"$class\::import"} = sub {
43 5     5   27 my $callpkg = caller(0);
44 5         6 my $theme = ${"$class\::Theme"};
  5         22  
45 5         15 my $meta = $class->new;
46 5     1   25 *{"$callpkg\::meta$theme"} = sub { $meta->name(@_) };
  5         1415  
  1         6  
47 10         55 };
48              
49 10         75 ${"$class\::meta"} = ${"$class\::meta"} = $class->new();
  10         75  
  10         93  
50             }
51              
52             sub name {
53 91     91 1 7716 my ( $self, $count ) = @_;
54 91         202 my $class = ref $self;
55              
56 91 50       171 if ( !$class ) { # called as a class method!
57 0         0 $class = $self;
58 11     11   61 no strict 'refs';
  11         15  
  11         1143  
59 0         0 $self = ${"$class\::meta"};
  0         0  
60             }
61              
62 91 100 100     314 if ( defined $count && $count == 0 ) {
63 11     11   43 no strict 'refs';
  11         12  
  11         1517  
64             return wantarray
65 44         437 ? shuffle @{ $self->{base} }
66 44 50       82 : scalar @{ $self->{base} };
  0         0  
67             }
68              
69 47   100     114 $count ||= 1;
70 47         56 my $list = $self->{cache};
71 47 100       38 if ( @{ $self->{base} } ) {
  47         90  
72 45         89 push @$list, shuffle @{ $self->{base} } while @$list < $count;
  48         307  
73             }
74 47         191 splice( @$list, 0, $count );
75             }
76              
77             sub new {
78 18     18 1 6732 my $class = shift;
79              
80 11     11   56 no strict 'refs';
  11         13  
  11         1581  
81 18         55 my $self = bless { @_, cache => [] }, $class;
82              
83             # compute some defaults
84 18   66     43 $self->{category} ||= ${"$class\::Default"};
  4         15  
85              
86             # fall back to last resort (FIXME should we carp()?)
87 1         4 $self->{category} = ${"$class\::Default"}
88             if $self->{category} ne ':all'
89 18 100 100     36 && !exists ${"$class\::MultiList"}{ $self->{category} };
  17         77  
90              
91 18         32 $self->_compute_base();
92 18         23 return $self;
93             }
94              
95             sub _compute_base {
96 73     73   119 my ($self) = @_;
97 73         83 my $class = ref $self;
98              
99             # compute the base list for this category
100 11     11   49 no strict 'refs';
  11         11  
  11         1661  
101 73         65 my %seen;
102             $self->{base} = [
103 680         1419 grep { !$seen{$_}++ }
104 87         70 map { @{ ${"$class\::MultiList"}{$_} } }
  87         72  
  87         443  
105             $self->{category} eq ':all'
106 2         29 ? ( keys %{"$class\::MultiList"} )
107             : ( $self->{category} )
108 73 100       227 ];
109 73         268 return;
110             }
111              
112 32     32 1 159 sub category { $_[0]->{category} }
113              
114             sub categories {
115 7     7 1 531 my $class = shift;
116 7 100       22 $class = ref $class if ref $class;
117              
118 11     11   49 no strict 'refs';
  11         14  
  11         869  
119 7         7 return keys %{"$class\::MultiList"};
  7         54  
120             }
121              
122             sub has_category {
123 6     6 1 433 my ($class, $category) = @_;
124 6 100       13 $class = ref $class if ref $class;
125              
126 11     11   48 no strict 'refs';
  11         15  
  11         899  
127 6         5 return exists ${"$class\::MultiList"}{$category};
  6         37  
128             }
129              
130             sub theme {
131 2   66 2 1 22 my $class = ref $_[0] || $_[0];
132 11     11   46 no strict 'refs';
  11         16  
  11         573  
133 2         3 return ${"$class\::Theme"};
  2         22  
134             }
135              
136             1;
137              
138             __END__