C4/Update/Database.pm

   1 package C4::Update::Database;
   2
   3 # Copyright Biblibre 2012
   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 get_filepath
  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
  77 sub get_md5 {
  78     my ( $filepath ) = @_;
  79     open(FILE, $filepath);
  80
  81     my $ctx = Digest::MD5->new;
  82     $ctx->addfile(*FILE);
  83     my $md5 = $ctx->hexdigest;
  84     close(FILE);
  85     return $md5;
  86 }
  87
  88 =head2 execute_version
  89
  90   $result = execute_version($version_number);
  91   Execute an update.
  92   This sub will detect if the number is made through a .pl or a .sql, and behave accordingly
  93   if there is more than 1 file with the same number, an error will be issued
  94   if you try to execute a version_number that has already be executed, then it will also issue an error
  95   the sub return an result hash, with the version number and the result
  96
  97 =cut
  98
  99 sub execute_version {
 100     my ( $version ) = @_;
 101     my $report;
 102
 103     my $filepath;
 104     eval {
 105         $filepath = get_filepath $version;
 106     };
 107     if ( $@ ) {
 108         return { $version => $@ };
 109     }
 110
 111     my @file_infos = fileparse( $filepath, qr/\.[^.]*/ );
 112     my $extension = $file_infos[2];
 113     my $filename = $version . $extension;
 114
 115     my $md5 = get_md5 $filepath;
 116     my $r = md5_already_exists( $md5 );
 117     if ( scalar @$r ) {
 118         my $p = @$r[0];
 119         $report->{$version} = {
 120             error => "ALREADY_EXISTS",
 121             filepath => $filepath,
 122             old_version => @$r[0]->{version},
 123             md5 => @$r[0]->{md5},
 124         };
 125         return $report;
 126     }
 127
 128     my $queries;
 129     given ( $extension ) {
 130         when ( /.sql/ ) {
 131             $queries = get_queries ( $filepath );
 132         }
 133         when ( /.pl/ ) {
 134             eval {
 135                 $queries = get_queries ( $filepath );
 136             };
 137             if ($@) {
 138                 $report->{$version} = {
 139                     error => "LOAD_FUNCTIONS_FAILED",
 140                     filename => $filename,
 141                     error_str => $@,
 142                 };
 143             }
 144         }
 145         default {
 146             $report->{$version} = {
 147                 error => "BAD_EXTENSION",
 148                 extension => $extension,
 149             };
 150         }
 151     }
 152
 153     return $report
 154         if ( defined $report->{$version} );
 155
 156     my $errors = execute ( $queries );
 157     $report->{$version} = scalar( @$errors ) ? $errors : "OK";
 158     set_infos ( $version, $queries, $errors, $md5 );
 159     return $report;
 160 }
 161
 162 =head2 list_versions_available
 163
 164   my @versions = list_versions_available;
 165   return an array with all version available
 166
 167 =cut
 168
 169 sub list_versions_available {
 170     my @versions;
 171
 172     my @files = File::Find::Rule->file->name( "*.sql", "*.pl" ) ->in( ( $VERSIONS_PATH ) );
 173
 174     for my $f ( @files ) {
 175         my @file_infos = fileparse( $f, qr/\.[^.]*/ );
 176         push @versions, $file_infos[0];
 177     }
 178     @versions = uniq @versions;
 179     return \@versions;
 180 }
 181
 182 =head2 list_versions_already_applied
 183
 184   my @versions = list_versions_available;
 185   return an array with all version that have already been applied
 186   This sub check first that the updatedb tables exist and create them if needed
 187
 188 =cut
 189
 190 sub list_versions_already_applied {
 191     # 1st check if tables exist, otherwise create them
 192         $dbh->do(qq{
 193                 CREATE TABLE IF NOT EXISTS `updatedb_error` ( `version` varchar(32) DEFAULT NULL, `error` text ) ENGINE=InnoDB CHARSET=utf8;
 194         });
 195             $dbh->do(qq{
 196             CREATE TABLE  IF NOT EXISTS `updatedb_query` ( `version` varchar(32) DEFAULT NULL, `query` text ) ENGINE=InnoDB CHARSET=utf8;
 197         });
 198         $dbh->do(qq{
 199             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;
 200         });
 201
 202     my $query = qq/ SELECT version, comment, status FROM updatedb_report ORDER BY version/;
 203     my $sth = $dbh->prepare( $query );
 204     $sth->execute;
 205     my $versions = $sth->fetchall_arrayref( {} );
 206     map {
 207         my $version = $_;
 208         my @comments = defined $_->{comment} ? split '\\\n', $_->{comment} : "";
 209         push @{ $version->{comments} }, { comment => $_ } for @comments;
 210         delete $version->{comment};
 211     } @$versions;
 212     $sth->finish;
 213     for my $version ( @$versions ) {
 214         $query = qq/ SELECT query FROM updatedb_query WHERE version = ? ORDER BY version/;
 215         $sth = $dbh->prepare( $query );
 216         $sth->execute( $version->{version} );
 217         $version->{queries} = $sth->fetchall_arrayref( {} );
 218         $sth->finish;
 219         $query = qq/ SELECT error FROM updatedb_error WHERE version = ? ORDER BY version/;
 220         $sth = $dbh->prepare( $query );
 221         $sth->execute( $version->{version} );
 222         $version->{errors} = $sth->fetchall_arrayref( {} );
 223         $sth->finish;
 224     }
 225     return $versions;
 226 }
 227
 228 =head2 execute
 229
 230   my @errors = $execute(\@queries);
 231   This sub will execute queries coming from an execute_version based on a .sql file
 232
 233 =cut
 234
 235 sub execute {
 236     my ( $queries ) = @_;
 237     my @errors;
 238     for my $query ( @{$queries->{queries}} ) {
 239         eval {
 240             $dbh->do( $query );
 241         };
 242         push @errors, get_error();
 243     }
 244     return \@errors;
 245 }
 246
 247 =head2 get_tables_name
 248
 249   my $tables = get_tables_name;
 250   return an array with all Koha mySQL table names
 251
 252 =cut
 253
 254 sub get_tables_name {
 255     my $sth = $dbh->prepare("SHOW TABLES");
 256     $sth->execute();
 257     my @tables;
 258     while ( my ( $table ) = $sth->fetchrow_array ) {
 259         push @tables, $table;
 260     }
 261     return \@tables;
 262 }
 263 my $tables;
 264
 265 =head2 check_coherency
 266
 267   my $errors = check_coherency($query); UNUSED
 268   This sub will try to check if a SQL query is useless or no.
 269   for queries that are CREATE TABLE, it will check if the table already exists
 270   for queries that are ALTER TABLE, it will search if the modification has already been made
 271   for queries that are INSERT, it will search if the insert has already been made if it's a syspref or a permission
 272
 273   Those test cover 90% of the updatedatabases cases. That will help finding duplicate or inconsistencies
 274
 275 =cut
 276
 277 #sub check_coherency {
 278 #    my ( $query ) = @_;
 279 #    $tables = get_tables_name() if not $tables;
 280 #
 281 #    given ( $query ) {
 282 #        when ( /CREATE TABLE(?:.*?)? `?(\w+)`?/ ) {
 283 #            my $table_name = $1;
 284 #            if ( grep { /$table_name/ } @$tables ) {
 285 #                die "COHERENCY: Table $table_name already exists";
 286 #            }
 287 #        }
 288 #
 289 #        when ( /ALTER TABLE *`?(\w+)`? *ADD *(?:COLUMN)? `?(\w+)`?/ ) {
 290 #            my $table_name = $1;
 291 #            my $column_name = $2;
 292 #            next if $column_name =~ /(UNIQUE|CONSTRAINT|INDEX|KEY|FOREIGN)/;
 293 #            if ( not grep { /$table_name/ } @$tables ) {
 294 #                return "COHERENCY: Table $table_name does not exist";
 295 #            } else {
 296 #                my $sth = $dbh->prepare( "DESC $table_name $column_name" );
 297 #                my $rv = $sth->execute;
 298 #                if ( $rv > 0 ) {
 299 #                    die "COHERENCY: Field $table_name.$column_name already exists";
 300 #                }
 301 #            }
 302 #        }
 303 #
 304 #        when ( /INSERT INTO `?(\w+)`?.*?VALUES *\((.*?)\)/ ) {
 305 #            my $table_name = $1;
 306 #            my @values = split /,/, $2;
 307 #            s/^ *'// foreach @values;
 308 #            s/' *$// foreach @values;
 309 #            given ( $table_name ) {
 310 #                when ( /systempreferences/ ) {
 311 #                    my $syspref = $values[0];
 312 #                    my $sth = $dbh->prepare( "SELECT COUNT(*) FROM systempreferences WHERE variable = ?" );
 313 #                    $sth->execute( $syspref );
 314 #                    if ( ( my $count = $sth->fetchrow_array ) > 0 ) {
 315 #                        die "COHERENCY: Syspref $syspref already exists";
 316 #                    }
 317 #                }
 318 #
 319 #                when ( /permissions/){
 320 #                    my $module_bit = $values[0];
 321 #                    my $code = $values[1];
 322 #                    my $sth = $dbh->prepare( "SELECT COUNT(*) FROM permissions WHERE module_bit = ? AND code = ?" );
 323 #                    $sth->execute($module_bit, $code);
 324 #                    if ( ( my $count = $sth->fetchrow_array ) > 0 ) {
 325 #                        die "COHERENCY: Permission $code already exists";
 326 #                    }
 327 #                }
 328 #            }
 329 #        }
 330 #    }
 331 #    return 1;
 332 #}
 333
 334 =head2 get_error
 335
 336   my $errors = get_error()
 337   This sub will return any mySQL error that occured during an update
 338
 339 =cut
 340
 341 sub get_error {
 342     my @errors = $dbh->selectrow_array(qq{SHOW ERRORS}); # Get errors
 343     my @warnings = $dbh->selectrow_array(qq{SHOW WARNINGS}); # Get warnings
 344     if ( @errors ) { # Catch specifics errors
 345         return qq{$errors[0] : $errors[1] => $errors[2]};
 346     } elsif ( @warnings ) {
 347         return qq{$warnings[0] : $warnings[1] => $warnings[2]}
 348             if $warnings[0] ne 'Note';
 349     }
 350     return;
 351 }
 352
 353 =head2 get_queries
 354
 355   my $result = get_queries($filepath);
 356   this sub will return a hashref with 2 entries:
 357     $result->{queries} is an array with all queries to execute
 358     $result->{comments} is an array with all comments in the .sql file
 359
 360 =cut
 361
 362 sub get_queries {
 363     my ( $filepath ) = @_;
 364     open my $fh, "<", $filepath;
 365     my @queries;
 366     my @comments;
 367     if ( $filepath =~ /\.pl$/ ) {
 368         if ( do $filepath ) {
 369             my $infos = _get_queries();
 370             @queries  = @{ $infos->{queries} }  if exists $infos->{queries};
 371             @comments = @{ $infos->{comments} } if exists $infos->{comments};
 372         }
 373         if ( $@ ) {
 374             die "I can't load $filepath. Please check the execute flag and if this file is a valid perl script ($@)";
 375         }
 376     } else {
 377         my $old_delimiter = $/;
 378         while ( <$fh> ) {
 379             my $line = $_;
 380             chomp $line;
 381             $line =~ s/^\s*//;
 382             if ( $line =~ /^--/ ) {
 383                 my @l = split $old_delimiter, $line;
 384                 if ( @l > 1 ) {
 385                     my $tmp_query;
 386                     for my $l ( @l ) {
 387                         if ( $l =~ /^--/ ) {
 388                             $l =~ s/^--\s*//;
 389                             push @comments, $l;
 390                             next;
 391                         }
 392                         $tmp_query .= $l . $old_delimiter;
 393                     }
 394                     push @queries, $tmp_query if $tmp_query;
 395                     next;
 396                 }
 397
 398                 $line =~ s/^--\s*//;
 399                 push @comments, $line;
 400                 next;
 401             }
 402             if ( $line =~ /^delimiter (.*)$/i ) {
 403                 $/ = $1;
 404                 next;
 405             }
 406             $line =~ s#$/##;
 407             push @queries, $line if not $line =~ /^\s*$/; # Push if query is not empty
 408         }
 409         $/ = $old_delimiter;
 410         close $fh;
 411     }
 412
 413     return { queries => \@queries, comments => \@comments };
 414 }
 415
 416 =head2 md5_already_exists
 417
 418   my $result = md5_already_exists($md5);
 419   check if the md5 of an update has already been applied on the database.
 420   If yes, it will return a hash with the version related to this md5
 421
 422 =cut
 423
 424 sub md5_already_exists {
 425     my ( $md5 ) = @_;
 426     my $query = qq/SELECT version, md5 FROM updatedb_report WHERE md5 = ?/;
 427     my $sth = $dbh->prepare( $query );
 428     $sth->execute( $md5 );
 429     my @r;
 430     while ( my ( $version, $md5 ) = $sth->fetchrow ) {
 431         push @r, { version => $version, md5 => $md5 };
 432     }
 433     $sth->finish;
 434     return \@r;
 435 }
 436
 437 =head2 set_infos
 438
 439   set_info($version,$queries, $error, $md5);
 440   this sub will insert into the updatedb tables what has been made on the database (queries, errors, result)
 441
 442 =cut
 443
 444 sub set_infos {
 445     my ( $version, $queries, $errors, $md5 ) = @_;
 446     SetVersion($version) if not -s $errors;
 447     for my $query ( @{ $queries->{queries} } ) {
 448         my $sth = $dbh->prepare("INSERT INTO updatedb_query(version, query) VALUES (?, ?)");
 449         $sth->execute( $version, $query );
 450         $sth->finish;
 451     }
 452     for my $error ( @$errors ) {
 453         my $sth = $dbh->prepare("INSERT INTO updatedb_error(version, error) VALUES (?, ?)");
 454         $sth->execute( $version, $error );
 455     }
 456     my $sth = $dbh->prepare("INSERT INTO updatedb_report(version, md5, comment, status) VALUES (?, ?, ?, ?)");
 457     $sth->execute(
 458         $version,
 459         $md5,
 460         join ('\n', @{ $queries->{comments} }),
 461         ( @$errors > 0 ) ? 0 : 1
 462     );
 463 }
 464
 465 =head2 mark_as_ok
 466
 467   mark_as_ok($version);
 468   this sub will force to mark as "OK" an update that has failed
 469   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
 470
 471 =cut
 472
 473 sub mark_as_ok {
 474     my ( $version ) = @_;
 475     my $sth = $dbh->prepare( "UPDATE updatedb_report SET status = 2 WHERE version=?" );
 476     my $affected = $sth->execute( $version );
 477     if ( $affected < 1 ) {
 478         my $filepath = get_filepath $version;
 479         my $queries  = get_queries $filepath;
 480         my $md5      = get_md5 $filepath;
 481         set_infos $version, $queries, undef, $md5;
 482
 483         $sth->execute( $version );
 484     }
 485     $sth->finish;
 486 }
 487
 488 =head2 is_uptodate
 489   is_uptodate();
 490   return 1 if the database is up to date else 0.
 491   The database is up to date if all versions are excecuted.
 492
 493 =cut
 494
 495 sub is_uptodate {
 496     my $versions_available = C4::Update::Database::list_versions_available;
 497     my $versions = C4::Update::Database::list_versions_already_applied;
 498     for my $v ( @$versions_available ) {
 499         if ( not grep { $v eq $$_{version} } @$versions ) {
 500             return 0;
 501         }
 502     }
 503     return 1;
 504 }
 505
 506 =head2 TransformToNum
 507
 508   Transform the Koha version from a 4 parts string
 509   to a number, with just 1 . (ie: it's a number)
 510
 511 =cut
 512
 513 sub TransformToNum {
 514     my $version = shift;
 515
 516     # remove the 3 last . to have a Perl number
 517     $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 518     $version =~ s/Bug(\d+)/$1/;
 519     return $version;
 520 }
 521
 522 sub SetVersion {
 523     my $new_version = TransformToNum(shift);
 524     return unless $new_version =~ /\d\.\d+/;
 525     my $current_version = TransformToNum( C4::Context->preference('Version') );
 526     unless ( C4::Context->preference('Version') ) {
 527         my $finish = $dbh->prepare(qq{
 528             INSERT IGNORE INTO systempreferences (variable,value,explanation)
 529             VALUES ('Version',?,'The Koha database version. WARNING: Do not change this value manually, it is maintained by the webinstaller')
 530         });
 531         $finish->execute($new_version);
 532         return;
 533     }
 534     if ( $new_version > $current_version ) {
 535         my $finish = $dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 536         $finish->execute($new_version);
 537     }
 538 }
 539
 540 =head2 TableExists($table)
 541
 542 =cut
 543
 544 sub TableExists {
 545     my $table = shift;
 546     eval {
 547         local $dbh->{PrintError} = 0;
 548         local $dbh->{RaiseError} = 0;
 549         $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 550     };
 551     return 1 unless $@;
 552     return 0;
 553 }
 554 1;