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; |