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");
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_offset_types.sql",
368 "$global_mandatory_dir/account_credit_types.sql",
369 "$global_mandatory_dir/account_debit_types.sql",
371 my $localization_file = C4::Context->config('intranetdir') .
372 "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
373 if ( $langchoice ne 'en' and -f $localization_file ) {
374 push @fnames, $localization_file;
376 foreach my $file (@fnames) {
379 my $error = $self->load_sql($file);
380 my @file = split qr(\/|\\), $file;
381 $lang = $file[ scalar(@file) - 3 ] unless ($lang);
382 my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
384 $systempreference .= "$file[scalar(@file)-1]|"
385 unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
388 #Bulding here a hierarchy to display files by level.
389 push @{ $hashlevel{$level} },
390 { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
393 #systempreference contains an ending |
394 chop $systempreference;
396 map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
398 for my $each_language (@$all_languages) {
400 # warn "CODE".$each_language->{'language_code'};
401 # warn "LANG:".$lang;
402 if ( $lang eq $each_language->{'language_code'} ) {
403 $fwk_language = $each_language->{language_locale_name};
408 "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
411 unless ( $updateflag == 1 ) {
413 "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
414 my $rq = $self->{'dbh'}->prepare($string);
417 return ($fwk_language, \@list);
420 =head2 set_marcflavour_syspref
422 $installer->set_marcflavour_syspref($marcflavour);
424 Set the 'marcflavour' system preference. The incoming
425 C<$marcflavour> references to a subdirectory of
426 installer/data/$dbms/$lang/marcflavour, and is
427 normalized to MARC21 or UNIMARC.
429 FIXME: this method assumes that the MARC flavour will be either
434 sub set_marcflavour_syspref {
436 my $marcflavour = shift;
438 # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
439 # marc_cleaned finds the marcflavour, without the variant.
440 my $marc_cleaned = 'MARC21';
441 $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
443 $self->{'dbh'}->prepare(
444 "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');"
449 =head2 set_version_syspref
451 $installer->set_version_syspref();
453 Set or update the 'Version' system preference to the current
454 Koha software version.
458 sub set_version_syspref {
461 my $kohaversion = Koha::version();
462 # remove the 3 last . to have a Perl number
463 $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
464 if (C4::Context->preference('Version')) {
465 warn "UPDATE Version";
466 my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
467 $finish->execute($kohaversion);
469 warn "INSERT Version";
470 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')");
471 $finish->execute($kohaversion);
473 C4::Context->clear_syspref_cache();
476 =head2 set_languages_syspref
478 $installer->set_languages_syspref();
480 Add the installation language to 'language' and 'OPACLanguages' system preferences
481 if different from 'en'
485 sub set_languages_syspref {
487 my $language = shift;
489 return if ( not $language or $language eq 'en' );
491 warn "UPDATE Languages";
493 my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
494 $pref->execute("en,$language");
496 $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
497 $pref->execute("en,$language");
499 C4::Context->clear_syspref_cache();
502 =head2 process_yml_table
504 my $query_info = $installer->process_yml_table($table);
506 Analyzes a table loaded in YAML format.
507 Returns the values required to build an insert statement.
511 sub process_yml_table {
513 my $table_name = ( keys %$table )[0]; # table name
514 my @rows = @{ $table->{$table_name}->{rows} }; #
515 my @columns = ( sort keys %{$rows[0]} ); # column names
516 my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined
517 my $query = "INSERT INTO $table_name ( $fields ) VALUES ";
518 my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
519 my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
521 foreach my $row ( @rows ) {
522 push @values, [ map {
524 ( @multiline and grep { $_ eq $col } @multiline )
525 ? join "\r\n", @{$row->{$col}} # join multiline values
529 return { query => $query, placeholders => $placeholders, values => \@values };
534 my $error = $installer->load_sql($filename);
536 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
537 Returns any strings sent to STDERR
539 # FIXME This should be improved: sometimes the caller and load_sql warn the same
546 my $filename = shift;
549 my $dbh = $self->{ dbh };
554 open STDERR, ">>", \$dup_stderr;
556 if ( $filename =~ /sql$/ ) { # SQL files
558 DBIx::RunSQL->run_sql_file(
566 my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML
567 for my $table ( @{ $yaml->{'tables'} } ) {
568 my $query_info = process_yml_table($table);
569 my $query = $query_info->{query};
570 my $placeholders = $query_info->{placeholders};
571 my $values = $query_info->{values};
572 # Doing only 1 INSERT query for the whole table
573 my @all_rows_values = map { @$_ } @$values;
574 $query .= join ', ', ( $placeholders ) x scalar @$values;
575 $dbh->do( $query, undef, @all_rows_values );
577 for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements
578 $dbh->do($statement);
583 warn "Something went wrong loading file $filename ($@)";
586 # errors thrown while loading installer data should be logged
588 warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
589 $error = $dup_stderr;
595 =head2 get_file_path_from_name
597 my $filename = $installer->get_file_path_from_name('script_name');
599 searches through the set of known SQL scripts and finds the fully
600 qualified path name for the script that mathches the input.
602 returns undef if no match was found.
607 sub get_file_path_from_name {
609 my $partialname = shift;
611 my $lang = 'en'; # FIXME: how do I know what language I want?
613 my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
614 # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
617 foreach my $frameworklist ( @$list ) {
618 push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
621 # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
622 if ( 0 == scalar @found ) {
624 } elsif ( 1 < scalar @found ) {
625 warn "multiple results found for $partialname";
628 return $found[0]->{'fwkfile'};
633 sub primary_key_exists {
634 my ( $table_name, $key_name ) = @_;
635 my $dbh = C4::Context->dbh;
636 my ($exists) = $dbh->selectrow_array(
638 SHOW INDEX FROM $table_name
639 WHERE key_name = 'PRIMARY' AND column_name = ?
645 sub foreign_key_exists {
646 my ( $table_name, $constraint_name ) = @_;
647 my $dbh = C4::Context->dbh;
648 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
649 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
652 sub unique_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|UNIQUE KEY `$constraint_name`|;
660 my ( $table_name, $key_name ) = @_;
661 my $dbh = C4::Context->dbh;
662 my ($exists) = $dbh->selectrow_array(
664 SHOW INDEX FROM $table_name
672 my ( $table_name, $column_name ) = @_;
673 return unless TableExists($table_name);
674 my $dbh = C4::Context->dbh;
675 my ($exists) = $dbh->selectrow_array(
677 SHOW COLUMNS FROM $table_name
679 |, undef, $column_name
684 sub TableExists { # Could be renamed table_exists for consistency
687 my $dbh = C4::Context->dbh;
688 local $dbh->{PrintError} = 0;
689 local $dbh->{RaiseError} = 1;
690 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
696 sub version_from_file {
698 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
699 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
703 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
704 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
705 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
707 for my $file ( @files ) {
708 my $version = version_from_file( $file );
710 unless ( $version ) {
711 warn "Invalid db_rev found: " . $file;
715 next unless CheckVersion( $version );
717 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
719 return \@need_update;
725 my $db_rev = do $file;
729 open my $outfh, '>', \$out;
731 my $schema = Koha::Database->new->schema;
734 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
743 $out = decode( 'UTF-8', $out );
747 bug_number => $db_rev->{bug_number},
748 description => $db_rev->{description},
750 version => scalar version_from_file($file),
751 time => POSIX::strftime( "%H:%M:%S", localtime ),
754 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
759 my ( $files, $params ) = @_;
761 my $force = $params->{force} || 0;
763 my ( @done, @errors );
764 for my $file ( @$files ) {
766 my $db_entry = run_db_rev($file);
768 if ( $db_entry->{error} ) {
769 push @errors, $db_entry;
770 $force ? next : last ;
771 # We stop the update if an error occurred!
774 SetVersion($db_entry->{version});
775 push @done, $db_entry;
777 return { success => \@done, error => \@errors };
780 sub generate_output_db_entry {
781 my ( $db_entry ) = @_;
783 my $description = $db_entry->{description};
784 my $output = $db_entry->{output};
785 my $DBversion = $db_entry->{version};
786 my $bug_number = $db_entry->{bug_number};
787 my $time = $db_entry->{time};
788 my $exec_output = $db_entry->{exec_output};
789 my $done = defined $db_entry->{done}
793 : ""; # For old versions, we don't know if we succeed or failed
799 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
801 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
803 } else { # Atomic update
805 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
806 } else { # Old atomic update syntax
807 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
812 foreach my $line (split /\n/, $exec_output) {
813 push @output, sprintf "\t%s", $line;
820 sub get_atomic_updates {
821 my @atomic_upate_files;
822 # if there is anything in the atomicupdate, read and execute it.
823 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
824 opendir( my $dirh, $update_dir );
825 foreach my $file ( sort readdir $dirh ) {
826 next if $file !~ /\.(perl|pl)$/; #skip other files
827 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
829 push @atomic_upate_files, $file;
831 return \@atomic_upate_files;
834 sub run_atomic_updates {
837 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
838 my ( @done, @errors );
839 for my $file ( @$files ) {
840 my $filepath = $update_dir . $file;
843 if ( $file =~ m{\.perl$} ) {
844 my $code = read_file( $filepath );
845 my ( $out, $err ) = ('', '');
847 open my $oldout, ">&STDOUT";
849 open STDOUT,'>:encoding(utf8)', \$out;
850 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
851 my $dbh = C4::Context->dbh;
852 eval $code; ## no critic (StringyEval)
856 open STDOUT, ">&", $oldout;
860 filepath => $filepath,
863 time => POSIX::strftime( "%H:%M:%S", localtime ),
867 $atomic_update->{output} =
869 ? [ split "\n", $out ]
870 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
872 $atomic_update->{error} = $err if $err;
873 } elsif ( $file =~ m{\.pl$} ) {
874 $atomic_update = run_db_rev($filepath);
876 warn "Atomic update must be .perl or .pl ($file)";
879 if ( $atomic_update->{error} ) {
880 push @errors, $atomic_update;
882 push @done, $atomic_update;
886 return { success => \@done, error => \@errors };
889 =head2 DropAllForeignKeys($table)
891 Drop all foreign keys of the table $table
895 sub DropAllForeignKeys {
897 # get the table description
898 my $dbh = C4::Context->dbh;
899 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
901 my $vsc_structure = $sth->fetchrow;
902 # split on CONSTRAINT keyword
903 my @fks = split /CONSTRAINT /,$vsc_structure;
906 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
907 $_ = /(.*) FOREIGN KEY.*/;
910 # we have found 1 foreign, drop it
911 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
918 =head2 TransformToNum
920 Transform the Koha version from a 4 parts string
921 to a number, with just 1 .
927 # remove the 3 last . to have a Perl number
928 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
929 # three X's at the end indicate that you are testing patch with dbrev
931 # prevents error on a < comparison between strings (should be: lt)
932 $version =~ s/XXX$/999/;
938 set the DBversion in the systempreferences
943 return if $_[0]=~ /XXX$/;
944 #you are testing a patch with a db revision; do not change version
945 my $kohaversion = TransformToNum($_[0]);
946 my $dbh = C4::Context->dbh;
947 if (C4::Context->preference('Version')) {
948 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
949 $finish->execute($kohaversion);
951 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')");
952 $finish->execute($kohaversion);
954 C4::Context::clear_syspref_cache(); # invalidate cached preferences
957 # DEPRECATED Don't use it!
958 # Used for compatibility with older versions (from updatedatabase.pl)
960 my ( $DBversion, $bug_number, $descriptions ) = @_;
962 SetVersion($DBversion);
964 my ( $description, $report );
965 if ( ref($descriptions) ) {
966 $description = shift @$descriptions;
967 $report = join( "\n", @{$descriptions} );
970 $description = $descriptions;
973 my $output = generate_output_db_entry( {
974 bug_number => $bug_number,
975 description => $description,
977 version => $DBversion,
978 time => POSIX::strftime( "%H:%M:%S", localtime ),
981 say join "\n", @$output;
987 Check whether a given update should be run when passed the proposed version
988 number. The update will always be run if the proposed version is greater
989 than the current database version and less than or equal to the version in
990 kohaversion.pl. The update is also run if the version contains XXX, though
991 this behavior will be changed following the adoption of non-linear updates
992 as implemented in bug 7167.
997 my ($proposed_version) = @_;
998 my $version_number = TransformToNum($proposed_version);
1000 # The following line should be deleted when bug 7167 is pushed
1001 return 1 if ( $proposed_version =~ m/XXX/ );
1003 if ( C4::Context->preference("Version") < $version_number
1004 && $version_number <= TransformToNum( $Koha::VERSION ) )
1012 sub sanitize_zero_date {
1013 my ( $table_name, $column_name ) = @_;
1015 my $dbh = C4::Context->dbh;
1017 my (undef, $datatype) = $dbh->selectrow_array(qq|
1018 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1020 if ( $datatype eq 'date' ) {
1023 SET $column_name = NULL
1024 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1029 SET $column_name = NULL
1030 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1037 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1038 originally written by Henri-Damien Laurant.
1040 Koha Development Team <http://koha-community.org/>
1042 Galen Charlton <galen.charlton@liblime.com>