3 # Copyright (C) 2008 LibLime
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
23 use Encode qw( encode decode is_utf8 );
26 use File::Slurp qw( read_file );
33 use vars qw(@ISA @EXPORT);
36 @ISA = qw( Exporter );
37 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 has_non_dynamic_row_format );
47 my $installer = C4::Installer->new();
48 my $all_languages = getAllLanguages();
49 my $error = $installer->load_db_schema();
51 #fill $list with list of sql files
52 my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list);
53 $installer->set_version_syspref();
54 $installer->set_marcflavour_syspref('MARC21');
64 my $installer = C4::Installer->new();
66 Creates a new installer.
75 # get basic information from context
76 $self->{'dbname'} = C4::Context->config("database_test") || C4::Context->config("database");
77 $self->{'dbms'} = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql";
78 $self->{'hostname'} = C4::Context->config("hostname");
79 $self->{'port'} = C4::Context->config("port");
80 $self->{'user'} = C4::Context->config("user");
81 $self->{'password'} = C4::Context->config("pass");
82 $self->{'tls'} = C4::Context->config("tls");
83 if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
84 $self->{'ca'} = C4::Context->config('ca');
85 $self->{'cert'} = C4::Context->config('cert');
86 $self->{'key'} = C4::Context->config('key');
87 $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
88 $self->{'tlscmdline'} = " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
90 $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
91 ( $self->{port} ? ";port=$self->{port}" : "" ).
92 ( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
93 $self->{'user'}, $self->{'password'});
94 $self->{'language'} = undef;
95 $self->{'marcflavour'} = undef;
96 $self->{'dbh'}->do('set NAMES "utf8"');
97 $self->{'dbh'}->{'mysql_enable_utf8'}=1;
103 =head2 marc_framework_sql_list
105 my ($defaulted_to_en, $list) =
106 $installer->marc_framework_sql_list($lang, $marcflavour);
108 Returns in C<$list> a structure listing the filename, description, section,
109 and mandatory/optional status of MARC framework scripts available for C<$lang>
112 If the C<$defaulted_to_en> return value is true, no scripts are available
113 for language C<$lang> and the 'en' ones are returned.
117 sub marc_framework_sql_list {
120 my $marcflavour = shift;
122 my $defaulted_to_en = 0;
125 my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
127 unless (opendir( $dir_h, $dir )) {
129 warn "cannot open MARC frameworks directory $dir";
131 # if no translated MARC framework is available,
133 $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
134 opendir($dir_h, $dir) or warn "cannot open English MARC frameworks directory $dir";
135 $defaulted_to_en = 1;
138 my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir($dir_h);
142 my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
144 my ($frameworksloaded) = $request->fetchrow;
145 $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
146 my %frameworksloaded;
147 foreach ( split( /\|/, $frameworksloaded ) ) {
148 $frameworksloaded{$_} = 1;
151 foreach my $requirelevel (@listdir) {
153 opendir( $dir_h, "$dir/$requirelevel" );
154 my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir($dir_h);
159 my ( $name, $ext ) = split /\./, $_;
161 if ( $ext =~ /yml/ ) {
162 my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext");
163 @lines = @{ $yaml->{'description'} };
165 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
167 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
168 @lines = split /\n/, $line;
170 my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
174 'fwkfile' => "$dir/$requirelevel/$_",
175 'fwkdescription' => \@lines,
176 'checked' => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
177 'mandatory' => $mandatory,
181 sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
183 $cell{"frameworks"} = \@fwks;
184 $cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
185 $cell{"code"} = lc($requirelevel);
186 push @fwklist, \%cell;
189 return ($defaulted_to_en, \@fwklist);
192 =head2 sample_data_sql_list
194 my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
196 Returns in C<$list> a structure listing the filename, description, section,
197 and mandatory/optional status of sample data scripts available for C<$lang>.
198 If the C<$defaulted_to_en> return value is true, no scripts are available
199 for language C<$lang> and the 'en' ones are returned.
203 sub sample_data_sql_list {
207 my $defaulted_to_en = 0;
210 my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
212 unless (opendir( $dir_h, $dir )) {
214 warn "cannot open sample data directory $dir";
216 # if no sample data is available,
218 $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
219 opendir($dir_h, $dir) or warn "cannot open English sample data directory $dir";
220 $defaulted_to_en = 1;
223 my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir($dir_h);
227 my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
229 my ($frameworksloaded) = $request->fetchrow;
230 $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
231 my %frameworksloaded;
232 foreach ( split( /\|/, $frameworksloaded ) ) {
233 $frameworksloaded{$_} = 1;
236 foreach my $requirelevel (@listdir) {
238 opendir( $dir_h, "$dir/$requirelevel" );
239 my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir($dir_h);
244 my ( $name, $ext ) = split /\./, $_;
246 if ( $ext =~ /yml/ ) {
247 my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext");
248 @lines = @{ $yaml->{'description'} };
250 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
252 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
253 @lines = split /\n/, $line;
255 my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
259 'fwkfile' => "$dir/$requirelevel/$_",
260 'fwkdescription' => \@lines,
261 'checked' => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
262 'mandatory' => $mandatory,
265 my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
267 $cell{"frameworks"} = \@fwks;
268 $cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
269 $cell{"code"} = lc($requirelevel);
270 push @levellist, \%cell;
273 return ($defaulted_to_en, \@levellist);
276 =head2 load_db_schema
278 my $error = $installer->load_db_schema();
280 Loads the SQL script that creates Koha's tables and indexes. The
281 return value is a string containing error messages reported by the
289 my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
291 # Disable checks before load
292 # NOTE: These lines are found in kohastructure itself, but DBIx::RunSQL ignores them!
293 $self->{'dbh'}->do(q{SET NAMES utf8mb4});
294 $self->{'dbh'}->do(q{SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0});
295 $self->{'dbh'}->do(q{SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0});
296 $self->{'dbh'}->do(q{SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO'});
297 $self->{'dbh'}->do(q{SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0});
300 my $error = $self->load_sql("$datadir/kohastructure.sql");
302 # Re-enable checks after load
303 $self->{'dbh'}->do(q{SET SQL_MODE=@OLD_SQL_MODE});
304 $self->{'dbh'}->do(q{SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS});
305 $self->{'dbh'}->do(q{SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS});
306 $self->{'dbh'}->do(q{SET SQL_NOTES=@OLD_SQL_NOTES});
312 =head2 load_sql_in_order
314 my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
316 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
317 into the database and sets the FrameworksLoaded system preference to names
318 of the scripts that were loaded.
320 The SQL files are loaded in alphabetical order by filename (not including
321 directory path). This means that dependencies among the scripts are to
322 be resolved by carefully naming them, keeping in mind that the directory name
323 does *not* currently count.
325 B<FIXME:> this is a rather delicate way of dealing with dependencies between
328 The return value C<$list> is an arrayref containing a hashref for each
329 "level" or directory containing SQL scripts; the hashref in turns contains
330 a list of hashrefs containing a list of each script load and any error
331 messages associated with the loading of each script.
333 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
334 moved to a different method.
338 sub load_sql_in_order {
340 my $langchoice = shift;
341 my $all_languages = shift;
347 my @aa = split /\/|\\/, ($a);
348 my @bb = split /\/|\\/, ($b);
351 my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
353 my ($systempreference) = $request->fetchrow;
354 $systempreference = '' unless defined $systempreference; # avoid warning
356 my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
358 # Make sure some stuffs are loaded first
360 "$global_mandatory_dir/sysprefs.sql",
361 "$global_mandatory_dir/subtag_registry.sql",
362 "$global_mandatory_dir/auth_val_cat.sql",
363 "$global_mandatory_dir/message_transport_types.sql",
364 "$global_mandatory_dir/sample_notices_message_attributes.sql",
365 "$global_mandatory_dir/sample_notices_message_transports.sql",
366 "$global_mandatory_dir/keyboard_shortcuts.sql",
369 push @fnames, "$global_mandatory_dir/userflags.sql",
370 "$global_mandatory_dir/userpermissions.sql",
371 "$global_mandatory_dir/audio_alerts.sql",
373 my $localization_file = C4::Context->config('intranetdir') .
374 "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
375 if ( -f $localization_file ) {
376 push @fnames, $localization_file;
378 foreach my $file (@fnames) {
381 my $error = $self->load_sql($file);
382 my @file = split qr(\/|\\), $file;
383 $lang = $file[ scalar(@file) - 3 ] unless ($lang);
384 my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
386 $systempreference .= "$file[scalar(@file)-1]|"
387 unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
390 #Bulding here a hierarchy to display files by level.
391 push @{ $hashlevel{$level} },
392 { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
395 #systempreference contains an ending |
396 chop $systempreference;
398 map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
400 for my $each_language (@$all_languages) {
402 # warn "CODE".$each_language->{'language_code'};
403 # warn "LANG:".$lang;
404 if ( $lang eq $each_language->{'language_code'} ) {
405 $fwk_language = $each_language->{language_locale_name};
410 "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
413 unless ( $updateflag == 1 ) {
415 "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
416 my $rq = $self->{'dbh'}->prepare($string);
419 return ($fwk_language, \@list);
422 =head2 set_marcflavour_syspref
424 $installer->set_marcflavour_syspref($marcflavour);
426 Set the 'marcflavour' system preference. The incoming
427 C<$marcflavour> references to a subdirectory of
428 installer/data/$dbms/$lang/marcflavour, and is
429 normalized to MARC21 or UNIMARC.
431 FIXME: this method assumes that the MARC flavour will be either
436 sub set_marcflavour_syspref {
438 my $marcflavour = shift;
440 # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
441 # marc_cleaned finds the marcflavour, without the variant.
442 my $marc_cleaned = 'MARC21';
443 $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
445 $self->{'dbh'}->prepare(
446 "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');"
451 =head2 set_version_syspref
453 $installer->set_version_syspref();
455 Set or update the 'Version' system preference to the current
456 Koha software version.
460 sub set_version_syspref {
463 my $kohaversion = Koha::version();
464 # remove the 3 last . to have a Perl number
465 $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
466 if (C4::Context->preference('Version')) {
467 warn "UPDATE Version";
468 my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
469 $finish->execute($kohaversion);
471 warn "INSERT Version";
472 my $finish=$self->{'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')");
473 $finish->execute($kohaversion);
475 C4::Context->clear_syspref_cache();
478 =head2 set_languages_syspref
480 $installer->set_languages_syspref();
482 Add the installation language to 'language' and 'OPACLanguages' system preferences
483 if different from 'en'
487 sub set_languages_syspref {
489 my $language = shift;
491 return if ( not $language or $language eq 'en' );
493 warn "UPDATE Languages";
495 my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
496 $pref->execute("en,$language");
498 $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
499 $pref->execute("en,$language");
501 C4::Context->clear_syspref_cache();
504 =head2 process_yml_table
506 my $query_info = $installer->process_yml_table($table);
508 Analyzes a table loaded in YAML format.
509 Returns the values required to build an insert statement.
513 sub process_yml_table {
515 my $table_name = ( keys %$table )[0]; # table name
516 my @rows = @{ $table->{$table_name}->{rows} }; #
517 my @columns = ( sort keys %{$rows[0]} ); # column names
518 my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined
519 my $query = "INSERT INTO $table_name ( $fields ) VALUES ";
520 my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
521 my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
523 foreach my $row ( @rows ) {
524 push @values, [ map {
526 ( @multiline and grep { $_ eq $col } @multiline )
527 ? join "\r\n", @{$row->{$col}} # join multiline values
531 return { query => $query, placeholders => $placeholders, values => \@values };
536 my $error = $installer->load_sql($filename);
538 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
539 Returns any strings sent to STDERR
541 # FIXME This should be improved: sometimes the caller and load_sql warn the same
548 my $filename = shift;
551 my $dbh = $self->{ dbh };
556 open STDERR, ">>", \$dup_stderr;
558 if ( $filename =~ /sql$/ ) { # SQL files
560 DBIx::RunSQL->run_sql_file(
568 my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML
569 for my $table ( @{ $yaml->{'tables'} } ) {
570 my $query_info = process_yml_table($table);
571 my $query = $query_info->{query};
572 my $placeholders = $query_info->{placeholders};
573 my $values = $query_info->{values};
574 # Doing only 1 INSERT query for the whole table
575 my @all_rows_values = map { @$_ } @$values;
576 $query .= join ', ', ( $placeholders ) x scalar @$values;
577 $dbh->do( $query, undef, @all_rows_values );
579 for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements
580 $dbh->do($statement);
585 warn "Something went wrong loading file $filename ($@)";
588 # errors thrown while loading installer data should be logged
590 warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
591 $error = $dup_stderr;
597 =head2 get_file_path_from_name
599 my $filename = $installer->get_file_path_from_name('script_name');
601 searches through the set of known SQL scripts and finds the fully
602 qualified path name for the script that mathches the input.
604 returns undef if no match was found.
609 sub get_file_path_from_name {
611 my $partialname = shift;
613 my $lang = 'en'; # FIXME: how do I know what language I want?
615 my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
616 # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
619 foreach my $frameworklist ( @$list ) {
620 push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
623 # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
624 if ( 0 == scalar @found ) {
626 } elsif ( 1 < scalar @found ) {
627 warn "multiple results found for $partialname";
630 return $found[0]->{'fwkfile'};
635 sub primary_key_exists {
636 my ( $table_name, $key_name ) = @_;
637 my $dbh = C4::Context->dbh;
638 my $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
641 $sql .= 'AND column_name = ? ' if $key_name;
642 ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
644 ($exists) = $dbh->selectrow_array( $sql, undef );
650 sub foreign_key_exists {
651 my ( $table_name, $constraint_name ) = @_;
652 my $dbh = C4::Context->dbh;
653 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
654 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
657 sub unique_key_exists {
658 my ( $table_name, $constraint_name ) = @_;
659 my $dbh = C4::Context->dbh;
660 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
661 return $infos =~ m|UNIQUE KEY `$constraint_name`|;
665 my ( $table_name, $key_name ) = @_;
666 my $dbh = C4::Context->dbh;
667 my ($exists) = $dbh->selectrow_array(
669 SHOW INDEX FROM $table_name
677 my ( $table_name, $column_name ) = @_;
678 return unless TableExists($table_name);
679 my $dbh = C4::Context->dbh;
680 my ($exists) = $dbh->selectrow_array(
682 SHOW COLUMNS FROM $table_name
684 |, undef, $column_name
689 sub TableExists { # Could be renamed table_exists for consistency
692 my $dbh = C4::Context->dbh;
693 local $dbh->{PrintError} = 0;
694 local $dbh->{RaiseError} = 1;
695 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
701 sub version_from_file {
703 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
704 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
708 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
709 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
710 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
712 for my $file ( @files ) {
713 my $version = version_from_file( $file );
715 unless ( $version ) {
716 warn "Invalid db_rev found: " . $file;
720 next unless CheckVersion( $version );
722 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
724 return \@need_update;
730 my $db_rev = do $file;
734 open my $outfh, '>', \$out;
736 my $schema = Koha::Database->new->schema;
739 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
748 $out = decode( 'UTF-8', $out );
752 bug_number => $db_rev->{bug_number},
753 description => $db_rev->{description},
755 version => scalar version_from_file($file),
756 time => POSIX::strftime( "%H:%M:%S", localtime ),
759 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
764 my ( $files, $params ) = @_;
766 my $force = $params->{force} || 0;
768 my ( @done, @errors );
769 for my $file ( @$files ) {
771 my $db_entry = run_db_rev($file);
773 if ( $db_entry->{error} ) {
774 push @errors, $db_entry;
775 $force ? next : last ;
776 # We stop the update if an error occurred!
779 SetVersion($db_entry->{version});
780 push @done, $db_entry;
782 return { success => \@done, error => \@errors };
785 sub generate_output_db_entry {
786 my ( $db_entry ) = @_;
788 my $description = $db_entry->{description};
789 my $output = $db_entry->{output};
790 my $DBversion = $db_entry->{version};
791 my $bug_number = $db_entry->{bug_number};
792 my $time = $db_entry->{time};
793 my $exec_output = $db_entry->{exec_output};
794 my $done = defined $db_entry->{done}
798 : ""; # For old versions, we don't know if we succeed or failed
804 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
806 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
808 } else { # Atomic update
810 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
811 } else { # Old atomic update syntax
812 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
817 foreach my $line (split /\n/, $exec_output) {
818 push @output, sprintf "\t%s", $line;
825 sub get_atomic_updates {
826 my @atomic_upate_files;
827 # if there is anything in the atomicupdate, read and execute it.
828 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
829 opendir( my $dirh, $update_dir );
830 foreach my $file ( sort readdir $dirh ) {
831 next if $file !~ /\.(perl|pl)$/; #skip other files
832 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
834 push @atomic_upate_files, $file;
836 return \@atomic_upate_files;
839 sub run_atomic_updates {
842 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
843 my ( @done, @errors );
844 for my $file ( @$files ) {
845 my $filepath = $update_dir . $file;
848 if ( $file =~ m{\.perl$} ) {
849 my $code = read_file( $filepath );
850 my ( $out, $err ) = ('', '');
852 open my $oldout, qw{>&}, "STDOUT";
854 open STDOUT,'>:encoding(utf8)', \$out;
855 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
856 my $dbh = C4::Context->dbh;
857 eval $code; ## no critic (StringyEval)
861 open STDOUT, ">&", $oldout;
865 filepath => $filepath,
868 time => POSIX::strftime( "%H:%M:%S", localtime ),
872 $atomic_update->{output} =
874 ? [ split "\n", $out ]
875 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
877 $atomic_update->{error} = $err if $err;
878 } elsif ( $file =~ m{\.pl$} ) {
879 $atomic_update = run_db_rev($filepath);
881 warn "Atomic update must be .perl or .pl ($file)";
884 if ( $atomic_update->{error} ) {
885 push @errors, $atomic_update;
887 push @done, $atomic_update;
891 return { success => \@done, error => \@errors };
894 =head2 DropAllForeignKeys($table)
896 Drop all foreign keys of the table $table
900 sub DropAllForeignKeys {
902 # get the table description
903 my $dbh = C4::Context->dbh;
904 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
906 my $vsc_structure = $sth->fetchrow;
907 # split on CONSTRAINT keyword
908 my @fks = split /CONSTRAINT /,$vsc_structure;
911 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
912 $_ = /(.*) FOREIGN KEY.*/;
915 # we have found 1 foreign, drop it
916 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
923 =head2 TransformToNum
925 Transform the Koha version from a 4 parts string
926 to a number, with just 1 .
932 # remove the 3 last . to have a Perl number
933 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
934 # three X's at the end indicate that you are testing patch with dbrev
936 # prevents error on a < comparison between strings (should be: lt)
937 $version =~ s/XXX$/999/;
943 set the DBversion in the systempreferences
948 return if $_[0]=~ /XXX$/;
949 #you are testing a patch with a db revision; do not change version
950 my $kohaversion = TransformToNum($_[0]);
951 my $dbh = C4::Context->dbh;
952 if (C4::Context->preference('Version')) {
953 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
954 $finish->execute($kohaversion);
956 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')");
957 $finish->execute($kohaversion);
959 C4::Context::clear_syspref_cache(); # invalidate cached preferences
962 # DEPRECATED Don't use it!
963 # Used for compatibility with older versions (from updatedatabase.pl)
965 my ( $DBversion, $bug_number, $descriptions ) = @_;
967 SetVersion($DBversion);
969 my ( $description, $report );
970 if ( ref($descriptions) ) {
971 $description = shift @$descriptions;
972 $report = join( "\n", @{$descriptions} );
975 $description = $descriptions;
978 my $output = generate_output_db_entry( {
979 bug_number => $bug_number,
980 description => $description,
982 version => $DBversion,
983 time => POSIX::strftime( "%H:%M:%S", localtime ),
986 say join "\n", @$output;
992 Check whether a given update should be run when passed the proposed version
993 number. The update will always be run if the proposed version is greater
994 than the current database version and less than or equal to the version in
995 kohaversion.pl. The update is also run if the version contains XXX, though
996 this behavior will be changed following the adoption of non-linear updates
997 as implemented in bug 7167.
1002 my ($proposed_version) = @_;
1003 my $version_number = TransformToNum($proposed_version);
1005 # The following line should be deleted when bug 7167 is pushed
1006 return 1 if ( $proposed_version =~ m/XXX/ );
1008 if ( C4::Context->preference("Version") < $version_number
1009 && $version_number <= TransformToNum( $Koha::VERSION ) )
1017 sub sanitize_zero_date {
1018 my ( $table_name, $column_name ) = @_;
1020 my $dbh = C4::Context->dbh;
1022 my (undef, $datatype) = $dbh->selectrow_array(qq|
1023 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1025 if ( $datatype eq 'date' ) {
1028 SET $column_name = NULL
1029 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1034 SET $column_name = NULL
1035 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1040 =head3 has_non_dynamic_row_format
1042 Return the number of tables with row_format that is not Dynamic
1046 sub has_non_dynamic_row_format {
1048 my $database = C4::Context->config('database');
1051 my $dbh = C4::Context->dbh;
1053 SELECT count(table_name)
1054 FROM information_schema.tables
1057 AND row_format != "Dynamic"
1059 ( $count ) = $dbh->selectrow_array($sql, undef, $database);
1066 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1067 originally written by Henri-Damien Laurant.
1069 Koha Development Team <http://koha-community.org/>
1071 Galen Charlton <galen.charlton@liblime.com>