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 );
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",
372 "$global_mandatory_dir/account_credit_types.sql",
373 "$global_mandatory_dir/account_debit_types.sql",
375 my $localization_file = C4::Context->config('intranetdir') .
376 "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
377 if ( -f $localization_file ) {
378 push @fnames, $localization_file;
380 foreach my $file (@fnames) {
383 my $error = $self->load_sql($file);
384 my @file = split qr(\/|\\), $file;
385 $lang = $file[ scalar(@file) - 3 ] unless ($lang);
386 my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
388 $systempreference .= "$file[scalar(@file)-1]|"
389 unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
392 #Bulding here a hierarchy to display files by level.
393 push @{ $hashlevel{$level} },
394 { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
397 #systempreference contains an ending |
398 chop $systempreference;
400 map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
402 for my $each_language (@$all_languages) {
404 # warn "CODE".$each_language->{'language_code'};
405 # warn "LANG:".$lang;
406 if ( $lang eq $each_language->{'language_code'} ) {
407 $fwk_language = $each_language->{language_locale_name};
412 "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
415 unless ( $updateflag == 1 ) {
417 "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
418 my $rq = $self->{'dbh'}->prepare($string);
421 return ($fwk_language, \@list);
424 =head2 set_marcflavour_syspref
426 $installer->set_marcflavour_syspref($marcflavour);
428 Set the 'marcflavour' system preference. The incoming
429 C<$marcflavour> references to a subdirectory of
430 installer/data/$dbms/$lang/marcflavour, and is
431 normalized to MARC21 or UNIMARC.
433 FIXME: this method assumes that the MARC flavour will be either
438 sub set_marcflavour_syspref {
440 my $marcflavour = shift;
442 # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
443 # marc_cleaned finds the marcflavour, without the variant.
444 my $marc_cleaned = 'MARC21';
445 $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
447 $self->{'dbh'}->prepare(
448 "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');"
453 =head2 set_version_syspref
455 $installer->set_version_syspref();
457 Set or update the 'Version' system preference to the current
458 Koha software version.
462 sub set_version_syspref {
465 my $kohaversion = Koha::version();
466 # remove the 3 last . to have a Perl number
467 $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
468 if (C4::Context->preference('Version')) {
469 warn "UPDATE Version";
470 my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
471 $finish->execute($kohaversion);
473 warn "INSERT Version";
474 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')");
475 $finish->execute($kohaversion);
477 C4::Context->clear_syspref_cache();
480 =head2 set_languages_syspref
482 $installer->set_languages_syspref();
484 Add the installation language to 'language' and 'OPACLanguages' system preferences
485 if different from 'en'
489 sub set_languages_syspref {
491 my $language = shift;
493 return if ( not $language or $language eq 'en' );
495 warn "UPDATE Languages";
497 my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
498 $pref->execute("en,$language");
500 $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
501 $pref->execute("en,$language");
503 C4::Context->clear_syspref_cache();
506 =head2 process_yml_table
508 my $query_info = $installer->process_yml_table($table);
510 Analyzes a table loaded in YAML format.
511 Returns the values required to build an insert statement.
515 sub process_yml_table {
517 my $table_name = ( keys %$table )[0]; # table name
518 my @rows = @{ $table->{$table_name}->{rows} }; #
519 my @columns = ( sort keys %{$rows[0]} ); # column names
520 my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined
521 my $query = "INSERT INTO $table_name ( $fields ) VALUES ";
522 my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
523 my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
525 foreach my $row ( @rows ) {
526 push @values, [ map {
528 ( @multiline and grep { $_ eq $col } @multiline )
529 ? join "\r\n", @{$row->{$col}} # join multiline values
533 return { query => $query, placeholders => $placeholders, values => \@values };
538 my $error = $installer->load_sql($filename);
540 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
541 Returns any strings sent to STDERR
543 # FIXME This should be improved: sometimes the caller and load_sql warn the same
550 my $filename = shift;
553 my $dbh = $self->{ dbh };
558 open STDERR, ">>", \$dup_stderr;
560 if ( $filename =~ /sql$/ ) { # SQL files
562 DBIx::RunSQL->run_sql_file(
570 my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML
571 for my $table ( @{ $yaml->{'tables'} } ) {
572 my $query_info = process_yml_table($table);
573 my $query = $query_info->{query};
574 my $placeholders = $query_info->{placeholders};
575 my $values = $query_info->{values};
576 # Doing only 1 INSERT query for the whole table
577 my @all_rows_values = map { @$_ } @$values;
578 $query .= join ', ', ( $placeholders ) x scalar @$values;
579 $dbh->do( $query, undef, @all_rows_values );
581 for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements
582 $dbh->do($statement);
587 warn "Something went wrong loading file $filename ($@)";
590 # errors thrown while loading installer data should be logged
592 warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
593 $error = $dup_stderr;
599 =head2 get_file_path_from_name
601 my $filename = $installer->get_file_path_from_name('script_name');
603 searches through the set of known SQL scripts and finds the fully
604 qualified path name for the script that mathches the input.
606 returns undef if no match was found.
611 sub get_file_path_from_name {
613 my $partialname = shift;
615 my $lang = 'en'; # FIXME: how do I know what language I want?
617 my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
618 # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
621 foreach my $frameworklist ( @$list ) {
622 push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
625 # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
626 if ( 0 == scalar @found ) {
628 } elsif ( 1 < scalar @found ) {
629 warn "multiple results found for $partialname";
632 return $found[0]->{'fwkfile'};
637 sub primary_key_exists {
638 my ( $table_name, $key_name ) = @_;
639 my $dbh = C4::Context->dbh;
640 my $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
643 $sql .= 'AND column_name = ? ' if $key_name;
644 ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
646 ($exists) = $dbh->selectrow_array( $sql, undef );
652 sub foreign_key_exists {
653 my ( $table_name, $constraint_name ) = @_;
654 my $dbh = C4::Context->dbh;
655 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
656 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
659 sub unique_key_exists {
660 my ( $table_name, $constraint_name ) = @_;
661 my $dbh = C4::Context->dbh;
662 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
663 return $infos =~ m|UNIQUE KEY `$constraint_name`|;
667 my ( $table_name, $key_name ) = @_;
668 my $dbh = C4::Context->dbh;
669 my ($exists) = $dbh->selectrow_array(
671 SHOW INDEX FROM $table_name
679 my ( $table_name, $column_name ) = @_;
680 return unless TableExists($table_name);
681 my $dbh = C4::Context->dbh;
682 my ($exists) = $dbh->selectrow_array(
684 SHOW COLUMNS FROM $table_name
686 |, undef, $column_name
691 sub TableExists { # Could be renamed table_exists for consistency
694 my $dbh = C4::Context->dbh;
695 local $dbh->{PrintError} = 0;
696 local $dbh->{RaiseError} = 1;
697 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
703 sub version_from_file {
705 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
706 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
710 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
711 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
712 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
714 for my $file ( @files ) {
715 my $version = version_from_file( $file );
717 unless ( $version ) {
718 warn "Invalid db_rev found: " . $file;
722 next unless CheckVersion( $version );
724 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
726 return \@need_update;
732 my $db_rev = do $file;
736 open my $outfh, '>', \$out;
738 my $schema = Koha::Database->new->schema;
741 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
750 $out = decode( 'UTF-8', $out );
754 bug_number => $db_rev->{bug_number},
755 description => $db_rev->{description},
757 version => scalar version_from_file($file),
758 time => POSIX::strftime( "%H:%M:%S", localtime ),
761 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
766 my ( $files, $params ) = @_;
768 my $force = $params->{force} || 0;
770 my ( @done, @errors );
771 for my $file ( @$files ) {
773 my $db_entry = run_db_rev($file);
775 if ( $db_entry->{error} ) {
776 push @errors, $db_entry;
777 $force ? next : last ;
778 # We stop the update if an error occurred!
781 SetVersion($db_entry->{version});
782 push @done, $db_entry;
784 return { success => \@done, error => \@errors };
787 sub generate_output_db_entry {
788 my ( $db_entry ) = @_;
790 my $description = $db_entry->{description};
791 my $output = $db_entry->{output};
792 my $DBversion = $db_entry->{version};
793 my $bug_number = $db_entry->{bug_number};
794 my $time = $db_entry->{time};
795 my $exec_output = $db_entry->{exec_output};
796 my $done = defined $db_entry->{done}
800 : ""; # For old versions, we don't know if we succeed or failed
806 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
808 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
810 } else { # Atomic update
812 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
813 } else { # Old atomic update syntax
814 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
819 foreach my $line (split /\n/, $exec_output) {
820 push @output, sprintf "\t%s", $line;
827 sub get_atomic_updates {
828 my @atomic_upate_files;
829 # if there is anything in the atomicupdate, read and execute it.
830 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
831 opendir( my $dirh, $update_dir );
832 foreach my $file ( sort readdir $dirh ) {
833 next if $file !~ /\.(perl|pl)$/; #skip other files
834 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
836 push @atomic_upate_files, $file;
838 return \@atomic_upate_files;
841 sub run_atomic_updates {
844 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
845 my ( @done, @errors );
846 for my $file ( @$files ) {
847 my $filepath = $update_dir . $file;
850 if ( $file =~ m{\.perl$} ) {
851 my $code = read_file( $filepath );
852 my ( $out, $err ) = ('', '');
854 open my $oldout, qw{>}, "&STDOUT";
856 open STDOUT,'>:encoding(utf8)', \$out;
857 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
858 my $dbh = C4::Context->dbh;
859 eval $code; ## no critic (StringyEval)
863 open STDOUT, ">&", $oldout;
867 filepath => $filepath,
870 time => POSIX::strftime( "%H:%M:%S", localtime ),
874 $atomic_update->{output} =
876 ? [ split "\n", $out ]
877 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
879 $atomic_update->{error} = $err if $err;
880 } elsif ( $file =~ m{\.pl$} ) {
881 $atomic_update = run_db_rev($filepath);
883 warn "Atomic update must be .perl or .pl ($file)";
886 if ( $atomic_update->{error} ) {
887 push @errors, $atomic_update;
889 push @done, $atomic_update;
893 return { success => \@done, error => \@errors };
896 =head2 DropAllForeignKeys($table)
898 Drop all foreign keys of the table $table
902 sub DropAllForeignKeys {
904 # get the table description
905 my $dbh = C4::Context->dbh;
906 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
908 my $vsc_structure = $sth->fetchrow;
909 # split on CONSTRAINT keyword
910 my @fks = split /CONSTRAINT /,$vsc_structure;
913 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
914 $_ = /(.*) FOREIGN KEY.*/;
917 # we have found 1 foreign, drop it
918 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
925 =head2 TransformToNum
927 Transform the Koha version from a 4 parts string
928 to a number, with just 1 .
934 # remove the 3 last . to have a Perl number
935 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
936 # three X's at the end indicate that you are testing patch with dbrev
938 # prevents error on a < comparison between strings (should be: lt)
939 $version =~ s/XXX$/999/;
945 set the DBversion in the systempreferences
950 return if $_[0]=~ /XXX$/;
951 #you are testing a patch with a db revision; do not change version
952 my $kohaversion = TransformToNum($_[0]);
953 my $dbh = C4::Context->dbh;
954 if (C4::Context->preference('Version')) {
955 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
956 $finish->execute($kohaversion);
958 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')");
959 $finish->execute($kohaversion);
961 C4::Context::clear_syspref_cache(); # invalidate cached preferences
964 # DEPRECATED Don't use it!
965 # Used for compatibility with older versions (from updatedatabase.pl)
967 my ( $DBversion, $bug_number, $descriptions ) = @_;
969 SetVersion($DBversion);
971 my ( $description, $report );
972 if ( ref($descriptions) ) {
973 $description = shift @$descriptions;
974 $report = join( "\n", @{$descriptions} );
977 $description = $descriptions;
980 my $output = generate_output_db_entry( {
981 bug_number => $bug_number,
982 description => $description,
984 version => $DBversion,
985 time => POSIX::strftime( "%H:%M:%S", localtime ),
988 say join "\n", @$output;
994 Check whether a given update should be run when passed the proposed version
995 number. The update will always be run if the proposed version is greater
996 than the current database version and less than or equal to the version in
997 kohaversion.pl. The update is also run if the version contains XXX, though
998 this behavior will be changed following the adoption of non-linear updates
999 as implemented in bug 7167.
1004 my ($proposed_version) = @_;
1005 my $version_number = TransformToNum($proposed_version);
1007 # The following line should be deleted when bug 7167 is pushed
1008 return 1 if ( $proposed_version =~ m/XXX/ );
1010 if ( C4::Context->preference("Version") < $version_number
1011 && $version_number <= TransformToNum( $Koha::VERSION ) )
1019 sub sanitize_zero_date {
1020 my ( $table_name, $column_name ) = @_;
1022 my $dbh = C4::Context->dbh;
1024 my (undef, $datatype) = $dbh->selectrow_array(qq|
1025 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1027 if ( $datatype eq 'date' ) {
1030 SET $column_name = NULL
1031 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1036 SET $column_name = NULL
1037 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1044 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1045 originally written by Henri-Damien Laurant.
1047 Koha Development Team <http://koha-community.org/>
1049 Galen Charlton <galen.charlton@liblime.com>