X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FInstaller.pm;h=ffab0ed76acc04f33490ce73adcc5c7e07384694;hb=5cfd9ce73090d988fa841f35ea3f861792e31ce6;hp=304698ed0eb9f3daa1ac7d4fb135372a57d0c40e;hpb=e5a24bbbdd0d0e9ff09bfaadfe4c4bb37312e7ec;p=koha-ffzg.git diff --git a/C4/Installer.pm b/C4/Installer.pm index 304698ed0e..ffab0ed76a 100644 --- a/C4/Installer.pm +++ b/C4/Installer.pm @@ -4,25 +4,38 @@ package C4::Installer; # # 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 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 3 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. +# 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. +# You should have received a copy of the GNU General Public License +# along with Koha; if not, see . -use strict; -#use warnings; FIXME - Bug 2505 +use Modern::Perl; + +use Try::Tiny; +use Encode qw( encode decode is_utf8 ); +use DBIx::RunSQL; +use YAML::XS; +use File::Slurp qw( read_file ); +use DBI; -our $VERSION = 3.07.00.049; use C4::Context; -use C4::Installer::PerlModules; +use Koha::Schema; +use Koha; + +use vars qw(@ISA @EXPORT); +BEGIN { + require Exporter; + @ISA = qw( Exporter ); + push @EXPORT, qw( primary_key_exists unique_key_exists foreign_key_exists index_exists column_exists TableExists marc_framework_sql_list TransformToNum CheckVersion NewVersion SetVersion sanitize_zero_date update get_db_entries get_atomic_updates run_atomic_updates ); +}; =head1 NAME @@ -34,11 +47,11 @@ C4::Installer my $installer = C4::Installer->new(); my $all_languages = getAllLanguages(); my $error = $installer->load_db_schema(); - my $list = $installer->sql_file_list('en', 'marc21', { optional => 1, mandatory => 1 }); + my $list; + #fill $list with list of sql files my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list); $installer->set_version_syspref(); $installer->set_marcflavour_syspref('MARC21'); - $installer->set_indexing_engine(0); =head1 DESCRIPTION @@ -60,14 +73,23 @@ sub new { my $self = {}; # get basic information from context - $self->{'dbname'} = C4::Context->config("database"); + $self->{'dbname'} = C4::Context->config("database_test") || C4::Context->config("database"); $self->{'dbms'} = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql"; $self->{'hostname'} = C4::Context->config("hostname"); $self->{'port'} = C4::Context->config("port"); $self->{'user'} = C4::Context->config("user"); $self->{'password'} = C4::Context->config("pass"); + $self->{'tls'} = C4::Context->config("tls"); + if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) { + $self->{'ca'} = C4::Context->config('ca'); + $self->{'cert'} = C4::Context->config('cert'); + $self->{'key'} = C4::Context->config('key'); + $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca}; + $self->{'tlscmdline'} = " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." " + } $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" . - ( $self->{port} ? ";port=$self->{port}" : "" ), + ( $self->{port} ? ";port=$self->{port}" : "" ). + ( $self->{tlsoptions} ? $self->{tlsoptions} : ""), $self->{'user'}, $self->{'password'}); $self->{'language'} = undef; $self->{'marcflavour'} = undef; @@ -78,27 +100,6 @@ sub new { return $self; } -=head2 marcflavour_list - - my ($marcflavours) = $installer->marcflavour_list($lang); - -Return a arrayref of the MARC flavour sets available for the -specified language C<$lang>. Returns 'undef' if a directory -for the language does not exist. - -=cut - -sub marcflavour_list { - my $self = shift; - my $lang = shift; - - my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour"; - opendir(MYDIR, $dir) or return; - my @list = grep { !/^\.|CVS/ && -d "$dir/$_" } readdir(MYDIR); - closedir MYDIR; - return \@list; -} - =head2 marc_framework_sql_list my ($defaulted_to_en, $list) = @@ -148,23 +149,28 @@ sub marc_framework_sql_list { foreach my $requirelevel (@listdir) { opendir( MYDIR, "$dir/$requirelevel" ); - my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR); + my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR); closedir MYDIR; my %cell; my @frameworklist; map { - my $name = substr( $_, 0, -4 ); - open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt"; - my $lines = <$fh>; - $lines =~ s/\n|\r/
/g; - use utf8; - utf8::encode($lines) unless ( utf8::is_utf8($lines) ); + my ( $name, $ext ) = split /\./, $_; + my @lines; + if ( $ext =~ /yml/ ) { + my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext"); + @lines = @{ $yaml->{'description'} }; + } else { + open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt"; + my $line = <$fh>; + $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) ); + @lines = split /\n/, $line; + } my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i); push @frameworklist, { 'fwkname' => $name, 'fwkfile' => "$dir/$requirelevel/$_", - 'fwkdescription' => $lines, + 'fwkdescription' => \@lines, 'checked' => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ), 'mandatory' => $mandatory, }; @@ -173,7 +179,7 @@ sub marc_framework_sql_list { sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist; $cell{"frameworks"} = \@fwks; - $cell{"label"} = ucfirst($requirelevel); + $cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional'; $cell{"code"} = lc($requirelevel); push @fwklist, \%cell; } @@ -226,23 +232,28 @@ sub sample_data_sql_list { foreach my $requirelevel (@listdir) { opendir( MYDIR, "$dir/$requirelevel" ); - my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR); + my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR); closedir MYDIR; my %cell; my @frameworklist; map { - my $name = substr( $_, 0, -4 ); - open my $fh , "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt"; - my $lines = <$fh>; - $lines =~ s/\n|\r/
/g; - use utf8; - utf8::encode($lines) unless ( utf8::is_utf8($lines) ); + my ( $name, $ext ) = split /\./, $_; + my @lines; + if ( $ext =~ /yml/ ) { + my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext"); + @lines = @{ $yaml->{'description'} }; + } else { + open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt"; + my $line = <$fh>; + $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) ); + @lines = split /\n/, $line; + } my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i); push @frameworklist, { 'fwkname' => $name, 'fwkfile' => "$dir/$requirelevel/$_", - 'fwkdescription' => $lines, + 'fwkdescription' => \@lines, 'checked' => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ), 'mandatory' => $mandatory, }; @@ -250,7 +261,7 @@ sub sample_data_sql_list { my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist; $cell{"frameworks"} = \@fwks; - $cell{"label"} = ucfirst($requirelevel); + $cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional'; $cell{"code"} = lc($requirelevel); push @levellist, \%cell; } @@ -258,41 +269,6 @@ sub sample_data_sql_list { return ($defaulted_to_en, \@levellist); } -=head2 sql_file_list - - my $list = $installer->sql_file_list($lang, $marcflavour, $subset_wanted); - -Returns an arrayref containing the filepaths of installer SQL scripts -available for laod. The C<$lang> and C<$marcflavour> arguments -specify the desired language and MARC flavour. while C<$subset_wanted> -is a hashref containing possible named parameters 'mandatory' and 'optional'. - -=cut - -sub sql_file_list { - my $self = shift; - my $lang = shift; - my $marcflavour = shift; - my $subset_wanted = shift; - - my ($marc_defaulted_to_en, $marc_sql) = $self->marc_framework_sql_list($lang, $marcflavour); - my ($sample_defaulted_to_en, $sample_sql) = $self->sample_data_sql_list($lang); - - my @sql_list = (); - map { - map { - if ($subset_wanted->{'mandatory'}) { - push @sql_list, $_->{'fwkfile'} if $_->{'mandatory'}; - } - if ($subset_wanted->{'optional'}) { - push @sql_list, $_->{'fwkfile'} unless $_->{'mandatory'}; - } - } @{ $_->{'frameworks'} } - } (@$marc_sql, @$sample_sql); - - return \@sql_list -} - =head2 load_db_schema my $error = $installer->load_db_schema(); @@ -307,7 +283,24 @@ sub load_db_schema { my $self = shift; my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}"; + + # Disable checks before load + # NOTE: These lines are found in kohastructure itself, but DBIx::RunSQL ignores them! + $self->{'dbh'}->do(q{SET NAMES utf8mb4}); + $self->{'dbh'}->do(q{SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0}); + $self->{'dbh'}->do(q{SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0}); + $self->{'dbh'}->do(q{SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO'}); + $self->{'dbh'}->do(q{SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0}); + + # Load kohastructure my $error = $self->load_sql("$datadir/kohastructure.sql"); + + # Re-enable checks after load + $self->{'dbh'}->do(q{SET SQL_MODE=@OLD_SQL_MODE}); + $self->{'dbh'}->do(q{SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS}); + $self->{'dbh'}->do(q{SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS}); + $self->{'dbh'}->do(q{SET SQL_NOTES=@OLD_SQL_NOTES}); + return $error; } @@ -340,6 +333,7 @@ moved to a different method. sub load_sql_in_order { my $self = shift; + my $langchoice = shift; my $all_languages = shift; my @sql_list = @_; @@ -354,16 +348,38 @@ sub load_sql_in_order { $request->execute; my ($systempreference) = $request->fetchrow; $systempreference = '' unless defined $systempreference; # avoid warning - # Make sure the global sysprefs.sql file is loaded first - my $globalsysprefs = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/sysprefs.sql"; - unshift(@fnames, $globalsysprefs); + + my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory"; + + # Make sure some stuffs are loaded first + unshift(@fnames, + "$global_mandatory_dir/sysprefs.sql", + "$global_mandatory_dir/subtag_registry.sql", + "$global_mandatory_dir/auth_val_cat.sql", + "$global_mandatory_dir/message_transport_types.sql", + "$global_mandatory_dir/sample_notices_message_attributes.sql", + "$global_mandatory_dir/sample_notices_message_transports.sql", + "$global_mandatory_dir/keyboard_shortcuts.sql", + ); + + push @fnames, "$global_mandatory_dir/userflags.sql", + "$global_mandatory_dir/userpermissions.sql", + "$global_mandatory_dir/audio_alerts.sql", + "$global_mandatory_dir/account_credit_types.sql", + "$global_mandatory_dir/account_debit_types.sql", + ; + my $localization_file = C4::Context->config('intranetdir') . + "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql"; + if ( -f $localization_file ) { + push @fnames, $localization_file; + } foreach my $file (@fnames) { # warn $file; undef $/; my $error = $self->load_sql($file); my @file = split qr(\/|\\), $file; $lang = $file[ scalar(@file) - 3 ] unless ($lang); - my $level = $file[ scalar(@file) - 2 ]; + my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ]; unless ($error) { $systempreference .= "$file[scalar(@file)-1]|" unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 ); @@ -430,31 +446,6 @@ sub set_marcflavour_syspref { $request->execute; } -=head2 set_indexing_engine - - $installer->set_indexing_engine($nozebra); - -Sets system preferences related to the indexing -engine. The C<$nozebra> argument is a boolean; -if true, turn on NoZebra mode and turn off QueryFuzzy, -QueryWeightFields, and QueryStemming. If false, turn -off NoZebra mode (i.e., use the Zebra search engine). - -=cut - -sub set_indexing_engine { - my $self = shift; - my $nozebra = shift; - - if ($nozebra) { - $self->{'dbh'}->do("UPDATE systempreferences SET value=1 WHERE variable='NoZebra'"); - $self->{'dbh'}->do("UPDATE systempreferences SET value=0 WHERE variable in ('QueryFuzzy','QueryWeightFields','QueryStemming')"); - } else { - $self->{'dbh'}->do("UPDATE systempreferences SET value=0 WHERE variable='NoZebra'"); - } - -} - =head2 set_version_syspref $installer->set_version_syspref(); @@ -467,7 +458,7 @@ Koha software version. sub set_version_syspref { my $self = shift; - my $kohaversion=C4::Context::KOHAVERSION; + my $kohaversion = Koha::version(); # remove the 3 last . to have a Perl number $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/; if (C4::Context->preference('Version')) { @@ -482,66 +473,122 @@ sub set_version_syspref { C4::Context->clear_syspref_cache(); } +=head2 set_languages_syspref + + $installer->set_languages_syspref(); + +Add the installation language to 'language' and 'OPACLanguages' system preferences +if different from 'en' + +=cut + +sub set_languages_syspref { + my $self = shift; + my $language = shift; + + return if ( not $language or $language eq 'en' ); + + warn "UPDATE Languages"; + # intranet + my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'"); + $pref->execute("en,$language"); + # opac + $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'"); + $pref->execute("en,$language"); + + C4::Context->clear_syspref_cache(); +} + +=head2 process_yml_table + + my $query_info = $installer->process_yml_table($table); + +Analyzes a table loaded in YAML format. +Returns the values required to build an insert statement. + +=cut + +sub process_yml_table { + my ($table) = @_; + my $table_name = ( keys %$table )[0]; # table name + my @rows = @{ $table->{$table_name}->{rows} }; # + my @columns = ( sort keys %{$rows[0]} ); # column names + my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined + my $query = "INSERT INTO $table_name ( $fields ) VALUES "; + my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values; + my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string + my @values; + foreach my $row ( @rows ) { + push @values, [ map { + my $col = $_; + ( @multiline and grep { $_ eq $col } @multiline ) + ? join "\r\n", @{$row->{$col}} # join multiline values + : $row->{$col}; + } @columns ]; + } + return { query => $query, placeholders => $placeholders, values => \@values }; +} + =head2 load_sql my $error = $installer->load_sql($filename); -Runs a the specified SQL using the DB's command-line -SQL tool, and returns any strings sent to STDERR -by the command-line tool. +Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader +Returns any strings sent to STDERR -B there has been a long-standing desire to -replace this with an SQL loader that goes -through DBI; partly for portability issues -and partly to improve error handling. - -B even using the command-line loader, some more -basic error handling should be added - deal -with missing files, e.g. +# FIXME This should be improved: sometimes the caller and load_sql warn the same +error. =cut sub load_sql { my $self = shift; my $filename = shift; - - my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}"; my $error; - my $strcmd; - my $cmd; - if ( $self->{dbms} eq 'mysql' ) { - $cmd = qx(which mysql 2>/dev/null || whereis mysql 2>/dev/null); - chomp $cmd; - $cmd = $1 if ($cmd && $cmd =~ /^(.+?)[\r\n]+$/); - $cmd = 'mysql' if (!$cmd || !-x $cmd); - $strcmd = "$cmd " - . ( $self->{hostname} ? " -h $self->{hostname} " : "" ) - . ( $self->{port} ? " -P $self->{port} " : "" ) - . ( $self->{user} ? " -u $self->{user} " : "" ) - . ( $self->{password} ? " -p'$self->{password}'" : "" ) - . " $self->{dbname} "; - $error = qx($strcmd --default-character-set=utf8 <$filename 2>&1 1>/dev/null); - } elsif ( $self->{dbms} eq 'Pg' ) { - $cmd = qx(which psql 2>/dev/null || whereis psql 2>/dev/null); - chomp $cmd; - $cmd = $1 if ($cmd && $cmd =~ /^(.+?)[\r\n]+$/); - $cmd = 'psql' if (!$cmd || !-x $cmd); - $strcmd = "$cmd " - . ( $self->{hostname} ? " -h $self->{hostname} " : "" ) - . ( $self->{port} ? " -p $self->{port} " : "" ) - . ( $self->{user} ? " -U $self->{user} " : "" ) -# . ( $self->{password} ? " -W $self->{password}" : "" ) # psql will NOT accept a password, but prompts... - . " $self->{dbname} "; # Therefore, be sure to run 'trust' on localhost in pg_hba.conf -fbcit - $error = qx($strcmd -f $filename 2>&1 1>/dev/null); - # Be sure to set 'client_min_messages = error' in postgresql.conf - # so that only true errors are returned to stderr or else the installer will - # report the import a failure although it really succeded -fbcit - } -# errors thrown while loading installer data should be logged - if($error) { - warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n"; - warn "$error"; + + my $dbh = $self->{ dbh }; + + my $dup_stderr; + do { + local *STDERR; + open STDERR, ">>", \$dup_stderr; + + if ( $filename =~ /sql$/ ) { # SQL files + eval { + DBIx::RunSQL->run_sql_file( + dbh => $dbh, + sql => $filename, + ); + }; + } + else { # YAML files + eval { + my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML + for my $table ( @{ $yaml->{'tables'} } ) { + my $query_info = process_yml_table($table); + my $query = $query_info->{query}; + my $placeholders = $query_info->{placeholders}; + my $values = $query_info->{values}; + # Doing only 1 INSERT query for the whole table + my @all_rows_values = map { @$_ } @$values; + $query .= join ', ', ( $placeholders ) x scalar @$values; + $dbh->do( $query, undef, @all_rows_values ); + } + for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements + $dbh->do($statement); + } + }; + } + if ($@){ + warn "Something went wrong loading file $filename ($@)"; + } + }; + # errors thrown while loading installer data should be logged + if( $dup_stderr ) { + warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n"; + $error = $dup_stderr; } + return $error; } @@ -583,6 +630,410 @@ sub get_file_path_from_name { } +sub primary_key_exists { + my ( $table_name, $key_name ) = @_; + my $dbh = C4::Context->dbh; + my $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |; + my $exists; + if( $key_name ){ + $sql .= 'AND column_name = ? ' if $key_name; + ($exists) = $dbh->selectrow_array( $sql, undef, $key_name ); + } else { + ($exists) = $dbh->selectrow_array( $sql, undef ); + } + + return $exists; +} + +sub foreign_key_exists { + my ( $table_name, $constraint_name ) = @_; + my $dbh = C4::Context->dbh; + my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|); + return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|; +} + +sub unique_key_exists { + my ( $table_name, $constraint_name ) = @_; + my $dbh = C4::Context->dbh; + my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|); + return $infos =~ m|UNIQUE KEY `$constraint_name`|; +} + +sub index_exists { + my ( $table_name, $key_name ) = @_; + my $dbh = C4::Context->dbh; + my ($exists) = $dbh->selectrow_array( + qq| + SHOW INDEX FROM $table_name + WHERE key_name = ? + |, undef, $key_name + ); + return $exists; +} + +sub column_exists { + my ( $table_name, $column_name ) = @_; + return unless TableExists($table_name); + my $dbh = C4::Context->dbh; + my ($exists) = $dbh->selectrow_array( + qq| + SHOW COLUMNS FROM $table_name + WHERE Field = ? + |, undef, $column_name + ); + return $exists; +} + +sub TableExists { # Could be renamed table_exists for consistency + my $table = shift; + eval { + my $dbh = C4::Context->dbh; + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 1; + $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 }); + }; + return 1 unless $@; + return 0; +} + +sub version_from_file { + my $file = shift; + return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|; + return sprintf "%s.%s.%s.%s", $2, $3, $4, $5; +} + +sub get_db_entries { + my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs'; + opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)"; + my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh; + my @need_update; + for my $file ( @files ) { + my $version = version_from_file( $file ); + + unless ( $version ) { + warn "Invalid db_rev found: " . $file; + next + } + + next unless CheckVersion( $version ); + + push @need_update, sprintf( "%s/%s", $db_revs_dir, $file ); + } + return \@need_update; +} + +sub run_db_rev { + my ($file) = @_; + + my $db_rev = do $file; + + my $error; + my $out = ''; + open my $outfh, '>', \$out; + try { + my $schema = Koha::Database->new->schema; + $schema->txn_do( + sub { + $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } ); + } + ); + } + catch { + $error = $_; + }; + + close $outfh; + $out = decode( 'UTF-8', $out ); + + my $db_entry = { + filepath => $file, + bug_number => $db_rev->{bug_number}, + description => $db_rev->{description}, + exec_output => $out, + version => scalar version_from_file($file), + time => POSIX::strftime( "%H:%M:%S", localtime ), + error => $error + }; + $db_entry->{output} = generate_output_db_entry($db_entry, $out); + return $db_entry; +} + +sub update { + my ( $files, $params ) = @_; + + my $force = $params->{force} || 0; + + my ( @done, @errors ); + for my $file ( @$files ) { + + my $db_entry = run_db_rev($file); + + if ( $db_entry->{error} ) { + push @errors, $db_entry; + $force ? next : last ; + # We stop the update if an error occurred! + } + + SetVersion($db_entry->{version}); + push @done, $db_entry; + } + return { success => \@done, error => \@errors }; +} + +sub generate_output_db_entry { + my ( $db_entry ) = @_; + + my $description = $db_entry->{description}; + my $output = $db_entry->{output}; + my $DBversion = $db_entry->{version}; + my $bug_number = $db_entry->{bug_number}; + my $time = $db_entry->{time}; + my $exec_output = $db_entry->{exec_output}; + my $done = defined $db_entry->{done} + ? $db_entry->{done} + ? " done" + : " failed" + : ""; # For old versions, we don't know if we succeed or failed + + my @output; + + if ( $DBversion ) { + if ($bug_number) { + push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description); + } else { + push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description); + } + } else { # Atomic update + if ($bug_number) { + push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description); + } else { # Old atomic update syntax + push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time); + } + } + + if ($exec_output) { + foreach my $line (split /\n/, $exec_output) { + push @output, sprintf "\t%s", $line; + } + } + + return \@output; +} + +sub get_atomic_updates { + my @atomic_upate_files; + # if there is anything in the atomicupdate, read and execute it. + my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/'; + opendir( my $dirh, $update_dir ); + foreach my $file ( sort readdir $dirh ) { + next if $file !~ /\.(perl|pl)$/; #skip other files + next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files + + push @atomic_upate_files, $file; + } + return \@atomic_upate_files; +} + +sub run_atomic_updates { + my ( $files ) = @_; + + my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/'; + my ( @done, @errors ); + for my $file ( @$files ) { + my $filepath = $update_dir . $file; + + my $atomic_update; + if ( $file =~ m{\.perl$} ) { + my $code = read_file( $filepath ); + my ( $out, $err ) = ('', ''); + { + open my $oldout, ">&STDOUT"; + close STDOUT; + open STDOUT,'>:encoding(utf8)', \$out; + my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval + my $dbh = C4::Context->dbh; + eval $code; ## no critic (StringyEval) + $err = $@; + warn $err if $err; + close STDOUT; + open STDOUT, ">&", $oldout; + } + + $atomic_update = { + filepath => $filepath, + description => '', + version => undef, + time => POSIX::strftime( "%H:%M:%S", localtime ), + }; + + + $atomic_update->{output} = + $out + ? [ split "\n", $out ] + : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion) + + $atomic_update->{error} = $err if $err; + } elsif ( $file =~ m{\.pl$} ) { + $atomic_update = run_db_rev($filepath); + } else { + warn "Atomic update must be .perl or .pl ($file)"; + } + + if ( $atomic_update->{error} ) { + push @errors, $atomic_update; + } else { + push @done, $atomic_update; + } + } + + return { success => \@done, error => \@errors }; +} + +=head2 DropAllForeignKeys($table) + +Drop all foreign keys of the table $table + +=cut + +sub DropAllForeignKeys { + my ($table) = @_; + # get the table description + my $dbh = C4::Context->dbh; + my $sth = $dbh->prepare("SHOW CREATE TABLE $table"); + $sth->execute; + my $vsc_structure = $sth->fetchrow; + # split on CONSTRAINT keyword + my @fks = split /CONSTRAINT /,$vsc_structure; + # parse each entry + foreach (@fks) { + # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop + $_ = /(.*) FOREIGN KEY.*/; + my $id = $1; + if ($id) { + # we have found 1 foreign, drop it + $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id"); + $id=""; + } + } +} + + +=head2 TransformToNum + +Transform the Koha version from a 4 parts string +to a number, with just 1 . + +=cut + +sub TransformToNum { + my $version = shift; + # remove the 3 last . to have a Perl number + $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/; + # three X's at the end indicate that you are testing patch with dbrev + # change it into 999 + # prevents error on a < comparison between strings (should be: lt) + $version =~ s/XXX$/999/; + return $version; +} + +=head2 SetVersion + +set the DBversion in the systempreferences + +=cut + +sub SetVersion { + return if $_[0]=~ /XXX$/; + #you are testing a patch with a db revision; do not change version + my $kohaversion = TransformToNum($_[0]); + my $dbh = C4::Context->dbh; + if (C4::Context->preference('Version')) { + my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'"); + $finish->execute($kohaversion); + } else { + my $finish=$dbh->prepare("INSERT 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($kohaversion); + } + C4::Context::clear_syspref_cache(); # invalidate cached preferences +} + +# DEPRECATED Don't use it! +# Used for compatibility with older versions (from updatedatabase.pl) +sub NewVersion { + my ( $DBversion, $bug_number, $descriptions ) = @_; + + SetVersion($DBversion); + + my ( $description, $report ); + if ( ref($descriptions) ) { + $description = shift @$descriptions; + $report = join( "\n", @{$descriptions} ); + } + else { + $description = $descriptions; + } + + my $output = generate_output_db_entry( { + bug_number => $bug_number, + description => $description, + report => $report, + version => $DBversion, + time => POSIX::strftime( "%H:%M:%S", localtime ), + }); + + say join "\n", @$output; + +} + +=head2 CheckVersion + +Check whether a given update should be run when passed the proposed version +number. The update will always be run if the proposed version is greater +than the current database version and less than or equal to the version in +kohaversion.pl. The update is also run if the version contains XXX, though +this behavior will be changed following the adoption of non-linear updates +as implemented in bug 7167. + +=cut + +sub CheckVersion { + my ($proposed_version) = @_; + my $version_number = TransformToNum($proposed_version); + + # The following line should be deleted when bug 7167 is pushed + return 1 if ( $proposed_version =~ m/XXX/ ); + + if ( C4::Context->preference("Version") < $version_number + && $version_number <= TransformToNum( $Koha::VERSION ) ) + { + return 1; + } + + return 0; +} + +sub sanitize_zero_date { + my ( $table_name, $column_name ) = @_; + + my $dbh = C4::Context->dbh; + + my (undef, $datatype) = $dbh->selectrow_array(qq| + SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name); + + if ( $datatype eq 'date' ) { + $dbh->do(qq| + UPDATE $table_name + SET $column_name = NULL + WHERE CAST($column_name AS CHAR(10)) = '0000-00-00'; + |); + } else { + $dbh->do(qq| + UPDATE $table_name + SET $column_name = NULL + WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00'; + |); + } +} =head1 AUTHOR