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