3 # This file is part of Koha.
5 # Copyright 2014 - Biblibre SARL
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
22 use Test
::More tests
=> 13;
24 use File
::Basename
qw(dirname);
30 use_ok
('t::lib::TestBuilder');
33 our $schema = Koha
::Database
->new->schema;
34 $schema->storage->txn_begin;
38 subtest
'Start with some trivial tests' => sub {
41 $builder = t
::lib
::TestBuilder
->new;
42 isnt
( $builder, undef, 'We got a builder' );
45 warning_like
{ $data = $builder->build; } qr/.+/, 'Catch a warning';
46 is
( $data, undef, 'build without arguments returns undef' );
47 is
( ref( $builder->schema ), 'Koha::Schema', 'check schema' );
48 is
( ref( $builder->can('delete') ), 'CODE', 'found delete method' );
51 warning_like
{ $builder->build({
53 value
=> { surname
=> { invalid_hash
=> 1 } },
54 }) } qr/^Hash not allowed for surname/,
55 'Build should not accept a hash for this column';
57 # return undef if a record exists
58 my $branchcode = $builder->build({ source
=> 'Branch' })->{branchcode
};
59 my $param = { source
=> 'Branch', value
=> { branchcode
=> $branchcode } };
60 warning_like
{ $builder->build( $param ) }
61 qr/Violation of unique constraint/,
62 'Catch warn on adding existing record';
66 subtest
'Build all sources' => sub {
69 my @sources = $builder->schema->sources;
70 my @source_in_failure;
71 for my $source ( @sources ) {
73 # Skip the source if it is a view
74 next if $schema->source($source)->isa('DBIx::Class::ResultSource::View');
75 eval { $res = $builder->build( { source
=> $source } ); };
76 push @source_in_failure, $source if $@
|| !defined( $res );
78 is
( @source_in_failure, 0,
79 'TestBuilder should be able to create an object for every source' );
80 if ( @source_in_failure ) {
81 diag
( "The following sources have not been generated correctly: " .
82 join ', ', @source_in_failure );
87 subtest
'Test length of some generated fields' => sub {
90 # Test the length of a returned character field
91 my $bookseller = $builder->build({ source
=> 'Aqbookseller' });
92 my $max = $schema->source('Aqbookseller')->column_info('phone')->{size
};
93 is
( length( $bookseller->{phone
} ) > 0, 1,
94 'The length for a generated string (phone) should not be zero' );
95 is
( length( $bookseller->{phone
} ) <= $max, 1,
96 'Check maximum length for a generated string (phone)' );
100 subtest
'Test FKs in overduerules_transport_type' => sub {
103 my $my_overduerules_transport_type = {
104 message_transport_type
=> {
105 message_transport_type
=> 'my msg_t_t',
108 branchcode
=> 'codeB',
109 categorycode
=> 'codeC',
113 my $overduerules_transport_type = $builder->build({
114 source
=> 'OverduerulesTransportType',
115 value
=> $my_overduerules_transport_type,
118 $overduerules_transport_type->{message_transport_type
},
119 $my_overduerules_transport_type->{message_transport_type
}->{message_transport_type
},
120 'build stores the message_transport_type correctly'
123 $schema->resultset('Overduerule')->find( $overduerules_transport_type->{overduerules_id
} )->branchcode,
124 $my_overduerules_transport_type->{overduerules_id
}->{branchcode
},
125 'build stores the branchcode correctly'
128 $schema->resultset('Overduerule')->find( $overduerules_transport_type->{overduerules_id
} )->categorycode,
129 $my_overduerules_transport_type->{overduerules_id
}->{categorycode
},
130 'build stores the categorycode correctly'
133 $schema->resultset('MessageTransportType')->find( $overduerules_transport_type->{message_transport_type
} )->message_transport_type,
134 $overduerules_transport_type->{message_transport_type
},
135 'build stores the foreign key message_transport_type correctly'
138 $schema->resultset('Overduerule')->find( $my_overduerules_transport_type->{overduerules_id
} )->letter2,
140 'build generates values if they are not given'
145 subtest
'Tests with composite FK in userpermission' => sub {
148 my $my_user_permission = default_userpermission
();
149 my $user_permission = $builder->build({
150 source
=> 'UserPermission',
151 value
=> $my_user_permission,
154 # Checks on top level of userpermission
156 $user_permission->{borrowernumber
},
158 'build generates a borrowernumber correctly'
161 $user_permission->{code
},
162 $my_user_permission->{code
}->{code
},
163 'build stores code correctly'
166 # Checks one level deeper userpermission -> borrower
167 my $patron = $schema->resultset('Borrower')->find({ borrowernumber
=> $user_permission->{borrowernumber
} });
170 $my_user_permission->{borrowernumber
}->{surname
},
171 'build stores surname correctly'
176 'build generated cardnumber'
179 # Checks two levels deeper userpermission -> borrower -> branch
180 my $branch = $schema->resultset('Branch')->find({ branchcode
=> $patron->branchcode->branchcode });
183 $my_user_permission->{borrowernumber
}->{branchcode
}->{branchname
},
184 'build stores branchname correctly'
187 $branch->branchaddress1,
189 'build generated branch address'
192 # Checks with composite FK: userpermission -> permission
193 my $perm = $schema->resultset('Permission')->find({ module_bit
=> $user_permission->{module_bit
}, code
=> $my_user_permission->{code
}->{code
} });
194 isnt
( $perm, undef, 'build generated record for composite FK' );
197 $my_user_permission->{code
}->{code
},
198 'build stored code correctly'
202 $my_user_permission->{code
}->{description
},
203 'build stored description correctly'
207 sub default_userpermission
{
210 surname
=> 'my surname',
211 address
=> 'my adress',
214 branchname
=> 'my branchname',
218 category_type
=> 'A',
219 default_privacy
=> 'default',
228 description
=> 'my desc',
234 subtest
'Test build with NULL values' => sub {
237 # PK should not be null
238 my $params = { source
=> 'Branch', value
=> { branchcode
=> undef }};
239 warning_like
{ $builder->build( $params ) }
240 qr/Null value for branchcode/,
241 'Catch warn on adding branch with a null branchcode';
243 my $info = $schema->source( 'Item' )->column_info( 'barcode' );
244 $params = { source
=> 'Item', value
=> { barcode
=> undef }};
245 my $item = $builder->build( $params );
246 is
( $info->{is_nullable
} && $item && !defined( $item->{barcode
} ), 1,
247 'Barcode can be NULL' );
249 $params = { source
=> 'Reserve', value
=> { itemnumber
=> undef }};
250 my $reserve = $builder->build( $params );
251 $info = $schema->source( 'Reserve' )->column_info( 'itemnumber' );
252 is
( $reserve && $info->{is_nullable
} && $info->{is_foreign_key
} &&
253 !defined( $reserve->{itemnumber
} ), 1, 'Nullable FK' );
257 subtest
'Tests for delete method' => sub {
260 # Test delete with single and multiple records
261 my $basket1 = $builder->build({ source
=> 'Aqbasket' });
262 my $basket2 = $builder->build({ source
=> 'Aqbasket' });
263 my $basket3 = $builder->build({ source
=> 'Aqbasket' });
264 my ( $id1, $id2 ) = ( $basket1->{basketno
}, $basket2->{basketno
} );
265 $builder->delete({ source
=> 'Aqbasket', records
=> $basket1 });
266 isnt
( exists $basket1->{basketno
}, 1, 'Delete cleared PK hash value' );
268 is
( $builder->schema->resultset('Aqbasket')->search({ basketno
=> $id1 })->count, 0, 'Basket1 is no longer found' );
269 is
( $builder->schema->resultset('Aqbasket')->search({ basketno
=> $id2 })->count, 1, 'Basket2 is still found' );
270 is
( $builder->delete({ source
=> 'Aqbasket', records
=> [ $basket2, $basket3 ] }), 2, "Returned two delete attempts" );
271 is
( $builder->schema->resultset('Aqbasket')->search({ basketno
=> $id2 })->count, 0, 'Basket2 is no longer found' );
274 # Test delete in table without primary key (..)
275 is
( $schema->source('TmpHoldsqueue')->primary_columns, 0,
276 'Table without primary key detected' );
277 my $bibno = 123; # just a number
278 my $cnt1 = $schema->resultset('TmpHoldsqueue')->count;
279 # Insert a new record in TmpHoldsqueue with that biblionumber
280 my $val = { biblionumber
=> $bibno };
281 my $rec = $builder->build({ source
=> 'TmpHoldsqueue', value
=> $val });
282 my $cnt2 = $schema->resultset('TmpHoldsqueue')->count;
283 is
( defined($rec) && $cnt2 == $cnt1 + 1 , 1, 'Created a record' );
284 is
( $builder->delete({ source
=> 'TmpHoldsqueue', records
=> $rec }),
285 undef, 'delete returns undef' );
286 is
( $rec->{biblionumber
}, $bibno, 'Hash value untouched' );
287 is
( $schema->resultset('TmpHoldsqueue')->count, $cnt2,
288 "Method did not delete record in table without PK" );
290 # Test delete with NULL values
291 $val = { branchcode
=> undef };
292 is
( $builder->delete({ source
=> 'Branch', records
=> $val }), 0,
293 'delete returns zero for an undef search with one key' );
294 $val = { module_bit
=> 1, #catalogue
296 is
( $builder->delete({ source
=> 'Permission', records
=> $val }), 0,
297 'delete returns zero for an undef search with a composite PK' );
301 subtest
'Auto-increment values tests' => sub {
304 # Pick a table with AI PK
305 my $source = 'Biblio'; # table
306 my $column = 'biblionumber'; # ai column
308 my $col_info = $schema->source( $source )->column_info( $column );
309 is
( $col_info->{is_auto_increment
}, 1, "biblio.biblionumber is detected as autoincrement");
312 my $biblio_1 = $builder->build({ source
=> $source });
314 my $ai_value = $biblio_1->{ biblionumber
};
316 my $biblio_2 = $builder->build({ source
=> $source });
317 # Get the next AI value
318 my $next_ai_value = $biblio_2->{ biblionumber
};
319 is
( $ai_value + 1, $next_ai_value, "AI values are consecutive");
321 # respect autoincr column
322 warning_like
{ $builder->build({
324 value
=> { biblionumber
=> 123 },
325 }) } qr/^Value not allowed for auto_incr/,
326 'Build should not overwrite an auto_incr column';
329 subtest
'Date handling' => sub {
332 $builder = t
::lib
::TestBuilder
->new;
334 my $patron = $builder->build( { source
=> 'Borrower' } );
335 is
( length( $patron->{updated_on
} ), 19, 'A timestamp column value should be YYYY-MM-DD HH:MM:SS' );
336 is
( length( $patron->{dateofbirth
} ), 10, 'A date column value should be YYYY-MM-DD' );
339 subtest
'Default values' => sub {
341 $builder = t
::lib
::TestBuilder
->new;
342 my $item = $builder->build( { source
=> 'Item' } );
343 is
( $item->{more_subfields_xml
}, undef, 'This xml field should be undef' );
344 $item = $builder->build( { source
=> 'Item', value
=> { more_subfields_xml
=> 'some xml' } } );
345 is
( $item->{more_subfields_xml
}, 'some xml', 'Default should not overwrite assigned value' );
348 subtest
'build_object() tests' => sub {
352 $builder = t
::lib
::TestBuilder
->new();
354 my $categorycode = $builder->build( { source
=> 'Category' } )->{categorycode
};
355 my $itemtype = $builder->build( { source
=> 'Itemtype' } )->{itemtype
};
357 my $issuing_rule = $builder->build_object(
358 { class => 'Koha::IssuingRules',
360 categorycode
=> $categorycode,
361 itemtype
=> $itemtype
366 is
( ref($issuing_rule), 'Koha::IssuingRule', 'Type is correct' );
367 is
( $issuing_rule->categorycode,
368 $categorycode, 'Category code correctly set' );
369 is
( $issuing_rule->itemtype, $itemtype, 'Item type correctly set' );
371 warning_is
{ $issuing_rule = $builder->build_object( {} ); }
372 { carped
=> 'Missing class param' },
373 'The class parameter is mandatory, raises a warning if absent';
374 is
( $issuing_rule, undef,
375 'If the class parameter is missing, undef is returned' );
377 subtest
'Test all classes' => sub {
378 my $Koha_modules_dir = dirname
(__FILE__
) . '/../../Koha';
379 my @koha_object_based_modules = `/bin/grep -rl 'sub object_class' $Koha_modules_dir`;
380 my @source_in_failure;
381 for my $module_filepath ( @koha_object_based_modules ) {
382 chomp $module_filepath;
383 next unless $module_filepath =~ m
|\
.pm
$|;
384 my $module = $module_filepath;
385 $module =~ s
|^.*/(Koha
.*)\
.pm
$|$1|;
387 next if $module eq 'Koha::Objects';
388 eval "require $module";;
389 my $object = $builder->build_object( { class => $module } );
390 is
( ref($object), $module->object_class, "Testing $module" );
395 subtest
'->build parameter' => sub {
398 # Test to make sure build() warns user of unknown parameters.
403 branchcode
=> 'BRANCH_1'
406 } [], "No warnings on correct use";
411 branchcode
=> 'BRANCH_2' # This is wrong!
413 } qr/unknown param/i, "Carp unknown parameters";
417 zource
=> 'Branch', # Intentional spelling error
419 } qr/Source parameter not specified/, "Catch warning on missing source";
422 $schema->storage->txn_rollback;