+package C4::Update::Database;
+
+# Copyright Biblibre 2012
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with Koha; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+use Modern::Perl;
+
+use C4::Context;
+
+use File::Basename;
+use File::Find::Rule;
+use Digest::MD5;
+use List::MoreUtils qw/uniq/;
+use YAML;
+
+=head1 NAME
+
+C4::Update::Database.pm
+
+=head1 SYNOPSIS
+
+ use C4::Update::Database;
+
+ This package is used by admin/updatedatabase.pl, to manage DB updates
+
+=head1 FUNCTIONS
+
+=cut
+
+my $VERSIONS_PATH = C4::Context->config('intranetdir') . '/installer/data/mysql/versions';
+
+my $version;
+my $list;
+
+my $dbh = C4::Context->dbh;
+
+=head2 get_filepath
+
+ my $file = get_filepath($version);
+ this sub will return the full path of a given DB update number
+
+=cut
+
+sub get_filepath {
+ my ( $version ) = @_;
+ my @files = File::Find::Rule->file->name( "$version.sql", "$version.pl" ) ->in( ( $VERSIONS_PATH ) );
+
+ if ( scalar @files != 1 ) {
+ die "This version ($version) returned has ".scalar @files." corresponding, need only 1";
+ }
+
+ return $files[0];
+}
+
+=head2 get_md5
+
+ my $md5 = get_md5($filepath)
+ returns the md5sum of the selected file.
+ This is used to check consistency of updates
+
+=cut
+
+sub get_md5 {
+ my ( $filepath ) = @_;
+ open(FILE, $filepath);
+
+ my $ctx = Digest::MD5->new;
+ $ctx->addfile(*FILE);
+ my $md5 = $ctx->hexdigest;
+ close(FILE);
+ return $md5;
+}
+
+=head2 execute_version
+
+ $result = execute_version($version_number);
+ Execute an update.
+ This sub will detect if the number is made through a .pl or a .sql, and behave accordingly
+ if there is more than 1 file with the same number, an error will be issued
+ if you try to execute a version_number that has already be executed, then it will also issue an error
+ the sub return an result hash, with the version number and the result
+
+=cut
+
+sub execute_version {
+ my ( $version ) = @_;
+ my $report;
+
+ my $filepath;
+ eval {
+ $filepath = get_filepath $version;
+ };
+ if ( $@ ) {
+ return { $version => $@ };
+ }
+
+ my @file_infos = fileparse( $filepath, qr/\.[^.]*/ );
+ my $extension = $file_infos[2];
+ my $filename = $version . $extension;
+
+ my $md5 = get_md5 $filepath;
+ my $r = md5_already_exists( $md5 );
+ if ( scalar @$r ) {
+ my $p = @$r[0];
+ $report->{$version} = {
+ error => "ALREADY_EXISTS",
+ filepath => $filepath,
+ old_version => @$r[0]->{version},
+ md5 => @$r[0]->{md5},
+ };
+ return $report;
+ }
+
+ my $queries;
+ given ( $extension ) {
+ when ( /.sql/ ) {
+ $queries = get_queries ( $filepath );
+ }
+ when ( /.pl/ ) {
+ eval {
+ $queries = get_queries ( $filepath );
+ };
+ if ($@) {
+ $report->{$version} = {
+ error => "LOAD_FUNCTIONS_FAILED",
+ filename => $filename,
+ error_str => $@,
+ };
+ }
+ }
+ default {
+ $report->{$version} = {
+ error => "BAD_EXTENSION",
+ extension => $extension,
+ };
+ }
+ }
+
+ return $report
+ if ( defined $report->{$version} );
+
+ my $errors = execute ( $queries );
+ $report->{$version} = scalar( @$errors ) ? $errors : "OK";
+ set_infos ( $version, $queries, $errors, $md5 );
+ return $report;
+}
+
+=head2 list_versions_available
+
+ my @versions = list_versions_available;
+ return an array with all version available
+
+=cut
+
+sub list_versions_available {
+ my @versions;
+
+ my @files = File::Find::Rule->file->name( "*.sql", "*.pl" ) ->in( ( $VERSIONS_PATH ) );
+
+ for my $f ( @files ) {
+ my @file_infos = fileparse( $f, qr/\.[^.]*/ );
+ push @versions, $file_infos[0];
+ }
+ @versions = uniq @versions;
+ return \@versions;
+}
+
+=head2 list_versions_already_applied
+
+ my @versions = list_versions_available;
+ return an array with all version that have already been applied
+ This sub check first that the updatedb tables exist and create them if needed
+
+=cut
+
+sub list_versions_already_applied {
+ # 1st check if tables exist, otherwise create them
+ $dbh->do(qq{
+ CREATE TABLE IF NOT EXISTS `updatedb_error` ( `version` varchar(32) DEFAULT NULL, `error` text ) ENGINE=InnoDB CHARSET=utf8;
+ });
+ $dbh->do(qq{
+ CREATE TABLE IF NOT EXISTS `updatedb_query` ( `version` varchar(32) DEFAULT NULL, `query` text ) ENGINE=InnoDB CHARSET=utf8;
+ });
+ $dbh->do(qq{
+ 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;
+ });
+
+ my $query = qq/ SELECT version, comment, status FROM updatedb_report ORDER BY version/;
+ my $sth = $dbh->prepare( $query );
+ $sth->execute;
+ my $versions = $sth->fetchall_arrayref( {} );
+ map {
+ my $version = $_;
+ my @comments = defined $_->{comment} ? split '\\\n', $_->{comment} : "";
+ push @{ $version->{comments} }, { comment => $_ } for @comments;
+ delete $version->{comment};
+ } @$versions;
+ $sth->finish;
+ for my $version ( @$versions ) {
+ $query = qq/ SELECT query FROM updatedb_query WHERE version = ? ORDER BY version/;
+ $sth = $dbh->prepare( $query );
+ $sth->execute( $version->{version} );
+ $version->{queries} = $sth->fetchall_arrayref( {} );
+ $sth->finish;
+ $query = qq/ SELECT error FROM updatedb_error WHERE version = ? ORDER BY version/;
+ $sth = $dbh->prepare( $query );
+ $sth->execute( $version->{version} );
+ $version->{errors} = $sth->fetchall_arrayref( {} );
+ $sth->finish;
+ }
+ return $versions;
+}
+
+=head2 execute
+
+ my @errors = $execute(\@queries);
+ This sub will execute queries coming from an execute_version based on a .sql file
+
+=cut
+
+sub execute {
+ my ( $queries ) = @_;
+ my @errors;
+ for my $query ( @{$queries->{queries}} ) {
+ eval {
+ $dbh->do( $query );
+ };
+ push @errors, get_error();
+ }
+ return \@errors;
+}
+
+=head2 get_tables_name
+
+ my $tables = get_tables_name;
+ return an array with all Koha mySQL table names
+
+=cut
+
+sub get_tables_name {
+ my $sth = $dbh->prepare("SHOW TABLES");
+ $sth->execute();
+ my @tables;
+ while ( my ( $table ) = $sth->fetchrow_array ) {
+ push @tables, $table;
+ }
+ return \@tables;
+}
+my $tables;
+
+=head2 check_coherency
+
+ my $errors = check_coherency($query); UNUSED
+ This sub will try to check if a SQL query is useless or no.
+ for queries that are CREATE TABLE, it will check if the table already exists
+ for queries that are ALTER TABLE, it will search if the modification has already been made
+ for queries that are INSERT, it will search if the insert has already been made if it's a syspref or a permission
+
+ Those test cover 90% of the updatedatabases cases. That will help finding duplicate or inconsistencies
+
+=cut
+
+#sub check_coherency {
+# my ( $query ) = @_;
+# $tables = get_tables_name() if not $tables;
+#
+# given ( $query ) {
+# when ( /CREATE TABLE(?:.*?)? `?(\w+)`?/ ) {
+# my $table_name = $1;
+# if ( grep { /$table_name/ } @$tables ) {
+# die "COHERENCY: Table $table_name already exists";
+# }
+# }
+#
+# when ( /ALTER TABLE *`?(\w+)`? *ADD *(?:COLUMN)? `?(\w+)`?/ ) {
+# my $table_name = $1;
+# my $column_name = $2;
+# next if $column_name =~ /(UNIQUE|CONSTRAINT|INDEX|KEY|FOREIGN)/;
+# if ( not grep { /$table_name/ } @$tables ) {
+# return "COHERENCY: Table $table_name does not exist";
+# } else {
+# my $sth = $dbh->prepare( "DESC $table_name $column_name" );
+# my $rv = $sth->execute;
+# if ( $rv > 0 ) {
+# die "COHERENCY: Field $table_name.$column_name already exists";
+# }
+# }
+# }
+#
+# when ( /INSERT INTO `?(\w+)`?.*?VALUES *\((.*?)\)/ ) {
+# my $table_name = $1;
+# my @values = split /,/, $2;
+# s/^ *'// foreach @values;
+# s/' *$// foreach @values;
+# given ( $table_name ) {
+# when ( /systempreferences/ ) {
+# my $syspref = $values[0];
+# my $sth = $dbh->prepare( "SELECT COUNT(*) FROM systempreferences WHERE variable = ?" );
+# $sth->execute( $syspref );
+# if ( ( my $count = $sth->fetchrow_array ) > 0 ) {
+# die "COHERENCY: Syspref $syspref already exists";
+# }
+# }
+#
+# when ( /permissions/){
+# my $module_bit = $values[0];
+# my $code = $values[1];
+# my $sth = $dbh->prepare( "SELECT COUNT(*) FROM permissions WHERE module_bit = ? AND code = ?" );
+# $sth->execute($module_bit, $code);
+# if ( ( my $count = $sth->fetchrow_array ) > 0 ) {
+# die "COHERENCY: Permission $code already exists";
+# }
+# }
+# }
+# }
+# }
+# return 1;
+#}
+
+=head2 get_error
+
+ my $errors = get_error()
+ This sub will return any mySQL error that occured during an update
+
+=cut
+
+sub get_error {
+ my @errors = $dbh->selectrow_array(qq{SHOW ERRORS}); # Get errors
+ my @warnings = $dbh->selectrow_array(qq{SHOW WARNINGS}); # Get warnings
+ if ( @errors ) { # Catch specifics errors
+ return qq{$errors[0] : $errors[1] => $errors[2]};
+ } elsif ( @warnings ) {
+ return qq{$warnings[0] : $warnings[1] => $warnings[2]}
+ if $warnings[0] ne 'Note';
+ }
+ return;
+}
+
+=head2 get_queries
+
+ my $result = get_queries($filepath);
+ this sub will return a hashref with 2 entries:
+ $result->{queries} is an array with all queries to execute
+ $result->{comments} is an array with all comments in the .sql file
+
+=cut
+
+sub get_queries {
+ my ( $filepath ) = @_;
+ open my $fh, "<", $filepath;
+ my @queries;
+ my @comments;
+ if ( $filepath =~ /\.pl$/ ) {
+ if ( do $filepath ) {
+ my $infos = _get_queries();
+ @queries = @{ $infos->{queries} } if exists $infos->{queries};
+ @comments = @{ $infos->{comments} } if exists $infos->{comments};
+ }
+ if ( $@ ) {
+ die "I can't load $filepath. Please check the execute flag and if this file is a valid perl script ($@)";
+ }
+ } else {
+ my $old_delimiter = $/;
+ while ( <$fh> ) {
+ my $line = $_;
+ chomp $line;
+ $line =~ s/^\s*//;
+ if ( $line =~ /^--/ ) {
+ my @l = split $old_delimiter, $line;
+ if ( @l > 1 ) {
+ my $tmp_query;
+ for my $l ( @l ) {
+ if ( $l =~ /^--/ ) {
+ $l =~ s/^--\s*//;
+ push @comments, $l;
+ next;
+ }
+ $tmp_query .= $l . $old_delimiter;
+ }
+ push @queries, $tmp_query if $tmp_query;
+ next;
+ }
+
+ $line =~ s/^--\s*//;
+ push @comments, $line;
+ next;
+ }
+ if ( $line =~ /^delimiter (.*)$/i ) {
+ $/ = $1;
+ next;
+ }
+ $line =~ s#$/##;
+ push @queries, $line if not $line =~ /^\s*$/; # Push if query is not empty
+ }
+ $/ = $old_delimiter;
+ close $fh;
+ }
+
+ return { queries => \@queries, comments => \@comments };
+}
+
+=head2 md5_already_exists
+
+ my $result = md5_already_exists($md5);
+ check if the md5 of an update has already been applied on the database.
+ If yes, it will return a hash with the version related to this md5
+
+=cut
+
+sub md5_already_exists {
+ my ( $md5 ) = @_;
+ my $query = qq/SELECT version, md5 FROM updatedb_report WHERE md5 = ?/;
+ my $sth = $dbh->prepare( $query );
+ $sth->execute( $md5 );
+ my @r;
+ while ( my ( $version, $md5 ) = $sth->fetchrow ) {
+ push @r, { version => $version, md5 => $md5 };
+ }
+ $sth->finish;
+ return \@r;
+}
+
+=head2 set_infos
+
+ set_info($version,$queries, $error, $md5);
+ this sub will insert into the updatedb tables what has been made on the database (queries, errors, result)
+
+=cut
+
+sub set_infos {
+ my ( $version, $queries, $errors, $md5 ) = @_;
+ SetVersion($version) if not -s $errors;
+ for my $query ( @{ $queries->{queries} } ) {
+ my $sth = $dbh->prepare("INSERT INTO updatedb_query(version, query) VALUES (?, ?)");
+ $sth->execute( $version, $query );
+ $sth->finish;
+ }
+ for my $error ( @$errors ) {
+ my $sth = $dbh->prepare("INSERT INTO updatedb_error(version, error) VALUES (?, ?)");
+ $sth->execute( $version, $error );
+ }
+ my $sth = $dbh->prepare("INSERT INTO updatedb_report(version, md5, comment, status) VALUES (?, ?, ?, ?)");
+ $sth->execute(
+ $version,
+ $md5,
+ join ('\n', @{ $queries->{comments} }),
+ ( @$errors > 0 ) ? 0 : 1
+ );
+}
+
+=head2 mark_as_ok
+
+ mark_as_ok($version);
+ this sub will force to mark as "OK" an update that has failed
+ 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
+
+=cut
+
+sub mark_as_ok {
+ my ( $version ) = @_;
+ my $sth = $dbh->prepare( "UPDATE updatedb_report SET status = 2 WHERE version=?" );
+ my $affected = $sth->execute( $version );
+ if ( $affected < 1 ) {
+ my $filepath = get_filepath $version;
+ my $queries = get_queries $filepath;
+ my $md5 = get_md5 $filepath;
+ set_infos $version, $queries, undef, $md5;
+
+ $sth->execute( $version );
+ }
+ $sth->finish;
+}
+
+=head2 is_uptodate
+ is_uptodate();
+ return 1 if the database is up to date else 0.
+ The database is up to date if all versions are excecuted.
+
+=cut
+
+sub is_uptodate {
+ my $versions_available = C4::Update::Database::list_versions_available;
+ my $versions = C4::Update::Database::list_versions_already_applied;
+ for my $v ( @$versions_available ) {
+ if ( not grep { $v eq $$_{version} } @$versions ) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+=head2 TransformToNum
+
+ Transform the Koha version from a 4 parts string
+ to a number, with just 1 . (ie: it's a number)
+
+=cut
+
+sub TransformToNum {
+ my $version = shift;
+
+ # remove the 3 last . to have a Perl number
+ $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
+ $version =~ s/Bug(\d+)/$1/;
+ return $version;
+}
+
+sub SetVersion {
+ my $new_version = TransformToNum(shift);
+ return unless $new_version =~ /\d\.\d+/;
+ my $current_version = TransformToNum( C4::Context->preference('Version') );
+ unless ( C4::Context->preference('Version') ) {
+ my $finish = $dbh->prepare(qq{
+ 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')
+ });
+ $finish->execute($new_version);
+ return;
+ }
+ if ( $new_version > $current_version ) {
+ my $finish = $dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
+ $finish->execute($new_version);
+ }
+}
+
+=head2 TableExists($table)
+
+=cut
+
+sub TableExists {
+ my $table = shift;
+ eval {
+ local $dbh->{PrintError} = 0;
+ local $dbh->{RaiseError} = 0;
+ $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
+ };
+ return 1 unless $@;
+ return 0;
+}
+1;