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.
20 use File::Temp qw/ tempdir /;
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
27 __PACKAGE__->SKIP_CLASS( 1 );
30 if ($ENV{SINGLE_TEST}) {
31 # if we're running the tests in one
32 # or more test files specified via
34 # make test-single TEST_FILES=lib/KohaTest/Foo.pm
36 # use this INIT trick taken from the POD for
39 Test::Class->runtests;
44 use Attribute::Handlers;
46 =head2 Expensive test method attribute
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.
52 To declare an entire test class and its subclasses expensive,
53 define a SKIP_CLASS with the Expensive attribute:
55 sub SKIP_CLASS : Expensive { }
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; }
66 *{$symbol} = sub { "Skipping expensive test classes $package (and subclasses)"; }
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"; }
76 =head2 startup methods
78 these are run once, at the beginning of the whole test suite
82 sub startup_15_truncate_tables : Test( startup => 1 ) {
85 # my @truncate_tables = qw( accountlines
96 # auth_subfield_structure
122 # import_record_matches
132 # language_descriptions
133 # language_rfc4646_to_iso639
134 # language_script_bidi
135 # language_script_mapping
136 # language_subtag_registry
139 # marc_subfield_structure
142 # matcher_matchpoints
143 # matchpoint_component_norms
144 # matchpoint_components
156 # repeatable_holidays
172 # subscriptionhistory
173 # subscriptionroutinglist
178 # virtualshelfcontents
184 my @truncate_tables = qw( accountlines
230 subscriptionroutinglist
236 my $failed_to_truncate = 0;
237 foreach my $table ( @truncate_tables ) {
238 my $dbh = C4::Context->dbh();
239 $dbh->do( "truncate $table" )
240 or $failed_to_truncate = 1;
242 is( $failed_to_truncate, 0, 'truncated tables' );
245 =head2 startup_20_add_bookseller
247 we need a bookseller for many of the tests, so let's insert one. Feel
248 free to use this one, or insert your own.
252 sub startup_20_add_bookseller : Test(startup => 1) {
255 my $booksellerinfo = { name => 'bookseller ' . $self->random_string(),
258 my $id = AddBookseller( $booksellerinfo );
259 ok( $id, "created bookseller: $id" );
260 $self->{'booksellerid'} = $id;
265 =head2 startup_22_add_bookfund
267 we need a bookfund for many of the tests. This currently uses one that
268 is in the skeleton database. free to use this one, or insert your
273 sub startup_22_add_bookfund : Test(startup => 2) {
276 my $bookfundid = 'GEN';
277 my $bookfund = GetBookFund( $bookfundid, undef );
278 # diag( Data::Dumper->Dump( [ $bookfund ], qw( bookfund ) ) );
279 is( $bookfund->{'bookfundid'}, $bookfundid, "found bookfund: '$bookfundid'" );
280 is( $bookfund->{'bookfundname'}, 'General Stacks', "found bookfund: '$bookfundid'" );
282 $self->{'bookfundid'} = $bookfundid;
286 =head2 startup_24_add_branch
290 sub startup_24_add_branch : Test(startup => 1) {
295 branchcode => $self->random_string(3),
296 branchname => $self->random_string(),
297 branchaddress1 => $self->random_string(),
298 branchaddress2 => $self->random_string(),
299 branchaddress3 => $self->random_string(),
300 branchphone => $self->random_phone(),
301 branchfax => $self->random_phone(),
302 brancemail => $self->random_email(),
303 branchip => $self->random_ip(),
304 branchprinter => $self->random_string(),
306 C4::Branch::ModBranch($branch_info);
307 $self->{'branchcode'} = $branch_info->{'branchcode'};
308 ok( $self->{'branchcode'}, "created branch: $self->{'branchcode'}" );
312 =head2 startup_24_add_member
314 Add a patron/member for the tests to use
318 sub startup_24_add_member : Test(startup => 1) {
321 my $memberinfo = { surname => 'surname ' . $self->random_string(),
322 firstname => 'firstname' . $self->random_string(),
323 address => 'address' . $self->random_string(),
324 city => 'city' . $self->random_string(),
325 cardnumber => 'card' . $self->random_string(),
326 branchcode => 'CPL', # CPL => Centerville
327 categorycode => 'PT', # PT => PaTron
328 dateexpiry => '2010-01-01',
329 password => 'testpassword',
330 dateofbirth => $self->random_date(),
333 my $borrowernumber = AddMember( %$memberinfo );
334 ok( $borrowernumber, "created member: $borrowernumber" );
335 $self->{'memberid'} = $borrowernumber;
340 =head2 startup_30_login
344 sub startup_30_login : Test( startup => 2 ) {
347 $self->{'sessionid'} = '12345678'; # does this value matter?
348 my $borrower_details = C4::Members::GetMemberDetails( $self->{'memberid'} );
349 ok( $borrower_details->{'cardnumber'}, 'cardnumber' );
351 # make a cookie and force it into $cgi.
352 # This would be a lot easier with Test::MockObject::Extends.
353 my $cgi = CGI->new( { userid => $borrower_details->{'cardnumber'},
354 password => 'testpassword' } );
355 my $setcookie = $cgi->cookie( -name => 'CGISESSID',
356 -value => $self->{'sessionid'} );
357 $cgi->{'.cookies'} = { CGISESSID => $setcookie };
358 is( $cgi->cookie('CGISESSID'), $self->{'sessionid'}, 'the CGISESSID cookie is set' );
359 # diag( Data::Dumper->Dump( [ $cgi->cookie('CGISESSID') ], [ qw( cookie ) ] ) );
361 # C4::Auth::checkauth sometimes emits a warning about unable to append to sessionlog. That's OK.
362 my ( $userid, $cookie, $sessionID ) = C4::Auth::checkauth( $cgi, 'noauth', {}, 'intranet' );
363 # diag( Data::Dumper->Dump( [ $userid, $cookie, $sessionID ], [ qw( userid cookie sessionID ) ] ) );
365 # my $session = C4::Auth::get_session( $sessionID );
366 # diag( Data::Dumper->Dump( [ $session ], [ qw( session ) ] ) );
373 setup methods are run before every test method
377 =head2 teardown methods
379 teardown methods are many time, once at the end of each test method.
383 =head2 shutdown methods
385 shutdown methods are run once, at the end of the test suite
389 =head2 utility methods
391 These are not test methods, but they're handy
397 Nice for generating names and such. It's not actually random, more
405 my $wordsize = shift || 6; # how many letters in your string?
407 # leave out these characters: "oOlL10". They're too confusing.
408 my @alphabet = ( 'a'..'k','m','n','p'..'z', 'A'..'K','M','N','P'..'Z', 2..9 );
411 foreach ( 0..$wordsize ) {
412 $randomstring .= $alphabet[ rand( scalar( @alphabet ) ) ];
414 return $randomstring;
420 generates a random phone number. Currently, it's not actually random. It's an unusable US phone number
427 return '212-555-5555';
433 generates a random email address. They're all in the unusable
434 'example.com' domain that is designed for this purpose.
441 return $self->random_string() . '@example.com';
447 returns an IP address suitable for testing purposes.
460 returns a somewhat random date in the iso (yyyy-mm-dd) format.
467 my $year = 1800 + int( rand(300) ); # 1800 - 2199
468 my $month = 1 + int( rand(12) ); # 1 - 12
469 my $day = 1 + int( rand(28) ); # 1 - 28
470 # stop at the 28th to keep us from generating February 31st and such.
472 return sprintf( '%04d-%02d-%02d', $year, $month, $day );
478 returns tomorrow's date as YYYY-MM-DD.
485 return $self->days_from_now( 1 );
491 returns yesterday's date as YYYY-MM-DD.
498 return $self->days_from_now( -1 );
504 returns an arbitrary date based on today in YYYY-MM-DD format.
510 my $days = shift or return;
512 my $seconds = time + $days * 60*60*24;
513 my $yyyymmdd = sprintf( '%04d-%02d-%02d',
514 localtime( $seconds )->year() + 1900,
515 localtime( $seconds )->mon() + 1,
516 localtime( $seconds )->mday() );
522 $self->add_biblios( count => 10,
526 count: number of biblios to add
527 add_items: should you add items for each one?
533 adds the biblionumbers to the $self->{'biblios'} listref
536 Should I allow you to pass in biblio information, like title?
537 Since this method is in the KohaTest class, all tests in it will be ignored, unless you call this from your own namespace.
538 This runs 10 tests, plus 4 for each "count", plus 3 more for each item added.
546 $param{'count'} = 1 unless defined( $param{'count'} );
547 $param{'add_items'} = 0 unless defined( $param{'add_items'} );
549 foreach my $counter ( 1..$param{'count'} ) {
550 my $marcrecord = MARC::Record->new();
551 isa_ok( $marcrecord, 'MARC::Record' );
552 my @marc_fields = ( MARC::Field->new( '100', '1', '0',
555 MARC::Field->new( '245', '1', '4',
556 a => sprintf( 'The Adventures of Huckleberry Finn Test %s', $counter ),
557 c => "Mark Twain ; illustrated by E.W. Kemble." ),
558 MARC::Field->new( '952', '0', '0',
559 p => '12345678' . $self->random_string() ), # barcode
560 MARC::Field->new( '952', '0', '0',
561 o => $self->random_string() ), # callnumber
562 MARC::Field->new( '952', '0', '0',
567 my $appendedfieldscount = $marcrecord->append_fields( @marc_fields );
569 diag $MARC::Record::ERROR if ( $MARC::Record::ERROR );
570 is( $appendedfieldscount, scalar @marc_fields, 'added correct number of MARC fields' );
572 my $frameworkcode = ''; # XXX I'd like to put something reasonable here.
573 my ( $biblionumber, $biblioitemnumber ) = AddBiblio( $marcrecord, $frameworkcode );
574 ok( $biblionumber, "the biblionumber is $biblionumber" );
575 ok( $biblioitemnumber, "the biblioitemnumber is $biblioitemnumber" );
576 if ( $param{'add_items'} ) {
577 # my @iteminfo = AddItem( {}, $biblionumber );
578 my @iteminfo = AddItemFromMarc( $marcrecord, $biblionumber );
579 is( $iteminfo[0], $biblionumber, "biblionumber is $biblionumber" );
580 is( $iteminfo[1], $biblioitemnumber, "biblioitemnumber is $biblioitemnumber" );
581 ok( $iteminfo[2], "itemnumber is $iteminfo[2]" );
582 push @{ $self->{'items'} },
583 { biblionumber => $iteminfo[0],
584 biblioitemnumber => $iteminfo[1],
585 itemnumber => $iteminfo[2],
588 push @{$self->{'biblios'}}, $biblionumber;
591 $self->reindex_marc();
592 my $query = 'Finn Test';
593 my ( $error, $results ) = SimpleSearch( $query );
594 if ( $param{'count'} <= scalar( @$results ) ) {
595 pass( "found all $param{'count'} titles" );
597 fail( "we never found all $param{'count'} titles" );
604 Do a fast reindexing of all of the bib and authority
605 records and mark all zebraqueue entries done.
607 Useful for test routines that need to do a
608 lot of indexing without having to wait for
611 In NoZebra model, this only marks zebraqueue
612 done - the records should already be indexed.
619 # mark zebraqueue done regardless of the indexing mode
620 my $dbh = C4::Context->dbh();
621 $dbh->do("UPDATE zebraqueue SET done = 1 WHERE done = 0");
623 return if C4::Context->preference('NoZebra');
625 my $directory = tempdir(CLEANUP => 1);
626 foreach my $record_type qw(biblio authority) {
627 mkdir "$directory/$record_type";
628 my $sth = $dbh->prepare($record_type eq "biblio" ? "SELECT marc FROM biblioitems" : "SELECT marc FROM auth_header");
630 open OUT, ">:utf8", "$directory/$record_type/records";
631 while (my ($blob) = $sth->fetchrow_array) {
635 my $zebra_server = "${record_type}server";
636 my $zebra_config = C4::Context->zebraconfig($zebra_server)->{'config'};
637 my $zebra_db_dir = C4::Context->zebraconfig($zebra_server)->{'directory'};
638 my $zebra_db = $record_type eq 'biblio' ? 'biblios' : 'authorities';
639 system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 init > /dev/null 2>\&1";
640 system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 update $directory/${record_type} > /dev/null 2>\&1";
641 system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 commit > /dev/null 2>\&1";
647 =head3 clear_test_database
649 removes all tables from test database so that install starts with a clean slate
653 sub clear_test_database {
655 diag "removing tables from test database";
657 my $dbh = C4::Context->dbh;
658 my $schema = C4::Context->config("database");
660 my @tables = get_all_tables($dbh, $schema);
661 foreach my $table (@tables) {
662 drop_all_foreign_keys($dbh, $table);
665 foreach my $table (@tables) {
666 drop_table($dbh, $table);
671 my ($dbh, $schema) = @_;
672 my $sth = $dbh->prepare("SELECT TABLE_NAME FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA = ?");
674 $sth->execute($schema);
675 while (my ($table) = $sth->fetchrow_array) {
676 push @tables, $table;
682 sub drop_all_foreign_keys {
683 my ($dbh, $table) = @_;
684 # get the table description
685 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
687 my $vsc_structure = $sth->fetchrow;
688 # split on CONSTRAINT keyword
689 my @fks = split /CONSTRAINT /,$vsc_structure;
692 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
693 $_ = /(.*) FOREIGN KEY.*/;
696 # we have found 1 foreign, drop it
697 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
699 diag "unable to DROP FOREIGN KEY '$id' on TABLE '$table' due to: " . $dbh->errstr();
707 my ($dbh, $table) = @_;
708 $dbh->do("DROP TABLE $table");
710 diag "unable to drop table: '$table' due to: " . $dbh->errstr();
714 =head3 create_test_database
716 sets up the test database.
720 sub create_test_database {
722 diag 'creating testing database...';
723 my $installer = C4::Installer->new() or die 'unable to create new installer';
724 # warn Data::Dumper->Dump( [ $installer ], [ 'installer' ] );
725 my $all_languages = getAllLanguages();
726 my $error = $installer->load_db_schema();
727 die "unable to load_db_schema: $error" if ( $error );
728 my $list = $installer->sql_file_list('en', 'marc21', { optional => 1,
730 my ($fwk_language, $installed_list) = $installer->load_sql_in_order($all_languages, @$list);
731 $installer->set_version_syspref();
732 $installer->set_marcflavour_syspref('MARC21');
733 $installer->set_indexing_engine(0);
734 diag 'database created.'
738 =head3 start_zebrasrv
740 This method deletes and reinitializes the zebra database directory,
741 and then spans off a zebra server.
748 diag 'cleaning zebrasrv...';
750 foreach my $zebra_server ( qw( biblioserver authorityserver ) ) {
751 my $zebra_config = C4::Context->zebraconfig($zebra_server)->{'config'};
752 my $zebra_db_dir = C4::Context->zebraconfig($zebra_server)->{'directory'};
753 foreach my $zebra_db_name ( qw( biblios authorities ) ) {
754 my $command = "zebraidx -c $zebra_config -d $zebra_db_name init";
755 my $return = system( $command . ' > /dev/null 2>&1' );
756 if ( $return != 0 ) {
757 diag( "command '$command' died with value: " . $? >> 8 );
760 $command = "zebraidx -c $zebra_config -d $zebra_db_name create $zebra_db_name";
762 $return = system( $command . ' > /dev/null 2>&1' );
763 if ( $return != 0 ) {
764 diag( "command '$command' died with value: " . $? >> 8 );
769 diag 'starting zebrasrv...';
771 my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
772 my $command = sprintf( 'zebrasrv -f %s -D -l %s -p %s',
774 File::Spec->catdir( C4::Context->config("logdir"), 'zebra.log' ),
778 my $output = qx( $command );
782 if ( -e $pidfile, 'pidfile exists' ) {
783 diag 'zebrasrv started.';
785 die 'unable to start zebrasrv';
792 using the PID file for the zebra server, send it a TERM signal with
793 "kill". We can't tell if the process actually dies or not.
799 my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
801 open( my $pidh, '<', $pidfile )
803 if ( defined $pidh ) {
804 my ( $pid ) = <$pidh> or return;
806 my $killed = kill 15, $pid; # 15 is TERM
807 if ( $killed != 1 ) {
808 warn "unable to kill zebrasrv with pid: $pid";
815 =head3 start_zebraqueue_daemon
817 kick off a zebraqueue_daemon.pl process.
821 sub start_zebraqueue_daemon {
823 my $command = q(run/bin/koha-zebraqueue-ctl.sh start);
825 my $started = system( $command );
826 diag "started: $started";
830 =head3 stop_zebraqueue_daemon
835 sub stop_zebraqueue_daemon {
837 my $command = q(run/bin/koha-zebraqueue-ctl.sh stop);
839 my $started = system( $command );
840 diag "started: $started";