File Coverage

blib/lib/Perl5/CoreSmokeDB/Schema.pm
Criterion Covered Total %
statement 55 62 88.7
branch 12 16 75.0
condition 3 4 75.0
subroutine 11 13 84.6
pod 6 6 100.0
total 87 101 86.1


line stmt bran cond sub pod time code
1 3     3   124832 use utf8;
  3         44  
  3         15  
2              
3             # Created by DBIx::Class::Schema::Loader
4             # DO NOT MODIFY THE FIRST PART OF THIS FILE
5              
6             use strict;
7 3     3   106 use warnings;
  3         6  
  3         51  
8 3     3   12  
  3         6  
  3         67  
9             use base 'DBIx::Class::Schema';
10 3     3   14  
  3         5  
  3         2583  
11             __PACKAGE__->load_namespaces;
12              
13              
14             # Created by DBIx::Class::Schema::Loader v0.07049 @ 2022-09-06 09:15:22
15             # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:vCye+8pfvU4CmiRtdudyxw
16              
17             our $VERSION = 1.07;
18             our $SCHEMAVERSION = 3;
19             our $PGAPPNAME = 'Perl5CoreSmokeDB';
20              
21             =head1 NAME
22              
23             Perl5::CoreSmokeDB::Schema - DBIC::Schema for the smoke reports database
24              
25             =head1 SYNOPSIS
26              
27             use Perl5::CoreSmokeDB::Schema;
28             my $schema = Perl5::CoreSmokeDB::Schema->connect($dsn, $user, $pswd, $options);
29              
30             my $report = $schema->resultset('Report')->find({ id => 1 });
31              
32             =head1 DESCRIPTION
33              
34             This class is used in the backend for accessing the database.
35              
36             Another use is: C<< $schema->deploy() >>
37              
38             =cut
39              
40             use Exception::Class (
41             'Perl5::CoreSmokeDB::Schema::Exception' =>
42 3         34 'Perl5::CoreSmokeDB::Schema::VersionMismatchException' => {
43             isa => 'Perl5::CoreSmokeDB::Schema::Exception',
44             alias => 'throw_version_mismatch'
45             },
46             'Perl5::CoreSmokeDB::Schema::DBDriverMismatchExeption' => {
47             isa => 'Perl5::CoreSmokeDB::Schema::Exception',
48             alias => 'throw_dbdriver_mismatch',
49             },
50             );
51 3     3   115431  
  3         7239  
52             =head2 $schema->connection
53              
54             after connection => sub { };
55              
56             Check the version in the database with our C<$SCHEMAVERSION> unless the option
57             C<ignore_version> was passed.
58              
59             =cut
60              
61             my $self = shift;
62             $self->next::method(@_);
63 7     7 1 110511  
64 7         76 $self->_check_version($_[3]);
65              
66 7         168773 $self->pg_post_connect if $_[0] =~ m{^ dbi:Pg: }x;
67             $self->sqlite_post_connect if $_[0] =~ m{^ dbi:SQLite: }x;
68 6 50       27  
69 6 100       36 return $self;
70             }
71 6         33  
72             my $self = shift;
73             my ($args) = @_;
74             $args ||= { };
75 7     7   16  
76 7         20 return 1 if $args->{ignore_version};
77 7   100     29  
78             my $dbversion = $self->resultset('TsgatewayConfig')->find(
79 7 100       25 {name => 'dbversion'}
80             )->value;
81 2         9  
82             if ($SCHEMAVERSION > $dbversion) {
83             throw_version_mismatch(
84             sprintf(
85 2 100       11930 "SCHEMAVersion %d does not match DBVersion %d",
86 1         36 $SCHEMAVERSION,
87             $dbversion
88             )
89             );
90             }
91             return $self;
92             }
93              
94 1         33 =head2 deploy()
95              
96             around deploy => sub { };
97              
98             Populate the tsgateway_config-table with data.
99              
100             =cut
101              
102             my $self = shift;
103              
104             if ($self->storage->connect_info->[0] =~ m{^dbi:SQLite}) {
105             $self->sqlite_post_connect();
106 4     4 1 106 }
107             elsif ($self->storage->connect_info->[0] =~ m{^dbi:Pg}) {
108 4 100       104 $self->pg_pre_deploy();
    50          
109 3         122 }
110             else {
111             my ($driver) = $self->storage->connect_info->[0] =~ m{^ (dbi: [^:]+) }x;
112 0         0 throw_dbdriver_mismatch(
113             sprintf("%s not supported for %s (dbi:Pg/dbi:SQLite)", $driver, __PACKAGE__)
114             );
115 1         60 }
116 1         98  
117             $self->next::method(@_);
118              
119             my $dbh = $self->storage->dbh;
120             # FIX the plevel column; DBIx::Class doesn't know how to do 'GENERATED'
121 3         27 # columns
122             $dbh->do(<<EOQ);
123 3         2244112 ALTER TABLE report
124             DROP COLUMN plevel
125             EOQ
126 3         1265 $dbh->do(<<EOQ);
127             ALTER TABLE report
128             ADD COLUMN plevel varchar GENERATED ALWAYS AS (git_describe_as_plevel(git_describe)) STORED
129             EOQ
130 3         30812  
131             $self->resultset('TsgatewayConfig')->populate(
132             [
133             {name => 'dbversion', value => $SCHEMAVERSION},
134             ]
135 3         27784 );
136             }
137              
138             use constant SQLITE_DETERMINISTIC => 0x800; # from sqlite3.c source in DBD::SQLite
139              
140             =head2 $schema->sqlite_post_connect
141              
142 3     3   3262 Install the function needed for the C<plevel> column (for this connection). It
  3         7  
  3         1210  
143             is called just before C<< $schema->deploy >> and also just after C<<
144             $schema->connect >>.
145              
146             =cut
147              
148             my $self = shift;
149             my $dbh = $self->storage->dbh;
150              
151             $dbh->sqlite_create_function(
152             'git_describe_as_plevel',
153 8     8 1 34 1, \&plevel,
154 8         145 SQLITE_DETERMINISTIC
155             );
156 8         102295 }
157              
158             =head2 $schema->pg_post_connect
159              
160             Set the C<application_name> for this connection to B<Perl5CoreSmokeDB>.
161              
162             =cut
163              
164             my $self = shift;
165              
166             $self->storage->dbh->do("SET application_name TO $PGAPPNAME");
167             }
168              
169             =head2 $schema->pg_pre_deploy
170 0     0 1 0  
171             Install the function needed for the C<plevel> column, this function is now part
172 0         0 of that database and doesn't need reinstalling for each connection.
173              
174             =cut
175              
176             my $self = shift;
177             my $dbh = $self->storage->dbh;
178              
179             $dbh->do(<<'EOQ');
180             CREATE OR REPLACE FUNCTION public.git_describe_as_plevel(varchar)
181             RETURNS varchar
182             LANGUAGE plpgsql
183 0     0 1 0 IMMUTABLE
184 0         0 AS $function$
185             DECLARE
186 0         0 vparts varchar array [5];
187             plevel varchar;
188             clean varchar;
189             BEGIN
190             SELECT regexp_replace($1, E'^v', '') INTO clean;
191             SELECT regexp_replace(clean, E'-g\.\+$', '') INTO clean;
192              
193             SELECT regexp_split_to_array(clean, E'[\.\-]') INTO vparts;
194              
195             SELECT vparts[1] || '.' INTO plevel;
196             SELECT plevel || lpad(vparts[2], 3, '0') INTO plevel;
197             SELECT plevel || lpad(vparts[3], 3, '0') INTO plevel;
198             if array_length(vparts, 1) = 3 then
199             SELECT array_append(vparts, '0') INTO vparts;
200             end if;
201             if regexp_matches(vparts[4], 'RC') = array['RC'] then
202             SELECT plevel || vparts[4] INTO plevel;
203             else
204             SELECT plevel || 'zzz' INTO plevel;
205             end if;
206             SELECT plevel || lpad(vparts[array_upper(vparts, 1)], 3, '0') INTO plevel;
207              
208             return plevel;
209             END;
210             $function$ ;
211             EOQ
212             }
213              
214             =head2 plevel($git-describe)
215              
216             This is the function used for SQLite to set the value of the C<plevel> column.
217              
218             =cut
219              
220             my $data = shift;
221              
222             (my $git_describe = $data) =~ s{^v}{};
223             $git_describe =~ s{-g[0-9a-f]+$}{}i;
224              
225             my @vparts = split(/[.-]/, $git_describe, 5);
226             my $plevel = sprintf("%u.%03u%03u", @vparts[0..2]);
227             if (@vparts < 4) {
228 3     3 1 39707 push(@vparts, '0');
229             }
230 3         24 my $rc = $vparts[3] =~ m{RC}i ? $vparts[3] : 'zzz';
231 3         22 $plevel .= $rc;
232             $plevel .= sprintf("%03u", $vparts[-1] // '0');
233 3         23  
234 3         29 return $plevel;
235 3 50       19 }
236 0         0  
237             =head1 AUTHOR
238 3 50       18  
239 3         10 E<copy> MMXIII- MMXII - Abe Timmerman <abeltje@cpan.org>, H.Merijn Brand
240 3   50     18  
241             =head1 LICENSE
242 3         65  
243             This library is free software; you can redistribute it and/or modify
244             it under the same terms as Perl itself.
245              
246             This program is distributed in the hope that it will be useful,
247             but WITHOUT ANY WARRANTY; without even the implied warranty of
248             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
249              
250             =cut
251             1;