Line 0
Link Here
|
|
|
1 |
package C4::Update::Database; |
2 |
|
3 |
# Copyright 2011 BibLibre |
4 |
# |
5 |
# This file is part of Koha. |
6 |
# |
7 |
# Koha is free software; you can redistribute it and/or modify it under the |
8 |
# terms of the GNU General Public License as published by the Free Software |
9 |
# Foundation; either version 2 of the License, or (at your option) any later |
10 |
# version. |
11 |
# |
12 |
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY |
13 |
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
14 |
# A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
15 |
# |
16 |
# You should have received a copy of the GNU General Public License along |
17 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
18 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
19 |
|
20 |
use Modern::Perl; |
21 |
|
22 |
use C4::Context; |
23 |
|
24 |
use File::Basename; |
25 |
use File::Find::Rule; |
26 |
use Digest::MD5; |
27 |
use List::MoreUtils qw/uniq/; |
28 |
use YAML; |
29 |
|
30 |
=head1 NAME |
31 |
|
32 |
C4::Update::Database.pm |
33 |
|
34 |
=head1 SYNOPSIS |
35 |
|
36 |
use C4::Update::Database; |
37 |
|
38 |
This package is used by admin/updatedatabase.pl, to manage DB updates |
39 |
|
40 |
=head1 FUNCTIONS |
41 |
|
42 |
=cut |
43 |
|
44 |
my $VERSIONS_PATH = C4::Context->config('intranetdir') . '/installer/data/mysql/versions'; |
45 |
|
46 |
my $version; |
47 |
my $list; |
48 |
|
49 |
my $dbh = C4::Context->dbh; |
50 |
|
51 |
=head2 |
52 |
|
53 |
my $file = get_filepath($version); |
54 |
this sub will return the full path of a given DB update number |
55 |
|
56 |
=cut |
57 |
|
58 |
sub get_filepath { |
59 |
my ( $version ) = @_; |
60 |
my @files = File::Find::Rule->file->name( "$version.sql", "$version.pl" ) ->in( ( $VERSIONS_PATH ) ); |
61 |
|
62 |
if ( scalar @files != 1 ) { |
63 |
die "This version ($version) returned has ".scalar @files." corresponding, need only 1"; |
64 |
} |
65 |
|
66 |
return $files[0]; |
67 |
} |
68 |
|
69 |
=head2 get_md5 |
70 |
|
71 |
my $md5 = get_md5($filepath) |
72 |
returns the md5sum of the selected file. |
73 |
This is used to check consistency of updates |
74 |
|
75 |
=cut |
76 |
sub get_md5 { |
77 |
my ( $filepath ) = @_; |
78 |
open(FILE, $filepath); |
79 |
|
80 |
my $ctx = Digest::MD5->new; |
81 |
$ctx->addfile(*FILE); |
82 |
my $md5 = $ctx->hexdigest; |
83 |
close(FILE); |
84 |
return $md5; |
85 |
} |
86 |
|
87 |
=head2 execute_version |
88 |
|
89 |
$result = execute_version($version_number); |
90 |
Execute an update. |
91 |
This sub will detect if the number is made through a .pl or a .sql, and behave accordingly |
92 |
if there is more than 1 file with the same number, an error will be issued |
93 |
if you try to execute a version_number that has already be executed, then it will also issue an error |
94 |
the sub return an result hash, with the version number and the result |
95 |
|
96 |
=cut |
97 |
|
98 |
sub execute_version { |
99 |
my ( $version ) = @_; |
100 |
my $report; |
101 |
|
102 |
my $filepath; |
103 |
eval { |
104 |
$filepath = get_filepath $version; |
105 |
}; |
106 |
if ( $@ ) { |
107 |
return { $version => $@ }; |
108 |
} |
109 |
|
110 |
my @file_infos = fileparse( $filepath, qr/\.[^.]*/ ); |
111 |
my $extension = $file_infos[2]; |
112 |
my $filename = $version . $extension; |
113 |
|
114 |
my $md5 = get_md5 $filepath; |
115 |
my $r = md5_already_exists( $md5 ); |
116 |
if ( scalar @$r ) { |
117 |
my $p = @$r[0]; |
118 |
$report->{$version} = { |
119 |
error => "ALREADY_EXISTS", |
120 |
filepath => $filepath, |
121 |
old_version => @$r[0]->{version}, |
122 |
md5 => @$r[0]->{md5}, |
123 |
}; |
124 |
return $report; |
125 |
} |
126 |
|
127 |
my $queries; |
128 |
given ( $extension ) { |
129 |
when ( /.sql/ ) { |
130 |
$queries = get_queries ( $filepath ); |
131 |
} |
132 |
when ( /.pl/ ) { |
133 |
my $versions_dir = C4::Context->intranetdir . '/installer/data/mysql/versions/'; |
134 |
my $version_file = $versions_dir . $filename; |
135 |
if ( do $version_file ) { |
136 |
$queries = _get_queries(); |
137 |
} else { |
138 |
$report->{$version} = { |
139 |
error => "LOAD_FUNCTIONS_FAILED", |
140 |
filename => $filename, |
141 |
}; |
142 |
} |
143 |
} |
144 |
default { |
145 |
$report->{$version} = { |
146 |
error => "BAD_EXTENSION", |
147 |
extension => $extension, |
148 |
}; |
149 |
} |
150 |
} |
151 |
|
152 |
return $report |
153 |
if ( defined $report->{$version} ); |
154 |
|
155 |
my $errors; |
156 |
for my $query ( @{$queries->{queries}} ) { |
157 |
eval { |
158 |
check_coherency( $query ); |
159 |
}; |
160 |
if ( $@ ) { |
161 |
push @$errors, $@ |
162 |
} |
163 |
} |
164 |
|
165 |
if ( $errors ) { |
166 |
$_ =~ s/at [^ ]* line \d*\.$// for @$errors; |
167 |
$report->{$version} = $errors; |
168 |
return $report; |
169 |
} |
170 |
|
171 |
$errors = execute ( $queries ); |
172 |
$report->{$version} = scalar( @$errors ) ? $errors : "OK"; |
173 |
set_infos ( $version, $queries, $errors, $md5 ); |
174 |
return $report; |
175 |
} |
176 |
|
177 |
=head2 list_versions_availables |
178 |
|
179 |
my @versions = list_versions_availables; |
180 |
return an array with all version available |
181 |
This list is retrieved from the directory defined in the etc/update/database/config.yaml, versions_dir parameter |
182 |
|
183 |
=cut |
184 |
|
185 |
sub list_versions_availables { |
186 |
my @versions; |
187 |
|
188 |
my @files = File::Find::Rule->file->name( "*.sql", "*.pl" ) ->in( ( $VERSIONS_PATH ) ); |
189 |
|
190 |
for my $f ( @files ) { |
191 |
my @file_infos = fileparse( $f, qr/\.[^.]*/ ); |
192 |
push @versions, $file_infos[0]; |
193 |
} |
194 |
@versions = uniq @versions; |
195 |
return \@versions; |
196 |
} |
197 |
|
198 |
=head2 list_versions_already_knows |
199 |
|
200 |
my @versions = list_versions_availables; |
201 |
return an array with all version that have already been applied |
202 |
This sub check first that the updatedb tables exist and create them if needed |
203 |
|
204 |
=cut |
205 |
|
206 |
sub list_versions_already_knows { |
207 |
# 1st check if tables exist, otherwise create them |
208 |
$dbh->do(qq{ |
209 |
CREATE TABLE IF NOT EXISTS `updatedb_error` ( `version` varchar(32) DEFAULT NULL, `error` text ) ENGINE=InnoDB CHARSET=utf8; |
210 |
}); |
211 |
$dbh->do(qq{ |
212 |
CREATE TABLE IF NOT EXISTS `updatedb_query` ( `version` varchar(32) DEFAULT NULL, `query` text ) ENGINE=InnoDB CHARSET=utf8; |
213 |
}); |
214 |
$dbh->do(qq{ |
215 |
CREATE TABLE IF NOT EXISTS `updatedb_report` ( `version` text, `md5` varchar(50) DEFAULT NULL, `comment` text, `status` int(1) DEFAULT NULL ) ENGINE=InnoDB CHARSET=utf8; |
216 |
}); |
217 |
|
218 |
my $query = qq/ SELECT version, comment, status FROM updatedb_report ORDER BY version/; |
219 |
my $sth = $dbh->prepare( $query ); |
220 |
$sth->execute; |
221 |
my $versions = $sth->fetchall_arrayref( {} ); |
222 |
map { |
223 |
my $version = $_; |
224 |
my @comments = defined $_->{comment} ? split '\\\n', $_->{comment} : ""; |
225 |
push @{ $version->{comments} }, { comment => $_ } for @comments; |
226 |
delete $version->{comment}; |
227 |
} @$versions; |
228 |
$sth->finish; |
229 |
for my $version ( @$versions ) { |
230 |
$query = qq/ SELECT query FROM updatedb_query WHERE version = ? ORDER BY version/; |
231 |
$sth = $dbh->prepare( $query ); |
232 |
$sth->execute( $version->{version} ); |
233 |
$version->{queries} = $sth->fetchall_arrayref( {} ); |
234 |
$sth->finish; |
235 |
$query = qq/ SELECT error FROM updatedb_error WHERE version = ? ORDER BY version/; |
236 |
$sth = $dbh->prepare( $query ); |
237 |
$sth->execute( $version->{version} ); |
238 |
$version->{errors} = $sth->fetchall_arrayref( {} ); |
239 |
$sth->finish; |
240 |
} |
241 |
return $versions; |
242 |
} |
243 |
|
244 |
=head2 execute |
245 |
|
246 |
my @errors = $execute(\@queries); |
247 |
This sub will execute queries coming from an execute_version based on a .sql file |
248 |
|
249 |
=cut |
250 |
|
251 |
sub execute { |
252 |
my ( $queries ) = @_; |
253 |
my @errors; |
254 |
for my $query ( @{$queries->{queries}} ) { |
255 |
eval { |
256 |
$dbh->do( $query ); |
257 |
}; |
258 |
push @errors, get_error(); |
259 |
} |
260 |
return \@errors; |
261 |
} |
262 |
|
263 |
=head2 get_tables_name |
264 |
|
265 |
my $tables = get_tables_name; |
266 |
return an array with all Koha mySQL table names |
267 |
|
268 |
=cut |
269 |
|
270 |
sub get_tables_name { |
271 |
my $sth = $dbh->prepare("SHOW TABLES"); |
272 |
$sth->execute(); |
273 |
my @tables; |
274 |
while ( my ( $table ) = $sth->fetchrow_array ) { |
275 |
push @tables, $table; |
276 |
} |
277 |
return \@tables; |
278 |
} |
279 |
my $tables; |
280 |
|
281 |
=head2 check_coherency |
282 |
|
283 |
my $errors = check_coherency($query); |
284 |
This sub will try to check if a SQL query is useless or no. |
285 |
for queries that are CREATE TABLE, it will check if the table already exists |
286 |
for queries that are ALTER TABLE, it will search if the modification has already been made |
287 |
for queries that are INSERT, it will search if the insert has already been made if it's a syspref or a permission |
288 |
|
289 |
Those test cover 90% of the updatedatabases cases. That will help finding duplicate or inconsistencies |
290 |
|
291 |
=cut |
292 |
|
293 |
sub check_coherency { |
294 |
my ( $query ) = @_; |
295 |
$tables = get_tables_name() if not $tables; |
296 |
|
297 |
given ( $query ) { |
298 |
when ( /CREATE TABLE(?:.*?)? `?(\w+)`?/ ) { |
299 |
my $table_name = $1; |
300 |
if ( grep { /$table_name/ } @$tables ) { |
301 |
die "COHERENCY: Table $table_name already exists"; |
302 |
} |
303 |
} |
304 |
|
305 |
when ( /ALTER TABLE *`?(\w+)`? *ADD *(?:COLUMN)? `?(\w+)`?/ ) { |
306 |
my $table_name = $1; |
307 |
my $column_name = $2; |
308 |
next if $column_name =~ /(UNIQUE|CONSTRAINT|INDEX|KEY|FOREIGN)/; |
309 |
if ( not grep { /$table_name/ } @$tables ) { |
310 |
return "COHERENCY: Table $table_name does not exist"; |
311 |
} else { |
312 |
my $sth = $dbh->prepare( "DESC $table_name $column_name" ); |
313 |
my $rv = $sth->execute; |
314 |
if ( $rv > 0 ) { |
315 |
die "COHERENCY: Field $table_name.$column_name already exists"; |
316 |
} |
317 |
} |
318 |
} |
319 |
|
320 |
when ( /INSERT INTO `?(\w+)`?.*?VALUES *\((.*?)\)/ ) { |
321 |
my $table_name = $1; |
322 |
my @values = split /,/, $2; |
323 |
s/^ *'// foreach @values; |
324 |
s/' *$// foreach @values; |
325 |
given ( $table_name ) { |
326 |
when ( /systempreferences/ ) { |
327 |
my $syspref = $values[0]; |
328 |
my $sth = $dbh->prepare( "SELECT COUNT(*) FROM systempreferences WHERE variable = ?" ); |
329 |
$sth->execute( $syspref ); |
330 |
if ( ( my $count = $sth->fetchrow_array ) > 0 ) { |
331 |
die "COHERENCY: Syspref $syspref already exists"; |
332 |
} |
333 |
} |
334 |
|
335 |
when ( /permissions/){ |
336 |
my $module_bit = $values[0]; |
337 |
my $code = $values[1]; |
338 |
my $sth = $dbh->prepare( "SELECT COUNT(*) FROM permissions WHERE module_bit = ? AND code = ?" ); |
339 |
$sth->execute($module_bit, $code); |
340 |
if ( ( my $count = $sth->fetchrow_array ) > 0 ) { |
341 |
die "COHERENCY: Permission $code already exists"; |
342 |
} |
343 |
} |
344 |
} |
345 |
} |
346 |
} |
347 |
return 1; |
348 |
} |
349 |
|
350 |
=head2 get_error |
351 |
|
352 |
my $errors = get_error() |
353 |
This sub will return any mySQL error that occured during an update |
354 |
|
355 |
=cut |
356 |
|
357 |
sub get_error { |
358 |
my @errors = $dbh->selectrow_array(qq{SHOW ERRORS}); # Get errors |
359 |
my @warnings = $dbh->selectrow_array(qq{SHOW WARNINGS}); # Get warnings |
360 |
if ( @errors ) { # Catch specifics errors |
361 |
return qq{$errors[0] : $errors[1] => $errors[2]}; |
362 |
} elsif ( @warnings ) { |
363 |
return qq{$warnings[0] : $warnings[1] => $warnings[2]} |
364 |
if $warnings[0] ne 'Note'; |
365 |
} |
366 |
return; |
367 |
} |
368 |
|
369 |
=head2 |
370 |
|
371 |
my $result = get_queries($filepath); |
372 |
this sub will return a hashref with 2 entries: |
373 |
$result->{queries} is an array with all queries to execute |
374 |
$result->{comments} is an array with all comments in the .sql file |
375 |
|
376 |
=cut |
377 |
|
378 |
sub get_queries { |
379 |
my ( $filepath ) = @_; |
380 |
open my $fh, "<", $filepath; |
381 |
my @queries; |
382 |
my @comments; |
383 |
my $old_delimiter = $/; |
384 |
while ( <$fh> ) { |
385 |
my $line = $_; |
386 |
chomp $line; |
387 |
$line =~ s/^\s*//; |
388 |
if ( $line =~ s/^--(.*)$// ) { |
389 |
push @comments, $1; |
390 |
next; |
391 |
} |
392 |
if ( $line =~ /^delimiter (.*)$/i ) { |
393 |
$/ = $1; |
394 |
next; |
395 |
} |
396 |
$line =~ s#$/##; |
397 |
push @queries, $line if not $line =~ /^\s*$/; # Push if query is not empty |
398 |
} |
399 |
$/ = $old_delimiter; |
400 |
close $fh; |
401 |
|
402 |
return { queries => \@queries, comments => \@comments }; |
403 |
} |
404 |
|
405 |
=head2 md5_already_exists |
406 |
|
407 |
my $result = md5_already_exists($md5); |
408 |
check if the md5 of an update has already been applied on the database. |
409 |
If yes, it will return a hash with the version related to this md5 |
410 |
|
411 |
=cut |
412 |
|
413 |
sub md5_already_exists { |
414 |
my ( $md5 ) = @_; |
415 |
my $query = qq/SELECT version, md5 FROM updatedb_report WHERE md5 = ?/; |
416 |
my $sth = $dbh->prepare( $query ); |
417 |
$sth->execute( $md5 ); |
418 |
my @r; |
419 |
while ( my ( $version, $md5 ) = $sth->fetchrow ) { |
420 |
push @r, { version => $version, md5 => $md5 }; |
421 |
} |
422 |
$sth->finish; |
423 |
return \@r; |
424 |
} |
425 |
|
426 |
=head2 set_infos |
427 |
|
428 |
set_info($version,$queries, $error, $md5); |
429 |
this sub will insert into the updatedb tables what has been made on the database (queries, errors, result) |
430 |
|
431 |
=cut |
432 |
sub set_infos { |
433 |
my ( $version, $queries, $errors, $md5 ) = @_; |
434 |
#SetVersion($DBversion) if not -s $errors; |
435 |
for my $query ( @{ $queries->{queries} } ) { |
436 |
my $sth = $dbh->prepare("INSERT INTO updatedb_query(version, query) VALUES (?, ?)"); |
437 |
$sth->execute( $version, $query ); |
438 |
$sth->finish; |
439 |
} |
440 |
for my $error ( @$errors ) { |
441 |
my $sth = $dbh->prepare("INSERT INTO updatedb_error(version, error) VALUES (?, ?)"); |
442 |
$sth->execute( $version, $error ); |
443 |
} |
444 |
my $sth = $dbh->prepare("INSERT INTO updatedb_report(version, md5, comment, status) VALUES (?, ?, ?, ?)"); |
445 |
$sth->execute( |
446 |
$version, |
447 |
$md5, |
448 |
join ('\n', @{ $queries->{comments} }), |
449 |
( @$errors > 0 ) ? 0 : 1 |
450 |
); |
451 |
} |
452 |
|
453 |
=head2 mark_as_ok |
454 |
|
455 |
mark_as_ok($version); |
456 |
this sub will force to mark as "OK" an update that has failed |
457 |
once this has been made, the status will look as "forced OK", and appear in green like versions that have been applied without any problem |
458 |
|
459 |
=cut |
460 |
sub mark_as_ok { |
461 |
my ( $version ) = @_; |
462 |
my $sth = $dbh->prepare( "UPDATE updatedb_report SET status = 2 WHERE version=?" ); |
463 |
my $affected = $sth->execute( $version ); |
464 |
if ( $affected < 1 ) { |
465 |
# For "Coherency" |
466 |
my $filepath = get_filepath $version; |
467 |
my $queries = get_queries $filepath; |
468 |
my $errors; |
469 |
for my $query ( @{$queries->{queries}} ) { |
470 |
eval { |
471 |
check_coherency( $query ); |
472 |
}; |
473 |
if ( $@ ) { |
474 |
push @$errors, $@ |
475 |
} |
476 |
} |
477 |
|
478 |
$_ =~ s/at [^ ]* line \d*\.$// for @$errors; |
479 |
my $md5 = get_md5 $filepath; |
480 |
set_infos $version, $queries, $errors, $md5; |
481 |
|
482 |
$sth->execute( $version ); |
483 |
} |
484 |
$sth->finish; |
485 |
} |
486 |
|
487 |
=head2 is_uptodate |
488 |
is_uptodate(); |
489 |
return 1 if the database is up to date else 0. |
490 |
The database is up to date if all versions are excecuted. |
491 |
=cut |
492 |
sub is_uptodate { |
493 |
my $versions_availables = C4::Update::Database::list_versions_availables; |
494 |
my $versions = C4::Update::Database::list_versions_already_knows; |
495 |
for my $v ( @$versions_availables ) { |
496 |
if ( not grep { $v eq $$_{version} } @$versions ) { |
497 |
return 0; |
498 |
} |
499 |
} |
500 |
return 1; |
501 |
} |
502 |
|
503 |
=head2 TransformToNum |
504 |
|
505 |
Transform the Koha version from a 4 parts string |
506 |
to a number, with just 1 . (ie: it's a number) |
507 |
|
508 |
=cut |
509 |
sub TransformToNum { |
510 |
my $version = shift; |
511 |
|
512 |
# remove the 3 last . to have a Perl number |
513 |
$version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/; |
514 |
$version =~ s/Bug(\d+)/$1/; |
515 |
return $version; |
516 |
} |
517 |
|
518 |
sub SetVersion { |
519 |
my $kohaversion = TransformToNum(shift); |
520 |
if ( C4::Context->preference('Version') ) { |
521 |
my $finish = $dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'"); |
522 |
$finish->execute($kohaversion); |
523 |
} else { |
524 |
my $finish = $dbh->prepare( |
525 |
"INSERT IGNORE INTO systempreferences (variable,value,explanation) values ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')" |
526 |
); |
527 |
$finish->execute($kohaversion); |
528 |
} |
529 |
} |
530 |
|
531 |
=head2 TableExists($table) |
532 |
|
533 |
=cut |
534 |
sub TableExists { |
535 |
my $table = shift; |
536 |
eval { |
537 |
local $dbh->{PrintError} = 0; |
538 |
local $dbh->{RaiseError} = 1; |
539 |
$dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 }); |
540 |
}; |
541 |
return 1 unless $@; |
542 |
return 0; |
543 |
} |
544 |
|
545 |
1; |