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 YAML::Syck qw( LoadFile );
  25 use C4::Context;
  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( primary_key_exists foreign_key_exists index_exists column_exists TableExists);
  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->{'tls'} = C4::Context->config("tls");
  79     if( $self->{'tls'} && $self->{'tls'} eq 'yes' ) {
  80         $self->{'ca'} = C4::Context->config('ca');
  81         $self->{'cert'} = C4::Context->config('cert');
  82         $self->{'key'} = C4::Context->config('key');
  83         $self->{'tlsoptions'} = ";mysql_ssl=1;mysql_ssl_client_key=".$self->{key}.";mysql_ssl_client_cert=".$self->{cert}.";mysql_ssl_ca_file=".$self->{ca};
  84         $self->{'tlscmdline'} =  " --ssl-cert ". $self->{cert} . " --ssl-key " . $self->{key} . " --ssl-ca ".$self->{ca}." "
  85     }
  86     $self->{'dbh'} = DBI->connect("DBI:$self->{dbms}:dbname=$self->{dbname};host=$self->{hostname}" .
  87                                   ( $self->{port} ? ";port=$self->{port}" : "" ).
  88                                   ( $self->{tlsoptions} ? $self->{tlsoptions} : ""),
  89                                   $self->{'user'}, $self->{'password'});
  90     $self->{'language'} = undef;
  91     $self->{'marcflavour'} = undef;
  92         $self->{'dbh'}->do('set NAMES "utf8"');
  93     $self->{'dbh'}->{'mysql_enable_utf8'}=1;
  94
  95     bless $self, $class;
  96     return $self;
  97 }
  98
  99 =head2 marc_framework_sql_list
 100
 101   my ($defaulted_to_en, $list) =
 102      $installer->marc_framework_sql_list($lang, $marcflavour);
 103
 104 Returns in C<$list> a structure listing the filename, description, section,
 105 and mandatory/optional status of MARC framework scripts available for C<$lang>
 106 and C<$marcflavour>.
 107
 108 If the C<$defaulted_to_en> return value is true, no scripts are available
 109 for language C<$lang> and the 'en' ones are returned.
 110
 111 =cut
 112
 113 sub marc_framework_sql_list {
 114     my $self = shift;
 115     my $lang = shift;
 116     my $marcflavour = shift;
 117
 118     my $defaulted_to_en = 0;
 119
 120     undef $/;
 121     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour);
 122     unless (opendir( MYDIR, $dir )) {
 123         if ($lang eq 'en') {
 124             warn "cannot open MARC frameworks directory $dir";
 125         } else {
 126             # if no translated MARC framework is available,
 127             # default to English
 128             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour);
 129             opendir(MYDIR, $dir) or warn "cannot open English MARC frameworks directory $dir";
 130             $defaulted_to_en = 1;
 131         }
 132     }
 133     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 134     closedir MYDIR;
 135
 136     my @fwklist;
 137     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 138     $request->execute;
 139     my ($frameworksloaded) = $request->fetchrow;
 140     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 141     my %frameworksloaded;
 142     foreach ( split( /\|/, $frameworksloaded ) ) {
 143         $frameworksloaded{$_} = 1;
 144     }
 145
 146     foreach my $requirelevel (@listdir) {
 147         opendir( MYDIR, "$dir/$requirelevel" );
 148         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR);
 149         closedir MYDIR;
 150         my %cell;
 151         my @frameworklist;
 152         map {
 153             my ( $name, $ext ) = split /\./, $_;
 154             my @lines;
 155             if ( $ext =~ /yml/ ) {
 156                 my $yaml = LoadFile("$dir/$requirelevel/$name\.$ext");
 157                 @lines = map { Encode::decode('UTF-8', $_) } @{ $yaml->{'description'} };
 158             } else {
 159                 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 160                 my $line = <$fh>;
 161                 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 162                 @lines = split /\n/, $line;
 163             }
 164             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 165             push @frameworklist,
 166               {
 167                 'fwkname'        => $name,
 168                 'fwkfile'        => "$dir/$requirelevel/$_",
 169                 'fwkdescription' => \@lines,
 170                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 171                 'mandatory'      => $mandatory,
 172               };
 173         } @listname;
 174         my @fwks =
 175           sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 176
 177         $cell{"frameworks"} = \@fwks;
 178         $cell{"label"}      = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
 179         $cell{"code"}       = lc($requirelevel);
 180         push @fwklist, \%cell;
 181     }
 182
 183     return ($defaulted_to_en, \@fwklist);
 184 }
 185
 186 =head2 sample_data_sql_list
 187
 188   my ($defaulted_to_en, $list) = $installer->sample_data_sql_list($lang);
 189
 190 Returns in C<$list> a structure listing the filename, description, section,
 191 and mandatory/optional status of sample data scripts available for C<$lang>.
 192 If the C<$defaulted_to_en> return value is true, no scripts are available
 193 for language C<$lang> and the 'en' ones are returned.
 194
 195 =cut
 196
 197 sub sample_data_sql_list {
 198     my $self = shift;
 199     my $lang = shift;
 200
 201     my $defaulted_to_en = 0;
 202
 203     undef $/;
 204     my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang";
 205     unless (opendir( MYDIR, $dir )) {
 206         if ($lang eq 'en') {
 207             warn "cannot open sample data directory $dir";
 208         } else {
 209             # if no sample data is available,
 210             # default to English
 211             $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en";
 212             opendir(MYDIR, $dir) or warn "cannot open English sample data directory $dir";
 213             $defaulted_to_en = 1;
 214         }
 215     }
 216     my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR);
 217     closedir MYDIR;
 218
 219     my @levellist;
 220     my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'");
 221     $request->execute;
 222     my ($frameworksloaded) = $request->fetchrow;
 223     $frameworksloaded = '' unless defined $frameworksloaded; # avoid warning
 224     my %frameworksloaded;
 225     foreach ( split( /\|/, $frameworksloaded ) ) {
 226         $frameworksloaded{$_} = 1;
 227     }
 228
 229     foreach my $requirelevel (@listdir) {
 230         opendir( MYDIR, "$dir/$requirelevel" );
 231         my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR);
 232         closedir MYDIR;
 233         my %cell;
 234         my @frameworklist;
 235         map {
 236             my ( $name, $ext ) = split /\./, $_;
 237             my @lines;
 238             if ( $ext =~ /yml/ ) {
 239                 my $yaml = LoadFile("$dir/$requirelevel/$name\.$ext");
 240                 @lines = map { Encode::decode('UTF-8', $_) } @{ $yaml->{'description'} };
 241             } else {
 242                 open my $fh, "<:encoding(UTF-8)", "$dir/$requirelevel/$name.txt";
 243                 my $line = <$fh>;
 244                 $line = Encode::encode('UTF-8', $line) unless ( Encode::is_utf8($line) );
 245                 @lines = split /\n/, $line;
 246             }
 247             my $mandatory = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i);
 248             push @frameworklist,
 249               {
 250                 'fwkname'        => $name,
 251                 'fwkfile'        => "$dir/$requirelevel/$_",
 252                 'fwkdescription' => \@lines,
 253                 'checked'        => ( ( $frameworksloaded{$_} || $mandatory ) ? 1 : 0 ),
 254                 'mandatory'      => $mandatory,
 255               };
 256         } @listname;
 257         my @fwks = sort { $a->{'fwkname'} cmp $b->{'fwkname'} } @frameworklist;
 258
 259         $cell{"frameworks"} = \@fwks;
 260         $cell{"label"}      = ($requirelevel =~ /(mandatory|requi|oblig|necess)/i)?'mandatory':'optional';
 261         $cell{"code"}       = lc($requirelevel);
 262         push @levellist, \%cell;
 263     }
 264
 265     return ($defaulted_to_en, \@levellist);
 266 }
 267
 268 =head2 load_db_schema
 269
 270   my $error = $installer->load_db_schema();
 271
 272 Loads the SQL script that creates Koha's tables and indexes.  The
 273 return value is a string containing error messages reported by the
 274 load.
 275
 276 =cut
 277
 278 sub load_db_schema {
 279     my $self = shift;
 280
 281     my $datadir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}";
 282     my $error = $self->load_sql("$datadir/kohastructure.sql");
 283     return $error;
 284
 285 }
 286
 287 =head2 load_sql_in_order
 288
 289   my ($fwk_language, $list) = $installer->load_sql_in_order($all_languages, @sql_list);
 290
 291 Given a list of SQL scripts supplied in C<@sql_list>, loads each of them
 292 into the database and sets the FrameworksLoaded system preference to names
 293 of the scripts that were loaded.
 294
 295 The SQL files are loaded in alphabetical order by filename (not including
 296 directory path).  This means that dependencies among the scripts are to
 297 be resolved by carefully naming them, keeping in mind that the directory name
 298 does *not* currently count.
 299
 300 B<FIXME:> this is a rather delicate way of dealing with dependencies between
 301 the install scripts.
 302
 303 The return value C<$list> is an arrayref containing a hashref for each
 304 "level" or directory containing SQL scripts; the hashref in turns contains
 305 a list of hashrefs containing a list of each script load and any error
 306 messages associated with the loading of each script.
 307
 308 B<FIXME:> The C<$fwk_language> code probably doesn't belong and needs to be
 309 moved to a different method.
 310
 311 =cut
 312
 313 sub load_sql_in_order {
 314     my $self = shift;
 315     my $langchoice = shift;
 316     my $all_languages = shift;
 317     my @sql_list = @_;
 318
 319     my $lang;
 320     my %hashlevel;
 321     my @fnames = sort {
 322         my @aa = split /\/|\\/, ($a);
 323         my @bb = split /\/|\\/, ($b);
 324         $aa[-1] cmp $bb[-1]
 325     } @sql_list;
 326     my $request = $self->{'dbh'}->prepare( "SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'" );
 327     $request->execute;
 328     my ($systempreference) = $request->fetchrow;
 329     $systempreference = '' unless defined $systempreference; # avoid warning
 330
 331     my $global_mandatory_dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/mandatory";
 332
 333     # Make sure some stuffs are loaded first
 334     unshift(@fnames,
 335         "$global_mandatory_dir/sysprefs.sql",
 336         "$global_mandatory_dir/subtag_registry.sql",
 337         "$global_mandatory_dir/auth_val_cat.sql",
 338         "$global_mandatory_dir/message_transport_types.sql",
 339         "$global_mandatory_dir/sample_notices_message_attributes.sql",
 340         "$global_mandatory_dir/sample_notices_message_transports.sql",
 341         "$global_mandatory_dir/keyboard_shortcuts.sql",
 342     );
 343
 344     push @fnames, "$global_mandatory_dir/userflags.sql",
 345                   "$global_mandatory_dir/userpermissions.sql",
 346                   "$global_mandatory_dir/audio_alerts.sql",
 347                   "$global_mandatory_dir/account_offset_types.sql",
 348                   "$global_mandatory_dir/account_credit_types.sql",
 349                   "$global_mandatory_dir/account_debit_types.sql",
 350                   ;
 351     my $localization_file = C4::Context->config('intranetdir') .
 352                             "/installer/data/$self->{dbms}/localization/$langchoice/custom.sql";
 353     if ( $langchoice ne 'en' and -f $localization_file ) {
 354         push @fnames, $localization_file;
 355     }
 356     foreach my $file (@fnames) {
 357         #      warn $file;
 358         undef $/;
 359         my $error = $self->load_sql($file);
 360         my @file = split qr(\/|\\), $file;
 361         $lang = $file[ scalar(@file) - 3 ] unless ($lang);
 362         my $level = ( $file =~ /(localization)/ ) ? $1 : $file[ scalar(@file) - 2 ];
 363         unless ($error) {
 364             $systempreference .= "$file[scalar(@file)-1]|"
 365               unless ( index( $systempreference, $file[ scalar(@file) - 1 ] ) >= 0 );
 366         }
 367
 368         #Bulding here a hierarchy to display files by level.
 369         push @{ $hashlevel{$level} },
 370           { "fwkname" => $file[ scalar(@file) - 1 ], "error" => $error };
 371     }
 372
 373     #systempreference contains an ending |
 374     chop $systempreference;
 375     my @list;
 376     map { push @list, { "level" => $_, "fwklist" => $hashlevel{$_} } } keys %hashlevel;
 377     my $fwk_language;
 378     for my $each_language (@$all_languages) {
 379
 380         #       warn "CODE".$each_language->{'language_code'};
 381         #       warn "LANG:".$lang;
 382         if ( $lang eq $each_language->{'language_code'} ) {
 383             $fwk_language = $each_language->{language_locale_name};
 384         }
 385     }
 386     my $updateflag =
 387       $self->{'dbh'}->do(
 388         "UPDATE systempreferences set value=\"$systempreference\" where variable='FrameworksLoaded'"
 389       );
 390
 391     unless ( $updateflag == 1 ) {
 392         my $string =
 393             "INSERT INTO systempreferences (value, variable, explanation, type) VALUES (\"$systempreference\",'FrameworksLoaded','Frameworks loaded through webinstaller','choice')";
 394         my $rq = $self->{'dbh'}->prepare($string);
 395         $rq->execute;
 396     }
 397     return ($fwk_language, \@list);
 398 }
 399
 400 =head2 set_marcflavour_syspref
 401
 402   $installer->set_marcflavour_syspref($marcflavour);
 403
 404 Set the 'marcflavour' system preference.  The incoming
 405 C<$marcflavour> references to a subdirectory of
 406 installer/data/$dbms/$lang/marcflavour, and is
 407 normalized to MARC21, UNIMARC or NORMARC.
 408
 409 FIXME: this method assumes that the MARC flavour will be either
 410 MARC21, UNIMARC or NORMARC.
 411
 412 =cut
 413
 414 sub set_marcflavour_syspref {
 415     my $self = shift;
 416     my $marcflavour = shift;
 417
 418     # we can have some variants of marc flavour, by having different directories, like : unimarc_small and unimarc_full, for small and complete unimarc frameworks.
 419     # marc_cleaned finds the marcflavour, without the variant.
 420     my $marc_cleaned = 'MARC21';
 421     $marc_cleaned = 'UNIMARC' if $marcflavour =~ /unimarc/i;
 422     $marc_cleaned = 'NORMARC' if $marcflavour =~ /normarc/i;
 423     my $request =
 424         $self->{'dbh'}->prepare(
 425           "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');"
 426         );
 427     $request->execute;
 428 }
 429
 430 =head2 set_version_syspref
 431
 432   $installer->set_version_syspref();
 433
 434 Set or update the 'Version' system preference to the current
 435 Koha software version.
 436
 437 =cut
 438
 439 sub set_version_syspref {
 440     my $self = shift;
 441
 442     my $kohaversion = Koha::version();
 443     # remove the 3 last . to have a Perl number
 444     $kohaversion =~ s/(.*\..*)\.(.*)\.(.*)/$1$2$3/;
 445     if (C4::Context->preference('Version')) {
 446         warn "UPDATE Version";
 447         my $finish=$self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='Version'");
 448         $finish->execute($kohaversion);
 449     } else {
 450         warn "INSERT Version";
 451         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')");
 452         $finish->execute($kohaversion);
 453     }
 454     C4::Context->clear_syspref_cache();
 455 }
 456
 457 =head2 set_languages_syspref
 458
 459   $installer->set_languages_syspref();
 460
 461 Add the installation language to 'language' and 'opaclanguages' system preferences
 462 if different from 'en'
 463
 464 =cut
 465
 466 sub set_languages_syspref {
 467     my $self     = shift;
 468     my $language = shift;
 469
 470     return if ( not $language or $language eq 'en' );
 471
 472     warn "UPDATE Languages";
 473     # intranet
 474     my $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='language'");
 475     $pref->execute("en,$language");
 476     # opac
 477     $pref = $self->{'dbh'}->prepare("UPDATE systempreferences SET value=? WHERE variable='opaclanguages'");
 478     $pref->execute("en,$language");
 479
 480     C4::Context->clear_syspref_cache();
 481 }
 482
 483 =head2 process_yml_table
 484
 485   my $query_info   = $installer->process_yml_table($table);
 486
 487 Analyzes a table loaded in YAML format.
 488 Returns the values required to build an insert statement.
 489
 490 =cut
 491
 492 sub process_yml_table {
 493     my ($table) = @_;
 494     my $table_name   = ( keys %$table )[0];                          # table name
 495     my @rows         = @{ $table->{$table_name}->{rows} };           #
 496     my @columns      = ( sort keys %{$rows[0]} );                    # column names
 497     my $fields       = join ",", map{sprintf("`%s`", $_)} @columns;  # idem, joined
 498     my $query        = "INSERT INTO $table_name ( $fields ) VALUES ";
 499     my @multiline    = @{ $table->{$table_name}->{'multiline'} };    # to check multiline values;
 500     my $placeholders = '(' . join ( ",", map { "?" } @columns ) . ')'; # '(?,..,?)' string
 501     my @values;
 502     foreach my $row ( @rows ) {
 503         push @values, [ map {
 504                         my $col = $_;
 505                         ( @multiline and grep { $_ eq $col } @multiline )
 506                         ? join "\r\n", @{$row->{$col}}                # join multiline values
 507                         : $row->{$col};
 508                      } @columns ];
 509     }
 510     return { query => $query, placeholders => $placeholders, values => \@values };
 511 }
 512
 513 =head2 load_sql
 514
 515   my $error = $installer->load_sql($filename);
 516
 517 Runs the specified input file using a sql loader DBIx::RunSQL, or a yaml loader
 518 Returns any strings sent to STDERR
 519
 520 # FIXME This should be improved: sometimes the caller and load_sql warn the same
 521 error.
 522
 523 =cut
 524
 525 sub load_sql {
 526     my $self = shift;
 527     my $filename = shift;
 528     my $error;
 529
 530     my $dbh = $self->{ dbh };
 531
 532     my $dup_stderr;
 533     do {
 534         local *STDERR;
 535         open STDERR, ">>", \$dup_stderr;
 536
 537         if ( $filename =~ /sql$/ ) {                                                        # SQL files
 538             eval {
 539                 DBIx::RunSQL->run_sql_file(
 540                     dbh     => $dbh,
 541                     sql     => $filename,
 542                 );
 543             };
 544         }
 545         else {                                                                       # YAML files
 546             eval {
 547                 my $yaml         = LoadFile( $filename );                            # Load YAML
 548                 for my $table ( @{ $yaml->{'tables'} } ) {
 549                     my $query_info   = process_yml_table($table);
 550                     my $query        = $query_info->{query};
 551                     my $placeholders = $query_info->{placeholders};
 552                     my $values       = $query_info->{values};
 553                     # Doing only 1 INSERT query for the whole table
 554                     my @all_rows_values = map { @$_ } @$values;
 555                     $query .= join ', ', ( $placeholders ) x scalar @$values;
 556                     $dbh->do( $query, undef, @all_rows_values );
 557                 }
 558                 for my $statement ( @{ $yaml->{'sql_statements'} } ) {               # extra SQL statements
 559                     $dbh->do($statement);
 560                 }
 561             };
 562         }
 563         if ($@){
 564             warn "Something went wrong loading file $filename ($@)";
 565         }
 566     };
 567     #   errors thrown while loading installer data should be logged
 568     if( $dup_stderr ) {
 569         warn "C4::Installer::load_sql returned the following errors while attempting to load $filename:\n";
 570         $error = $dup_stderr;
 571     }
 572
 573     return $error;
 574 }
 575
 576 =head2 get_file_path_from_name
 577
 578   my $filename = $installer->get_file_path_from_name('script_name');
 579
 580 searches through the set of known SQL scripts and finds the fully
 581 qualified path name for the script that mathches the input.
 582
 583 returns undef if no match was found.
 584
 585
 586 =cut
 587
 588 sub get_file_path_from_name {
 589     my $self = shift;
 590     my $partialname = shift;
 591
 592     my $lang = 'en'; # FIXME: how do I know what language I want?
 593
 594     my ($defaulted_to_en, $list) = $self->sample_data_sql_list($lang);
 595     # warn( Data::Dumper->Dump( [ $list ], [ 'list' ] ) );
 596
 597     my @found;
 598     foreach my $frameworklist ( @$list ) {
 599         push @found, grep { $_->{'fwkfile'} =~ /$partialname$/ } @{$frameworklist->{'frameworks'}};
 600     }
 601
 602     # warn( Data::Dumper->Dump( [ \@found ], [ 'found' ] ) );
 603     if ( 0 == scalar @found ) {
 604         return;
 605     } elsif ( 1 < scalar @found ) {
 606         warn "multiple results found for $partialname";
 607         return;
 608     } else {
 609         return $found[0]->{'fwkfile'};
 610     }
 611
 612 }
 613
 614 sub primary_key_exists {
 615     my ( $table_name, $key_name ) = @_;
 616     my $dbh = C4::Context->dbh;
 617     my ($exists) = $dbh->selectrow_array(
 618         qq|
 619         SHOW INDEX FROM $table_name
 620         WHERE key_name = 'PRIMARY' AND column_name = ?
 621         |, undef, $key_name
 622     );
 623     return $exists;
 624 }
 625
 626 sub foreign_key_exists {
 627     my ( $table_name, $constraint_name ) = @_;
 628     my $dbh = C4::Context->dbh;
 629     my (undef, $infos) = $dbh->selectrow_array(qq|SHOW CREATE TABLE $table_name|);
 630     return $infos =~ m|CONSTRAINT `$constraint_name` FOREIGN KEY|;
 631 }
 632
 633 sub index_exists {
 634     my ( $table_name, $key_name ) = @_;
 635     my $dbh = C4::Context->dbh;
 636     my ($exists) = $dbh->selectrow_array(
 637         qq|
 638         SHOW INDEX FROM $table_name
 639         WHERE key_name = ?
 640         |, undef, $key_name
 641     );
 642     return $exists;
 643 }
 644
 645 sub column_exists {
 646     my ( $table_name, $column_name ) = @_;
 647     return unless TableExists($table_name);
 648     my $dbh = C4::Context->dbh;
 649     my ($exists) = $dbh->selectrow_array(
 650         qq|
 651         SHOW COLUMNS FROM $table_name
 652         WHERE Field = ?
 653         |, undef, $column_name
 654     );
 655     return $exists;
 656 }
 657
 658 sub TableExists { # Could be renamed table_exists for consistency
 659     my $table = shift;
 660     eval {
 661                 my $dbh = C4::Context->dbh;
 662                 local $dbh->{PrintError} = 0;
 663                 local $dbh->{RaiseError} = 1;
 664                 $dbh->do(qq{SELECT * FROM $table WHERE 1 = 0 });
 665             };
 666     return 1 unless $@;
 667     return 0;
 668 }
 669
 670
 671 =head1 AUTHOR
 672
 673 C4::Installer is a refactoring of logic originally from installer/installer.pl, which was
 674 originally written by Henri-Damien Laurant.
 675
 676 Koha Development Team <http://koha-community.org/>
 677
 678 Galen Charlton <galen.charlton@liblime.com>
 679
 680 =cut
 681
 682 1;