Skip to content

Commit 8c53bbf

Browse files
preactionpreaction
committed
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
1 parent 63b0f6e commit 8c53bbf

File tree

8 files changed

+322
-4
lines changed

8 files changed

+322
-4
lines changed

‎lib/CPAN/Testers/Schema/Result/PerlVersion.pm‎

Lines changed: 126 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,126 @@
1+
use utf8;
2+
package CPAN::Testers::Schema::Result::PerlVersion;
3+
our $VERSION = '0.023';
4+
# ABSTRACT: Metadata about Perl versions
5+
6+
=head1 SYNOPSIS
7+
8+
my $perl = $schema->resultset( 'PerlVersion' )->find( '5.26.0' );
9+
say "Stable" unless $perl->devel;
10+
11+
$schema->resultset( 'PerlVersion' )->find_or_create({
12+
version => '5.30.0', # Version reported by Perl
13+
perl => '5.30.0', # Parsed Perl version string
14+
patch => 0, # Has patches applied
15+
devel => 0, # Is development version (odd minor version)
16+
});
17+
18+
# Fill in metadata automatically
19+
$schema->resultset( 'PerlVersion' )->find_or_create({
20+
version => '5.31.0 patch 1231',
21+
# devel will be set to 1
22+
# patch will be set to 1
23+
# perl will be set to 5.31.0
24+
});
25+
26+
=head1 DESCRIPTION
27+
28+
This table holds metadata about known Perl versions. Through this table we can
29+
quickly list which Perl versions are stable/development.
30+
31+
=head1 SEE ALSO
32+
33+
L<DBIx::Class::Row>, L<CPAN::Testers::Schema>
34+
35+
=cut
36+
37+
use CPAN::Testers::Schema::Base 'Result';
38+
39+
table 'perl_version';
40+
41+
=attr version
42+
43+
The Perl version reported by the tester. This is the primary key.
44+
45+
=cut
46+
47+
primary_column version => {
48+
data_type => 'varchar',
49+
size => 255,
50+
is_nullable => 0,
51+
};
52+
53+
=attr perl
54+
55+
The parsed version of Perl in C<REVISION.VERSION.SUBVERSION> format.
56+
57+
If not specified when creating a new row, the Perl version will be parsed
58+
and this field updated accordingly.
59+
60+
=cut
61+
62+
column perl => {
63+
data_type => 'varchar',
64+
size => 32,
65+
is_nullable => 1,
66+
};
67+
68+
=attr patch
69+
70+
If true (C<1>), this Perl has patches applied. Defaults to false (C<0>).
71+
72+
If not specified when creating a new row, the Perl version will be parsed
73+
and this field updated accordingly.
74+
75+
=cut
76+
77+
column patch => {
78+
data_type => 'tinyint',
79+
size => 1,
80+
default_value => 0,
81+
};
82+
83+
=attr devel
84+
85+
If true (C<1>), this Perl is a development Perl version. Development Perl
86+
versions have an odd C<VERSION> field (the second number) like C<5.27.0>,
87+
C<5.29.0>, C<5.31.0>, etc... Release candidates (like C<5.28.0 RC0>) are
88+
also considered development versions.
89+
90+
If not specified when creating a new row, the Perl version will be parsed
91+
and this field updated accordingly.
92+
93+
=cut
94+
95+
column devel => {
96+
data_type => 'tinyint',
97+
size => 1,
98+
default_value => 0,
99+
};
100+
101+
=method new
102+
103+
The constructor will automatically fill in any missing information based
104+
on the supplied C<version> field.
105+
106+
=cut
107+
108+
sub new( $class, $attrs ) {
109+
if ( !$attrs->{perl} ) {
110+
( $attrs->{perl} ) = $attrs->{version} =~ m{^v?(\d+\.\d+\.\d+)};
111+
}
112+
if ( !$attrs->{patch} ) {
113+
$attrs->{patch} = ( $attrs->{version} =~ m{patch} ) ? 1 : 0;
114+
}
115+
if ( !$attrs->{devel} ) {
116+
my ( $version ) = $attrs->{version} =~ m{^v?\d+\.(\d+)};
117+
$attrs->{devel} =
118+
(
119+
( $version >= 7 && $version % 2 ) ||
120+
$attrs->{version} =~ m{^v?\d+\.\d+\.\d+ RC\d+}
121+
) ? 1 : 0;
122+
}
123+
return $class->next::method( $attrs );
124+
}
125+
126+
1;

‎lib/CPAN/Testers/Schema/ResultSet/PerlVersion.pm‎

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
use utf8;
2+
package CPAN::Testers::Schema::ResultSet::PerlVersion;
3+
our $VERSION = '0.023';
4+
# ABSTRACT: Query Perl version metadata
5+
6+
=head1 SYNOPSIS
7+
8+
my $rs = $schema->resultset( 'PerlVersion' );
9+
$rs->find_or_create({ version => '5.27.0' });
10+
11+
$rs = $rs->maturity( 'stable' ); # or 'dev'
12+
13+
=head1 DESCRIPTION
14+
15+
This object helps to query Perl version metadata.
16+
17+
=head1 SEE ALSO
18+
19+
L<CPAN::Testers::Schema::Result::PerlVersion>, L<DBIx::Class::ResultSet>,
20+
L<CPAN::Testers::Schema>
21+
22+
=cut
23+
24+
use CPAN::Testers::Schema::Base 'ResultSet';
25+
use Log::Any '$LOG';
26+
use Carp ();
27+
28+
=method maturity
29+
30+
Filter Perl versions of the given maturity. One of C<stable> or C<dev>.
31+
32+
=cut
33+
34+
sub maturity( $self, $maturity ) {
35+
if ( $maturity eq 'stable' ) {
36+
return $self->search({ devel => 0 });
37+
}
38+
elsif ( $maturity eq 'dev' ) {
39+
return $self->search({ devel => 1 });
40+
}
41+
Carp::croak "Unknown maturity: $maturity. Must be one of: 'stable', 'dev'";
42+
}
43+
44+
45+
1;
46+

‎share/CPAN-Testers-Schema-0.022-0.023-MySQL.sql‎

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,19 @@
11
-- Convert schema '/Users/doug/perl/cpantesters/schema/share/CPAN-Testers-Schema-0.022-MySQL.sql' to 'CPAN::Testers::Schema v0.023':;
22

3-
-- No differences found;
3+
BEGIN;
4+
5+
SET foreign_key_checks=0;
6+
7+
CREATE TABLE IF NOT EXISTS `perl_version` (
8+
`version` varchar(255) NOT NULL,
9+
`perl` varchar(32) NULL,
10+
`patch` tinyint(1) NOT NULL DEFAULT 0,
11+
`devel` tinyint(1) NOT NULL DEFAULT 0,
12+
PRIMARY KEY (`version`)
13+
);
14+
15+
SET foreign_key_checks=1;
16+
17+
18+
COMMIT;
419

‎share/CPAN-Testers-Schema-0.022-0.023-SQLite.sql‎

Lines changed: 12 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,15 @@
11
-- 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':;
22

3-
-- No differences found;
3+
BEGIN;
4+
5+
CREATE TABLE "perl_version" (
6+
"version" varchar(255) NOT NULL,
7+
"perl" varchar(32),
8+
"patch" tinyint(1) NOT NULL DEFAULT 0,
9+
"devel" tinyint(1) NOT NULL DEFAULT 0,
10+
PRIMARY KEY ("version")
11+
);
12+
13+
14+
COMMIT;
415

‎share/CPAN-Testers-Schema-0.023-MySQL.sql‎

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
--
22
-- Created by SQL::Translator::Producer::MySQL
3-
-- Created on Thu Apr 19 14:31:13 2018
3+
-- Created on Sun Apr 22 13:09:39 2018
44
--
55
SET foreign_key_checks=0;
66

@@ -18,6 +18,19 @@ CREATE TABLE `metabase_user` (
1818
UNIQUE `metabase_user_resource` (`resource`)
1919
);
2020

21+
DROP TABLE IF EXISTS `perl_version`;
22+
23+
--
24+
-- Table: `perl_version`
25+
--
26+
CREATE TABLE `perl_version` (
27+
`version` varchar(255) NOT NULL,
28+
`perl` varchar(32) NULL,
29+
`patch` tinyint(1) NOT NULL DEFAULT 0,
30+
`devel` tinyint(1) NOT NULL DEFAULT 0,
31+
PRIMARY KEY (`version`)
32+
);
33+
2134
DROP TABLE IF EXISTS `test_report`;
2235

2336
--

‎share/CPAN-Testers-Schema-0.023-SQLite.sql‎

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
--
22
-- Created by SQL::Translator::Producer::SQLite
3-
-- Created on Thu Apr 19 14:31:14 2018
3+
-- Created on Sun Apr 22 13:09:39 2018
44
--
55

66
BEGIN TRANSACTION;
@@ -19,6 +19,19 @@ CREATE TABLE metabase_user (
1919

2020
CREATE UNIQUE INDEX metabase_user_resource ON metabase_user (resource);
2121

22+
--
23+
-- Table: perl_version
24+
--
25+
DROP TABLE perl_version;
26+
27+
CREATE TABLE perl_version (
28+
version varchar(255) NOT NULL,
29+
perl varchar(32),
30+
patch tinyint(1) NOT NULL DEFAULT 0,
31+
devel tinyint(1) NOT NULL DEFAULT 0,
32+
PRIMARY KEY (version)
33+
);
34+
2235
--
2336
-- Table: test_report
2437
--

‎t/result/perl_version.t‎

Lines changed: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,58 @@
1+
2+
=head1 DESCRIPTION
3+
4+
This file tests the L<CPAN::Testers::Schema::Result::PerlVersion> class.
5+
6+
=head1 SEE ALSO
7+
8+
L<CPAN::Testers::Schema>, L<DBIx::Class>
9+
10+
=cut
11+
12+
use CPAN::Testers::Schema::Base 'Test';
13+
14+
subtest 'fill in data' => sub {
15+
my $schema = prepare_temp_schema;
16+
17+
subtest 'stable perl' => sub {
18+
my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.5.1' });
19+
is $row->perl, '5.5.1', 'parsed Perl version is correct';
20+
is $row->patch, 0, 'not a patch perl';
21+
is $row->devel, 0, 'not a devel perl';
22+
};
23+
24+
subtest 'devel perl' => sub {
25+
my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.7.1' });
26+
is $row->perl, '5.7.1', 'parsed Perl version is correct';
27+
is $row->patch, 0, 'not a patch perl';
28+
is $row->devel, 1, 'a devel perl';
29+
};
30+
31+
subtest 'patch perl' => sub {
32+
my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.9.6 patch 31753' });
33+
is $row->perl, '5.9.6', 'parsed Perl version is correct';
34+
is $row->patch, 1, 'a patch perl';
35+
is $row->devel, 1, 'a devel perl';
36+
37+
$row = $schema->resultset( 'PerlVersion' )->create({ version => '5.10.0 patch GitLive-maint-5.10-1462-g178839f' });
38+
is $row->perl, '5.10.0', 'parsed Perl version is correct';
39+
is $row->patch, 1, 'a patch perl';
40+
is $row->devel, 0, 'not a devel perl';
41+
};
42+
43+
subtest 'leading v' => sub {
44+
my $row = $schema->resultset( 'PerlVersion' )->create({ version => 'v5.15.0' });
45+
is $row->perl, '5.15.0', 'parsed Perl version is correct';
46+
is $row->patch, 0, 'not a patch perl';
47+
is $row->devel, 1, 'a devel perl';
48+
};
49+
50+
subtest 'release candidates' => sub {
51+
my $row = $schema->resultset( 'PerlVersion' )->create({ version => '5.20.0 RC0' });
52+
is $row->perl, '5.20.0', 'parsed Perl version is correct';
53+
is $row->patch, 0, 'not a patch perl';
54+
is $row->devel, 1, 'a devel perl';
55+
};
56+
};
57+
58+
done_testing;

‎t/resultset/perl_version.t‎

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
2+
=head1 DESCRIPTION
3+
4+
This file tests the L<CPAN::Testers::Schema::ResultSet::PerlVersion> module which
5+
queries for L<CPAN::Testers::Schema::Result::PerlVersion> objects.
6+
7+
=head1 SEE ALSO
8+
9+
=over
10+
11+
=item L<DBIx::Class::ResultSet>
12+
13+
=back
14+
15+
=cut
16+
17+
use CPAN::Testers::Schema::Base 'Test';
18+
19+
my $schema = prepare_temp_schema;
20+
my $rs = $schema->resultset( 'PerlVersion' );
21+
$rs->find_or_create({ version => '5.9.5' });
22+
$rs->find_or_create({ version => '5.5.1' });
23+
$rs->find_or_create({ version => '5.23.5 patch 12' });
24+
$rs->find_or_create({ version => '5.24.0 RC0' });
25+
$rs->find_or_create({ version => '5.11.2' });
26+
$rs->find_or_create({ version => '5.10.1' });
27+
28+
subtest 'maturity' => sub {
29+
my $rs = $schema->resultset( 'PerlVersion' )->maturity( 'stable' );
30+
is_deeply [ sort map { $_->perl } $rs->all ], [qw( 5.10.1 5.5.1 )];
31+
$rs = $schema->resultset( 'PerlVersion' )->maturity( 'dev' );
32+
is_deeply [ sort map { $_->perl } $rs->all ], [qw( 5.11.2 5.23.5 5.24.0 5.9.5 )];
33+
};
34+
35+
done_testing;
36+

0 commit comments

Comments
 (0)