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);
126 unless (opendir( MYDIR, $dir )) {
128 warn "cannot open MARC frameworks directory $dir";
130 # if no translated MARC framework is available,
132 $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
133 opendir(MYDIR, $dir) or warn "cannot open English MARC frameworks directory $dir";
134 $defaulted_to_en = 1;
137 my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
141 my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
143 my ($frameworksloaded) = $request->fetchrow;
144 $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
145 my %frameworksloaded;
146 foreach ( split( /\|/, $frameworksloaded ) ) {
147 $frameworksloaded{$_} = 1;
150 foreach my $requirelevel (@listdir) {
151 opendir( MYDIR, "$dir/$requirelevel" );
152 my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR);
157 my ( $name, $ext ) = split /\./, $_;
159 if ( $ext =~ /yml/ ) {
160 my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext");
161 @lines = @{ $yaml->{'description'} };
163 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
165 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
166 @lines = split /\n/, $line;
168 my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
172 'fwkfile' => "$dir/$requirelevel/$_",
173 'fwkdescription' => \@lines,
174 'checked' => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
175 'mandatory' => $mandatory,
179 sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
181 $cell{"frameworks"} = \@fwks;
182 $cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
183 $cell{"code"} = lc($requirelevel);
184 push @fwklist, \%cell;
187 return ($defaulted_to_en, \@fwklist);
190 =head2 sample_data_sql_list
192 my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
194 Returns in C<$list> a structure listing the filename, description, section,
195 and mandatory/optional status of sample data scripts available for C<$lang>.
196 If the C<$defaulted_to_en> return value is true, no scripts are available
197 for language C<$lang> and the 'en' ones are returned.
201 sub sample_data_sql_list {
205 my $defaulted_to_en = 0;
208 my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
209 unless (opendir( MYDIR, $dir )) {
211 warn "cannot open sample data directory $dir";
213 # if no sample data is available,
215 $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
216 opendir(MYDIR, $dir) or warn "cannot open English sample data directory $dir";
217 $defaulted_to_en = 1;
220 my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
224 my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
226 my ($frameworksloaded) = $request->fetchrow;
227 $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
228 my %frameworksloaded;
229 foreach ( split( /\|/, $frameworksloaded ) ) {
230 $frameworksloaded{$_} = 1;
233 foreach my $requirelevel (@listdir) {
234 opendir( MYDIR, "$dir/$requirelevel" );
235 my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR);
240 my ( $name, $ext ) = split /\./, $_;
242 if ( $ext =~ /yml/ ) {
243 my $yaml = YAML::XS::LoadFile("$dir/$requirelevel/$name\.$ext");
244 @lines = @{ $yaml->{'description'} };
246 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
248 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
249 @lines = split /\n/, $line;
251 my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
255 'fwkfile' => "$dir/$requirelevel/$_",
256 'fwkdescription' => \@lines,
257 'checked' => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
258 'mandatory' => $mandatory,
261 my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
263 $cell{"frameworks"} = \@fwks;
264 $cell{"label"} = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
265 $cell{"code"} = lc($requirelevel);
266 push @levellist, \%cell;
269 return ($defaulted_to_en, \@levellist);
272 =head2 load_db_schema
274 my $error = $installer->load_db_schema();
276 Loads the SQL script that creates Koha's tables and indexes. The
277 return value is a string containing error messages reported by the
285 my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
287 # Disable checks before load
288 $self->{'dbh'}->do(q{SET NAMES utf8mb4});
289 $self->{'dbh'}->do(q{SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0});
290 $self->{'dbh'}->do(q{SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0});
291 $self->{'dbh'}->do(q{SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO'});
292 $self->{'dbh'}->do(q{SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0});
295 my $error = $self->load_sql("$datadir/kohastructure.sql");
297 # Re-enable checks after load
298 $self->{'dbh'}->do(q{SET SQL_MODE=@OLD_SQL_MODE});
299 $self->{'dbh'}->do(q{SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS});
300 $self->{'dbh'}->do(q{SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS});
301 $self->{'dbh'}->do(q{SET SQL_NOTES=@OLD_SQL_NOTES});
307 =head2 load_sql_in_order
309 my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
311 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
312 into the database and sets the FrameworksLoaded system preference to names
313 of the scripts that were loaded.
315 The SQL files are loaded in alphabetical order by filename (not including
316 directory path). This means that dependencies among the scripts are to
317 be resolved by carefully naming them, keeping in mind that the directory name
318 does *not* currently count.
320 B<FIXME:> this is a rather delicate way of dealing with dependencies between
323 The return value C<$list> is an arrayref containing a hashref for each
324 "level" or directory containing SQL scripts; the hashref in turns contains
325 a list of hashrefs containing a list of each script load and any error
326 messages associated with the loading of each script.
328 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
329 moved to a different method.
333 sub load_sql_in_order {
335 my $langchoice = shift;
336 my $all_languages = shift;
342 my @aa = split /\/|\\/, ($a);
343 my @bb = split /\/|\\/, ($b);
346 my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
348 my ($systempreference) = $request->fetchrow;
349 $systempreference = '' unless defined $systempreference; # avoid warning
351 my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
353 # Make sure some stuffs are loaded first
355 "$global_mandatory_dir/sysprefs.sql",
356 "$global_mandatory_dir/subtag_registry.sql",
357 "$global_mandatory_dir/auth_val_cat.sql",
358 "$global_mandatory_dir/message_transport_types.sql",
359 "$global_mandatory_dir/sample_notices_message_attributes.sql",
360 "$global_mandatory_dir/sample_notices_message_transports.sql",
361 "$global_mandatory_dir/keyboard_shortcuts.sql",
364 push @fnames, "$global_mandatory_dir/userflags.sql",
365 "$global_mandatory_dir/userpermissions.sql",
366 "$global_mandatory_dir/audio_alerts.sql",
367 "$global_mandatory_dir/account_credit_types.sql",
368 "$global_mandatory_dir/account_debit_types.sql",
370 my $localization_file = C4::Context->config('intranetdir') .
371 "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
372 if ( $langchoice ne 'en' and -f $localization_file ) {
373 push @fnames, $localization_file;
375 foreach my $file (@fnames) {
378 my $error = $self->load_sql($file);
379 my @file = split qr(\/|\\), $file;
380 $lang = $file[ scalar(@file) - 3 ] unless ($lang);
381 my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
383 $systempreference .= "$file[scalar(@file)-1]|"
384 unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
387 #Bulding here a hierarchy to display files by level.
388 push @{ $hashlevel{$level} },
389 { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
392 #systempreference contains an ending |
393 chop $systempreference;
395 map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
397 for my $each_language (@$all_languages) {
399 # warn "CODE".$each_language->{'language_code'};
400 # warn "LANG:".$lang;
401 if ( $lang eq $each_language->{'language_code'} ) {
402 $fwk_language = $each_language->{language_locale_name};
407 "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
410 unless ( $updateflag == 1 ) {
412 "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
413 my $rq = $self->{'dbh'}->prepare($string);
416 return ($fwk_language, \@list);
419 =head2 set_marcflavour_syspref
421 $installer->set_marcflavour_syspref($marcflavour);
423 Set the 'marcflavour' system preference. The incoming
424 C<$marcflavour> references to a subdirectory of
425 installer/data/$dbms/$lang/marcflavour, and is
426 normalized to MARC21 or UNIMARC.
428 FIXME: this method assumes that the MARC flavour will be either
433 sub set_marcflavour_syspref {
435 my $marcflavour = shift;
437 # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
438 # marc_cleaned finds the marcflavour, without the variant.
439 my $marc_cleaned = 'MARC21';
440 $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
442 $self->{'dbh'}->prepare(
443 "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');"
448 =head2 set_version_syspref
450 $installer->set_version_syspref();
452 Set or update the 'Version' system preference to the current
453 Koha software version.
457 sub set_version_syspref {
460 my $kohaversion = Koha::version();
461 # remove the 3 last . to have a Perl number
462 $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
463 if (C4::Context->preference('Version')) {
464 warn "UPDATE Version";
465 my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
466 $finish->execute($kohaversion);
468 warn "INSERT Version";
469 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')");
470 $finish->execute($kohaversion);
472 C4::Context->clear_syspref_cache();
475 =head2 set_languages_syspref
477 $installer->set_languages_syspref();
479 Add the installation language to 'language' and 'OPACLanguages' system preferences
480 if different from 'en'
484 sub set_languages_syspref {
486 my $language = shift;
488 return if ( not $language or $language eq 'en' );
490 warn "UPDATE Languages";
492 my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
493 $pref->execute("en,$language");
495 $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
496 $pref->execute("en,$language");
498 C4::Context->clear_syspref_cache();
501 =head2 process_yml_table
503 my $query_info = $installer->process_yml_table($table);
505 Analyzes a table loaded in YAML format.
506 Returns the values required to build an insert statement.
510 sub process_yml_table {
512 my $table_name = ( keys %$table )[0]; # table name
513 my @rows = @{ $table->{$table_name}->{rows} }; #
514 my @columns = ( sort keys %{$rows[0]} ); # column names
515 my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined
516 my $query = "INSERT INTO $table_name ( $fields ) VALUES ";
517 my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
518 my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
520 foreach my $row ( @rows ) {
521 push @values, [ map {
523 ( @multiline and grep { $_ eq $col } @multiline )
524 ? join "\r\n", @{$row->{$col}} # join multiline values
528 return { query => $query, placeholders => $placeholders, values => \@values };
533 my $error = $installer->load_sql($filename);
535 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
536 Returns any strings sent to STDERR
538 # FIXME This should be improved: sometimes the caller and load_sql warn the same
545 my $filename = shift;
548 my $dbh = $self->{ dbh };
553 open STDERR, ">>", \$dup_stderr;
555 if ( $filename =~ /sql$/ ) { # SQL files
557 DBIx::RunSQL->run_sql_file(
565 my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML
566 for my $table ( @{ $yaml->{'tables'} } ) {
567 my $query_info = process_yml_table($table);
568 my $query = $query_info->{query};
569 my $placeholders = $query_info->{placeholders};
570 my $values = $query_info->{values};
571 # Doing only 1 INSERT query for the whole table
572 my @all_rows_values = map { @$_ } @$values;
573 $query .= join ', ', ( $placeholders ) x scalar @$values;
574 $dbh->do( $query, undef, @all_rows_values );
576 for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements
577 $dbh->do($statement);
582 warn "Something went wrong loading file $filename ($@)";
585 # errors thrown while loading installer data should be logged
587 warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
588 $error = $dup_stderr;
594 =head2 get_file_path_from_name
596 my $filename = $installer->get_file_path_from_name('script_name');
598 searches through the set of known SQL scripts and finds the fully
599 qualified path name for the script that mathches the input.
601 returns undef if no match was found.
606 sub get_file_path_from_name {
608 my $partialname = shift;
610 my $lang = 'en'; # FIXME: how do I know what language I want?
612 my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
613 # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
616 foreach my $frameworklist ( @$list ) {
617 push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
620 # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
621 if ( 0 == scalar @found ) {
623 } elsif ( 1 < scalar @found ) {
624 warn "multiple results found for $partialname";
627 return $found[0]->{'fwkfile'};
632 sub primary_key_exists {
633 my ( $table_name, $key_name ) = @_;
634 my $dbh = C4::Context->dbh;
635 my ($exists) = $dbh->selectrow_array(
637 SHOW INDEX FROM $table_name
638 WHERE key_name = 'PRIMARY' AND column_name = ?
644 sub foreign_key_exists {
645 my ( $table_name, $constraint_name ) = @_;
646 my $dbh = C4::Context->dbh;
647 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
648 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
651 sub unique_key_exists {
652 my ( $table_name, $constraint_name ) = @_;
653 my $dbh = C4::Context->dbh;
654 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
655 return $infos =~ m|UNIQUE KEY `$constraint_name`|;
659 my ( $table_name, $key_name ) = @_;
660 my $dbh = C4::Context->dbh;
661 my ($exists) = $dbh->selectrow_array(
663 SHOW INDEX FROM $table_name
671 my ( $table_name, $column_name ) = @_;
672 return unless TableExists($table_name);
673 my $dbh = C4::Context->dbh;
674 my ($exists) = $dbh->selectrow_array(
676 SHOW COLUMNS FROM $table_name
678 |, undef, $column_name
683 sub TableExists { # Could be renamed table_exists for consistency
686 my $dbh = C4::Context->dbh;
687 local $dbh->{PrintError} = 0;
688 local $dbh->{RaiseError} = 1;
689 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
695 sub version_from_file {
697 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
698 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
702 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
703 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
704 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
706 for my $file ( @files ) {
707 my $version = version_from_file( $file );
709 unless ( $version ) {
710 warn "Invalid db_rev found: " . $file;
714 next unless CheckVersion( $version );
716 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
718 return \@need_update;
724 my $db_rev = do $file;
728 open my $outfh, '>', \$out;
730 my $schema = Koha::Database->new->schema;
733 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
742 $out = decode( 'UTF-8', $out );
746 bug_number => $db_rev->{bug_number},
747 description => $db_rev->{description},
749 version => scalar version_from_file($file),
750 time => POSIX::strftime( "%H:%M:%S", localtime ),
753 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
758 my ( $files, $params ) = @_;
760 my $force = $params->{force} || 0;
762 my ( @done, @errors );
763 for my $file ( @$files ) {
765 my $db_entry = run_db_rev($file);
767 if ( $db_entry->{error} ) {
768 push @errors, $db_entry;
769 $force ? next : last ;
770 # We stop the update if an error occurred!
773 SetVersion($db_entry->{version});
774 push @done, $db_entry;
776 return { success => \@done, error => \@errors };
779 sub generate_output_db_entry {
780 my ( $db_entry ) = @_;
782 my $description = $db_entry->{description};
783 my $output = $db_entry->{output};
784 my $DBversion = $db_entry->{version};
785 my $bug_number = $db_entry->{bug_number};
786 my $time = $db_entry->{time};
787 my $exec_output = $db_entry->{exec_output};
788 my $done = defined $db_entry->{done}
792 : ""; # For old versions, we don't know if we succeed or failed
798 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
800 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
802 } else { # Atomic update
804 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
805 } else { # Old atomic update syntax
806 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
811 foreach my $line (split /\n/, $exec_output) {
812 push @output, sprintf "\t%s", $line;
819 sub get_atomic_updates {
820 my @atomic_upate_files;
821 # if there is anything in the atomicupdate, read and execute it.
822 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
823 opendir( my $dirh, $update_dir );
824 foreach my $file ( sort readdir $dirh ) {
825 next if $file !~ /\.(perl|pl)$/; #skip other files
826 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
828 push @atomic_upate_files, $file;
830 return \@atomic_upate_files;
833 sub run_atomic_updates {
836 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
837 my ( @done, @errors );
838 for my $file ( @$files ) {
839 my $filepath = $update_dir . $file;
842 if ( $file =~ m{\.perl$} ) {
843 my $code = read_file( $filepath );
844 my ( $out, $err ) = ('', '');
846 open my $oldout, ">&STDOUT";
848 open STDOUT,'>:encoding(utf8)', \$out;
849 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
850 my $dbh = C4::Context->dbh;
851 eval $code; ## no critic (StringyEval)
855 open STDOUT, ">&", $oldout;
859 filepath => $filepath,
862 time => POSIX::strftime( "%H:%M:%S", localtime ),
866 $atomic_update->{output} =
868 ? [ split "\n", $out ]
869 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
871 $atomic_update->{error} = $err if $err;
872 } elsif ( $file =~ m{\.pl$} ) {
873 $atomic_update = run_db_rev($filepath);
875 warn "Atomic update must be .perl or .pl ($file)";
878 if ( $atomic_update->{error} ) {
879 push @errors, $atomic_update;
881 push @done, $atomic_update;
885 return { success => \@done, error => \@errors };
888 =head2 DropAllForeignKeys($table)
890 Drop all foreign keys of the table $table
894 sub DropAllForeignKeys {
896 # get the table description
897 my $dbh = C4::Context->dbh;
898 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
900 my $vsc_structure = $sth->fetchrow;
901 # split on CONSTRAINT keyword
902 my @fks = split /CONSTRAINT /,$vsc_structure;
905 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
906 $_ = /(.*) FOREIGN KEY.*/;
909 # we have found 1 foreign, drop it
910 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
917 =head2 TransformToNum
919 Transform the Koha version from a 4 parts string
920 to a number, with just 1 .
926 # remove the 3 last . to have a Perl number
927 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
928 # three X's at the end indicate that you are testing patch with dbrev
930 # prevents error on a < comparison between strings (should be: lt)
931 $version =~ s/XXX$/999/;
937 set the DBversion in the systempreferences
942 return if $_[0]=~ /XXX$/;
943 #you are testing a patch with a db revision; do not change version
944 my $kohaversion = TransformToNum($_[0]);
945 my $dbh = C4::Context->dbh;
946 if (C4::Context->preference('Version')) {
947 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
948 $finish->execute($kohaversion);
950 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')");
951 $finish->execute($kohaversion);
953 C4::Context::clear_syspref_cache(); # invalidate cached preferences
956 # DEPRECATED Don't use it!
957 # Used for compatibility with older versions (from updatedatabase.pl)
959 my ( $DBversion, $bug_number, $descriptions ) = @_;
961 SetVersion($DBversion);
963 my ( $description, $report );
964 if ( ref($descriptions) ) {
965 $description = shift @$descriptions;
966 $report = join( "\n", @{$descriptions} );
969 $description = $descriptions;
972 my $output = generate_output_db_entry( {
973 bug_number => $bug_number,
974 description => $description,
976 version => $DBversion,
977 time => POSIX::strftime( "%H:%M:%S", localtime ),
980 say join "\n", @$output;
986 Check whether a given update should be run when passed the proposed version
987 number. The update will always be run if the proposed version is greater
988 than the current database version and less than or equal to the version in
989 kohaversion.pl. The update is also run if the version contains XXX, though
990 this behavior will be changed following the adoption of non-linear updates
991 as implemented in bug 7167.
996 my ($proposed_version) = @_;
997 my $version_number = TransformToNum($proposed_version);
999 # The following line should be deleted when bug 7167 is pushed
1000 return 1 if ( $proposed_version =~ m/XXX/ );
1002 if ( C4::Context->preference("Version") < $version_number
1003 && $version_number <= TransformToNum( $Koha::VERSION ) )
1011 sub sanitize_zero_date {
1012 my ( $table_name, $column_name ) = @_;
1014 my $dbh = C4::Context->dbh;
1016 my (undef, $datatype) = $dbh->selectrow_array(qq|
1017 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1019 if ( $datatype eq 'date' ) {
1022 SET $column_name = NULL
1023 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1028 SET $column_name = NULL
1029 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1036 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1037 originally written by Henri-Damien Laurant.
1039 Koha Development Team <http://koha-community.org/>
1041 Galen Charlton <galen.charlton@liblime.com>