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 $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
638 $sql .= 'AND column_name = ? ' if $key_name;
639 ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
641 ($exists) = $dbh->selectrow_array( $sql, undef );
647 sub foreign_key_exists {
648 my ( $table_name, $constraint_name ) = @_;
649 my $dbh = C4::Context->dbh;
650 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
651 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
654 sub unique_key_exists {
655 my ( $table_name, $constraint_name ) = @_;
656 my $dbh = C4::Context->dbh;
657 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
658 return $infos =~ m|UNIQUE KEY `$constraint_name`|;
662 my ( $table_name, $key_name ) = @_;
663 my $dbh = C4::Context->dbh;
664 my ($exists) = $dbh->selectrow_array(
666 SHOW INDEX FROM $table_name
674 my ( $table_name, $column_name ) = @_;
675 return unless TableExists($table_name);
676 my $dbh = C4::Context->dbh;
677 my ($exists) = $dbh->selectrow_array(
679 SHOW COLUMNS FROM $table_name
681 |, undef, $column_name
686 sub TableExists { # Could be renamed table_exists for consistency
689 my $dbh = C4::Context->dbh;
690 local $dbh->{PrintError} = 0;
691 local $dbh->{RaiseError} = 1;
692 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
698 sub version_from_file {
700 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
701 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
705 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
706 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
707 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
709 for my $file ( @files ) {
710 my $version = version_from_file( $file );
712 unless ( $version ) {
713 warn "Invalid db_rev found: " . $file;
717 next unless CheckVersion( $version );
719 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
721 return \@need_update;
727 my $db_rev = do $file;
731 open my $outfh, '>', \$out;
733 my $schema = Koha::Database->new->schema;
736 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
745 $out = decode( 'UTF-8', $out );
749 bug_number => $db_rev->{bug_number},
750 description => $db_rev->{description},
752 version => scalar version_from_file($file),
753 time => POSIX::strftime( "%H:%M:%S", localtime ),
756 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
761 my ( $files, $params ) = @_;
763 my $force = $params->{force} || 0;
765 my ( @done, @errors );
766 for my $file ( @$files ) {
768 my $db_entry = run_db_rev($file);
770 if ( $db_entry->{error} ) {
771 push @errors, $db_entry;
772 $force ? next : last ;
773 # We stop the update if an error occurred!
776 SetVersion($db_entry->{version});
777 push @done, $db_entry;
779 return { success => \@done, error => \@errors };
782 sub generate_output_db_entry {
783 my ( $db_entry ) = @_;
785 my $description = $db_entry->{description};
786 my $output = $db_entry->{output};
787 my $DBversion = $db_entry->{version};
788 my $bug_number = $db_entry->{bug_number};
789 my $time = $db_entry->{time};
790 my $exec_output = $db_entry->{exec_output};
791 my $done = defined $db_entry->{done}
795 : ""; # For old versions, we don't know if we succeed or failed
801 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
803 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
805 } else { # Atomic update
807 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
808 } else { # Old atomic update syntax
809 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
814 foreach my $line (split /\n/, $exec_output) {
815 push @output, sprintf "\t%s", $line;
822 sub get_atomic_updates {
823 my @atomic_upate_files;
824 # if there is anything in the atomicupdate, read and execute it.
825 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
826 opendir( my $dirh, $update_dir );
827 foreach my $file ( sort readdir $dirh ) {
828 next if $file !~ /\.(perl|pl)$/; #skip other files
829 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
831 push @atomic_upate_files, $file;
833 return \@atomic_upate_files;
836 sub run_atomic_updates {
839 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
840 my ( @done, @errors );
841 for my $file ( @$files ) {
842 my $filepath = $update_dir . $file;
845 if ( $file =~ m{\.perl$} ) {
846 my $code = read_file( $filepath );
847 my ( $out, $err ) = ('', '');
849 open my $oldout, ">&STDOUT";
851 open STDOUT,'>:encoding(utf8)', \$out;
852 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
853 my $dbh = C4::Context->dbh;
854 eval $code; ## no critic (StringyEval)
858 open STDOUT, ">&", $oldout;
862 filepath => $filepath,
865 time => POSIX::strftime( "%H:%M:%S", localtime ),
869 $atomic_update->{output} =
871 ? [ split "\n", $out ]
872 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
874 $atomic_update->{error} = $err if $err;
875 } elsif ( $file =~ m{\.pl$} ) {
876 $atomic_update = run_db_rev($filepath);
878 warn "Atomic update must be .perl or .pl ($file)";
881 if ( $atomic_update->{error} ) {
882 push @errors, $atomic_update;
884 push @done, $atomic_update;
888 return { success => \@done, error => \@errors };
891 =head2 DropAllForeignKeys($table)
893 Drop all foreign keys of the table $table
897 sub DropAllForeignKeys {
899 # get the table description
900 my $dbh = C4::Context->dbh;
901 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
903 my $vsc_structure = $sth->fetchrow;
904 # split on CONSTRAINT keyword
905 my @fks = split /CONSTRAINT /,$vsc_structure;
908 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
909 $_ = /(.*) FOREIGN KEY.*/;
912 # we have found 1 foreign, drop it
913 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
920 =head2 TransformToNum
922 Transform the Koha version from a 4 parts string
923 to a number, with just 1 .
929 # remove the 3 last . to have a Perl number
930 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
931 # three X's at the end indicate that you are testing patch with dbrev
933 # prevents error on a < comparison between strings (should be: lt)
934 $version =~ s/XXX$/999/;
940 set the DBversion in the systempreferences
945 return if $_[0]=~ /XXX$/;
946 #you are testing a patch with a db revision; do not change version
947 my $kohaversion = TransformToNum($_[0]);
948 my $dbh = C4::Context->dbh;
949 if (C4::Context->preference('Version')) {
950 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
951 $finish->execute($kohaversion);
953 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')");
954 $finish->execute($kohaversion);
956 C4::Context::clear_syspref_cache(); # invalidate cached preferences
959 # DEPRECATED Don't use it!
960 # Used for compatibility with older versions (from updatedatabase.pl)
962 my ( $DBversion, $bug_number, $descriptions ) = @_;
964 SetVersion($DBversion);
966 my ( $description, $report );
967 if ( ref($descriptions) ) {
968 $description = shift @$descriptions;
969 $report = join( "\n", @{$descriptions} );
972 $description = $descriptions;
975 my $output = generate_output_db_entry( {
976 bug_number => $bug_number,
977 description => $description,
979 version => $DBversion,
980 time => POSIX::strftime( "%H:%M:%S", localtime ),
983 say join "\n", @$output;
989 Check whether a given update should be run when passed the proposed version
990 number. The update will always be run if the proposed version is greater
991 than the current database version and less than or equal to the version in
992 kohaversion.pl. The update is also run if the version contains XXX, though
993 this behavior will be changed following the adoption of non-linear updates
994 as implemented in bug 7167.
999 my ($proposed_version) = @_;
1000 my $version_number = TransformToNum($proposed_version);
1002 # The following line should be deleted when bug 7167 is pushed
1003 return 1 if ( $proposed_version =~ m/XXX/ );
1005 if ( C4::Context->preference("Version") < $version_number
1006 && $version_number <= TransformToNum( $Koha::VERSION ) )
1014 sub sanitize_zero_date {
1015 my ( $table_name, $column_name ) = @_;
1017 my $dbh = C4::Context->dbh;
1019 my (undef, $datatype) = $dbh->selectrow_array(qq|
1020 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1022 if ( $datatype eq 'date' ) {
1025 SET $column_name = NULL
1026 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1031 SET $column_name = NULL
1032 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1039 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1040 originally written by Henri-Damien Laurant.
1042 Koha Development Team <http://koha-community.org/>
1044 Galen Charlton <galen.charlton@liblime.com>