t/lib/KohaTest.pm

   1 package KohaTest;
   2 use base qw(Test::Class);
   3
   4 use Test::More;
   5 use Data::Dumper;
   6
   7 eval "use Test::Class";
   8 plan skip_all => "Test::Class required for performing database tests" if $@;
   9 # Or, maybe I should just die there.
  10
  11 use C4::Auth;
  12 use C4::Biblio;
  13 use C4::Bookfund;
  14 use C4::Bookseller;
  15 use C4::Context;
  16 use C4::Items;
  17 use C4::Members;
  18 use C4::Search;
  19 use C4::Installer;
  20 use C4::Languages;
  21 use File::Temp qw/ tempdir /;
  22
  23 # Since this is an abstract base class, this prevents these tests from
  24 # being run directly unless we're testing a subclass. It just makes
  25 # things faster.
  26 __PACKAGE__->SKIP_CLASS( 1 );
  27
  28 use Attribute::Handlers;
  29
  30 =head2 Expensive test method attribute
  31
  32 If a test method is decorated with an Expensive
  33 attribute, it is skipped unless the RUN_EXPENSIVE_TESTS
  34 environment variable is defined.
  35
  36 To declare an entire test class and its subclasses expensive,
  37 define a SKIP_CLASS with the Expensive attribute:
  38
  39     sub SKIP_CLASS : Expensive { }
  40
  41 =cut
  42
  43 sub Expensive : ATTR(CODE) {
  44     my ($package, $symbol, $sub, $attr, $data, $phase) = @_;
  45     my $name = *{$symbol}{NAME};
  46     if ($name eq 'SKIP_CLASS') {
  47         if ($ENV{'RUN_EXPENSIVE_TESTS'}) {
  48             *{$symbol} = sub { 0; }
  49         } else {
  50             *{$symbol} = sub { "Skipping expensive test classes $package (and subclasses)"; }
  51         }
  52     } else {
  53         unless ($ENV{'RUN_EXPENSIVE_TESTS'}) {
  54             # a test method that runs no tests and just returns a scalar is viewed by Test::Class as a skip
  55             *{$symbol} = sub { "Skipping expensive test $package\:\:$name"; }
  56         }
  57     }
  58 }
  59
  60 =head2 startup methods
  61
  62 these are run once, at the beginning of the whole test suite
  63
  64 =cut
  65
  66 sub startup_15_truncate_tables : Test( startup => 1 ) {
  67     my $self = shift;
  68
  69 #     my @truncate_tables = qw( accountlines
  70 #                               accountoffsets
  71 #                               action_logs
  72 #                               alert
  73 #                               aqbasket
  74 #                               aqbookfund
  75 #                               aqbooksellers
  76 #                               aqbudget
  77 #                               aqorderbreakdown
  78 #                               aqorderdelivery
  79 #                               aqorders
  80 #                               auth_header
  81 #                               auth_subfield_structure
  82 #                               auth_tag_structure
  83 #                               auth_types
  84 #                               authorised_values
  85 #                               biblio
  86 #                               biblio_framework
  87 #                               biblioitems
  88 #                               borrowers
  89 #                               branchcategories
  90 #                               branches
  91 #                               branchrelations
  92 #                               branchtransfers
  93 #                               browser
  94 #                               categories
  95 #                               cities
  96 #                               class_sort_rules
  97 #                               class_sources
  98 #                               currency
  99 #                               deletedbiblio
 100 #                               deletedbiblioitems
 101 #                               deletedborrowers
 102 #                               deleteditems
 103 #                               ethnicity
 104 #                               import_batches
 105 #                               import_biblios
 106 #                               import_items
 107 #                               import_record_matches
 108 #                               import_records
 109 #                               issues
 110 #                               issuingrules
 111 #                               items
 112 #                               itemtypes
 113 #                               labels
 114 #                               labels_conf
 115 #                               labels_profile
 116 #                               labels_templates
 117 #                               language_descriptions
 118 #                               language_rfc4646_to_iso639
 119 #                               language_script_bidi
 120 #                               language_script_mapping
 121 #                               language_subtag_registry
 122 #                               letter
 123 #                               marc_matchers
 124 #                               marc_subfield_structure
 125 #                               marc_tag_structure
 126 #                               matchchecks
 127 #                               matcher_matchpoints
 128 #                               matchpoint_component_norms
 129 #                               matchpoint_components
 130 #                               matchpoints
 131 #                               notifys
 132 #                               nozebra
 133 #                               old_issues
 134 #                               old_reserves
 135 #                               opac_news
 136 #                               overduerules
 137 #                               patroncards
 138 #                               patronimage
 139 #                               printers
 140 #                               printers_profile
 141 #                               repeatable_holidays
 142 #                               reports_dictionary
 143 #                               reserveconstraints
 144 #                               reserves
 145 #                               reviews
 146 #                               roadtype
 147 #                               saved_reports
 148 #                               saved_sql
 149 #                               serial
 150 #                               serialitems
 151 #                               services_throttle
 152 #                               sessions
 153 #                               special_holidays
 154 #                               statistics
 155 #                               stopwords
 156 #                               subscription
 157 #                               subscriptionhistory
 158 #                               subscriptionroutinglist
 159 #                               suggestions
 160 #                               systempreferences
 161 #                               tags
 162 #                               userflags
 163 #                               virtualshelfcontents
 164 #                               virtualshelves
 165 #                               z3950servers
 166 #                               zebraqueue
 167 #                         );
 168
 169     my @truncate_tables = qw( accountlines
 170                               accountoffsets
 171                               alert
 172                               aqbasket
 173                               aqbooksellers
 174                               aqorderbreakdown
 175                               aqorderdelivery
 176                               aqorders
 177                               auth_header
 178                               branchcategories
 179                               branchrelations
 180                               branchtransfers
 181                               browser
 182                               cities
 183                               deletedbiblio
 184                               deletedbiblioitems
 185                               deletedborrowers
 186                               deleteditems
 187                               ethnicity
 188                               issues
 189                               issuingrules
 190                               labels
 191                               labels_profile
 192                               matchchecks
 193                               notifys
 194                               nozebra
 195                               old_issues
 196                               old_reserves
 197                               overduerules
 198                               patroncards
 199                               patronimage
 200                               printers
 201                               printers_profile
 202                               reports_dictionary
 203                               reserveconstraints
 204                               reserves
 205                               reviews
 206                               roadtype
 207                               saved_reports
 208                               saved_sql
 209                               serial
 210                               serialitems
 211                               services_throttle
 212                               special_holidays
 213                               statistics
 214                               subscription
 215                               subscriptionhistory
 216                               subscriptionroutinglist
 217                               suggestions
 218                               tags
 219                               virtualshelfcontents
 220                         );
 221
 222     my $failed_to_truncate = 0;
 223     foreach my $table ( @truncate_tables ) {
 224         my $dbh = C4::Context->dbh();
 225         $dbh->do( "truncate $table" )
 226           or $failed_to_truncate = 1;
 227     }
 228     is( $failed_to_truncate, 0, 'truncated tables' );
 229 }
 230
 231 =head2 startup_20_add_bookseller
 232
 233 we need a bookseller for many of the tests, so let's insert one. Feel
 234 free to use this one, or insert your own.
 235
 236 =cut
 237
 238 sub startup_20_add_bookseller : Test(startup => 1) {
 239     my $self = shift;
 240
 241     my $booksellerinfo = { name => 'bookseller ' . $self->random_string(),
 242                       };
 243
 244     my $id = AddBookseller( $booksellerinfo );
 245     ok( $id, "created bookseller: $id" );
 246     $self->{'booksellerid'} = $id;
 247
 248     return;
 249 }
 250
 251 =head2 startup_22_add_bookfund
 252
 253 we need a bookfund for many of the tests. This currently uses one that
 254 is in the skeleton database.  free to use this one, or insert your
 255 own.
 256
 257 =cut
 258
 259 sub startup_22_add_bookfund : Test(startup => 2) {
 260     my $self = shift;
 261
 262     my $bookfundid = 'GEN';
 263     my $bookfund = GetBookFund( $bookfundid, undef );
 264     # diag( Data::Dumper->Dump( [ $bookfund ], qw( bookfund  ) ) );
 265     is( $bookfund->{'bookfundid'},   $bookfundid,      "found bookfund: '$bookfundid'" );
 266     is( $bookfund->{'bookfundname'}, 'General Stacks', "found bookfund: '$bookfundid'" );
 267
 268     $self->{'bookfundid'} = $bookfundid;
 269     return;
 270 }
 271
 272 =head2 startup_24_add_member
 273
 274 Add a patron/member for the tests to use
 275
 276 =cut
 277
 278 sub startup_24_add_member : Test(startup => 1) {
 279     my $self = shift;
 280
 281     my $memberinfo = { surname      => 'surname '  . $self->random_string(),
 282                        firstname    => 'firstname' . $self->random_string(),
 283                        address      => 'address'   . $self->random_string(),
 284                        city         => 'city'      . $self->random_string(),
 285                        cardnumber   => 'card'      . $self->random_string(),
 286                        branchcode   => 'CPL', # CPL => Centerville
 287                        categorycode => 'PT',  # PT  => PaTron
 288                        dateexpiry   => '2010-01-01',
 289                        password     => 'testpassword',
 290                   };
 291
 292     my $borrowernumber = AddMember( %$memberinfo );
 293     ok( $borrowernumber, "created member: $borrowernumber" );
 294     $self->{'memberid'} = $borrowernumber;
 295
 296     return;
 297 }
 298
 299 =head2 startup_30_login
 300
 301 =cut
 302
 303 sub startup_30_login : Test( startup => 2 ) {
 304     my $self = shift;
 305
 306     $self->{'sessionid'} = '12345678'; # does this value matter?
 307     my $borrower_details = C4::Members::GetMemberDetails( $self->{'memberid'} );
 308     ok( $borrower_details->{'cardnumber'}, 'cardnumber' );
 309
 310     # make a cookie and force it into $cgi.
 311     # This would be a lot easier with Test::MockObject::Extends.
 312     my $cgi = CGI->new( { userid   => $borrower_details->{'cardnumber'},
 313                           password => 'testpassword' } );
 314     my $setcookie = $cgi->cookie( -name  => 'CGISESSID',
 315                                   -value => $self->{'sessionid'} );
 316     $cgi->{'.cookies'} = { CGISESSID => $setcookie };
 317     is( $cgi->cookie('CGISESSID'), $self->{'sessionid'}, 'the CGISESSID cookie is set' );
 318     # diag( Data::Dumper->Dump( [ $cgi->cookie('CGISESSID') ], [ qw( cookie ) ] ) );
 319
 320     # C4::Auth::checkauth sometimes emits a warning about unable to append to sessionlog. That's OK.
 321     my ( $userid, $cookie, $sessionID ) = C4::Auth::checkauth( $cgi, 'noauth', {}, 'intranet' );
 322     # diag( Data::Dumper->Dump( [ $userid, $cookie, $sessionID ], [ qw( userid cookie sessionID ) ] ) );
 323
 324     # my $session = C4::Auth::get_session( $sessionID );
 325     # diag( Data::Dumper->Dump( [ $session ], [ qw( session ) ] ) );
 326
 327
 328 }
 329
 330 =head2 setup methods
 331
 332 setup methods are run before every test method
 333
 334 =cut
 335
 336 =head2 teardown methods
 337
 338 teardown methods are many time, once at the end of each test method.
 339
 340 =cut
 341
 342 =head2 shutdown methods
 343
 344 shutdown methods are run once, at the end of the test suite
 345
 346 =cut
 347
 348 =head2 utility methods
 349
 350 These are not test methods, but they're handy
 351
 352 =cut
 353
 354 =head3 random_string
 355
 356 Nice for generating names and such. It's not actually random, more
 357 like arbitrary.
 358
 359 =cut
 360
 361 sub random_string {
 362     my $self = shift;
 363
 364     my $wordsize = 6;  # how many letters in your string?
 365
 366     # leave out these characters: "oOlL10". They're too confusing.
 367     my @alphabet = ( 'a'..'k','m','n','p'..'z', 'A'..'K','M','N','P'..'Z', 2..9 );
 368
 369     my $randomstring;
 370     foreach ( 0..$wordsize ) {
 371         $randomstring .= $alphabet[ rand( scalar( @alphabet ) ) ];
 372     }
 373     return $randomstring;
 374
 375 }
 376
 377 =head3 add_biblios
 378
 379   $self->add_biblios( count     => 10,
 380                       add_items => 1, );
 381
 382   named parameters:
 383      count: number of biblios to add
 384      add_items: should you add items for each one?
 385
 386   returns:
 387     I don't know yet.
 388
 389   side effects:
 390     adds the biblionumbers to the $self->{'biblios'} listref
 391
 392   Notes:
 393     Should I allow you to pass in biblio information, like title?
 394     Since this method is in the KohaTest class, all tests in it will be ignored, unless you call this from your own namespace.
 395     This runs 10 tests, plus 4 for each "count", plus 3 more for each item added.
 396
 397 =cut
 398
 399 sub add_biblios {
 400     my $self = shift;
 401     my %param = @_;
 402
 403     $param{'count'}     = 1 unless defined( $param{'count'} );
 404     $param{'add_items'} = 0 unless defined( $param{'add_items'} );
 405
 406     foreach my $counter ( 1..$param{'count'} ) {
 407         my $marcrecord  = MARC::Record->new();
 408         isa_ok( $marcrecord, 'MARC::Record' );
 409         my $appendedfieldscount = $marcrecord->append_fields( MARC::Field->new( '100', '1', '0',
 410                                                                                 a => 'Twain, Mark',
 411                                                                                 d => "1835-1910." ),
 412                                                               MARC::Field->new( '245', '1', '4',
 413                                                                                 a => sprintf( 'The Adventures of Huckleberry Finn Test %s', $counter ),
 414                                                                                 c => "Mark Twain ; illustrated by E.W. Kemble." ),
 415                                                               MARC::Field->new( '952', '0', '0',
 416                                                                                 p => '12345678' . $self->random_string() ),   # barcode
 417                                                               MARC::Field->new( '952', '0', '0',
 418                                                                                 a => 'CPL',
 419                                                                                 b => 'CPL' ),
 420                                                          );
 421
 422         diag $MARC::Record::ERROR if ( $MARC::Record::ERROR );
 423         is( $appendedfieldscount, 4, 'added 4 fields' );
 424
 425         my $frameworkcode = ''; # XXX I'd like to put something reasonable here.
 426         my ( $biblionumber, $biblioitemnumber ) = AddBiblio( $marcrecord, $frameworkcode );
 427         ok( $biblionumber, "the biblionumber is $biblionumber" );
 428         ok( $biblioitemnumber, "the biblioitemnumber is $biblioitemnumber" );
 429         if ( $param{'add_items'} ) {
 430             # my @iteminfo = AddItem( {}, $biblionumber );
 431             my @iteminfo = AddItemFromMarc( $marcrecord, $biblionumber );
 432             is( $iteminfo[0], $biblionumber,     "biblionumber is $biblionumber" );
 433             is( $iteminfo[1], $biblioitemnumber, "biblioitemnumber is $biblioitemnumber" );
 434             ok( $iteminfo[2], "itemnumber is $iteminfo[2]" );
 435         }
 436         push @{$self->{'biblios'}}, $biblionumber;
 437     }
 438
 439     my $query = 'Finn Test';
 440
 441     # XXX we're going to repeatedly try to fetch the marc records that
 442     # we inserted above. It may take a while before they all show
 443     # up. why?
 444     my $tries = 30;
 445     DELAY: foreach my $trial ( 1..$tries ) {
 446         diag "waiting for zebra indexing. Trial: $trial of $tries";
 447         my ( $error, $results ) = SimpleSearch( $query );
 448         if ( $param{'count'} <= scalar( @$results ) ) {
 449             ok( $tries, "found all $param{'count'} titles after $trial tries" );
 450             last DELAY;
 451         }
 452         sleep( 3 );
 453     } continue {
 454         if ( $trial == $tries ) {
 455             fail( "we never found all $param{'count'} titles even after $tries tries." );
 456         }
 457     }
 458
 459
 460 }
 461
 462 =head3 reindex_marc
 463
 464 Do a fast reindexing of all of the bib and authority
 465 records and mark all zebraqueue entries done.
 466
 467 Useful for test routines that need to do a
 468 lot of indexing without having to wait for
 469 zebraqueue.
 470
 471 In NoZebra model, this only marks zebraqueue
 472 done - the records should already be indexed.
 473
 474 =cut
 475
 476 sub reindex_marc {
 477     my $self = shift;
 478
 479     # mark zebraqueue done regardless of the indexing mode
 480     my $dbh = C4::Context->dbh();
 481     $dbh->do("UPDATE zebraqueue SET done = 1 WHERE done = 0");
 482
 483     return if C4::Context->preference('NoZebra');
 484
 485     my $directory = tempdir(CLEANUP => 1);
 486     foreach my $record_type qw(biblio authority) {
 487         mkdir "$directory/$record_type";
 488         my $sth = $dbh->prepare($record_type eq "biblio" ? "SELECT marc FROM biblioitems" : "SELECT marc FROM auth_header");
 489         $sth->execute();
 490         open OUT, ">:utf8", "$directory/$record_type/records";
 491         while (my ($blob) = $sth->fetchrow_array) {
 492             print OUT $blob;
 493         }
 494         close OUT;
 495         my $zebra_server = "${record_type}server";
 496         my $zebra_config  = C4::Context->zebraconfig($zebra_server)->{'config'};
 497         my $zebra_db_dir  = C4::Context->zebraconfig($zebra_server)->{'directory'};
 498         my $zebra_db = $record_type eq 'biblio' ? 'biblios' : 'authorities';
 499         system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 init > /dev/null 2>\&1";
 500         system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 update $directory/${record_type} > /dev/null 2>\&1";
 501         system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 commit > /dev/null 2>\&1";
 502     }
 503
 504 }
 505
 506
 507 =head3 clear_test_database
 508
 509   removes all tables from test database so that install starts with a clean slate
 510
 511 =cut
 512
 513 sub clear_test_database {
 514
 515     diag "removing tables from test database";
 516
 517     my $dbh = C4::Context->dbh;
 518     my $schema = C4::Context->config("database");
 519
 520     my @tables = get_all_tables($dbh, $schema);
 521     foreach my $table (@tables) {
 522         drop_all_foreign_keys($dbh, $table);
 523     }
 524
 525     foreach my $table (@tables) {
 526         drop_table($dbh, $table);
 527     }
 528 }
 529
 530 sub get_all_tables {
 531   my ($dbh, $schema) = @_;
 532   my $sth = $dbh->prepare("SELECT TABLE_NAME FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA = ?");
 533   my @tables = ();
 534   $sth->execute($schema);
 535   while (my ($table) = $sth->fetchrow_array) {
 536     push @tables, $table;
 537   }
 538   $sth->finish;
 539   return @tables;
 540 }
 541
 542 sub drop_all_foreign_keys {
 543     my ($dbh, $table) = @_;
 544     # get the table description
 545     my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
 546     $sth->execute;
 547     my $vsc_structure = $sth->fetchrow;
 548     # split on CONSTRAINT keyword
 549     my @fks = split /CONSTRAINT /,$vsc_structure;
 550     # parse each entry
 551     foreach (@fks) {
 552         # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
 553         $_ = /(.*) FOREIGN KEY.*/;
 554         my $id = $1;
 555         if ($id) {
 556             # we have found 1 foreign, drop it
 557             $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
 558             $id="";
 559         }
 560     }
 561 }
 562
 563 sub drop_table {
 564     my ($dbh, $table) = @_;
 565     $dbh->do("DROP TABLE $table");
 566 }
 567
 568 =head3 create_test_database
 569
 570   sets up the test database.
 571
 572 =cut
 573
 574 sub create_test_database {
 575
 576     diag 'creating testing database...';
 577     my $installer = C4::Installer->new() or die 'unable to create new installer';
 578     # warn Data::Dumper->Dump( [ $installer ], [ 'installer' ] );
 579     my $all_languages = getAllLanguages();
 580     my $error = $installer->load_db_schema();
 581     die "unable to load_db_schema: $error" if ( $error );
 582     my $list = $installer->sql_file_list('en', 'marc21', { optional  => 1,
 583                                                            mandatory => 1 } );
 584     my ($fwk_language, $installed_list) = $installer->load_sql_in_order($all_languages, @$list);
 585     $installer->set_version_syspref();
 586     $installer->set_marcflavour_syspref('MARC21');
 587     $installer->set_indexing_engine(0);
 588     diag 'database created.'
 589 }
 590
 591
 592 =head3 start_zebrasrv
 593
 594   This method deletes and reinitializes the zebra database directory,
 595   and then spans off a zebra server.
 596
 597 =cut
 598
 599 sub start_zebrasrv {
 600
 601     stop_zebrasrv();
 602     diag 'cleaning zebrasrv...';
 603
 604     foreach my $zebra_server ( qw( biblioserver authorityserver ) ) {
 605         my $zebra_config  = C4::Context->zebraconfig($zebra_server)->{'config'};
 606         my $zebra_db_dir  = C4::Context->zebraconfig($zebra_server)->{'directory'};
 607         foreach my $zebra_db_name ( qw( biblios authorities ) ) {
 608             my $command = "zebraidx -c $zebra_config -d $zebra_db_name init";
 609             my $return = system( $command . ' > /dev/null 2>&1' );
 610             if ( $return != 0 ) {
 611                 diag( "command '$command' died with value: " . $? >> 8 );
 612             }
 613
 614             $command = "zebraidx -c $zebra_config -d $zebra_db_name create $zebra_db_name";
 615             diag $command;
 616             $return = system( $command . ' > /dev/null 2>&1' );
 617             if ( $return != 0 ) {
 618                 diag( "command '$command' died with value: " . $? >> 8 );
 619             }
 620         }
 621     }
 622
 623     diag 'starting zebrasrv...';
 624
 625     my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
 626     my $command = sprintf( 'zebrasrv -f %s -D -l %s -p %s',
 627                            $ENV{'KOHA_CONF'},
 628                            File::Spec->catdir( C4::Context->config("logdir"), 'zebra.log' ),
 629                            $pidfile,
 630                       );
 631     diag $command;
 632     my $output = qx( $command );
 633     if ( $output ) {
 634         diag $output;
 635     }
 636     if ( -e $pidfile, 'pidfile exists' ) {
 637         diag 'zebrasrv started.';
 638     } else {
 639         die 'unable to start zebrasrv';
 640     }
 641     return $output;
 642 }
 643
 644 =head3 stop_zebrasrv
 645
 646   using the PID file for the zebra server, send it a TERM signal with
 647   "kill". We can't tell if the process actually dies or not.
 648
 649 =cut
 650
 651 sub stop_zebrasrv {
 652
 653     my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
 654     if ( -e $pidfile ) {
 655         open( my $pidh, '<', $pidfile )
 656           or return;
 657         if ( defined $pidh ) {
 658             my ( $pid ) = <$pidh> or return;
 659             close $pidh;
 660             my $killed = kill 15, $pid; # 15 is TERM
 661             if ( $killed != 1 ) {
 662                 warn "unable to kill zebrasrv with pid: $pid";
 663             }
 664         }
 665     }
 666 }
 667
 668
 669 =head3 start_zebraqueue_daemon
 670
 671   kick off a zebraqueue_daemon.pl process.
 672
 673 =cut
 674
 675 sub start_zebraqueue_daemon {
 676
 677     my $command = q(run/bin/koha-zebraqueue-ctl.sh start);
 678     diag $command;
 679     my $started = system( $command );
 680     diag "started: $started";
 681
 682 }
 683
 684 =head3 stop_zebraqueue_daemon
 685
 686
 687 =cut
 688
 689 sub stop_zebraqueue_daemon {
 690
 691     my $command = q(run/bin/koha-zebraqueue-ctl.sh stop);
 692     diag $command;
 693     my $started = system( $command );
 694     diag "started: $started";
 695
 696 }
 697
 698 1;