File Coverage

lib/Badger/Factory/Class.pm
Criterion Covered Total %
statement 32 44 72.7
branch 8 12 66.6
condition 4 9 44.4
subroutine 6 9 66.6
pod 5 5 100.0
total 55 79 69.6


line stmt bran cond sub pod time code
1             #========================================================================
2             #
3             # Badger::Factory::Class
4             #
5             # DESCRIPTION
6             # Subclass of Badger::Class for creating Badger::Factory sub-classes.
7             #
8             # AUTHOR
9             # Andy Wardley
10             #
11             #========================================================================
12              
13             package Badger::Factory::Class;
14              
15 24     24   615 use Carp;
  24         42  
  24         1984  
16             use Badger::Class
17 24         201 version => 0.01,
18             debug => 0,
19             uber => 'Badger::Class',
20             hooks => 'item path names default',
21             words => 'ITEM ITEMS',
22             utils => 'plural permute_fragments',
23             import => 'CLASS',
24             constants => 'DELIMITER ARRAY HASH',
25             constant => {
26             PATH_SUFFIX => '_PATH',
27             NAMES_SUFFIX => '_NAMES',
28             FACTORY => 'Badger::Factory',
29 24     24   133 };
  24         48  
30             # chicken and egg
31             # exports => {
32             # fail => \&_export_fail_hook,
33             # };
34              
35             CLASS->export_before(\&_export_before_hook);
36             CLASS->export_fail(\&_export_fail_hook);
37              
38             # catch a hook that has the same name as the items, i.e. widgets
39              
40             sub _export_before_hook {
41 24     24   58 my ($class, $target) = @_;
42 24         67 my $klass = class($target, $class);
43             # special-case: we don't want to force the factory base class on
44             # Badger::Class if it's loading this module as the uber parent of a
45             # Factory::Class subclass (e.g. Template::TT3::Factory::Class).
46 24 50       78 return if $target eq 'Badger::Class';
47 24         34 $class->debug("$class setting $klass ($target) base class to ", $class->FACTORY)
48             if DEBUG;
49 24         181 $klass->base($class->FACTORY);
50             }
51              
52              
53             sub _export_fail_hook {
54 48     48   114 my ($class, $target, $symbol, $symbols) = @_;
55 48         116 my $klass = class($target, $class);
56 48         191 my $items = $klass->var(ITEMS);
57              
58             # look for $ITEMS or fall back on plural($ITEM)
59 48 50       145 unless ($items) {
60 48         149 my $item = $klass->var(ITEM);
61 48 100       243 $items = plural($item) if $item;
62             }
63              
64             # $target->debug("looking for $items to match $symbol\n");
65              
66             # if the import symbols matches $items (e.g. widgets) then push the
67             # next argument into the relevant package var (e.g. $WIDGETS)
68 48 100 100     200 if ($items && $items eq $symbol) {
69 1 50       3 croak "You didn't specify a value for the '$items' load option."
70             unless @$symbols;
71 1         4 $klass->var( uc($items) => shift @$symbols );
72             }
73             else {
74 47         200 $class->_export_fail($target, $symbol, $symbols);
75             }
76             }
77              
78              
79             sub default {
80 0     0 1 0 my ($self, $item) = @_;
81 0         0 $self->var( DEFAULT => $item );
82 0         0 return $self;
83             }
84              
85              
86             sub item {
87 24     24 1 63 my ($self, $item) = @_;
88 24         90 $self->var( ITEM => $item );
89 24         89 return $self;
90             }
91              
92              
93             sub items {
94 0     0 1 0 my ($self, $items) = @_;
95 0         0 $self->var( ITEMS => $items );
96 0         0 return $self;
97             }
98              
99              
100             sub path {
101 23     23 1 59 my ($self, $path) = @_;
102 23   33     65 my $type = $self->var(ITEM)
103             || croak "\$ITEM is not defined for $self. Please add an 'item' option";
104 23         80 my $var = uc($type) . PATH_SUFFIX;
105              
106 23 50       212 $path = [ map { permute_fragments($_) } split(DELIMITER, $path) ]
  31         155  
107             unless ref $path eq ARRAY;
108              
109 23         42 $self->debug("adding $var => [", join(', ', @$path), "]") if DEBUG;
110             # $self->base(FACTORY);
111              
112             # we use import_symbol() rather than var() so that it gets declared
113             # properly, thus avoiding undefined symbol warnings
114 23         163 $self->import_symbol( $var => \$path );
115            
116 23         105 return $self;
117             }
118              
119              
120             sub names {
121 0     0 1   my ($self, $map) = @_;
122 0   0       my $type = $self->var(ITEM)
123             || croak "\$ITEM is not defined for $self. Please add an 'item' option";
124 0           my $var = uc($type) . NAMES_SUFFIX;
125              
126 0           $self->debug("$self adding names $var => {", join(', ', %$map), "}") if DEBUG;
127              
128             # we use import_symbol() rather than var() so that it gets declared
129             # properly, thus avoiding undefined symbol warnings
130 0           $self->import_symbol( $var => \$map );
131            
132 0           return $self;
133             }
134              
135              
136             =head1 NAME
137              
138             Badger::Factory::Class - class module for Badger::Factory sub-classes
139              
140             =head1 SYNOPSIS
141              
142             This module can be used to create subclasses of L.
143              
144             package My::Widgets;
145            
146             use Badger::Factory::Class
147             version => 0.01,
148             item => 'widget',
149             path => 'My::Widget Your::Widget',
150             widgets => {
151             extra => 'Another::Widget::Module',
152             super => 'Golly::Gosh',
153             },
154             names => {
155             html => 'HTML',
156             color => 'Colour',
157             };
158              
159             package main;
160            
161             # class method
162             my $widget = My::Widgets->widget( foo => @args );
163            
164             # object method
165             my $widgets = My::Widgets->new;
166             my $widget = $widgets->widget( foo => @args );
167              
168             =head1 DESCRIPTION
169              
170             This module is a subclass of L specialised for the purpose
171             of creating L subclasses. It is used by the
172             L module among others.
173              
174             =head1 METHODS
175              
176             The following methods are provided in addition to those inherited
177             from the L base class.
178              
179             =head2 item($name)
180              
181             The singular name of the item that the factory manages. This is used
182             to set the C<$ITEM> package variable for L to use.
183              
184             =head2 items($name)
185              
186             The plural name of the item that the factory manages. This is used
187             to set the C<$ITEMS> package variable for L to use.
188              
189             =head2 path($name)
190              
191             A list of module names that form the search path when loading modules. This
192             will set the relevant package variable depending on the value of C<$ITEMS> (or
193             the regular plural form of C<$ITEM> if C<$ITEMS> is undefined). For example,
194             is C<$ITEMS> is set to C then this method will set C<$WIDGETS_PATH>.
195              
196             You can specify the path as a reference to a list of module bases, e.g.
197              
198             use Badger::Factory::Class
199             item => 'widget',
200             path => ['My::Widget', 'Your::Widget'];
201              
202             Or as a single string containing multiple values separated by whitespace.
203              
204             use Badger::Factory::Class
205             item => 'widget',
206             path => 'My::Widget Your::Widget';
207              
208             If you specify it as a single string then you can also include optional
209             and/or alternate parts in parentheses. For example the above can be
210             written more concisely as:
211              
212             use Badger::Factory::Class
213             item => 'widget',
214             path => '(My|Your)::Widget';
215              
216             If the parentheses don't contain a vertical bar then then enclosed fragment
217             is treated as being optional. So instead of writing something like:
218              
219             use Badger::Factory::Class
220             item => 'widget',
221             path => 'Badger::Widget BadgerX::Widget';
222              
223             You can write:
224              
225             use Badger::Factory::Class
226             item => 'widget',
227             path => 'Badger(X)::Widget';
228              
229             See the L function in
230             L for further details on how fragments are expanded.
231              
232             =head2 names($names)
233              
234             A reference to a hash array of name mappings. This can be used to handle any
235             unusual spellings or capitalisations. See L for further
236             details.
237              
238             =head2 default($name)
239              
240             The default name to use when none is specified in a request for a module.
241              
242             =head1 AUTHOR
243              
244             Andy Wardley L
245              
246             =head1 COPYRIGHT
247              
248             Copyright (C) 2006-2009 Andy Wardley. All Rights Reserved.
249              
250             This module is free software; you can redistribute it and/or
251             modify it under the same terms as Perl itself.
252              
253             =head1 SEE ALSO
254              
255             L, L
256              
257             =cut
258              
259             # Local Variables:
260             # mode: perl
261             # perl-indent-level: 4
262             # indent-tabs-mode: nil
263             # End:
264             #
265             # vim: expandtab shiftwidth=4:
266              
267              
268              
269             1;