C4/Installer.pm

   1 package C4::Installer;
   2
   3 # Copyright (C) 2008 LibLime
   4 #
   5 # This file is part of Koha.
   6 #
   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.
  11 #
  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.
  16 #
  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>.
  19
  20 use Modern::Perl;
  21
  22 use Encode qw( encode is_utf8 );
  23 use DBIx::RunSQL;
  24 use C4::Context;
  25 use DBI;
  26 use Koha;
  27
  28 use vars qw(@ISA @EXPORT);
  29 BEGIN {
  30     require Exporter;
  31     @ISA = qw( Exporter );
  32     push @EXPORT, qw( foreign_key_exists index_exists column_exists TableExists);
  33 };
  34
  35 =head1 NAME
  36
  37 C4::Installer
  38
  39 =head1 SYNOPSIS
  40
  41  use C4::Installer;
  42  my $installer = C4::Installer->new();
  43  my $all_languages = getAllLanguages();
  44  my $error = $installer->load_db_schema();
  45  my $list;
  46  #fill $list with list of sql files
  47  my ($fwk_language, $error_list) = $installer->load_sql_in_order($all_languages, @$list);
  48  $installer->set_version_syspref();
  49  $installer->set_marcflavour_syspref('MARC21');
  50
  51 =head1 DESCRIPTION
  52
  53 =cut
  54
  55 =head1 METHODS
  56
  57 =head2 new
  58
  59   my $installer = C4::Installer->new();
  60
  61 Creates a new installer.
  62
  63 =cut
  64
  65 sub new {
  66     my $class = shift;
  67
  68     my $self = {};
  69
  70     # get basic information from context
  71     $self->{'dbname'}   = C4::Context->config("database");
  72     $self->{'dbms'}     = C4::Context->config("db_scheme") ? C4::Context->config("db_scheme") : "mysql";
  73     $self->{'hostname'} = C4::Context->config("hostname");
  74     $self->{'port'}     = C4::Context->config("port");
  75     $self->{'user'}     = C4::Context->config("user");
  76     $self->{'password'} = C4::Context->config("pass");
  77     $self->{'tls'} = C4::Context->config("tls");
  78     if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
  79         $self->{'ca'} = C4::Context->config('ca');
  80         $self->{'cert'} = C4::Context->config('cert');
  81         $self->{'key'} = C4::Context->config('key');
  82         $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
  83         $self->{'tlscmdline'} =  " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
  84     }
  85     $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
  86                                   ( $self->{port} ? ";port=$self->{port}" : "" ).
  87                                   ( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
  88                                   $self->{'user'}, $self->{'password'});
  89     $self->{'language'} = undef;
  90     $self->{'marcflavour'} = undef;
  91         $self->{'dbh'}->do('set NAMES "utf8"');
  92     $self->{'dbh'}->{'mysql_enable_utf8'}=1;
  93
  94     bless $self, $class;
  95     return $self;
  96 }
  97
  98 =head2 marc_framework_sql_list
  99
 100   my ($defaulted_to_en, $list) =
 101      $installer->marc_framework_sql_list($lang, $marcflavour);
 102
 103 Returns in C<$list> a structure listing the filename, description, section,
 104 and mandatory/optional status of MARC framework scripts available for C<$lang>
 105 and C<$marcflavour>.
 106
 107 If the C<$defaulted_to_en> return value is true, no scripts are available
 108 for language C<$lang> and the 'en' ones are returned.
 109
 110 =cut
 111
 112 sub marc_framework_sql_list {
 113     my $self = shift;
 114     my $lang = shift;
 115     my $marcflavour = shift;
 116
 117     my $defaulted_to_en = 0;
 118
 119     undef $/;
 120     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
 121     unless (opendir( MYDIR, $dir )) {
 122         if ($lang eq 'en') {
 123             warn "cannot open MARC frameworks directory $dir";
 124         } else {
 125             # if no translated MARC framework is available,
 126             # default to English
 127             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
 128             opendir(MYDIR, $dir) or warn "cannot open English MARC frameworks directory $dir";
 129             $defaulted_to_en = 1;
 130         }
 131     }
 132     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 133     closedir MYDIR;
 134
 135     my @fwklist;
 136     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 137     $request->execute;
 138     my ($frameworksloaded) = $request->fetchrow;
 139     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 140     my %frameworksloaded;
 141     foreach ( split( /\|/, $frameworksloaded ) ) {
 142         $frameworksloaded{$_} = 1;
 143     }
 144
 145     foreach my $requirelevel (@listdir) {
 146         opendir( MYDIR, "$dir/$requirelevel" );
 147         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR);
 148         closedir MYDIR;
 149         my %cell;
 150         my @frameworklist;
 151         map {
 152             my $name = substr( $_, 0, -4 );
 153             open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 154             my $line = <$fh>;
 155             $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 156             my @lines = split /\n/, $line;
 157             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 158             push @frameworklist,
 159               {
 160                 'fwkname'        => $name,
 161                 'fwkfile'        => "$dir/$requirelevel/$_",
 162                 'fwkdescription' => \@lines,
 163                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 164                 'mandatory'      => $mandatory,
 165               };
 166         } @listname;
 167         my @fwks =
 168           sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 169
 170         $cell{"frameworks"} = \@fwks;
 171         $cell{"label"}      = ucfirst($requirelevel);
 172         $cell{"code"}       = lc($requirelevel);
 173         push @fwklist, \%cell;
 174     }
 175
 176     return ($defaulted_to_en, \@fwklist);
 177 }
 178
 179 =head2 sample_data_sql_list
 180
 181   my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
 182
 183 Returns in C<$list> a structure listing the filename, description, section,
 184 and mandatory/optional status of sample data scripts available for C<$lang>.
 185 If the C<$defaulted_to_en> return value is true, no scripts are available
 186 for language C<$lang> and the 'en' ones are returned.
 187
 188 =cut
 189
 190 sub sample_data_sql_list {
 191     my $self = shift;
 192     my $lang = shift;
 193
 194     my $defaulted_to_en = 0;
 195
 196     undef $/;
 197     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
 198     unless (opendir( MYDIR, $dir )) {
 199         if ($lang eq 'en') {
 200             warn "cannot open sample data directory $dir";
 201         } else {
 202             # if no sample data is available,
 203             # default to English
 204             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
 205             opendir(MYDIR, $dir) or warn "cannot open English sample data directory $dir";
 206             $defaulted_to_en = 1;
 207         }
 208     }
 209     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 210     closedir MYDIR;
 211
 212     my @levellist;
 213     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 214     $request->execute;
 215     my ($frameworksloaded) = $request->fetchrow;
 216     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 217     my %frameworksloaded;
 218     foreach ( split( /\|/, $frameworksloaded ) ) {
 219         $frameworksloaded{$_} = 1;
 220     }
 221
 222     foreach my $requirelevel (@listdir) {
 223         opendir( MYDIR, "$dir/$requirelevel" );
 224         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.sql$/ } readdir(MYDIR);
 225         closedir MYDIR;
 226         my %cell;
 227         my @frameworklist;
 228         map {
 229             my $name = substr( $_, 0, -4 );
 230             open my $fh , "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 231             my $line = <$fh>;
 232             $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 233             my @lines = split /\n/, $line;
 234             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 235             push @frameworklist,
 236               {
 237                 'fwkname'        => $name,
 238                 'fwkfile'        => "$dir/$requirelevel/$_",
 239                 'fwkdescription' => \@lines,
 240                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 241                 'mandatory'      => $mandatory,
 242               };
 243         } @listname;
 244         my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 245
 246         $cell{"frameworks"} = \@fwks;
 247         $cell{"label"}      = ucfirst($requirelevel);
 248         $cell{"code"}       = lc($requirelevel);
 249         push @levellist, \%cell;
 250     }
 251
 252     return ($defaulted_to_en, \@levellist);
 253 }
 254
 255 =head2 load_db_schema
 256
 257   my $error = $installer->load_db_schema();
 258
 259 Loads the SQL script that creates Koha's tables and indexes.  The
 260 return value is a string containing error messages reported by the
 261 load.
 262
 263 =cut
 264
 265 sub load_db_schema {
 266     my $self = shift;
 267
 268     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
 269     my $error = $self->load_sql("$datadir/kohastructure.sql");
 270     return $error;
 271
 272 }
 273
 274 =head2 load_sql_in_order
 275
 276   my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
 277
 278 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
 279 into the database and sets the FrameworksLoaded system preference to names
 280 of the scripts that were loaded.
 281
 282 The SQL files are loaded in alphabetical order by filename (not including
 283 directory path).  This means that dependencies among the scripts are to
 284 be resolved by carefully naming them, keeping in mind that the directory name
 285 does *not* currently count.
 286
 287 B<FIXME:> this is a rather delicate way of dealing with dependencies between
 288 the install scripts.
 289
 290 The return value C<$list> is an arrayref containing a hashref for each
 291 "level" or directory containing SQL scripts; the hashref in turns contains
 292 a list of hashrefs containing a list of each script load and any error
 293 messages associated with the loading of each script.
 294
 295 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
 296 moved to a different method.
 297
 298 =cut
 299
 300 sub load_sql_in_order {
 301     my $self = shift;
 302     my $all_languages = shift;
 303     my @sql_list = @_;
 304
 305     my $lang;
 306     my %hashlevel;
 307     my @fnames = sort {
 308         my @aa = split /\/|\\/, ($a);
 309         my @bb = split /\/|\\/, ($b);
 310         $aa[-1] cmp $bb[-1]
 311     } @sql_list;
 312     my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
 313     $request->execute;
 314     my ($systempreference) = $request->fetchrow;
 315     $systempreference = '' unless defined $systempreference; # avoid warning
 316
 317     my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
 318
 319     # Make sure some stuffs are loaded first
 320     unshift(@fnames, C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/sysprefs.sql");
 321     unshift(@fnames,
 322         "$global_mandatory_dir/subtag_registry.sql",
 323         "$global_mandatory_dir/auth_val_cat.sql",
 324         "$global_mandatory_dir/message_transport_types.sql",
 325         "$global_mandatory_dir/sample_notices_message_attributes.sql",
 326         "$global_mandatory_dir/sample_notices_message_transports.sql",
 327         "$global_mandatory_dir/keyboard_shortcuts.sql",
 328     );
 329
 330     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userflags.sql";
 331     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/userpermissions.sql";
 332     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/audio_alerts.sql";
 333     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_offset_types.sql";
 334     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_credit_types.sql";
 335     push @fnames, C4::Context->config('intranetdir') . "/installer/data/mysql/account_debit_types.sql";
 336     foreach my $file (@fnames) {
 337         #      warn $file;
 338         undef $/;
 339         my $error = $self->load_sql($file);
 340         my @file = split qr(\/|\\), $file;
 341         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 342         my $level = $file[ scalar(@file) - 2 ];
 343         unless ($error) {
 344             $systempreference .= "$file[scalar(@file)-1]|"
 345               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 346         }
 347
 348         #Bulding here a hierarchy to display files by level.
 349         push @{ $hashlevel{$level} },
 350           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 351     }
 352
 353     #systempreference contains an ending |
 354     chop $systempreference;
 355     my @list;
 356     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 357     my $fwk_language;
 358     for my $each_language (@$all_languages) {
 359
 360         #       warn "CODE".$each_language->{'language_code'};
 361         #       warn "LANG:".$lang;
 362         if ( $lang eq $each_language->{'language_code'} ) {
 363             $fwk_language = $each_language->{language_locale_name};
 364         }
 365     }
 366     my $updateflag =
 367       $self->{'dbh'}->do(
 368         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 369       );
 370
 371     unless ( $updateflag == 1 ) {
 372         my $string =
 373             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 374         my $rq = $self->{'dbh'}->prepare($string);
 375         $rq->execute;
 376     }
 377     return ($fwk_language, \@list);
 378 }
 379
 380 =head2 set_marcflavour_syspref
 381
 382   $installer->set_marcflavour_syspref($marcflavour);
 383
 384 Set the 'marcflavour' system preference.  The incoming
 385 C<$marcflavour> references to a subdirectory of
 386 installer/data/$dbms/$lang/marcflavour, and is
 387 normalized to MARC21, UNIMARC or NORMARC.
 388
 389 FIXME: this method assumes that the MARC flavour will be either
 390 MARC21, UNIMARC or NORMARC.
 391
 392 =cut
 393
 394 sub set_marcflavour_syspref {
 395     my $self = shift;
 396     my $marcflavour = shift;
 397
 398     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 399     # marc_cleaned finds the marcflavour, without the variant.
 400     my $marc_cleaned = 'MARC21';
 401     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
 402     $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
 403     my $request =
 404         $self->{'dbh'}->prepare(
 405           "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');"
 406         );
 407     $request->execute;
 408 }
 409
 410 =head2 set_version_syspref
 411
 412   $installer->set_version_syspref();
 413
 414 Set or update the 'Version' system preference to the current
 415 Koha software version.
 416
 417 =cut
 418
 419 sub set_version_syspref {
 420     my $self = shift;
 421
 422     my $kohaversion = Koha::version();
 423     # remove the 3 last . to have a Perl number
 424     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 425     if (C4::Context->preference('Version')) {
 426         warn "UPDATE Version";
 427         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 428         $finish->execute($kohaversion);
 429     } else {
 430         warn "INSERT Version";
 431         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')");
 432         $finish->execute($kohaversion);
 433     }
 434     C4::Context->clear_syspref_cache();
 435 }
 436
 437 =head2 load_sql
 438
 439   my $error = $installer->load_sql($filename);
 440
 441 Runs a the specified SQL file using a sql loader DBIx::RunSQL
 442 Returns any strings sent to STDERR
 443
 444 # FIXME This should be improved: sometimes the caller and load_sql warn the same
 445 error.
 446
 447 =cut
 448
 449 sub load_sql {
 450     my $self = shift;
 451     my $filename = shift;
 452     my $error;
 453
 454     my $dbh = $self->{ dbh };
 455
 456     my $dup_stderr;
 457     do {
 458         local *STDERR;
 459         open STDERR, ">>", \$dup_stderr;
 460
 461         eval {
 462             DBIx::RunSQL->run_sql_file(
 463                 dbh     => $dbh,
 464                 sql     => $filename,
 465             );
 466         };
 467     };
 468     #   errors thrown while loading installer data should be logged
 469     if( $dup_stderr ) {
 470         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
 471         $error = $dup_stderr;
 472     }
 473
 474     return $error;
 475 }
 476
 477 =head2 get_file_path_from_name
 478
 479   my $filename = $installer->get_file_path_from_name('script_name');
 480
 481 searches through the set of known SQL scripts and finds the fully
 482 qualified path name for the script that mathches the input.
 483
 484 returns undef if no match was found.
 485
 486
 487 =cut
 488
 489 sub get_file_path_from_name {
 490     my $self = shift;
 491     my $partialname = shift;
 492
 493     my $lang = 'en'; # FIXME: how do I know what language I want?
 494
 495     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
 496     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
 497
 498     my @found;
 499     foreach my $frameworklist ( @$list ) {
 500         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
 501     }
 502
 503     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
 504     if ( 0 == scalar @found ) {
 505         return;
 506     } elsif ( 1 < scalar @found ) {
 507         warn "multiple results found for $partialname";
 508         return;
 509     } else {
 510         return $found[0]->{'fwkfile'};
 511     }
 512
 513 }
 514
 515 sub foreign_key_exists {
 516     my ( $table_name, $constraint_name ) = @_;
 517     my $dbh = C4::Context->dbh;
 518     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 519     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
 520 }
 521
 522 sub index_exists {
 523     my ( $table_name, $key_name ) = @_;
 524     my $dbh = C4::Context->dbh;
 525     my ($exists) = $dbh->selectrow_array(
 526         qq|
 527         SHOW INDEX FROM $table_name
 528         WHERE key_name = ?
 529         |, undef, $key_name
 530     );
 531     return $exists;
 532 }
 533
 534 sub column_exists {
 535     my ( $table_name, $column_name ) = @_;
 536     return unless TableExists($table_name);
 537     my $dbh = C4::Context->dbh;
 538     my ($exists) = $dbh->selectrow_array(
 539         qq|
 540         SHOW COLUMNS FROM $table_name
 541         WHERE Field = ?
 542         |, undef, $column_name
 543     );
 544     return $exists;
 545 }
 546
 547 sub TableExists { # Could be renamed table_exists for consistency
 548     my $table = shift;
 549     eval {
 550                 my $dbh = C4::Context->dbh;
 551                 local $dbh->{PrintError} = 0;
 552                 local $dbh->{RaiseError} = 1;
 553                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 554             };
 555     return 1 unless $@;
 556     return 0;
 557 }
 558
 559
 560 =head1 AUTHOR
 561
 562 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
 563 originally written by Henri-Damien Laurant.
 564
 565 Koha Development Team <http://koha-community.org/>
 566
 567 Galen Charlton <galen.charlton@liblime.com>
 568
 569 =cut
 570
 571 1;