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