Release limit per dist

lib/CPAN/Testers/Schema/ResultSet/Release.pm

@@ -81,5 +81,53 @@ sub maturity( $self, $maturity ) {
     return $self->search( { 'me.distmat' => $maturity } );
 }
 
+=method limit_per_dist
+
+    $rs = $rs->limit_per_dist( 2 );
+
+Restrict results to a maximum number per distribution.
+
+=cut
+
+sub limit_per_dist( $self, $limit, %args ) {
+    my $seq_sql = q{
+        SELECT COUNT(*)
+        FROM uploads
+        WHERE uploads.dist = me.dist
+        AND uploads.version >= me.version
+    };
+
+    my @bind;
+
+    if ( $args{'maturity'} ) {
+        $seq_sql .= qq{
+            AND me.distmat = ?
+        };
+        push @bind, $args{'maturity'};
+    }
+
+    if ( $args{'author'} ) {
+        $seq_sql .= q{
+            AND uploads.author = ?
+        };
+        push @bind, $args{'author'};
+    };
+
+    $seq_sql = "( $seq_sql ) <= ?";
+
+    push @bind, $limit;
+
+    my $rs = $self->search(
+        {
+            -and => [
+                \[ $seq_sql => @bind ],
+            ],
+        },
+        { join => 'upload' },
+    );
+
+    return $rs;
+}
+
 1;
 __END__

t/resultset/release.t

@@ -208,8 +208,36 @@ my %data = (
     ],
 );
 
-my $schema = prepare_temp_schema;
-$schema->populate( $_, $data{ $_ } ) for keys %data;
+if ( !eval { require Test::mysqld; 1 } ) {
+    plan skip_all => 'Requires Test::mysqld';
+    return;
+}
+
+no warnings 'once';
+my $mysqld = Test::mysqld->new(
+    my_cnf => {
+        'skip-networking' => '', # no TCP socket
+    },
+);
+if ( !$mysqld ) {
+    plan skip_all => "Failed to start up server: $Test::mysqld::errstr";
+    return;
+}
+
+my ( undef, $version ) = DBI->connect( $mysqld->dsn(dbname => 'test') )->selectrow_array( q{SHOW VARIABLES LIKE 'version'} );
+my ( $mversion ) = $version =~ /^(\d+[.]\d+)/;
+if ( $mversion < 5.7 ) {
+    plan skip_all => "Need MySQL version 5.7 or higher. This is $version";
+    return;
+}
+
+my $schema = CPAN::Testers::Schema->connect(
+    $mysqld->dsn(dbname => 'test'), undef, undef, { ignore_version => 1 },
+);
+$schema->deploy;
+
+# Order is important else we can get a FK error on insert
+$schema->populate( $_, $data{ $_ } ) for ( qw/ Upload Stats Release / );
 
 my $rs = $schema->resultset( 'Release' );
 $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
@@ -240,15 +268,44 @@ subtest 'maturity' => sub {
     };
 };
 
+subtest 'limit_per_dist' => sub {
+    my $rs = $schema->resultset( 'Release' )->limit_per_dist( 1 );
+    $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
+    is_deeply [ $rs->all ], [ $data{Release}->@[1,3] ], 'limit 1 result per dist'
+        or diag explain [ $rs->all ];
+};
+
 subtest 'since and maturity' => sub {
      my $rs = $schema->resultset( 'Release' )
        ->since( '2016-08-20T00:00:00' )
        ->maturity( 'stable' );
     $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
-    is_deeply [ $rs->all ], [ $data{Release}->@[1..2] ], 'get stable items since 2016-08-20'
+    is_deeply [ $rs->all ], [ $data{Release}->@[1,2] ], 'get stable items since 2016-08-20'
+        or diag explain [ $rs->all ];
+};
+
+subtest 'since and limit_per_dist' => sub {
+     my $rs = $schema->resultset( 'Release' )
+       ->since( '2016-08-20T00:00:00' )
+       ->limit_per_dist( 1 );
+    $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
+    is_deeply [ $rs->all ], [ $data{Release}->@[1,3] ], 'get one item per dist since 2016-08-20'
+        or diag explain [ $rs->all ];
+};
+
+subtest 'maturity and limit_per_dist' => sub {
+    my $rs = $schema->resultset( 'Release' )
+       ->maturity( 'stable' )
+       ->limit_per_dist( 1, maturity => 1 );
+    $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
+$schema->storage->debug(1);
+    my $res = $rs->all;
+$schema->storage->debug(0);
+    is_deeply [ $rs->all ], [ $data{Release}->@[1,2] ], 'get one stable item per dist'
         or diag explain [ $rs->all ];
 };
 
+
 subtest 'by_dist' => sub {
     my $rs = $schema->resultset( 'Release' )->by_dist( 'My-Dist' );
     $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
@@ -271,6 +328,13 @@ subtest 'by_dist' => sub {
             or diag explain [ $rs->all ];
     };
 
+    subtest 'limit_per_dist' => sub {
+        my $rs = $schema->resultset( 'Release' )->by_dist( 'My-Dist' )
+                ->limit_per_dist( 1 );
+        $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
+        is_deeply [ $rs->all ], [ $data{Release}[1] ], 'get maximum 1 item for My-Dist'
+            or diag explain [ $rs->all ];
+    };
 };
 
 subtest 'by_author' => sub {
@@ -294,6 +358,14 @@ subtest 'by_author' => sub {
         is_deeply [ $rs->all ], [ $data{Release}[3] ], 'get dev items for PREACTION'
             or diag explain [ $rs->all ];
     };
+
+    subtest 'limit_per_dist' => sub {
+        my $rs = $schema->resultset( 'Release' )->by_author( 'PREACTION' )
+                ->limit_per_dist( 1, author => 'PREACTION' );
+        $rs->result_class( 'DBIx::Class::ResultClass::HashRefInflator' );
+        is_deeply [ $rs->all ], [ $data{Release}->@[0,3] ], 'get maximum 1 item for each PREACTION dist'
+            or diag explain [ $rs->all ];
+    };
 };
 
 done_testing;