1package TAP::Parser::IteratorFactory;
2
3use strict;
4use warnings;
5
6use Carp qw( confess );
7use File::Basename qw( fileparse );
8
9use base 'TAP::Object';
10
11use constant handlers => [];
12
13=head1 NAME
14
15TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source
16
17=head1 VERSION
18
19Version 3.48
20
21=cut
22
23our $VERSION = '3.48';
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
33This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the
34registered L<TAP::Parser::SourceHandler>s to see which one should handle the source.
35
36If you're a plugin author, you'll be interested in how to L</register_handler>s,
37how L</detect_source> works.
38
39=head1 METHODS
40
41=head2 Class Methods
42
43=head3 C<new>
44
45Creates a new factory class:
46
47  my $sf = TAP::Parser::IteratorFactory->new( $config );
48
49C<$config> is optional.  If given, sets L</config> and calls L</load_handlers>.
50
51=cut
52
53sub _initialize {
54    my ( $self, $config ) = @_;
55    $self->config( $config || {} )->load_handlers;
56    return $self;
57}
58
59=head3 C<register_handler>
60
61Registers a new L<TAP::Parser::SourceHandler> with this factory.
62
63  __PACKAGE__->register_handler( $handler_class );
64
65=head3 C<handlers>
66
67List of handlers that have been registered.
68
69=cut
70
71sub 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
94Chaining getter/setter for the configuration of the available source handlers.
95This is a hashref keyed on handler class whose values contain config to be passed
96onto the handlers during detection & creation.  Class names may be fully qualified
97or abbreviated, eg:
98
99  # these are equivalent
100  $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } });
101  $sf->config({ 'Perl' => { %config } });
102
103=cut
104
105sub 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
115sub _last_handler {
116    my $self = shift;
117    return $self->{last_handler} unless @_;
118    $self->{last_handler} = shift;
119    return $self;
120}
121
122sub _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
135Loads the handler classes defined in L</config>.  For example, given a config:
136
137  $sf->config({
138    MySourceHandler => { some => 'config' },
139  });
140
141C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in
142C<@INC> for it in this order:
143
144  TAP::Parser::SourceHandler::MySourceHandler
145  MySourceHandler
146
147C<croak>s on error.
148
149=cut
150
151sub 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
161sub _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
193Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler>
194to use to create a L<TAP::Parser::Iterator> (see L</detect_source>).  Dies on error.
195
196=cut
197
198sub 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
224Given a L<TAP::Parser::Source>, detects what kind of source it is and
225returns I<one> L<TAP::Parser::SourceHandler> (the most confident one).  Dies
226on error.
227
228The 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
236Ties are handled by choosing the first handler.
237
238=cut
239
240sub 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 %confidence_for;
247    for my $handler ( @{ $self->handlers } ) {
248        my $confidence = $handler->can_handle($source);
249        # warn "handler: $handler: $confidence\n";
250        $confidence_for{$handler} = $confidence if $confidence;
251    }
252
253    if ( !%confidence_for ) {
254        # error: can't detect source
255        my $raw_source_short = substr( ${ $source->raw }, 0, 50 );
256        confess("Cannot detect source of '$raw_source_short'!");
257        return;
258    }
259
260    # if multiple handlers can handle it, choose the most confident one
261    my @handlers =
262          sort { $confidence_for{$b} <=> $confidence_for{$a} }
263          keys %confidence_for;
264
265    # Check for a tie.
266    if( @handlers > 1 &&
267        $confidence_for{$handlers[0]} == $confidence_for{$handlers[1]}
268    ) {
269        my $filename = $source->meta->{file}{basename};
270        die("There is a tie between $handlers[0] and $handlers[1].\n".
271            "Both voted $confidence_for{$handlers[0]} on $filename.\n");
272    }
273
274    # this is really useful for debugging handlers:
275    if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) {
276        warn(
277            "votes: ",
278            join( ', ', map {"$_: $confidence_for{$_}"} @handlers ),
279            "\n"
280        );
281    }
282
283    # return 1st
284    return $handlers[0];
285}
286
2871;
288
289__END__
290
291=head1 SUBCLASSING
292
293Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
294
295=head2 Example
296
297If we've done things right, you'll probably want to write a new source,
298rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that).
299
300But in case you find the need to...
301
302  package MyIteratorFactory;
303
304  use strict;
305
306  use base 'TAP::Parser::IteratorFactory';
307
308  # override source detection algorithm
309  sub detect_source {
310    my ($self, $raw_source_ref, $meta) = @_;
311    # do detective work, using $meta and whatever else...
312  }
313
314  1;
315
316=head1 AUTHORS
317
318Steve Purkis
319
320=head1 ATTRIBUTION
321
322Originally ripped off from L<Test::Harness>.
323
324Moved out of L<TAP::Parser> & converted to a factory class to support
325extensible TAP source detective work by Steve Purkis.
326
327=head1 SEE ALSO
328
329L<TAP::Object>,
330L<TAP::Parser>,
331L<TAP::Parser::SourceHandler>,
332L<TAP::Parser::SourceHandler::File>,
333L<TAP::Parser::SourceHandler::Perl>,
334L<TAP::Parser::SourceHandler::RawTAP>,
335L<TAP::Parser::SourceHandler::Handle>,
336L<TAP::Parser::SourceHandler::Executable>
337
338=cut
339
340