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