add classes for perl version metadata tables

These classes allow access to the `perl_version` table, which stores metadata about released Perl versions. Fixes #13
cpan-testers · Apr 22, 2018 · 8c53bbf · 8c53bbf
1 parent 63b0f6e
commit 8c53bbf
Show file tree

Hide file tree

Showing 8 changed files with 322 additions and 4 deletions.
diff --git a/lib/CPAN/Testers/Schema/Result/PerlVersion.pm b/lib/CPAN/Testers/Schema/Result/PerlVersion.pm
@@ -0,0 +1,126 @@
+use utf8;
+package CPAN::Testers::Schema::Result::PerlVersion;
+our $VERSION = '0.023';
+# ABSTRACT: Metadata about Perl versions
+
+=head1 SYNOPSIS
+
+    my $perl = $schema->resultset( 'PerlVersion' )->find( '5.26.0' );
+    say "Stable" unless $perl->devel;
+
+    $schema->resultset( 'PerlVersion' )->find_or_create({
+        version => '5.30.0',    # Version reported by Perl
+        perl => '5.30.0',       # Parsed Perl version string
+        patch => 0,             # Has patches applied
+        devel => 0,             # Is development version (odd minor version)
+    });
+
+    # Fill in metadata automatically
+    $schema->resultset( 'PerlVersion' )->find_or_create({
+        version => '5.31.0 patch 1231',
+        # devel will be set to 1
+        # patch will be set to 1
+        # perl will be set to 5.31.0
+    });
+
+=head1 DESCRIPTION
+
+This table holds metadata about known Perl versions. Through this table we can
+quickly list which Perl versions are stable/development.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Row>, L<CPAN::Testers::Schema>
+
+=cut
+
+use CPAN::Testers::Schema::Base 'Result';
+
+table 'perl_version';
+
+=attr version
+
+The Perl version reported by the tester. This is the primary key.
+
+=cut
+
+primary_column version => {
+    data_type => 'varchar',
+    size => 255,
+    is_nullable => 0,
+};
+
+=attr perl
+
+The parsed version of Perl in C<REVISION.VERSION.SUBVERSION> format.
+
+If not specified when creating a new row, the Perl version will be parsed
+and this field updated accordingly.
+
+=cut
+
+column perl => {
+    data_type => 'varchar',
+    size => 32,
+    is_nullable => 1,
+};
+
+=attr patch
+
+If true (C<1>), this Perl has patches applied. Defaults to false (C<0>).
+
+If not specified when creating a new row, the Perl version will be parsed
+and this field updated accordingly.
+
+=cut
+
+column patch => {
+    data_type => 'tinyint',
+    size => 1,
+    default_value => 0,
+};
+
+=attr devel
+
+If true (C<1>), this Perl is a development Perl version. Development Perl
+versions have an odd C<VERSION> field (the second number) like C<5.27.0>,
+C<5.29.0>, C<5.31.0>, etc... Release candidates (like C<5.28.0 RC0>) are
+also considered development versions.
+
+If not specified when creating a new row, the Perl version will be parsed
+and this field updated accordingly.
+
+=cut
+
+column devel => {
+    data_type => 'tinyint',
+    size => 1,
+    default_value => 0,
+};
+
+=method new
+
+The constructor will automatically fill in any missing information based
+on the supplied C<version> field.
+
+=cut
+
+sub new( $class, $attrs ) {
+    if ( !$attrs->{perl} ) {
+        ( $attrs->{perl} ) = $attrs->{version} =~ m{^v?(\d+\.\d+\.\d+)};
+    }
+    if ( !$attrs->{patch} ) {
+        $attrs->{patch} = ( $attrs->{version} =~ m{patch} ) ? 1 : 0;
+    }
+    if ( !$attrs->{devel} ) {
+        my ( $version ) = $attrs->{version} =~ m{^v?\d+\.(\d+)};
+        $attrs->{devel} =
+            (
+                ( $version >= 7 && $version % 2 ) ||
+                $attrs->{version} =~ m{^v?\d+\.\d+\.\d+ RC\d+}
+            ) ? 1 : 0;
+    }
+    return $class->next::method( $attrs );
+}
+
+1;
diff --git a/lib/CPAN/Testers/Schema/ResultSet/PerlVersion.pm b/lib/CPAN/Testers/Schema/ResultSet/PerlVersion.pm
@@ -0,0 +1,46 @@
+use utf8;
+package CPAN::Testers::Schema::ResultSet::PerlVersion;
+our $VERSION = '0.023';
+# ABSTRACT: Query Perl version metadata
+
+=head1 SYNOPSIS
+
+    my $rs = $schema->resultset( 'PerlVersion' );
+    $rs->find_or_create({ version => '5.27.0' });
+
+    $rs = $rs->maturity( 'stable' ); # or 'dev'
+
+=head1 DESCRIPTION
+
+This object helps to query Perl version metadata.
+
+=head1 SEE ALSO
+
+L<CPAN::Testers::Schema::Result::PerlVersion>, L<DBIx::Class::ResultSet>,
+L<CPAN::Testers::Schema>
+
+=cut
+
+use CPAN::Testers::Schema::Base 'ResultSet';
+use Log::Any '$LOG';
+use Carp ();
+
+=method maturity
+
+Filter Perl versions of the given maturity. One of C<stable> or C<dev>.
+
+=cut
+
+sub maturity( $self, $maturity ) {
+    if ( $maturity eq 'stable' ) {
+        return $self->search({ devel => 0 });
+    }
+    elsif ( $maturity eq 'dev' ) {
+        return $self->search({ devel => 1 });
+    }
+    Carp::croak "Unknown maturity: $maturity. Must be one of: 'stable', 'dev'";
+}
+
+
+1;
+
diff --git a/share/CPAN-Testers-Schema-0.022-0.023-MySQL.sql b/share/CPAN-Testers-Schema-0.022-0.023-MySQL.sql
@@ -1,4 +1,19 @@
 -- Convert schema '/Users/doug/perl/cpantesters/schema/share/CPAN-Testers-Schema-0.022-MySQL.sql' to 'CPAN::Testers::Schema v0.023':;
 
--- No differences found;
+BEGIN;
+
+SET foreign_key_checks=0;
+
+CREATE TABLE IF NOT EXISTS `perl_version` (
+  `version` varchar(255) NOT NULL,
+  `perl` varchar(32) NULL,
+  `patch` tinyint(1) NOT NULL DEFAULT 0,
+  `devel` tinyint(1) NOT NULL DEFAULT 0,
+  PRIMARY KEY (`version`)
+);
+
+SET foreign_key_checks=1;
+
+
+COMMIT;
 
diff --git a/share/CPAN-Testers-Schema-0.022-0.023-SQLite.sql b/share/CPAN-Testers-Schema-0.022-0.023-SQLite.sql
@@ -1,4 +1,15 @@
 -- Convert schema '/Users/doug/perl/cpantesters/schema/share/CPAN-Testers-Schema-0.022-SQLite.sql' to '/Users/doug/perl/cpantesters/schema/share/CPAN-Testers-Schema-0.023-SQLite.sql':;
 
--- No differences found;
+BEGIN;
+
+CREATE TABLE "perl_version" (
+  "version" varchar(255) NOT NULL,
+  "perl" varchar(32),
+  "patch" tinyint(1) NOT NULL DEFAULT 0,
+  "devel" tinyint(1) NOT NULL DEFAULT 0,
+  PRIMARY KEY ("version")
+);
+
+
+COMMIT;
 
diff --git a/share/CPAN-Testers-Schema-0.023-MySQL.sql b/share/CPAN-Testers-Schema-0.023-MySQL.sql
@@ -1,6 +1,6 @@
 -- 
 -- Created by SQL::Translator::Producer::MySQL
--- Created on Thu Apr 19 14:31:13 2018
+-- Created on Sun Apr 22 13:09:39 2018
 -- 
 SET foreign_key_checks=0;
 
@@ -18,6 +18,19 @@ CREATE TABLE `metabase_user` (
   UNIQUE `metabase_user_resource` (`resource`)
 );
 
+DROP TABLE IF EXISTS `perl_version`;
+
+--
+-- Table: `perl_version`
+--
+CREATE TABLE `perl_version` (
+  `version` varchar(255) NOT NULL,
+  `perl` varchar(32) NULL,
+  `patch` tinyint(1) NOT NULL DEFAULT 0,
+  `devel` tinyint(1) NOT NULL DEFAULT 0,
+  PRIMARY KEY (`version`)
+);
+
 DROP TABLE IF EXISTS `test_report`;
 
 --

diff --git a/share/CPAN-Testers-Schema-0.023-SQLite.sql b/share/CPAN-Testers-Schema-0.023-SQLite.sql
@@ -1,6 +1,6 @@
 -- 
 -- Created by SQL::Translator::Producer::SQLite
--- Created on Thu Apr 19 14:31:14 2018
+-- Created on Sun Apr 22 13:09:39 2018
 -- 
 
 BEGIN TRANSACTION;
@@ -19,6 +19,19 @@ CREATE TABLE metabase_user (
 
 CREATE UNIQUE INDEX metabase_user_resource ON metabase_user (resource);
 
+--
+-- Table: perl_version
+--
+DROP TABLE perl_version;
+
+CREATE TABLE perl_version (
+  version varchar(255) NOT NULL,
+  perl varchar(32),
+  patch tinyint(1) NOT NULL DEFAULT 0,
+  devel tinyint(1) NOT NULL DEFAULT 0,
+  PRIMARY KEY (version)
+);
+
 --
 -- Table: test_report
 --

diff --git a/t/result/perl_version.t b/t/result/perl_version.t
@@ -0,0 +1,58 @@
+
+=head1 DESCRIPTION
+
+This file tests the L<CPAN::Testers::Schema::Result::PerlVersion> class.
+
+=head1 SEE ALSO
+
+L<CPAN::Testers::Schema>, L<DBIx::Class>
+
+=cut
+
+use CPAN::Testers::Schema::Base 'Test';
+
+subtest 'fill in data' => sub {
+    my $schema = prepare_temp_schema;
+
+    subtest 'stable perl' => sub {
+        my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.5.1' });
+        is $row->perl, '5.5.1', 'parsed Perl version is correct';
+        is $row->patch, 0, 'not a patch perl';
+        is $row->devel, 0, 'not a devel perl';
+    };
+
+    subtest 'devel perl' => sub {
+        my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.7.1' });
+        is $row->perl, '5.7.1', 'parsed Perl version is correct';
+        is $row->patch, 0, 'not a patch perl';
+        is $row->devel, 1, 'a devel perl';
+    };
+
+    subtest 'patch perl' => sub {
+        my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.9.6 patch 31753' });
+        is $row->perl, '5.9.6', 'parsed Perl version is correct';
+        is $row->patch, 1, 'a patch perl';
+        is $row->devel, 1, 'a devel perl';
+
+        $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.10.0 patch GitLive-maint-5.10-1462-g178839f' });
+        is $row->perl, '5.10.0', 'parsed Perl version is correct';
+        is $row->patch, 1, 'a patch perl';
+        is $row->devel, 0, 'not a devel perl';
+    };
+
+    subtest 'leading v' => sub {
+        my $row = $schema->resultset( 'PerlVersion' )->create({ version => 'v5.15.0' });
+        is $row->perl, '5.15.0', 'parsed Perl version is correct';
+        is $row->patch, 0, 'not a patch perl';
+        is $row->devel, 1, 'a devel perl';
+    };
+
+    subtest 'release candidates' => sub {
+        my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.20.0 RC0' });
+        is $row->perl, '5.20.0', 'parsed Perl version is correct';
+        is $row->patch, 0, 'not a patch perl';
+        is $row->devel, 1, 'a devel perl';
+    };
+};
+
+done_testing;
diff --git a/t/resultset/perl_version.t b/t/resultset/perl_version.t
@@ -0,0 +1,36 @@
+
+=head1 DESCRIPTION
+
+This file tests the L<CPAN::Testers::Schema::ResultSet::PerlVersion> module which
+queries for L<CPAN::Testers::Schema::Result::PerlVersion> objects.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<DBIx::Class::ResultSet>
+
+=back
+
+=cut
+
+use CPAN::Testers::Schema::Base 'Test';
+
+my $schema = prepare_temp_schema;
+my $rs = $schema->resultset( 'PerlVersion' );
+$rs->find_or_create({ version => '5.9.5' });
+$rs->find_or_create({ version => '5.5.1' });
+$rs->find_or_create({ version => '5.23.5 patch 12' });
+$rs->find_or_create({ version => '5.24.0 RC0' });
+$rs->find_or_create({ version => '5.11.2' });
+$rs->find_or_create({ version => '5.10.1' });
+
+subtest 'maturity' => sub {
+    my $rs = $schema->resultset( 'PerlVersion' )->maturity( 'stable' );
+    is_deeply [ sort map { $_->perl } $rs->all ], [qw( 5.10.1 5.5.1 )];
+    $rs = $schema->resultset( 'PerlVersion' )->maturity( 'dev' );
+    is_deeply [ sort map { $_->perl } $rs->all ], [qw( 5.11.2 5.23.5 5.24.0 5.9.5 )];
+};
+
+done_testing;
+