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 # NOTE: These lines are found in kohastructure itself, but DBIx::RunSQL ignores them!
289 $self->{'dbh'}->do(q{SET NAMES utf8mb4});
290 $self->{'dbh'}->do(q{SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0});
291 $self->{'dbh'}->do(q{SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0});
292 $self->{'dbh'}->do(q{SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO'});
293 $self->{'dbh'}->do(q{SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0});
296 my $error = $self->load_sql("$datadir/kohastructure.sql");
298 # Re-enable checks after load
299 $self->{'dbh'}->do(q{SET SQL_MODE=@OLD_SQL_MODE});
300 $self->{'dbh'}->do(q{SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS});
301 $self->{'dbh'}->do(q{SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS});
302 $self->{'dbh'}->do(q{SET SQL_NOTES=@OLD_SQL_NOTES});
308 =head2 load_sql_in_order
310 my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
312 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
313 into the database and sets the FrameworksLoaded system preference to names
314 of the scripts that were loaded.
316 The SQL files are loaded in alphabetical order by filename (not including
317 directory path). This means that dependencies among the scripts are to
318 be resolved by carefully naming them, keeping in mind that the directory name
319 does *not* currently count.
321 B<FIXME:> this is a rather delicate way of dealing with dependencies between
324 The return value C<$list> is an arrayref containing a hashref for each
325 "level" or directory containing SQL scripts; the hashref in turns contains
326 a list of hashrefs containing a list of each script load and any error
327 messages associated with the loading of each script.
329 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
330 moved to a different method.
334 sub load_sql_in_order {
336 my $langchoice = shift;
337 my $all_languages = shift;
343 my @aa = split /\/|\\/, ($a);
344 my @bb = split /\/|\\/, ($b);
347 my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
349 my ($systempreference) = $request->fetchrow;
350 $systempreference = '' unless defined $systempreference; # avoid warning
352 my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
354 # Make sure some stuffs are loaded first
356 "$global_mandatory_dir/sysprefs.sql",
357 "$global_mandatory_dir/subtag_registry.sql",
358 "$global_mandatory_dir/auth_val_cat.sql",
359 "$global_mandatory_dir/message_transport_types.sql",
360 "$global_mandatory_dir/sample_notices_message_attributes.sql",
361 "$global_mandatory_dir/sample_notices_message_transports.sql",
362 "$global_mandatory_dir/keyboard_shortcuts.sql",
365 push @fnames, "$global_mandatory_dir/userflags.sql",
366 "$global_mandatory_dir/userpermissions.sql",
367 "$global_mandatory_dir/audio_alerts.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 ( -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 $sql = qq| SHOW INDEX FROM $table_name WHERE key_name='PRIMARY' |;
639 $sql .= 'AND column_name = ? ' if $key_name;
640 ($exists) = $dbh->selectrow_array( $sql, undef, $key_name );
642 ($exists) = $dbh->selectrow_array( $sql, undef );
648 sub foreign_key_exists {
649 my ( $table_name, $constraint_name ) = @_;
650 my $dbh = C4::Context->dbh;
651 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
652 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
655 sub unique_key_exists {
656 my ( $table_name, $constraint_name ) = @_;
657 my $dbh = C4::Context->dbh;
658 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
659 return $infos =~ m|UNIQUE KEY `$constraint_name`|;
663 my ( $table_name, $key_name ) = @_;
664 my $dbh = C4::Context->dbh;
665 my ($exists) = $dbh->selectrow_array(
667 SHOW INDEX FROM $table_name
675 my ( $table_name, $column_name ) = @_;
676 return unless TableExists($table_name);
677 my $dbh = C4::Context->dbh;
678 my ($exists) = $dbh->selectrow_array(
680 SHOW COLUMNS FROM $table_name
682 |, undef, $column_name
687 sub TableExists { # Could be renamed table_exists for consistency
690 my $dbh = C4::Context->dbh;
691 local $dbh->{PrintError} = 0;
692 local $dbh->{RaiseError} = 1;
693 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
699 sub version_from_file {
701 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
702 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
706 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
707 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
708 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
710 for my $file ( @files ) {
711 my $version = version_from_file( $file );
713 unless ( $version ) {
714 warn "Invalid db_rev found: " . $file;
718 next unless CheckVersion( $version );
720 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
722 return \@need_update;
728 my $db_rev = do $file;
732 open my $outfh, '>', \$out;
734 my $schema = Koha::Database->new->schema;
737 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
746 $out = decode( 'UTF-8', $out );
750 bug_number => $db_rev->{bug_number},
751 description => $db_rev->{description},
753 version => scalar version_from_file($file),
754 time => POSIX::strftime( "%H:%M:%S", localtime ),
757 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
762 my ( $files, $params ) = @_;
764 my $force = $params->{force} || 0;
766 my ( @done, @errors );
767 for my $file ( @$files ) {
769 my $db_entry = run_db_rev($file);
771 if ( $db_entry->{error} ) {
772 push @errors, $db_entry;
773 $force ? next : last ;
774 # We stop the update if an error occurred!
777 SetVersion($db_entry->{version});
778 push @done, $db_entry;
780 return { success => \@done, error => \@errors };
783 sub generate_output_db_entry {
784 my ( $db_entry ) = @_;
786 my $description = $db_entry->{description};
787 my $output = $db_entry->{output};
788 my $DBversion = $db_entry->{version};
789 my $bug_number = $db_entry->{bug_number};
790 my $time = $db_entry->{time};
791 my $exec_output = $db_entry->{exec_output};
792 my $done = defined $db_entry->{done}
796 : ""; # For old versions, we don't know if we succeed or failed
802 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
804 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
806 } else { # Atomic update
808 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
809 } else { # Old atomic update syntax
810 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
815 foreach my $line (split /\n/, $exec_output) {
816 push @output, sprintf "\t%s", $line;
823 sub get_atomic_updates {
824 my @atomic_upate_files;
825 # if there is anything in the atomicupdate, read and execute it.
826 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
827 opendir( my $dirh, $update_dir );
828 foreach my $file ( sort readdir $dirh ) {
829 next if $file !~ /\.(perl|pl)$/; #skip other files
830 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
832 push @atomic_upate_files, $file;
834 return \@atomic_upate_files;
837 sub run_atomic_updates {
840 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
841 my ( @done, @errors );
842 for my $file ( @$files ) {
843 my $filepath = $update_dir . $file;
846 if ( $file =~ m{\.perl$} ) {
847 my $code = read_file( $filepath );
848 my ( $out, $err ) = ('', '');
850 open my $oldout, ">&STDOUT";
852 open STDOUT,'>:encoding(utf8)', \$out;
853 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
854 my $dbh = C4::Context->dbh;
855 eval $code; ## no critic (StringyEval)
859 open STDOUT, ">&", $oldout;
863 filepath => $filepath,
866 time => POSIX::strftime( "%H:%M:%S", localtime ),
870 $atomic_update->{output} =
872 ? [ split "\n", $out ]
873 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
875 $atomic_update->{error} = $err if $err;
876 } elsif ( $file =~ m{\.pl$} ) {
877 $atomic_update = run_db_rev($filepath);
879 warn "Atomic update must be .perl or .pl ($file)";
882 if ( $atomic_update->{error} ) {
883 push @errors, $atomic_update;
885 push @done, $atomic_update;
889 return { success => \@done, error => \@errors };
892 =head2 DropAllForeignKeys($table)
894 Drop all foreign keys of the table $table
898 sub DropAllForeignKeys {
900 # get the table description
901 my $dbh = C4::Context->dbh;
902 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
904 my $vsc_structure = $sth->fetchrow;
905 # split on CONSTRAINT keyword
906 my @fks = split /CONSTRAINT /,$vsc_structure;
909 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
910 $_ = /(.*) FOREIGN KEY.*/;
913 # we have found 1 foreign, drop it
914 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
921 =head2 TransformToNum
923 Transform the Koha version from a 4 parts string
924 to a number, with just 1 .
930 # remove the 3 last . to have a Perl number
931 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
932 # three X's at the end indicate that you are testing patch with dbrev
934 # prevents error on a < comparison between strings (should be: lt)
935 $version =~ s/XXX$/999/;
941 set the DBversion in the systempreferences
946 return if $_[0]=~ /XXX$/;
947 #you are testing a patch with a db revision; do not change version
948 my $kohaversion = TransformToNum($_[0]);
949 my $dbh = C4::Context->dbh;
950 if (C4::Context->preference('Version')) {
951 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
952 $finish->execute($kohaversion);
954 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')");
955 $finish->execute($kohaversion);
957 C4::Context::clear_syspref_cache(); # invalidate cached preferences
960 # DEPRECATED Don't use it!
961 # Used for compatibility with older versions (from updatedatabase.pl)
963 my ( $DBversion, $bug_number, $descriptions ) = @_;
965 SetVersion($DBversion);
967 my ( $description, $report );
968 if ( ref($descriptions) ) {
969 $description = shift @$descriptions;
970 $report = join( "\n", @{$descriptions} );
973 $description = $descriptions;
976 my $output = generate_output_db_entry( {
977 bug_number => $bug_number,
978 description => $description,
980 version => $DBversion,
981 time => POSIX::strftime( "%H:%M:%S", localtime ),
984 say join "\n", @$output;
990 Check whether a given update should be run when passed the proposed version
991 number. The update will always be run if the proposed version is greater
992 than the current database version and less than or equal to the version in
993 kohaversion.pl. The update is also run if the version contains XXX, though
994 this behavior will be changed following the adoption of non-linear updates
995 as implemented in bug 7167.
1000 my ($proposed_version) = @_;
1001 my $version_number = TransformToNum($proposed_version);
1003 # The following line should be deleted when bug 7167 is pushed
1004 return 1 if ( $proposed_version =~ m/XXX/ );
1006 if ( C4::Context->preference("Version") < $version_number
1007 && $version_number <= TransformToNum( $Koha::VERSION ) )
1015 sub sanitize_zero_date {
1016 my ( $table_name, $column_name ) = @_;
1018 my $dbh = C4::Context->dbh;
1020 my (undef, $datatype) = $dbh->selectrow_array(qq|
1021 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1023 if ( $datatype eq 'date' ) {
1026 SET $column_name = NULL
1027 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1032 SET $column_name = NULL
1033 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1040 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1041 originally written by Henri-Damien Laurant.
1043 Koha Development Team <http://koha-community.org/>
1045 Galen Charlton <galen.charlton@liblime.com>