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