File Coverage

blib/lib/CPAN/Common/Index/Mux/Ordered.pm
Criterion Covered Total %
statement 38 74 51.3
branch 9 24 37.5
condition 1 6 16.6
subroutine 8 11 72.7
pod 4 5 80.0
total 60 120 50.0


line stmt bran cond sub pod time code
1 2     2   1485 use 5.008001;
  2         7  
2 2     2   9 use strict;
  2         5  
  2         40  
3 2     2   8 use warnings;
  2         4  
  2         88  
4              
5             package CPAN::Common::Index::Mux::Ordered;
6             # ABSTRACT: Consult indices in order and return the first result
7              
8             our $VERSION = '0.007';
9              
10 2     2   398 use parent 'CPAN::Common::Index';
  2         237  
  2         12  
11              
12 2     2   101 use Class::Tiny qw/resolvers/;
  2         4  
  2         9  
13              
14 2     2   705 use Module::Load ();
  2         757  
  2         954  
15              
16             #pod =attr resolvers
17             #pod
18             #pod An array reference of CPAN::Common::Index::* objects
19             #pod
20             #pod =cut
21              
22             sub BUILD {
23 5     5 0 5364 my $self = shift;
24              
25 5         100 my $resolvers = $self->resolvers;
26 5 100       33 $resolvers = [] unless defined $resolvers;
27 5 100       18 if ( ref $resolvers ne 'ARRAY' ) {
28 1         184 Carp::croak("The 'resolvers' argument must be an array reference");
29             }
30 4         10 for my $r (@$resolvers) {
31 4 50       6 if ( !eval { $r->isa("CPAN::Common::Index") } ) {
  4         28  
32 0         0 Carp::croak("Resolver '$r' is not a CPAN::Common::Index object");
33             }
34             }
35 4         59 $self->resolvers($resolvers);
36              
37 4         24 return;
38             }
39              
40             #pod =method assemble
41             #pod
42             #pod $index = CPAN::Common::Index::Mux::Ordered->assemble(
43             #pod MetaDB => {},
44             #pod Mirror => { mirror => "http://www.cpan.org" },
45             #pod );
46             #pod
47             #pod This class method provides a shorthand for constructing a multiplexer.
48             #pod The arguments must be pairs of subclass suffixes and arguments. For
49             #pod example, "MetaDB" means to use "CPAN::Common::Index::MetaDB". Empty
50             #pod arguments must be given as an empty hash reference.
51             #pod
52             #pod =cut
53              
54             sub assemble {
55 0     0 1 0 my ( $class, @backends ) = @_;
56              
57 0         0 my @resolvers;
58              
59 0         0 while (@backends) {
60 0         0 my ( $subclass, $config ) = splice @backends, 0, 2;
61 0         0 my $full_class = "CPAN::Common::Index::${subclass}";
62 0 0       0 eval { Module::Load::load($full_class); 1 }
  0         0  
  0         0  
63             or Carp::croak($@);
64 0         0 my $object = $full_class->new($config);
65 0         0 push @resolvers, $object;
66             }
67              
68 0         0 return $class->new( { resolvers => \@resolvers } );
69             }
70              
71             sub validate_attributes {
72 0     0 1 0 my ($self) = @_;
73 0         0 my $resolvers = $self->resolvers;
74 0         0 return 1;
75             }
76              
77             # have to think carefully about the sematics of regex search when indices
78             # are stacked; only one result for any given package (or package/version)
79             sub search_packages {
80 11     11 1 8600 my ( $self, $args ) = @_;
81 11 50       39 Carp::croak("Argument to search_packages must be hash reference")
82             unless ref $args eq 'HASH';
83 11         21 my @found;
84 11 50 33     46 if ( $args->{name} and ref $args->{name} eq '' ) {
85             # looking for exact match, so we just want the first hit
86 0         0 for my $source ( @{ $self->resolvers } ) {
  0         0  
87 0 0       0 if ( my @result = $source->search_packages($args) ) {
88             # XXX double check against remaining $args
89 0         0 push @found, @result;
90 0         0 last;
91             }
92             }
93             }
94             else {
95             # accumulate results from all resolvers
96 11         19 my %seen;
97 11         21 for my $source ( @{ $self->resolvers } ) {
  11         287  
98 19         125 my @result = $source->search_packages($args);
99 19         59 push @found, grep { !$seen{ $_->{package} }++ } @result;
  15         111  
100             }
101             }
102 11 100       72 return wantarray ? @found : $found[0];
103             }
104              
105             # have to think carefully about the sematics of regex search when indices
106             # are stacked; only one result for any given package (or package/version)
107             sub search_authors {
108 0     0 1   my ( $self, $args ) = @_;
109 0 0         Carp::croak("Argument to search_authors must be hash reference")
110             unless ref $args eq 'HASH';
111 0           my @found;
112 0 0 0       if ( $args->{name} and ref $args->{name} eq '' ) {
113             # looking for exact match, so we just want the first hit
114 0           for my $source ( @{ $self->resolvers } ) {
  0            
115 0 0         if ( my @result = $source->search_authors($args) ) {
116             # XXX double check against remaining $args
117 0           push @found, @result;
118 0           last;
119             }
120             }
121             }
122             else {
123             # accumulate results from all resolvers
124 0           my %seen;
125 0           for my $source ( @{ $self->resolvers } ) {
  0            
126 0           my @result = $source->search_authors($args);
127 0           push @found, grep { !$seen{ $_->{package} }++ } @result;
  0            
128             }
129             }
130 0 0         return wantarray ? @found : $found[0];
131             }
132              
133             1;
134              
135              
136             # vim: ts=4 sts=4 sw=4 et:
137              
138             __END__