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, UNIMARC or NORMARC.
429 FIXME: this method assumes that the MARC flavour will be either
430 MARC21, UNIMARC or NORMARC.
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;
442 $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
444 $self->{'dbh'}->prepare(
445 "INSERT IGNORE INTO `systempreferences` (variable,value,explanation,options,type) VALUES('marcflavour','$marc_cleaned','Define global MARC flavor (MARC21, UNIMARC or NORMARC) used for character encoding','MARC21|UNIMARC|NORMARC','Choice');"
450 =head2 set_version_syspref
452 $installer->set_version_syspref();
454 Set or update the 'Version' system preference to the current
455 Koha software version.
459 sub set_version_syspref {
462 my $kohaversion = Koha::version();
463 # remove the 3 last . to have a Perl number
464 $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
465 if (C4::Context->preference('Version')) {
466 warn "UPDATE Version";
467 my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
468 $finish->execute($kohaversion);
470 warn "INSERT Version";
471 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')");
472 $finish->execute($kohaversion);
474 C4::Context->clear_syspref_cache();
477 =head2 set_languages_syspref
479 $installer->set_languages_syspref();
481 Add the installation language to 'language' and 'OPACLanguages' system preferences
482 if different from 'en'
486 sub set_languages_syspref {
488 my $language = shift;
490 return if ( not $language or $language eq 'en' );
492 warn "UPDATE Languages";
494 my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
495 $pref->execute("en,$language");
497 $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='OPACLanguages'");
498 $pref->execute("en,$language");
500 C4::Context->clear_syspref_cache();
503 =head2 process_yml_table
505 my $query_info = $installer->process_yml_table($table);
507 Analyzes a table loaded in YAML format.
508 Returns the values required to build an insert statement.
512 sub process_yml_table {
514 my $table_name = ( keys %$table )[0]; # table name
515 my @rows = @{ $table->{$table_name}->{rows} }; #
516 my @columns = ( sort keys %{$rows[0]} ); # column names
517 my $fields = join ",", map{sprintf("`%s`", $_)} @columns; # idem, joined
518 my $query = "INSERT INTO $table_name ( $fields ) VALUES ";
519 my @multiline = @{ $table->{$table_name}->{'multiline'} }; # to check multiline values;
520 my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
522 foreach my $row ( @rows ) {
523 push @values, [ map {
525 ( @multiline and grep { $_ eq $col } @multiline )
526 ? join "\r\n", @{$row->{$col}} # join multiline values
530 return { query => $query, placeholders => $placeholders, values => \@values };
535 my $error = $installer->load_sql($filename);
537 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
538 Returns any strings sent to STDERR
540 # FIXME This should be improved: sometimes the caller and load_sql warn the same
547 my $filename = shift;
550 my $dbh = $self->{ dbh };
555 open STDERR, ">>", \$dup_stderr;
557 if ( $filename =~ /sql$/ ) { # SQL files
559 DBIx::RunSQL->run_sql_file(
567 my $yaml = YAML::XS::LoadFile( $filename ); # Load YAML
568 for my $table ( @{ $yaml->{'tables'} } ) {
569 my $query_info = process_yml_table($table);
570 my $query = $query_info->{query};
571 my $placeholders = $query_info->{placeholders};
572 my $values = $query_info->{values};
573 # Doing only 1 INSERT query for the whole table
574 my @all_rows_values = map { @$_ } @$values;
575 $query .= join ', ', ( $placeholders ) x scalar @$values;
576 $dbh->do( $query, undef, @all_rows_values );
578 for my $statement ( @{ $yaml->{'sql_statements'} } ) { # extra SQL statements
579 $dbh->do($statement);
584 warn "Something went wrong loading file $filename ($@)";
587 # errors thrown while loading installer data should be logged
589 warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
590 $error = $dup_stderr;
596 =head2 get_file_path_from_name
598 my $filename = $installer->get_file_path_from_name('script_name');
600 searches through the set of known SQL scripts and finds the fully
601 qualified path name for the script that mathches the input.
603 returns undef if no match was found.
608 sub get_file_path_from_name {
610 my $partialname = shift;
612 my $lang = 'en'; # FIXME: how do I know what language I want?
614 my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
615 # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
618 foreach my $frameworklist ( @$list ) {
619 push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
622 # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
623 if ( 0 == scalar @found ) {
625 } elsif ( 1 < scalar @found ) {
626 warn "multiple results found for $partialname";
629 return $found[0]->{'fwkfile'};
634 sub primary_key_exists {
635 my ( $table_name, $key_name ) = @_;
636 my $dbh = C4::Context->dbh;
637 my ($exists) = $dbh->selectrow_array(
639 SHOW INDEX FROM $table_name
640 WHERE key_name = 'PRIMARY' AND column_name = ?
646 sub foreign_key_exists {
647 my ( $table_name, $constraint_name ) = @_;
648 my $dbh = C4::Context->dbh;
649 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
650 return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
653 sub unique_key_exists {
654 my ( $table_name, $constraint_name ) = @_;
655 my $dbh = C4::Context->dbh;
656 my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
657 return $infos =~ m|UNIQUE KEY `$constraint_name`|;
661 my ( $table_name, $key_name ) = @_;
662 my $dbh = C4::Context->dbh;
663 my ($exists) = $dbh->selectrow_array(
665 SHOW INDEX FROM $table_name
673 my ( $table_name, $column_name ) = @_;
674 return unless TableExists($table_name);
675 my $dbh = C4::Context->dbh;
676 my ($exists) = $dbh->selectrow_array(
678 SHOW COLUMNS FROM $table_name
680 |, undef, $column_name
685 sub TableExists { # Could be renamed table_exists for consistency
688 my $dbh = C4::Context->dbh;
689 local $dbh->{PrintError} = 0;
690 local $dbh->{RaiseError} = 1;
691 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
697 sub version_from_file {
699 return unless $file =~ m|(^\|/)(\d{2})(\d{2})(\d{2})(\d{3}).pl$|;
700 return sprintf "%s.%s.%s.%s", $2, $3, $4, $5;
704 my $db_revs_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/db_revs';
705 opendir my $dh, $db_revs_dir or die "Cannot open $db_revs_dir dir ($!)";
706 my @files = sort grep { m|\.pl$| && ! m|skeleton\.pl$| } readdir $dh;
708 for my $file ( @files ) {
709 my $version = version_from_file( $file );
711 unless ( $version ) {
712 warn "Invalid db_rev found: " . $file;
716 next unless CheckVersion( $version );
718 push @need_update, sprintf( "%s/%s", $db_revs_dir, $file );
720 return \@need_update;
726 my $db_rev = do $file;
730 open my $outfh, '>', \$out;
732 my $schema = Koha::Database->new->schema;
735 $db_rev->{up}->( { dbh => $schema->storage->dbh, out => $outfh } );
744 $out = decode( 'UTF-8', $out );
748 bug_number => $db_rev->{bug_number},
749 description => $db_rev->{description},
751 version => scalar version_from_file($file),
752 time => POSIX::strftime( "%H:%M:%S", localtime ),
755 $db_entry->{output} = generate_output_db_entry($db_entry, $out);
760 my ( $files, $params ) = @_;
762 my $force = $params->{force} || 0;
764 my ( @done, @errors );
765 for my $file ( @$files ) {
767 my $db_entry = run_db_rev($file);
769 if ( $db_entry->{error} ) {
770 push @errors, $db_entry;
771 $force ? next : last ;
772 # We stop the update if an error occurred!
775 SetVersion($db_entry->{version});
776 push @done, $db_entry;
778 return { success => \@done, error => \@errors };
781 sub generate_output_db_entry {
782 my ( $db_entry ) = @_;
784 my $description = $db_entry->{description};
785 my $output = $db_entry->{output};
786 my $DBversion = $db_entry->{version};
787 my $bug_number = $db_entry->{bug_number};
788 my $time = $db_entry->{time};
789 my $exec_output = $db_entry->{exec_output};
790 my $done = defined $db_entry->{done}
794 : ""; # For old versions, we don't know if we succeed or failed
800 push @output, sprintf('Upgrade to %s %s [%s]: Bug %5s - %s', $DBversion, $done, $time, $bug_number, $description);
802 push @output, sprintf('Upgrade to %s %s [%s]: %s', $DBversion, $done, $time, $description);
804 } else { # Atomic update
806 push @output, sprintf('DEV atomic update %s %s [%s]: Bug %5s - %s', $db_entry->{filepath}, $done, $time, $bug_number, $description);
807 } else { # Old atomic update syntax
808 push @output, sprintf('DEV atomic update %s %s [%s]', $db_entry->{filepath}, $done, $time);
813 foreach my $line (split /\n/, $exec_output) {
814 push @output, sprintf "\t%s", $line;
821 sub get_atomic_updates {
822 my @atomic_upate_files;
823 # if there is anything in the atomicupdate, read and execute it.
824 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
825 opendir( my $dirh, $update_dir );
826 foreach my $file ( sort readdir $dirh ) {
827 next if $file !~ /\.(perl|pl)$/; #skip other files
828 next if $file eq 'skeleton.perl' || $file eq 'skeleton.pl'; # skip the skeleton files
830 push @atomic_upate_files, $file;
832 return \@atomic_upate_files;
835 sub run_atomic_updates {
838 my $update_dir = C4::Context->config('intranetdir') . '/installer/data/mysql/atomicupdate/';
839 my ( @done, @errors );
840 for my $file ( @$files ) {
841 my $filepath = $update_dir . $file;
844 if ( $file =~ m{\.perl$} ) {
845 my $code = read_file( $filepath );
846 my ( $out, $err ) = ('', '');
848 open my $oldout, ">&STDOUT";
850 open STDOUT,'>:encoding(utf8)', \$out;
851 my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval
852 my $dbh = C4::Context->dbh;
853 eval $code; ## no critic (StringyEval)
857 open STDOUT, ">&", $oldout;
861 filepath => $filepath,
864 time => POSIX::strftime( "%H:%M:%S", localtime ),
868 $atomic_update->{output} =
870 ? [ split "\n", $out ]
871 : generate_output_db_entry($atomic_update); # There wad an error, we didn't reach NewVersion)
873 $atomic_update->{error} = $err if $err;
874 } elsif ( $file =~ m{\.pl$} ) {
875 $atomic_update = run_db_rev($filepath);
877 warn "Atomic update must be .perl or .pl ($file)";
880 if ( $atomic_update->{error} ) {
881 push @errors, $atomic_update;
883 push @done, $atomic_update;
887 return { success => \@done, error => \@errors };
890 =head2 DropAllForeignKeys($table)
892 Drop all foreign keys of the table $table
896 sub DropAllForeignKeys {
898 # get the table description
899 my $dbh = C4::Context->dbh;
900 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
902 my $vsc_structure = $sth->fetchrow;
903 # split on CONSTRAINT keyword
904 my @fks = split /CONSTRAINT /,$vsc_structure;
907 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
908 $_ = /(.*) FOREIGN KEY.*/;
911 # we have found 1 foreign, drop it
912 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
919 =head2 TransformToNum
921 Transform the Koha version from a 4 parts string
922 to a number, with just 1 .
928 # remove the 3 last . to have a Perl number
929 $version =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
930 # three X's at the end indicate that you are testing patch with dbrev
932 # prevents error on a < comparison between strings (should be: lt)
933 $version =~ s/XXX$/999/;
939 set the DBversion in the systempreferences
944 return if $_[0]=~ /XXX$/;
945 #you are testing a patch with a db revision; do not change version
946 my $kohaversion = TransformToNum($_[0]);
947 my $dbh = C4::Context->dbh;
948 if (C4::Context->preference('Version')) {
949 my $finish=$dbh->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
950 $finish->execute($kohaversion);
952 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')");
953 $finish->execute($kohaversion);
955 C4::Context::clear_syspref_cache(); # invalidate cached preferences
958 # DEPRECATED Don't use it!
959 # Used for compatibility with older versions (from updatedatabase.pl)
961 my ( $DBversion, $bug_number, $descriptions ) = @_;
963 SetVersion($DBversion);
965 my ( $description, $report );
966 if ( ref($descriptions) ) {
967 $description = shift @$descriptions;
968 $report = join( "\n", @{$descriptions} );
971 $description = $descriptions;
974 my $output = generate_output_db_entry( {
975 bug_number => $bug_number,
976 description => $description,
978 version => $DBversion,
979 time => POSIX::strftime( "%H:%M:%S", localtime ),
982 say join "\n", @$output;
988 Check whether a given update should be run when passed the proposed version
989 number. The update will always be run if the proposed version is greater
990 than the current database version and less than or equal to the version in
991 kohaversion.pl. The update is also run if the version contains XXX, though
992 this behavior will be changed following the adoption of non-linear updates
993 as implemented in bug 7167.
998 my ($proposed_version) = @_;
999 my $version_number = TransformToNum($proposed_version);
1001 # The following line should be deleted when bug 7167 is pushed
1002 return 1 if ( $proposed_version =~ m/XXX/ );
1004 if ( C4::Context->preference("Version") < $version_number
1005 && $version_number <= TransformToNum( $Koha::VERSION ) )
1013 sub sanitize_zero_date {
1014 my ( $table_name, $column_name ) = @_;
1016 my $dbh = C4::Context->dbh;
1018 my (undef, $datatype) = $dbh->selectrow_array(qq|
1019 SHOW COLUMNS FROM $table_name WHERE Field = ?|, undef, $column_name);
1021 if ( $datatype eq 'date' ) {
1024 SET $column_name = NULL
1025 WHERE CAST($column_name AS CHAR(10)) = '0000-00-00';
1030 SET $column_name = NULL
1031 WHERE CAST($column_name AS CHAR(19)) = '0000-00-00 00:00:00';
1038 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
1039 originally written by Henri-Damien Laurant.
1041 Koha Development Team <http://koha-community.org/>
1043 Galen Charlton <galen.charlton@liblime.com>