Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Parser / IteratorFactory.pm
1 package TAP::Parser::IteratorFactory;
2
3 use strict;
4 use warnings;
5
6 use Carp qw( confess );
7 use File::Basename qw( fileparse );
8
9 use base 'TAP::Object';
10
11 use constant handlers => [];
12
13 =head1 NAME
14
15 TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source
16
17 =head1 VERSION
18
19 Version 3.39
20
21 =cut
22
23 our $VERSION = '3.39';
24
25 =head1 SYNOPSIS
26
27   use TAP::Parser::IteratorFactory;
28   my $factory = TAP::Parser::IteratorFactory->new({ %config });
29   my $iterator  = $factory->make_iterator( $filename );
30
31 =head1 DESCRIPTION
32
33 This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the
34 registered L<TAP::Parser::SourceHandler>s to see which one should handle the source.
35
36 If you're a plugin author, you'll be interested in how to L</register_handler>s,
37 how L</detect_source> works.
38
39 =head1 METHODS
40
41 =head2 Class Methods
42
43 =head3 C<new>
44
45 Creates a new factory class:
46
47   my $sf = TAP::Parser::IteratorFactory->new( $config );
48
49 C<$config> is optional.  If given, sets L</config> and calls L</load_handlers>.
50
51 =cut
52
53 sub _initialize {
54     my ( $self, $config ) = @_;
55     $self->config( $config || {} )->load_handlers;
56     return $self;
57 }
58
59 =head3 C<register_handler>
60
61 Registers a new L<TAP::Parser::SourceHandler> with this factory.
62
63   __PACKAGE__->register_handler( $handler_class );
64
65 =head3 C<handlers>
66
67 List of handlers that have been registered.
68
69 =cut
70
71 sub register_handler {
72     my ( $class, $dclass ) = @_;
73
74     confess("$dclass must implement can_handle & make_iterator methods!")
75       unless UNIVERSAL::can( $dclass, 'can_handle' )
76           && UNIVERSAL::can( $dclass, 'make_iterator' );
77
78     my $handlers = $class->handlers;
79     push @{$handlers}, $dclass
80       unless grep { $_ eq $dclass } @{$handlers};
81
82     return $class;
83 }
84
85 ##############################################################################
86
87 =head2 Instance Methods
88
89 =head3 C<config>
90
91  my $cfg = $sf->config;
92  $sf->config({ Perl => { %config } });
93
94 Chaining getter/setter for the configuration of the available source handlers.
95 This is a hashref keyed on handler class whose values contain config to be passed
96 onto the handlers during detection & creation.  Class names may be fully qualified
97 or abbreviated, eg:
98
99   # these are equivalent
100   $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } });
101   $sf->config({ 'Perl' => { %config } });
102
103 =cut
104
105 sub config {
106     my $self = shift;
107     return $self->{config} unless @_;
108     unless ( 'HASH' eq ref $_[0] ) {
109         $self->_croak('Argument to &config must be a hash reference');
110     }
111     $self->{config} = shift;
112     return $self;
113 }
114
115 sub _last_handler {
116     my $self = shift;
117     return $self->{last_handler} unless @_;
118     $self->{last_handler} = shift;
119     return $self;
120 }
121
122 sub _testing {
123     my $self = shift;
124     return $self->{testing} unless @_;
125     $self->{testing} = shift;
126     return $self;
127 }
128
129 ##############################################################################
130
131 =head3 C<load_handlers>
132
133  $sf->load_handlers;
134
135 Loads the handler classes defined in L</config>.  For example, given a config:
136
137   $sf->config({
138     MySourceHandler => { some => 'config' },
139   });
140
141 C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in
142 C<@INC> for it in this order:
143
144   TAP::Parser::SourceHandler::MySourceHandler
145   MySourceHandler
146
147 C<croak>s on error.
148
149 =cut
150
151 sub load_handlers {
152     my ($self) = @_;
153     for my $handler ( keys %{ $self->config } ) {
154         my $sclass = $self->_load_handler($handler);
155
156         # TODO: store which class we loaded anywhere?
157     }
158     return $self;
159 }
160
161 sub _load_handler {
162     my ( $self, $handler ) = @_;
163
164     my @errors;
165     for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) {
166         return $dclass
167           if UNIVERSAL::can( $dclass, 'can_handle' )
168               && UNIVERSAL::can( $dclass, 'make_iterator' );
169
170         eval "use $dclass";
171         if ( my $e = $@ ) {
172             push @errors, $e;
173             next;
174         }
175
176         return $dclass
177           if UNIVERSAL::can( $dclass, 'can_handle' )
178               && UNIVERSAL::can( $dclass, 'make_iterator' );
179         push @errors,
180           "handler '$dclass' does not implement can_handle & make_iterator";
181     }
182
183     $self->_croak(
184         "Cannot load handler '$handler': " . join( "\n", @errors ) );
185 }
186
187 ##############################################################################
188
189 =head3 C<make_iterator>
190
191   my $iterator = $src_factory->make_iterator( $source );
192
193 Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler>
194 to use to create a L<TAP::Parser::Iterator> (see L</detect_source>).  Dies on error.
195
196 =cut
197
198 sub make_iterator {
199     my ( $self, $source ) = @_;
200
201     $self->_croak('no raw source defined!') unless defined $source->raw;
202
203     $source->config( $self->config )->assemble_meta;
204
205     # is the raw source already an object?
206     return $source->raw
207       if ( $source->meta->{is_object}
208         && UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) );
209
210     # figure out what kind of source it is
211     my $sd_class = $self->detect_source($source);
212     $self->_last_handler($sd_class);
213
214     return if $self->_testing;
215
216     # create it
217     my $iterator = $sd_class->make_iterator($source);
218
219     return $iterator;
220 }
221
222 =head3 C<detect_source>
223
224 Given a L<TAP::Parser::Source>, detects what kind of source it is and
225 returns I<one> L<TAP::Parser::SourceHandler> (the most confident one).  Dies
226 on error.
227
228 The detection algorithm works something like this:
229
230   for (@registered_handlers) {
231     # ask them how confident they are about handling this source
232     $confidence{$handler} = $handler->can_handle( $source )
233   }
234   # choose the most confident handler
235
236 Ties are handled by choosing the first handler.
237
238 =cut
239
240 sub detect_source {
241     my ( $self, $source ) = @_;
242
243     confess('no raw source ref defined!') unless defined $source->raw;
244
245     # find a list of handlers that can handle this source:
246     my %handlers;
247     for my $dclass ( @{ $self->handlers } ) {
248         my $confidence = $dclass->can_handle($source);
249
250         # warn "handler: $dclass: $confidence\n";
251         $handlers{$dclass} = $confidence if $confidence;
252     }
253
254     if ( !%handlers ) {
255
256         # use Data::Dump qw( pp );
257         # warn pp( $meta );
258
259         # error: can't detect source
260         my $raw_source_short = substr( ${ $source->raw }, 0, 50 );
261         confess("Cannot detect source of '$raw_source_short'!");
262         return;
263     }
264
265     # if multiple handlers can handle it, choose the most confident one
266     my @handlers = (
267         map    {$_}
268           sort { $handlers{$a} cmp $handlers{$b} }
269           keys %handlers
270     );
271
272     # this is really useful for debugging handlers:
273     if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) {
274         warn(
275             "votes: ",
276             join( ', ', map {"$_: $handlers{$_}"} @handlers ),
277             "\n"
278         );
279     }
280
281     # return 1st
282     return pop @handlers;
283 }
284
285 1;
286
287 __END__
288
289 =head1 SUBCLASSING
290
291 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
292
293 =head2 Example
294
295 If we've done things right, you'll probably want to write a new source,
296 rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that).
297
298 But in case you find the need to...
299
300   package MyIteratorFactory;
301
302   use strict;
303
304   use base 'TAP::Parser::IteratorFactory';
305
306   # override source detection algorithm
307   sub detect_source {
308     my ($self, $raw_source_ref, $meta) = @_;
309     # do detective work, using $meta and whatever else...
310   }
311
312   1;
313
314 =head1 AUTHORS
315
316 Steve Purkis
317
318 =head1 ATTRIBUTION
319
320 Originally ripped off from L<Test::Harness>.
321
322 Moved out of L<TAP::Parser> & converted to a factory class to support
323 extensible TAP source detective work by Steve Purkis.
324
325 =head1 SEE ALSO
326
327 L<TAP::Object>,
328 L<TAP::Parser>,
329 L<TAP::Parser::SourceHandler>,
330 L<TAP::Parser::SourceHandler::File>,
331 L<TAP::Parser::SourceHandler::Perl>,
332 L<TAP::Parser::SourceHandler::RawTAP>,
333 L<TAP::Parser::SourceHandler::Handle>,
334 L<TAP::Parser::SourceHandler::Executable>
335
336 =cut
337