X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FInstaller.pm;h=ffab0ed76acc04f33490ce73adcc5c7e07384694;hb=a195708e97159831184a081dabae007bfe00e14a;hp=012bc1c3cdcebc9035a568bcf1f47d379cc7b1bc;hpb=e925eb7a145bd6e206d6770ce7c73dbc32d1decd;p=koha-ffzg.git diff --git a/C4/Installer.pm b/C4/Installer.pm index 012bc1c3cd..ffab0ed76a 100644 --- a/C4/Installer.pm +++ b/C4/Installer.pm @@ -19,18 +19,22 @@ package C4::Installer; use Modern::Perl; -use Encode qw( encode is_utf8 ); +use Try::Tiny; +use Encode qw( encode decode is_utf8 ); use DBIx::RunSQL; -use YAML::Syck qw( LoadFile ); -use C4::Context; +use YAML::XS; +use File::Slurp qw( read_file ); use DBI; + +use C4::Context; +use Koha::Schema; use Koha; use vars qw(@ISA @EXPORT); BEGIN { require Exporter; @ISA = qw( Exporter ); - push @EXPORT, qw( foreign_key_exists index_exists column_exists TableExists); + 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 @@ -69,7 +73,7 @@ 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"); @@ -153,8 +157,8 @@ sub marc_framework_sql_list { my ( $name, $ext ) = split /\./, $_; my @lines; if ( $ext =~ /yml/ ) { - my $yaml = LoadFile("$dir/$requirelevel/$name\.$ext"); - @lines = map { Encode::decode('UTF-8', $_) } @{ $yaml->{'description'} }; + 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>; @@ -175,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; } @@ -236,8 +240,8 @@ sub sample_data_sql_list { my ( $name, $ext ) = split /\./, $_; my @lines; if ( $ext =~ /yml/ ) { - my $yaml = LoadFile("$dir/$requirelevel/$name\.$ext"); - @lines = map { Encode::decode('UTF-8', $_) } @{ $yaml->{'description'} }; + 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>; @@ -257,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; } @@ -279,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; } @@ -312,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 = @_; @@ -330,8 +352,8 @@ sub load_sql_in_order { my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory"; # Make sure some stuffs are loaded first - unshift(@fnames, C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/sysprefs.sql"); 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", @@ -340,19 +362,24 @@ sub load_sql_in_order { "$global_mandatory_dir/keyboard_shortcuts.sql", ); - push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userflags.sql"; - push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userpermissions.sql"; - push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/audio_alerts.sql"; - push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_offset_types.sql"; - push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_credit_types.sql"; - push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_debit_types.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 ); @@ -397,10 +424,10 @@ sub load_sql_in_order { Set the 'marcflavour' system preference. The incoming C<$marcflavour> references to a subdirectory of installer/data/$dbms/$lang/marcflavour, and is -normalized to MARC21, UNIMARC or NORMARC. +normalized to MARC21 or UNIMARC. FIXME: this method assumes that the MARC flavour will be either -MARC21, UNIMARC or NORMARC. +MARC21 or UNIMARC. =cut @@ -412,10 +439,9 @@ sub set_marcflavour_syspref { # marc_cleaned finds the marcflavour, without the variant. my $marc_cleaned = 'MARC21'; $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i; - $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i; my $request = $self->{'dbh'}->prepare( - "INSERT IGNORE INTO `systempreferences` (variable,value,explanation,options,type) VALUES('marcflavour','$marc_cleaned','Define global MARC flavor (MARC21, UNIMARC or NORMARC) used for character encoding','MARC21|UNIMARC|NORMARC','Choice');" + "INSERT IGNORE INTO `systempreferences` (variable,value,explanation,options,type) VALUES('marcflavour','$marc_cleaned','Define global MARC flavor (MARC21 or UNIMARC) used for character encoding','MARC21|UNIMARC','Choice');" ); $request->execute; } @@ -447,6 +473,62 @@ 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); @@ -481,25 +563,16 @@ sub load_sql { } else { # YAML files eval { - my $yaml = LoadFile( $filename ); # Load YAML + my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML for my $table ( @{ $yaml->{'tables'} } ) { - 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 $placeholders = join ",", map { "?" } @columns; # '?,..,?' string - my $query = "INSERT INTO $table_name ( $fields ) VALUES ( $placeholders )"; - my $sth = $dbh->prepare($query); - my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values; - foreach my $row ( @rows ) { - my @values = map { - my $col = $_; - ( @multiline and grep { $_ eq $col } @multiline ) - ? join "\r\n", @{$row->{$col}} # join multiline values - : $row->{$col}; - } @columns; - $sth->execute( @values ); - } + 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); @@ -557,6 +630,21 @@ 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; @@ -564,6 +652,13 @@ sub foreign_key_exists { 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; @@ -601,6 +696,344 @@ sub TableExists { # Could be renamed table_exists for consistency 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