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 /;
25 # Since this is an abstract base class, this prevents these tests from
26 # being run directly unless we're testing a subclass. It just makes
28 __PACKAGE__->SKIP_CLASS( 1 );
31 if ($ENV{SINGLE_TEST}) {
32 # if we're running the tests in one
33 # or more test files specified via
35 # make single-test TEST_FILES=lib/KohaTest/Foo.pm
37 # use this INIT trick taken from the POD for
40 Test::Class->runtests;
45 use Attribute::Handlers;
47 =head2 Expensive test method attribute
49 If a test method is decorated with an Expensive
50 attribute, it is skipped unless the RUN_EXPENSIVE_TESTS
51 environment variable is defined.
53 To declare an entire test class and its subclasses expensive,
54 define a SKIP_CLASS with the Expensive attribute:
56 sub SKIP_CLASS : Expensive { }
60 sub Expensive : ATTR(CODE) {
61 my ($package, $symbol, $sub, $attr, $data, $phase) = @_;
62 my $name = *{$symbol}{NAME};
63 if ($name eq 'SKIP_CLASS') {
64 if ($ENV{'RUN_EXPENSIVE_TESTS'}) {
65 *{$symbol} = sub { 0; }
67 *{$symbol} = sub { "Skipping expensive test classes $package (and subclasses)"; }
70 unless ($ENV{'RUN_EXPENSIVE_TESTS'}) {
71 # a test method that runs no tests and just returns a scalar is viewed by Test::Class as a skip
72 *{$symbol} = sub { "Skipping expensive test $package\:\:$name"; }
77 =head2 startup methods
79 these are run once, at the beginning of the whole test suite
83 sub startup_15_truncate_tables : Test( startup => 1 ) {
86 # my @truncate_tables = qw( accountlines
98 # auth_subfield_structure
124 # import_record_matches
134 # language_descriptions
135 # language_rfc4646_to_iso639
136 # language_script_bidi
137 # language_script_mapping
138 # language_subtag_registry
141 # marc_subfield_structure
144 # matcher_matchpoints
145 # matchpoint_component_norms
146 # matchpoint_components
158 # repeatable_holidays
174 # subscriptionhistory
175 # subscriptionroutinglist
180 # virtualshelfcontents
186 my @truncate_tables = qw( accountlines
233 subscriptionroutinglist
239 my $failed_to_truncate = 0;
240 foreach my $table ( @truncate_tables ) {
241 my $dbh = C4::Context->dbh();
242 $dbh->do( "truncate $table" )
243 or $failed_to_truncate = 1;
245 is( $failed_to_truncate, 0, 'truncated tables' );
248 =head2 startup_20_add_bookseller
250 we need a bookseller for many of the tests, so let's insert one. Feel
251 free to use this one, or insert your own.
255 sub startup_20_add_bookseller : Test(startup => 1) {
258 my $booksellerinfo = { name => 'bookseller ' . $self->random_string(),
261 my $id = AddBookseller( $booksellerinfo );
262 ok( $id, "created bookseller: $id" );
263 $self->{'booksellerid'} = $id;
268 =head2 startup_22_add_bookfund
270 we need a bookfund for many of the tests. This currently uses one that
271 is in the skeleton database. free to use this one, or insert your
276 sub startup_22_add_bookfund : Test(startup => 2) {
279 my $bookfundid = 'GEN';
280 my $bookfund = GetBookFund( $bookfundid, undef );
281 # diag( Data::Dumper->Dump( [ $bookfund ], qw( bookfund ) ) );
282 is( $bookfund->{'bookfundid'}, $bookfundid, "found bookfund: '$bookfundid'" );
283 is( $bookfund->{'bookfundname'}, 'General Stacks', "found bookfund: '$bookfundid'" );
285 $self->{'bookfundid'} = $bookfundid;
289 =head2 startup_24_add_branch
293 sub startup_24_add_branch : Test(startup => 1) {
298 branchcode => $self->random_string(3),
299 branchname => $self->random_string(),
300 branchaddress1 => $self->random_string(),
301 branchaddress2 => $self->random_string(),
302 branchaddress3 => $self->random_string(),
303 branchphone => $self->random_phone(),
304 branchfax => $self->random_phone(),
305 brancemail => $self->random_email(),
306 branchip => $self->random_ip(),
307 branchprinter => $self->random_string(),
309 C4::Branch::ModBranch($branch_info);
310 $self->{'branchcode'} = $branch_info->{'branchcode'};
311 ok( $self->{'branchcode'}, "created branch: $self->{'branchcode'}" );
315 =head2 startup_24_add_member
317 Add a patron/member for the tests to use
321 sub startup_24_add_member : Test(startup => 1) {
324 my $memberinfo = { surname => 'surname ' . $self->random_string(),
325 firstname => 'firstname' . $self->random_string(),
326 address => 'address' . $self->random_string(),
327 city => 'city' . $self->random_string(),
328 cardnumber => 'card' . $self->random_string(),
329 branchcode => 'CPL', # CPL => Centerville
330 categorycode => 'PT', # PT => PaTron
331 dateexpiry => '2010-01-01',
332 password => 'testpassword',
333 dateofbirth => $self->random_date(),
336 my $borrowernumber = AddMember( %$memberinfo );
337 ok( $borrowernumber, "created member: $borrowernumber" );
338 $self->{'memberid'} = $borrowernumber;
343 =head2 startup_30_login
347 sub startup_30_login : Test( startup => 2 ) {
350 $self->{'sessionid'} = '12345678'; # does this value matter?
351 my $borrower_details = C4::Members::GetMemberDetails( $self->{'memberid'} );
352 ok( $borrower_details->{'cardnumber'}, 'cardnumber' );
354 # make a cookie and force it into $cgi.
355 # This would be a lot easier with Test::MockObject::Extends.
356 my $cgi = CGI->new( { userid => $borrower_details->{'cardnumber'},
357 password => 'testpassword' } );
358 my $setcookie = $cgi->cookie( -name => 'CGISESSID',
359 -value => $self->{'sessionid'} );
360 $cgi->{'.cookies'} = { CGISESSID => $setcookie };
361 is( $cgi->cookie('CGISESSID'), $self->{'sessionid'}, 'the CGISESSID cookie is set' );
362 # diag( Data::Dumper->Dump( [ $cgi->cookie('CGISESSID') ], [ qw( cookie ) ] ) );
364 # C4::Auth::checkauth sometimes emits a warning about unable to append to sessionlog. That's OK.
365 my ( $userid, $cookie, $sessionID ) = C4::Auth::checkauth( $cgi, 'noauth', {}, 'intranet' );
366 # diag( Data::Dumper->Dump( [ $userid, $cookie, $sessionID ], [ qw( userid cookie sessionID ) ] ) );
368 # my $session = C4::Auth::get_session( $sessionID );
369 # diag( Data::Dumper->Dump( [ $session ], [ qw( session ) ] ) );
376 setup methods are run before every test method
380 =head2 teardown methods
382 teardown methods are many time, once at the end of each test method.
386 =head2 shutdown methods
388 shutdown methods are run once, at the end of the test suite
392 =head2 utility methods
394 These are not test methods, but they're handy
400 Nice for generating names and such. It's not actually random, more
408 my $wordsize = shift || 6; # how many letters in your string?
410 # leave out these characters: "oOlL10". They're too confusing.
411 my @alphabet = ( 'a'..'k','m','n','p'..'z', 'A'..'K','M','N','P'..'Z', 2..9 );
414 foreach ( 0..$wordsize ) {
415 $randomstring .= $alphabet[ rand( scalar( @alphabet ) ) ];
417 return $randomstring;
423 generates a random phone number. Currently, it's not actually random. It's an unusable US phone number
430 return '212-555-5555';
436 generates a random email address. They're all in the unusable
437 'example.com' domain that is designed for this purpose.
444 return $self->random_string() . '@example.com';
450 returns an IP address suitable for testing purposes.
463 returns a somewhat random date in the iso (yyyy-mm-dd) format.
470 my $year = 1800 + int( rand(300) ); # 1800 - 2199
471 my $month = 1 + int( rand(12) ); # 1 - 12
472 my $day = 1 + int( rand(28) ); # 1 - 28
473 # stop at the 28th to keep us from generating February 31st and such.
475 return sprintf( '%04d-%02d-%02d', $year, $month, $day );
481 returns tomorrow's date as YYYY-MM-DD.
488 return $self->days_from_now( 1 );
494 returns yesterday's date as YYYY-MM-DD.
501 return $self->days_from_now( -1 );
507 returns an arbitrary date based on today in YYYY-MM-DD format.
513 my $days = shift or return;
515 my $seconds = time + $days * 60*60*24;
516 my $yyyymmdd = sprintf( '%04d-%02d-%02d',
517 localtime( $seconds )->year() + 1900,
518 localtime( $seconds )->mon() + 1,
519 localtime( $seconds )->mday() );
525 $self->add_biblios( count => 10,
529 count: number of biblios to add
530 add_items: should you add items for each one?
536 adds the biblionumbers to the $self->{'biblios'} listref
539 Should I allow you to pass in biblio information, like title?
540 Since this method is in the KohaTest class, all tests in it will be ignored, unless you call this from your own namespace.
541 This runs 10 tests, plus 4 for each "count", plus 3 more for each item added.
549 $param{'count'} = 1 unless defined( $param{'count'} );
550 $param{'add_items'} = 0 unless defined( $param{'add_items'} );
552 foreach my $counter ( 1..$param{'count'} ) {
553 my $marcrecord = MARC::Record->new();
554 isa_ok( $marcrecord, 'MARC::Record' );
555 my @marc_fields = ( MARC::Field->new( '100', '1', '0',
558 MARC::Field->new( '245', '1', '4',
559 a => sprintf( 'The Adventures of Huckleberry Finn Test %s', $counter ),
560 c => "Mark Twain ; illustrated by E.W. Kemble." ),
561 MARC::Field->new( '952', '0', '0',
562 p => '12345678' . $self->random_string() ), # barcode
563 MARC::Field->new( '952', '0', '0',
564 o => $self->random_string() ), # callnumber
565 MARC::Field->new( '952', '0', '0',
570 my $appendedfieldscount = $marcrecord->append_fields( @marc_fields );
572 diag $MARC::Record::ERROR if ( $MARC::Record::ERROR );
573 is( $appendedfieldscount, scalar @marc_fields, 'added correct number of MARC fields' );
575 my $frameworkcode = ''; # XXX I'd like to put something reasonable here.
576 my ( $biblionumber, $biblioitemnumber ) = AddBiblio( $marcrecord, $frameworkcode );
577 ok( $biblionumber, "the biblionumber is $biblionumber" );
578 ok( $biblioitemnumber, "the biblioitemnumber is $biblioitemnumber" );
579 if ( $param{'add_items'} ) {
580 # my @iteminfo = AddItem( {}, $biblionumber );
581 my @iteminfo = AddItemFromMarc( $marcrecord, $biblionumber );
582 is( $iteminfo[0], $biblionumber, "biblionumber is $biblionumber" );
583 is( $iteminfo[1], $biblioitemnumber, "biblioitemnumber is $biblioitemnumber" );
584 ok( $iteminfo[2], "itemnumber is $iteminfo[2]" );
585 push @{ $self->{'items'} },
586 { biblionumber => $iteminfo[0],
587 biblioitemnumber => $iteminfo[1],
588 itemnumber => $iteminfo[2],
591 push @{$self->{'biblios'}}, $biblionumber;
594 $self->reindex_marc();
595 my $query = 'Finn Test';
596 my ( $error, $results ) = SimpleSearch( $query );
597 if ( $param{'count'} <= scalar( @$results ) ) {
598 pass( "found all $param{'count'} titles" );
600 fail( "we never found all $param{'count'} titles" );
607 Do a fast reindexing of all of the bib and authority
608 records and mark all zebraqueue entries done.
610 Useful for test routines that need to do a
611 lot of indexing without having to wait for
614 In NoZebra model, this only marks zebraqueue
615 done - the records should already be indexed.
622 # mark zebraqueue done regardless of the indexing mode
623 my $dbh = C4::Context->dbh();
624 $dbh->do("UPDATE zebraqueue SET done = 1 WHERE done = 0");
626 return if C4::Context->preference('NoZebra');
628 my $directory = tempdir(CLEANUP => 1);
629 foreach my $record_type qw(biblio authority) {
630 mkdir "$directory/$record_type";
631 my $sth = $dbh->prepare($record_type eq "biblio" ? "SELECT marc FROM biblioitems" : "SELECT marc FROM auth_header");
633 open OUT, ">:utf8", "$directory/$record_type/records";
634 while (my ($blob) = $sth->fetchrow_array) {
638 my $zebra_server = "${record_type}server";
639 my $zebra_config = C4::Context->zebraconfig($zebra_server)->{'config'};
640 my $zebra_db_dir = C4::Context->zebraconfig($zebra_server)->{'directory'};
641 my $zebra_db = $record_type eq 'biblio' ? 'biblios' : 'authorities';
642 system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 init > /dev/null 2>\&1";
643 system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 update $directory/${record_type} > /dev/null 2>\&1";
644 system "zebraidx -c $zebra_config -d $zebra_db -g iso2709 commit > /dev/null 2>\&1";
650 =head3 clear_test_database
652 removes all tables from test database so that install starts with a clean slate
656 sub clear_test_database {
658 diag "removing tables from test database";
660 my $dbh = C4::Context->dbh;
661 my $schema = C4::Context->config("database");
663 my @tables = get_all_tables($dbh, $schema);
664 foreach my $table (@tables) {
665 drop_all_foreign_keys($dbh, $table);
668 foreach my $table (@tables) {
669 drop_table($dbh, $table);
674 my ($dbh, $schema) = @_;
675 my $sth = $dbh->prepare("SELECT TABLE_NAME FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA = ?");
677 $sth->execute($schema);
678 while (my ($table) = $sth->fetchrow_array) {
679 push @tables, $table;
685 sub drop_all_foreign_keys {
686 my ($dbh, $table) = @_;
687 # get the table description
688 my $sth = $dbh->prepare("SHOW CREATE TABLE $table");
690 my $vsc_structure = $sth->fetchrow;
691 # split on CONSTRAINT keyword
692 my @fks = split /CONSTRAINT /,$vsc_structure;
695 # isolate what is before FOREIGN KEY, if there is something, it's a foreign key to drop
696 $_ = /(.*) FOREIGN KEY.*/;
699 # we have found 1 foreign, drop it
700 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $id");
707 my ($dbh, $table) = @_;
708 $dbh->do("DROP TABLE $table");
711 =head3 create_test_database
713 sets up the test database.
717 sub create_test_database {
719 diag 'creating testing database...';
720 my $installer = C4::Installer->new() or die 'unable to create new installer';
721 # warn Data::Dumper->Dump( [ $installer ], [ 'installer' ] );
722 my $all_languages = getAllLanguages();
723 my $error = $installer->load_db_schema();
724 die "unable to load_db_schema: $error" if ( $error );
725 my $list = $installer->sql_file_list('en', 'marc21', { optional => 1,
727 my ($fwk_language, $installed_list) = $installer->load_sql_in_order($all_languages, @$list);
728 $installer->set_version_syspref();
729 $installer->set_marcflavour_syspref('MARC21');
730 $installer->set_indexing_engine(0);
731 diag 'database created.'
735 =head3 start_zebrasrv
737 This method deletes and reinitializes the zebra database directory,
738 and then spans off a zebra server.
745 diag 'cleaning zebrasrv...';
747 foreach my $zebra_server ( qw( biblioserver authorityserver ) ) {
748 my $zebra_config = C4::Context->zebraconfig($zebra_server)->{'config'};
749 my $zebra_db_dir = C4::Context->zebraconfig($zebra_server)->{'directory'};
750 foreach my $zebra_db_name ( qw( biblios authorities ) ) {
751 my $command = "zebraidx -c $zebra_config -d $zebra_db_name init";
752 my $return = system( $command . ' > /dev/null 2>&1' );
753 if ( $return != 0 ) {
754 diag( "command '$command' died with value: " . $? >> 8 );
757 $command = "zebraidx -c $zebra_config -d $zebra_db_name create $zebra_db_name";
759 $return = system( $command . ' > /dev/null 2>&1' );
760 if ( $return != 0 ) {
761 diag( "command '$command' died with value: " . $? >> 8 );
766 diag 'starting zebrasrv...';
768 my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
769 my $command = sprintf( 'zebrasrv -f %s -D -l %s -p %s',
771 File::Spec->catdir( C4::Context->config("logdir"), 'zebra.log' ),
775 my $output = qx( $command );
779 if ( -e $pidfile, 'pidfile exists' ) {
780 diag 'zebrasrv started.';
782 die 'unable to start zebrasrv';
789 using the PID file for the zebra server, send it a TERM signal with
790 "kill". We can't tell if the process actually dies or not.
796 my $pidfile = File::Spec->catdir( C4::Context->config("logdir"), 'zebra.pid' );
798 open( my $pidh, '<', $pidfile )
800 if ( defined $pidh ) {
801 my ( $pid ) = <$pidh> or return;
803 my $killed = kill 15, $pid; # 15 is TERM
804 if ( $killed != 1 ) {
805 warn "unable to kill zebrasrv with pid: $pid";
812 =head3 start_zebraqueue_daemon
814 kick off a zebraqueue_daemon.pl process.
818 sub start_zebraqueue_daemon {
820 my $command = q(run/bin/koha-zebraqueue-ctl.sh start);
822 my $started = system( $command );
823 diag "started: $started";
827 =head3 stop_zebraqueue_daemon
832 sub stop_zebraqueue_daemon {
834 my $command = q(run/bin/koha-zebraqueue-ctl.sh stop);
836 my $started = system( $command );
837 diag "started: $started";