641 lines
21 KiB
Perl
Executable File
641 lines
21 KiB
Perl
Executable File
#!/usr/bin/perl
|
||
|
||
# This file is part of Koha.
|
||
#
|
||
# Copyright 2014 - Biblibre SARL
|
||
#
|
||
# Koha is free software; you can redistribute it and/or modify it
|
||
# under the terms of the GNU General Public License as published by
|
||
# the Free Software Foundation; either version 3 of the License, or
|
||
# (at your option) any later version.
|
||
#
|
||
# Koha is distributed in the hope that it will be useful, but
|
||
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
# GNU General Public License for more details.
|
||
#
|
||
# You should have received a copy of the GNU General Public License
|
||
# along with Koha; if not, see <https://www.gnu.org/licenses>.
|
||
|
||
use Modern::Perl;
|
||
|
||
use utf8;
|
||
|
||
use Test::NoWarnings;
|
||
use Test::More tests => 16;
|
||
use Test::Warn;
|
||
use Try::Tiny;
|
||
use File::Basename qw(dirname);
|
||
|
||
use Koha::Database;
|
||
use Koha::Patrons;
|
||
|
||
BEGIN {
|
||
use_ok('t::lib::TestBuilder');
|
||
}
|
||
|
||
our $schema = Koha::Database->new->schema;
|
||
our $builder;
|
||
|
||
subtest 'Start with some trivial tests' => sub {
|
||
plan tests => 7;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
$builder = t::lib::TestBuilder->new;
|
||
isnt( $builder, undef, 'We got a builder' );
|
||
|
||
my $data;
|
||
warning_like { $data = $builder->build; } qr/.+/, 'Catch a warning';
|
||
is( $data, undef, 'build without arguments returns undef' );
|
||
is( ref( $builder->schema ), 'Koha::Schema', 'check schema' );
|
||
is( ref( $builder->can('delete') ), 'CODE', 'found delete method' );
|
||
|
||
# invalid argument
|
||
warning_like {
|
||
$builder->build(
|
||
{
|
||
source => 'Borrower',
|
||
value => { surname => { invalid_hash => 1 } },
|
||
}
|
||
)
|
||
}
|
||
qr/^Hash not allowed for surname/,
|
||
'Build should not accept a hash for this column';
|
||
|
||
# return undef if a record exists
|
||
my $branchcode = $builder->build( { source => 'Branch' } )->{branchcode};
|
||
my $param = { source => 'Branch', value => { branchcode => $branchcode } };
|
||
warning_like { $builder->build($param) }
|
||
qr/Violation of unique constraint/,
|
||
'Catch warn on adding existing record';
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Build all sources' => sub {
|
||
plan tests => 1;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
my @sources = $builder->schema->sources;
|
||
my @source_in_failure;
|
||
for my $source (@sources) {
|
||
my $res;
|
||
|
||
# Skip the source if it is a view
|
||
next if $schema->source($source)->isa('DBIx::Class::ResultSource::View');
|
||
eval { $res = $builder->build( { source => $source } ); };
|
||
push @source_in_failure, $source if $@ || !defined($res);
|
||
}
|
||
is(
|
||
@source_in_failure, 0,
|
||
'TestBuilder should be able to create an object for every source'
|
||
);
|
||
if (@source_in_failure) {
|
||
diag( "The following sources have not been generated correctly: " . join ', ', @source_in_failure );
|
||
}
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Test length of some generated fields' => sub {
|
||
plan tests => 3;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
# Test the length of a returned character field
|
||
my $bookseller = $builder->build( { source => 'Aqbookseller' } );
|
||
my $max = $schema->source('Aqbookseller')->column_info('phone')->{size};
|
||
is(
|
||
length( $bookseller->{phone} ) > 0, 1,
|
||
'The length for a generated string (phone) should not be zero'
|
||
);
|
||
is(
|
||
length( $bookseller->{phone} ) <= $max, 1,
|
||
'Check maximum length for a generated string (phone)'
|
||
);
|
||
|
||
my $item = $builder->build( { source => 'Item' } );
|
||
is(
|
||
$item->{replacementprice}, sprintf( "%.2f", $item->{replacementprice} ),
|
||
"The number of decimals for floats should not be more than 2"
|
||
);
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Tests with composite FK in userpermission' => sub {
|
||
plan tests => 9;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
my $my_user_permission = default_userpermission();
|
||
my $user_permission = $builder->build(
|
||
{
|
||
source => 'UserPermission',
|
||
value => $my_user_permission,
|
||
}
|
||
);
|
||
|
||
# Checks on top level of userpermission
|
||
isnt(
|
||
$user_permission->{borrowernumber},
|
||
undef,
|
||
'build generates a borrowernumber correctly'
|
||
);
|
||
is(
|
||
$user_permission->{code},
|
||
$my_user_permission->{code}->{code},
|
||
'build stores code correctly'
|
||
);
|
||
|
||
# Checks one level deeper userpermission -> borrower
|
||
my $patron = $schema->resultset('Borrower')->find( { borrowernumber => $user_permission->{borrowernumber} } );
|
||
is(
|
||
$patron->surname,
|
||
$my_user_permission->{borrowernumber}->{surname},
|
||
'build stores surname correctly'
|
||
);
|
||
isnt(
|
||
$patron->cardnumber,
|
||
undef,
|
||
'build generated cardnumber'
|
||
);
|
||
|
||
# Checks two levels deeper userpermission -> borrower -> branch
|
||
my $branch = $schema->resultset('Branch')->find( { branchcode => $patron->branchcode->branchcode } );
|
||
is(
|
||
$branch->branchname,
|
||
$my_user_permission->{borrowernumber}->{branchcode}->{branchname},
|
||
'build stores branchname correctly'
|
||
);
|
||
isnt(
|
||
$branch->branchaddress1,
|
||
undef,
|
||
'build generated branch address'
|
||
);
|
||
|
||
# Checks with composite FK: userpermission -> permission
|
||
my $perm = $schema->resultset('Permission')
|
||
->find( { module_bit => $user_permission->{module_bit}, code => $my_user_permission->{code}->{code} } );
|
||
isnt( $perm, undef, 'build generated record for composite FK' );
|
||
is(
|
||
$perm->code,
|
||
$my_user_permission->{code}->{code},
|
||
'build stored code correctly'
|
||
);
|
||
is(
|
||
$perm->description,
|
||
$my_user_permission->{code}->{description},
|
||
'build stored description correctly'
|
||
);
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
sub default_userpermission {
|
||
return {
|
||
borrowernumber => {
|
||
surname => 'my surname',
|
||
address => 'my adress',
|
||
city => 'my city',
|
||
branchcode => {
|
||
branchname => 'my branchname',
|
||
},
|
||
categorycode => {
|
||
hidelostitems => 0,
|
||
category_type => 'A',
|
||
default_privacy => 'default',
|
||
},
|
||
privacy => 1,
|
||
},
|
||
module_bit => {
|
||
module_bit => {
|
||
flag => 'my flag',
|
||
},
|
||
},
|
||
code => {
|
||
code => 'my code',
|
||
description => 'my desc',
|
||
},
|
||
};
|
||
}
|
||
|
||
subtest 'Test build with NULL values' => sub {
|
||
plan tests => 3;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
# PK should not be null
|
||
my $params = { source => 'Branch', value => { branchcode => undef } };
|
||
warning_like { $builder->build($params) }
|
||
qr/Null value for branchcode/,
|
||
'Catch warn on adding branch with a null branchcode';
|
||
|
||
# Nullable column
|
||
my $info = $schema->source('Item')->column_info('barcode');
|
||
$params = { source => 'Item', value => { barcode => undef } };
|
||
my $item = $builder->build($params);
|
||
is(
|
||
$info->{is_nullable} && $item && !defined( $item->{barcode} ), 1,
|
||
'Barcode can be NULL'
|
||
);
|
||
|
||
# Nullable FK
|
||
$params = { source => 'Reserve', value => { itemnumber => undef } };
|
||
my $reserve = $builder->build($params);
|
||
$info = $schema->source('Reserve')->column_info('itemnumber');
|
||
is(
|
||
$reserve && $info->{is_nullable} && $info->{is_foreign_key} && !defined( $reserve->{itemnumber} ), 1,
|
||
'Nullable FK'
|
||
);
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Tests for delete method' => sub {
|
||
plan tests => 11;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
# Test delete with single and multiple records
|
||
my $basket1 = $builder->build( { source => 'Aqbasket' } );
|
||
my $basket2 = $builder->build( { source => 'Aqbasket' } );
|
||
my $basket3 = $builder->build( { source => 'Aqbasket' } );
|
||
my ( $id1, $id2 ) = ( $basket1->{basketno}, $basket2->{basketno} );
|
||
$builder->delete( { source => 'Aqbasket', records => $basket1 } );
|
||
isnt( exists $basket1->{basketno}, 1, 'Delete cleared PK hash value' );
|
||
|
||
is(
|
||
$builder->schema->resultset('Aqbasket')->search( { basketno => $id1 } )->count, 0,
|
||
'Basket1 is no longer found'
|
||
);
|
||
is( $builder->schema->resultset('Aqbasket')->search( { basketno => $id2 } )->count, 1, 'Basket2 is still found' );
|
||
is(
|
||
$builder->delete( { source => 'Aqbasket', records => [ $basket2, $basket3 ] } ), 2,
|
||
"Returned two delete attempts"
|
||
);
|
||
is(
|
||
$builder->schema->resultset('Aqbasket')->search( { basketno => $id2 } )->count, 0,
|
||
'Basket2 is no longer found'
|
||
);
|
||
|
||
# Test delete in table without primary key (..)
|
||
is(
|
||
$schema->source('AccountCreditTypesBranch')->primary_columns, 0,
|
||
'Table without primary key detected'
|
||
);
|
||
my $cnt1 = $schema->resultset('AccountCreditTypesBranch')->count;
|
||
|
||
# Insert a new record in AccountCreditTypesBranch with that biblionumber
|
||
my $rec = $builder->build( { source => 'AccountCreditTypesBranch' } );
|
||
my $cnt2 = $schema->resultset('AccountCreditTypesBranch')->count;
|
||
is( defined($rec) && $cnt2 == $cnt1 + 1, 1, 'Created a record' );
|
||
is(
|
||
$builder->delete( { source => 'AccountCreditTypesBranch', records => $rec } ),
|
||
undef, 'delete returns undef'
|
||
);
|
||
is(
|
||
$schema->resultset('AccountCreditTypesBranch')->count, $cnt2,
|
||
"Method did not delete record in table without PK"
|
||
);
|
||
|
||
# Test delete with NULL values
|
||
my $val = { branchcode => undef };
|
||
is(
|
||
$builder->delete( { source => 'Branch', records => $val } ), 0,
|
||
'delete returns zero for an undef search with one key'
|
||
);
|
||
$val = {
|
||
module_bit => 1, #catalogue
|
||
code => undef
|
||
};
|
||
is(
|
||
$builder->delete( { source => 'Permission', records => $val } ), 0,
|
||
'delete returns zero for an undef search with a composite PK'
|
||
);
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Auto-increment values tests' => sub {
|
||
plan tests => 3;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
# Pick a table with AI PK
|
||
my $source = 'Biblio'; # table
|
||
my $column = 'biblionumber'; # ai column
|
||
|
||
my $col_info = $schema->source($source)->column_info($column);
|
||
is( $col_info->{is_auto_increment}, 1, "biblio.biblionumber is detected as autoincrement" );
|
||
|
||
# Create a biblio
|
||
my $biblio_1 = $builder->build( { source => $source } );
|
||
|
||
# Get the AI value
|
||
my $ai_value = $biblio_1->{biblionumber};
|
||
|
||
# Create a biblio
|
||
my $biblio_2 = $builder->build( { source => $source } );
|
||
|
||
# Get the next AI value
|
||
my $next_ai_value = $biblio_2->{biblionumber};
|
||
is( $ai_value + 1, $next_ai_value, "AI values are consecutive" );
|
||
|
||
# respect autoincr column
|
||
warning_like {
|
||
$builder->build(
|
||
{
|
||
source => $source,
|
||
value => { biblionumber => 123 },
|
||
}
|
||
)
|
||
}
|
||
qr/^Value not allowed for auto_incr/,
|
||
'Build should not overwrite an auto_incr column';
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Date handling' => sub {
|
||
plan tests => 2;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
$builder = t::lib::TestBuilder->new;
|
||
|
||
my $patron = $builder->build( { source => 'Borrower' } );
|
||
is( length( $patron->{updated_on} ), 19, 'A timestamp column value should be YYYY-MM-DD HH:MM:SS' );
|
||
is( length( $patron->{dateofbirth} ), 10, 'A date column value should be YYYY-MM-DD' );
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Default values' => sub {
|
||
plan tests => 3;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
$builder = t::lib::TestBuilder->new;
|
||
my $item = $builder->build( { source => 'Item' } );
|
||
is( $item->{more_subfields_xml}, undef, 'This xml field should be undef' );
|
||
$item = $builder->build( { source => 'Item', value => { more_subfields_xml => 'some xml' } } );
|
||
is( $item->{more_subfields_xml}, 'some xml', 'Default should not overwrite assigned value' );
|
||
|
||
subtest 'generated dynamically (coderef)' => sub {
|
||
plan tests => 2;
|
||
my $patron = $builder->build_object( { class => 'Koha::Patrons' } );
|
||
like( $patron->category->category_type, qr{^(A|C|S|I|P|)$}, );
|
||
|
||
my $patron_category_X =
|
||
$builder->build_object( { class => 'Koha::Patron::Categories', value => { category_type => 'X' } } );
|
||
$patron = $builder->build_object(
|
||
{ class => 'Koha::Patrons', value => { categorycode => $patron_category_X->categorycode } } );
|
||
is( $patron->category->category_type, 'X', );
|
||
};
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'build_object() tests' => sub {
|
||
|
||
plan tests => 5;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
$builder = t::lib::TestBuilder->new();
|
||
|
||
my $branchcode = $builder->build( { source => 'Branch' } )->{branchcode};
|
||
my $categorycode = $builder->build( { source => 'Category' } )->{categorycode};
|
||
my $itemtype = $builder->build( { source => 'Itemtype' } )->{itemtype};
|
||
|
||
my $issuing_rule = $builder->build_object(
|
||
{
|
||
class => 'Koha::CirculationRules',
|
||
value => {
|
||
branchcode => $branchcode,
|
||
categorycode => $categorycode,
|
||
itemtype => $itemtype
|
||
}
|
||
}
|
||
);
|
||
|
||
is( ref($issuing_rule), 'Koha::CirculationRule', 'Type is correct' );
|
||
is(
|
||
$issuing_rule->categorycode,
|
||
$categorycode, 'Category code correctly set'
|
||
);
|
||
is( $issuing_rule->itemtype, $itemtype, 'Item type correctly set' );
|
||
|
||
subtest 'Test all classes' => sub {
|
||
my $Koha_modules_dir = dirname(__FILE__) . '/../../Koha';
|
||
my @koha_object_based_modules = `/bin/grep -rl -e '^sub object_class' $Koha_modules_dir`;
|
||
my @source_in_failure;
|
||
for my $module_filepath (@koha_object_based_modules) {
|
||
chomp $module_filepath;
|
||
next unless $module_filepath =~ m|\.pm$|;
|
||
my $module = $module_filepath;
|
||
$module =~ s|^.*/(Koha.*)\.pm$|$1|;
|
||
$module =~ s|/|::|g;
|
||
next if $module eq 'Koha::Objects';
|
||
|
||
eval "require $module";
|
||
|
||
# Check if this is a polymorphic class
|
||
my $is_polymorphic = $module->can('_polymorphic_field') && $module->can('_polymorphic_map');
|
||
|
||
if ($is_polymorphic) {
|
||
|
||
# Test each concrete implementation
|
||
my $polymorphic_field = $module->_polymorphic_field();
|
||
my $polymorphic_map = $module->_polymorphic_map();
|
||
|
||
foreach my $type_value ( keys %$polymorphic_map ) {
|
||
my $expected_class = $polymorphic_map->{$type_value};
|
||
|
||
# Create an object of this type
|
||
my $object = $builder->build_object(
|
||
{
|
||
class => $module,
|
||
value => { $polymorphic_field => $type_value }
|
||
}
|
||
);
|
||
|
||
is(
|
||
ref($object), $expected_class,
|
||
"Testing polymorphic $module with $polymorphic_field=$type_value"
|
||
);
|
||
|
||
# Do the storage test
|
||
if ( !grep { $module eq $_ } qw(Koha::Old::Patrons Koha::Statistics) ) {
|
||
eval { $object->get_from_storage };
|
||
is(
|
||
$@, '',
|
||
"Module $module with $polymorphic_field=$type_value should have koha_object[s]_class method if needed"
|
||
);
|
||
}
|
||
|
||
# Test class loading
|
||
my $object_class = Koha::Object::_get_object_class( $object->_result->result_class );
|
||
eval "require $object_class";
|
||
is( $@, '', "Module $object_class should be defined" );
|
||
|
||
my $objects_class = Koha::Objects::_get_objects_class( $object->_result->result_class );
|
||
eval "require $objects_class";
|
||
is( $@, '', "Module $objects_class should be defined" );
|
||
}
|
||
} else {
|
||
|
||
# Regular class
|
||
my $object = $builder->build_object( { class => $module } );
|
||
is( ref($object), $module->object_class, "Testing $module" );
|
||
|
||
if ( !grep { $module eq $_ } qw( Koha::Old::Patrons Koha::Statistics ) )
|
||
{ # FIXME deletedborrowers and statistics do not have a PK
|
||
eval { $object->get_from_storage };
|
||
is( $@, '', "Module $module should have koha_object[s]_class method if needed" );
|
||
}
|
||
|
||
# Testing koha_object_class and koha_objects_class
|
||
my $object_class = Koha::Object::_get_object_class( $object->_result->result_class );
|
||
eval "require $object_class";
|
||
is( $@, '', "Module $object_class should be defined" );
|
||
my $objects_class = Koha::Objects::_get_objects_class( $object->_result->result_class );
|
||
eval "require $objects_class";
|
||
is( $@, '', "Module $objects_class should be defined" );
|
||
}
|
||
}
|
||
};
|
||
|
||
subtest 'test parameters' => sub {
|
||
plan tests => 3;
|
||
|
||
warning_is { $issuing_rule = $builder->build_object( {} ); }
|
||
{ carped => 'Missing class param' },
|
||
'The class parameter is mandatory, raises a warning if absent';
|
||
is(
|
||
$issuing_rule, undef,
|
||
'If the class parameter is missing, undef is returned'
|
||
);
|
||
|
||
warnings_like {
|
||
$builder->build_object( { class => 'Koha::Patrons', categorycode => 'foobar' } );
|
||
}
|
||
qr{Unknown parameter\(s\): categorycode}, "Unknown parameter detected";
|
||
};
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest '->build parameter' => sub {
|
||
plan tests => 4;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
# Test to make sure build() warns user of unknown parameters.
|
||
warnings_are {
|
||
$builder->build(
|
||
{
|
||
source => 'Branch',
|
||
value => { branchcode => 'BRANCH_1' }
|
||
}
|
||
)
|
||
}
|
||
[], "No warnings on correct use";
|
||
|
||
warnings_like {
|
||
$builder->build(
|
||
{
|
||
source => 'Branch',
|
||
branchcode => 'BRANCH_2' # This is wrong!
|
||
}
|
||
)
|
||
}
|
||
qr/unknown param/i, "Carp unknown parameters";
|
||
|
||
warnings_like {
|
||
$builder->build(
|
||
{
|
||
zource => 'Branch', # Intentional spelling error
|
||
}
|
||
)
|
||
}
|
||
qr/Source parameter not specified/, "Catch warning on missing source";
|
||
|
||
warnings_like {
|
||
$builder->build( { source => 'Borrower', categorycode => 'foobar' } );
|
||
}
|
||
qr{Unknown parameter\(s\): categorycode}, "Unknown parameter detected";
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'build_sample_biblio() tests' => sub {
|
||
|
||
plan tests => 1;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
warnings_are { $builder->build_sample_biblio( { title => 'hell❤️' } ); }
|
||
[],
|
||
"No encoding warnings!";
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Existence of object is only checked using primary keys' => sub {
|
||
|
||
plan tests => 1;
|
||
|
||
$schema->storage->txn_begin;
|
||
|
||
my $biblio = $builder->build_sample_biblio();
|
||
my $item1 = $builder->build_sample_item( { biblionumber => $biblio->biblionumber } );
|
||
my $item2 = $builder->build_sample_item( { biblionumber => $biblio->biblionumber } );
|
||
warnings_are {
|
||
$builder->build_object(
|
||
{
|
||
class => 'Koha::Holds',
|
||
value => { biblionumber => $biblio->biblionumber }
|
||
}
|
||
);
|
||
}
|
||
[], "No warning about query returning more than one row";
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|
||
|
||
subtest 'Test bad columns' => sub {
|
||
plan tests => 3;
|
||
$schema->storage->txn_begin;
|
||
|
||
try {
|
||
my $patron = $builder->build_object( { class => 'Koha::Patrons', value => { wrong => 1 } } );
|
||
ok( 0, 'Unexpected pass with wrong column' );
|
||
} catch {
|
||
like( $_, qr/^Error: value hash contains unrecognized columns: wrong/, 'Column wrong is bad' );
|
||
};
|
||
try {
|
||
my $patron = $builder->build_object(
|
||
{ class => 'Koha::Patrons', value => { surname => 'Pass', nested => { ignored => 1 } } } );
|
||
ok( 1, 'Nested hash ignored' );
|
||
} catch {
|
||
ok( 0, 'Unexpected trouble with nested hash' );
|
||
};
|
||
try {
|
||
my $patron = $builder->build_object(
|
||
{
|
||
class => 'Koha::Patrons',
|
||
value => { surname => 'WontPass', categorycode => { description => 'bla', wrong_nested => 1 } },
|
||
}
|
||
);
|
||
ok( 0, 'Unexpected pass with wrong nested column' );
|
||
} catch {
|
||
like( $_, qr/^Error: value hash contains unrecognized columns: wrong_nested/, 'Column wrong_nested is bad' );
|
||
};
|
||
|
||
$schema->storage->txn_rollback;
|
||
};
|