2 use base qw(Test::Class);
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.
21 use File::Temp qw/ tempdir /;
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
26 __PACKAGE__->SKIP_CLASS( 1 );
28 use Attribute::Handlers;
30 =head2 Expensive test method attribute
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.
36 To declare an entire test class and its subclasses expensive,
37 define a SKIP_CLASS with the Expensive attribute:
39 sub SKIP_CLASS : Expensive { }
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; }
50 *{$symbol} = sub { "Skipping expensive test classes $package (and subclasses)"; }
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"; }
60 =head2 startup methods
62 these are run once, at the beginning of the whole test suite
66 sub startup_15_truncate_tables : Test( startup => 1 ) {
69 # my @truncate_tables = qw( accountlines
81 # auth_subfield_structure
107 # import_record_matches
117 # language_descriptions
118 # language_rfc4646_to_iso639
119 # language_script_bidi
120 # language_script_mapping
121 # language_subtag_registry
124 # marc_subfield_structure
127 # matcher_matchpoints
128 # matchpoint_component_norms
129 # matchpoint_components
141 # repeatable_holidays
157 # subscriptionhistory
158 # subscriptionroutinglist
163 # virtualshelfcontents
169 my @truncate_tables = qw( accountlines
216 subscriptionroutinglist
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;
228 is( $failed_to_truncate, 0, 'truncated tables' );
231 =head2 startup_20_add_bookseller
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.
238 sub startup_20_add_bookseller : Test(startup => 1) {
241 my $booksellerinfo = { name => 'bookseller ' . $self->random_string(),
244 my $id = AddBookseller( $booksellerinfo );
245 ok( $id, "created bookseller: $id" );
246 $self->{'booksellerid'} = $id;
251 =head2 startup_22_add_bookfund
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
259 sub startup_22_add_bookfund : Test(startup => 2) {
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'" );
268 $self->{'bookfundid'} = $bookfundid;
272 =head2 startup_24_add_member
274 Add a patron/member for the tests to use
278 sub startup_24_add_member : Test(startup => 1) {
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',
292 my $borrowernumber = AddMember( %$memberinfo );
293 ok( $borrowernumber, "created member: $borrowernumber" );
294 $self->{'memberid'} = $borrowernumber;
299 =head2 startup_30_login
303 sub startup_30_login : Test( startup => 2 ) {
306 $self->{'sessionid'} = '12345678'; # does this value matter?
307 my $borrower_details = C4::Members::GetMemberDetails( $self->{'memberid'} );
308 ok( $borrower_details->{'cardnumber'}, 'cardnumber' );
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 ) ] ) );
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 ) ] ) );
324 # my $session = C4::Auth::get_session( $sessionID );
325 # diag( Data::Dumper->Dump( [ $session ], [ qw( session ) ] ) );
332 setup methods are run before every test method
336 =head2 teardown methods
338 teardown methods are many time, once at the end of each test method.
342 =head2 shutdown methods
344 shutdown methods are run once, at the end of the test suite
348 =head2 utility methods
350 These are not test methods, but they're handy
356 Nice for generating names and such. It's not actually random, more
364 my $wordsize = 6; # how many letters in your string?
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 );
370 foreach ( 0..$wordsize ) {
371 $randomstring .= $alphabet[ rand( scalar( @alphabet ) ) ];
373 return $randomstring;
379 $self->add_biblios( count => 10,
383 count: number of biblios to add
384 add_items: should you add items for each one?
390 adds the biblionumbers to the $self->{'biblios'} listref
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.
403 $param{'count'} = 1 unless defined( $param{'count'} );
404 $param{'add_items'} = 0 unless defined( $param{'add_items'} );
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',
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',
422 diag $MARC::Record::ERROR if ( $MARC::Record::ERROR );
423 is( $appendedfieldscount, 4, 'added 4 fields' );
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]" );
436 push @{$self->{'biblios'}}, $biblionumber;
439 my $query = 'Finn Test';
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
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" );
454 if ( $trial == $tries ) {
455 fail( "we never found all $param{'count'} titles even after $tries tries." );
464 Do a fast reindexing of all of the bib and authority
465 records and mark all zebraqueue entries done.
467 Useful for test routines that need to do a
468 lot of indexing without having to wait for
471 In NoZebra model, this only marks zebraqueue
472 done - the records should already be indexed.
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");
483 return if C4::Context->preference('NoZebra');
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");
490 open OUT, ">:utf8", "$directory/$record_type/records";
491 while (my ($blob) = $sth->fetchrow_array) {
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";
507 =head3 clear_test_database
509 removes all tables from test database so that install starts with a clean slate
513 sub clear_test_database {
515 diag "removing tables from test database";
517 my $dbh = C4::Context->dbh;
518 my $schema = C4::Context->config("database");
520 my @tables = get_all_tables($dbh, $schema);
521 foreach my $table (@tables) {
522 drop_all_foreign_keys($dbh, $table);
525 foreach my $table (@tables) {
526 drop_table($dbh, $table);
531 my ($dbh, $schema) = @_;
532 my $sth = $dbh->prepare("SELECT TABLE_NAME FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA = ?");
534 $sth->execute($schema);
535 while (my ($table) = $sth->fetchrow_array) {
536 push @tables, $table;
542 sub drop_all_foreign_keys {
543 my ($dbh, $table) = @_;
544 # get the table description
545 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
547 my $vsc_structure = $sth->fetchrow;
548 # split on CONSTRAINT keyword
549 my @fks = split /CONSTRAINT /,$vsc_structure;
552 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
553 $_ = /(.*) FOREIGN KEY.*/;
556 # we have found 1 foreign, drop it
557 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
564 my ($dbh, $table) = @_;
565 $dbh->do("DROP TABLE $table");
568 =head3 create_test_database
570 sets up the test database.
574 sub create_test_database {
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,
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.'
592 =head3 start_zebrasrv
594 This method deletes and reinitializes the zebra database directory,
595 and then spans off a zebra server.
602 diag 'cleaning zebrasrv...';
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 );
614 $command = "zebraidx -c $zebra_config -d $zebra_db_name create $zebra_db_name";
616 $return = system( $command . ' > /dev/null 2>&1' );
617 if ( $return != 0 ) {
618 diag( "command '$command' died with value: " . $? >> 8 );
623 diag 'starting zebrasrv...';
625 my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
626 my $command = sprintf( 'zebrasrv -f %s -D -l %s -p %s',
628 File::Spec->catdir( C4::Context->config("logdir"), 'zebra.log' ),
632 my $output = qx( $command );
636 if ( -e $pidfile, 'pidfile exists' ) {
637 diag 'zebrasrv started.';
639 die 'unable to start zebrasrv';
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.
653 my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
655 open( my $pidh, '<', $pidfile )
657 if ( defined $pidh ) {
658 my ( $pid ) = <$pidh> or return;
660 my $killed = kill 15, $pid; # 15 is TERM
661 if ( $killed != 1 ) {
662 warn "unable to kill zebrasrv with pid: $pid";
669 =head3 start_zebraqueue_daemon
671 kick off a zebraqueue_daemon.pl process.
675 sub start_zebraqueue_daemon {
677 my $command = q(run/bin/koha-zebraqueue-ctl.sh start);
679 my $started = system( $command );
680 diag "started: $started";
684 =head3 stop_zebraqueue_daemon
689 sub stop_zebraqueue_daemon {
691 my $command = q(run/bin/koha-zebraqueue-ctl.sh stop);
693 my $started = system( $command );
694 diag "started: $started";