support history API for CPANMetaDB

Perl-Toolchain-Gang · Apr 30, 2015 · fda6083 · fda6083
1 parent 11e979f
commit fda6083
Show file tree

Hide file tree

Showing 2 changed files with 72 additions and 10 deletions.
diff --git a/lib/CPAN/Common/Index/MetaDB.pm b/lib/CPAN/Common/Index/MetaDB.pm
@@ -13,6 +13,7 @@ use Class::Tiny qw/uri/;
 
 use Carp;
 use CPAN::Meta::YAML;
+use CPAN::Meta::Requirements;
 use HTTP::Tiny;
 
 =attr uri
@@ -38,25 +39,61 @@ sub search_packages {
     Carp::croak("Argument to search_packages must be hash reference")
       unless ref $args eq 'HASH';
 
-    # only support direct package query
     return
-      unless keys %$args == 1 && exists $args->{package} && ref $args->{package} eq '';
+      unless exists $args->{package} && ref $args->{package} eq '';
 
     my $mod = $args->{package};
-    my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
-    return unless $res->{success};
 
-    if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
-        my $meta = $yaml->[0];
-        if ( $meta && $meta->{distfile} ) {
-            my $file = $meta->{distfile};
+    if ($args->{version} || $args->{version_range}) {
+        my $res = HTTP::Tiny->new->get( $self->uri . "history/$mod" );
+        return unless $res->{success};
+
+        my $range = defined $args->{version} ? "== $args->{version}" : $args->{version_range};
+        my $reqs = CPAN::Meta::Requirements->from_string_hash({ $mod => $range });
+
+        my @found;
+        for my $line ( split /\r?\n/, $res->{content} ) {
+            if ($line =~ /^$mod\s+(\S+)\s+(\S+)$/) {
+                push @found, {
+                    version => $1,
+                    version_o => version::->parse($1),
+                    distfile => $2,
+                };
+            }
+        }
+
+        my $match;
+        for my $try (sort { $b->{version_o} <=> $a->{version_o} } @found) {
+            if ($reqs->accepts_module($mod => $try->{version_o})) {
+                $match = $try, last;
+            }
+        }
+
+        if ($match) {
+            my $file = $match->{distfile};
             $file =~ s{^./../}{}; # strip leading
             return {
                 package => $mod,
-                version => $meta->{version},
+                version => $match->{version},
                 uri     => "cpan:///distfile/$file",
             };
         }
+    } else {
+        my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
+        return unless $res->{success};
+
+        if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
+            my $meta = $yaml->[0];
+            if ( $meta && $meta->{distfile} ) {
+                my $file = $meta->{distfile};
+                $file =~ s{^./../}{}; # strip leading
+                return {
+                    package => $mod,
+                    version => $meta->{version},
+                    uri     => "cpan:///distfile/$file",
+                };
+            }
+        }
     }
 
     return;
@@ -76,6 +113,9 @@ sub search_authors { return };    # not supported
 
   $index = CPAN::Common::Index::MetaDB->new;
 
+  $index->search_packages({ package => "Moose" });
+  $index->search_packages({ package => "Moose", version_range => ">= 2.0" });
+
 =head1 DESCRIPTION
 
 This module implements a CPAN::Common::Index that searches for packages against

diff --git a/t/metadb.t b/t/metadb.t
@@ -28,7 +28,7 @@ subtest "constructor tests" => sub {
     # uri specified
     new_ok(
         'CPAN::Common::Index::MetaDB' => [ { uri => "http://example.com" } ],
-        "new with cache"
+        "new with uri"
     );
 
 };
@@ -47,6 +47,28 @@ subtest 'find package' => sub {
 
 };
 
+subtest 'find package with fixed version' => sub {
+    my $index = new_ok("CPAN::Common::Index::MetaDB");
+
+    my $got = $index->search_packages( { package => 'Moose', version => '2.1404' } );
+    ok( $got,                    "found package" );
+    is( $got->{version}, 2.1404, "has a version" );
+    is(
+        $got->{uri},
+        "cpan:///distfile/ETHER/Moose-2.1404.tar.gz",
+        "uri is OK"
+    );
+
+};
+
+subtest 'find package with version range' => sub {
+    my $index = new_ok("CPAN::Common::Index::MetaDB");
+
+    my $got = $index->search_packages( { package => 'Moose', version_range => '< 2.14' } );
+    ok( $got,                    "found package" );
+    ok( $got->{version} <  2.14, "has a version" );
+};
+
 done_testing;
 # COPYRIGHT
 # vim: ts=4 sts=4 sw=4 et: