1 package t::lib::TestBuilder;
5 use Koha::Database qw( schema );
6 use C4::Biblio qw( AddBiblio );
7 use Koha::Biblios qw( _type );
8 use Koha::Items qw( _type );
9 use Koha::DateUtils qw( dt_from_string );
11 use Bytes::Random::Secure;
13 use Module::Load qw( load );
15 use Array::Utils qw( array_minus );
18 SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
24 bless( $self, $class );
26 $self->schema( Koha::Database->new()->schema );
27 $self->schema->storage->sql_maker->quote_char('`');
29 $self->{gen_type} = _gen_type();
30 $self->{default_values} = _gen_default_values();
35 my ($self, $schema) = @_;
37 if( defined( $schema ) ) {
38 $self->{schema} = $schema;
40 return $self->{schema};
43 # sub clear has been obsoleted; use delete_all from the schema resultset
46 my ( $self, $params ) = @_;
47 my $source = $params->{source} || return;
48 my @recs = ref( $params->{records} ) eq 'ARRAY'?
49 @{$params->{records}}: ( $params->{records} // () );
50 # tables without PK are not supported
51 my @pk = $self->schema->source( $source )->primary_columns;
54 foreach my $rec ( @recs ) {
55 # delete only works when you supply full primary key values
56 # $cond does not include searches for undef (not allowed in PK)
57 my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
58 next if keys %$cond < @pk;
59 $self->schema->resultset( $source )->search( $cond )->delete;
60 # we clear the pk columns in the supplied hash
61 # this indirectly signals at least an attempt to delete
62 map { delete $rec->{$_}; } @pk;
69 my ( $self, $params ) = @_;
71 my $class = $params->{class};
72 my $value = $params->{value};
74 if ( not defined $class ) {
75 carp "Missing class param";
79 my @unknowns = grep( !/^(class|value)$/, keys %{ $params });
80 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
83 my $source = $class->_type;
85 my $hashref = $self->build({ source => $source, value => $value });
87 if ( $class eq 'Koha::Old::Patrons' ) {
88 $object = $class->search({ borrowernumber => $hashref->{borrowernumber} })->next;
89 } elsif ( $class eq 'Koha::Statistics' ) {
90 $object = $class->search({ datetime => $hashref->{datetime} })->next;
93 my @pks = $self->schema->source( $class->_type )->primary_columns;
94 foreach my $pk ( @pks ) {
95 push @ids, $hashref->{ $pk };
98 $object = $class->find( @ids );
105 # build returns a hash of column values for a created record, or undef
106 # build does NOT update a record, or pass back values of an existing record
107 my ($self, $params) = @_;
108 my $source = $params->{source};
110 carp "Source parameter not specified!";
113 my $value = $params->{value};
115 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
116 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
118 my $col_values = $self->_buildColumnValues({
122 return if !$col_values; # did not meet unique constraints?
124 # loop thru all fk and create linked records if needed
125 # fills remaining entries in $col_values
126 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
128 for my $fk ( @$foreign_keys ) {
129 # skip when FK points to itself: e.g. borrowers:guarantorid
130 next if $fk->{source} eq $source;
132 # If we have more than one FK on the same column, we only generate values for the first one
134 if scalar @{ $fk->{keys} } == 1
135 && exists $col_names->{ $fk->{keys}->[0]->{col_name} };
137 my $keys = $fk->{keys};
138 my $tbl = $fk->{source};
139 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
140 return if !$res; # failed: no need to go further
141 foreach( keys %$res ) { # save new values
142 $col_values->{$_} = $res->{$_};
145 $col_names->{ $fk->{keys}->[0]->{col_name} } = 1
146 if scalar @{ $fk->{keys} } == 1
149 # store this record and return hashref
150 return $self->_storeColumnValues({
152 values => $col_values,
156 sub build_sample_biblio {
157 my ( $self, $args ) = @_;
159 my $title = $args->{title} || 'Some boring read';
160 my $author = $args->{author} || 'Some boring author';
161 my $frameworkcode = $args->{frameworkcode} || '';
162 my $itemtype = $args->{itemtype}
163 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
165 my $marcflavour = C4::Context->preference('marcflavour');
167 my $record = MARC::Record->new();
168 $record->encoding( 'UTF-8' );
170 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
171 $record->append_fields(
172 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
175 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
176 $record->append_fields(
177 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
180 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
181 $record->append_fields(
182 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
185 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
186 return Koha::Biblios->find($biblio_id);
189 sub build_sample_item {
190 my ( $self, $args ) = @_;
193 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
194 my $library = delete $args->{library}
195 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
197 # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
199 my $barcode = delete $args->{barcode}
200 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
202 return Koha::Item->new(
204 biblionumber => $biblionumber,
205 homebranch => $library,
206 holdingbranch => $library,
210 )->store->get_from_storage;
213 # ------------------------------------------------------------------------------
214 # Internal helper routines
217 # returns undef for failure to create linked records
218 # otherwise returns hashref containing new column values for parent record
219 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
222 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
224 # First, collect all values for creating a linked record (if needed)
225 foreach my $fk ( @$keys ) {
226 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
227 if( ref( $value->{$col} ) eq 'HASH' ) {
228 # add all keys from the FK hash
229 $fk_value = { %{ $value->{$col} }, %$fk_value };
231 if( exists $col_values->{$col} ) {
232 # add specific value (this does not necessarily exclude some
233 # values from the hash in the preceding if)
234 $fk_value->{ $destcol } = $col_values->{ $col };
236 $cnt_null++ if !defined( $col_values->{$col} );
240 # If we saw all FK columns, first run the following checks
241 if( $cnt_scalar == @$keys ) {
242 # if one or more fk cols are null, the FK constraint will not be forced
243 return {} if $cnt_null > 0;
245 # does the record exist already?
246 my @pks = $self->schema->source( $linked_tbl )->primary_columns;
249 $fk_pk_value{$_} = $fk_value->{$_} if defined $fk_value->{$_};
251 return {} if !(keys %fk_pk_value);
252 return {} if $self->schema->resultset($linked_tbl)->find( \%fk_pk_value );
254 # create record with a recursive build call
255 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
256 return if !$row; # failure
258 # Finally, only return the new values
260 foreach my $fk ( @$keys ) {
261 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
262 next if exists $col_values->{ $col };
263 $rv->{ $col } = $row->{ $destcol };
265 return $rv; # success
270 my $source = $params->{source} || return;
271 $source =~ s|(\w+)$|$1|;
275 sub _buildColumnValues {
276 my ($self, $params) = @_;
277 my $source = _formatSource( $params ) || return;
278 my $original_value = $params->{value};
281 my @columns = $self->schema->source($source)->columns;
282 my %unique_constraints = $self->schema->source($source)->unique_constraints();
284 my @passed_keys = grep { ref($original_value->{$_}) ne 'HASH' } keys %$original_value;
285 my @minus = array_minus( @passed_keys, @columns );
286 die "Error: value hash contains unrecognized columns: ". (join ',', @minus) if @minus;
289 # we try max $build_value times if there are unique constraints
290 BUILD_VALUE: while ( $build_value ) {
291 # generate random values for all columns
292 for my $col_name( @columns ) {
293 my $valref = $self->_buildColumnValue({
295 column_name => $col_name,
296 value => $original_value,
298 return if !$valref; # failure
299 if( @$valref ) { # could be empty
300 # there will be only one value, but it could be undef
301 $col_values->{$col_name} = $valref->[0];
305 # verify the data would respect each unique constraint
306 # note that this is INCOMPLETE since not all col_values are filled
307 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
310 my $constraint_columns = $unique_constraints{$constraint};
311 # loop through all constraint columns and build the condition
312 foreach my $constraint_column ( @$constraint_columns ) {
314 # if one column does not exist or is undef, skip it
315 # an insert with a null will not trigger the constraint
317 if !exists $col_values->{ $constraint_column } ||
318 !defined $col_values->{ $constraint_column };
319 $condition->{ $constraint_column } =
320 $col_values->{ $constraint_column };
322 my $count = $self->schema
323 ->resultset( $source )
324 ->search( $condition )
327 # no point checking more stuff, exit the loop
332 last; # you passed all tests
334 return $col_values if $build_value > 0;
336 # if you get here, we have a problem
337 warn "Violation of unique constraint in $source";
341 sub _getForeignKeys {
343 # Returns the following arrayref
344 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
345 # The array gives source name and keys for each FK constraint
347 my ($self, $params) = @_;
348 my $source = $self->schema->source( $params->{source} );
350 my ( @foreign_keys, $check_dupl );
351 my @relationships = $source->relationships;
352 for my $rel_name( @relationships ) {
353 my $rel_info = $source->relationship_info($rel_name);
354 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
355 $rel_info->{source} =~ s/^.*:://g;
356 my $rel = { source => $rel_info->{source} };
359 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
360 $col_name =~ s|self.(\w+)|$1|;
361 $col_fk_name =~ s|foreign.(\w+)|$1|;
363 col_name => $col_name,
364 col_fk_name => $col_fk_name,
367 # check if the combination table and keys is unique
368 # so skip double belongs_to relations (as in Biblioitem)
369 my $tag = $rel->{source}. ':'.
370 join ',', sort map { $_->{col_name} } @keys;
371 next if $check_dupl->{$tag};
372 $check_dupl->{$tag} = 1;
373 $rel->{keys} = \@keys;
374 push @foreign_keys, $rel;
377 return \@foreign_keys;
380 sub _storeColumnValues {
381 my ($self, $params) = @_;
382 my $source = $params->{source};
383 my $col_values = $params->{values};
384 my $new_row = $self->schema->resultset( $source )->create( $col_values );
385 return $new_row? { $new_row->get_columns }: {};
388 sub _buildColumnValue {
389 # returns an arrayref if all goes well
390 # an empty arrayref typically means: auto_incr column or fk column
391 # undef means failure
392 my ($self, $params) = @_;
393 my $source = $params->{source};
394 my $value = $params->{value};
395 my $col_name = $params->{column_name};
397 my $col_info = $self->schema->source($source)->column_info($col_name);
400 if( $col_info->{is_auto_increment} ) {
401 if( exists $value->{$col_name} ) {
402 warn "Value not allowed for auto_incr $col_name in $source";
405 # otherwise: no need to assign a value
406 } elsif( !exists $value->{$col_name}
407 && exists $self->{default_values}{$source}{$col_name} ) {
408 my $v = $self->{default_values}{$source}{$col_name};
409 $v = &$v() if ref($v) eq 'CODE';
411 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
412 if( exists $value->{$col_name} ) {
413 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
414 # This explicit undef is not allowed
415 warn "Null value for $col_name in $source not allowed";
418 if( ref( $value->{$col_name} ) ne 'HASH' ) {
419 push @$retvalue, $value->{$col_name};
421 # sub build will handle a passed hash value later on
423 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
424 # this is not allowed for a column that is not a FK
425 warn "Hash not allowed for $col_name in $source";
427 } elsif( exists $value->{$col_name} ) {
428 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
429 # This explicit undef is not allowed
430 warn "Null value for $col_name in $source not allowed";
433 push @$retvalue, $value->{$col_name};
435 my $data_type = $col_info->{data_type};
436 $data_type =~ s| |_|;
437 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
438 push @$retvalue, &$hdlr( $self, { info => $col_info } );
440 warn "Unknown type $data_type for $col_name in $source";
448 # This sub is only needed for inconsistencies in the schema
449 # A column is not marked as FK, but a belongs_to relation is defined
450 my ( $source, $column ) = @_;
451 my $inconsistencies = {
452 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
453 'CheckoutRenewal.checkout_id' => 1, #FIXME: Please remove when issues and old_issues are merged
455 return $inconsistencies->{ "$source.$column" };
460 tinyint => \&_gen_bool,
461 smallint => \&_gen_int,
462 mediumint => \&_gen_int,
463 integer => \&_gen_int,
464 bigint => \&_gen_int,
466 float => \&_gen_real,
467 decimal => \&_gen_real,
468 double_precision => \&_gen_real,
470 timestamp => \&_gen_datetime,
471 datetime => \&_gen_datetime,
475 varchar => \&_gen_text,
476 tinytext => \&_gen_text,
478 mediumtext => \&_gen_text,
479 longtext => \&_gen_text,
481 set => \&_gen_set_enum,
482 enum => \&_gen_set_enum,
484 tinyblob => \&_gen_blob,
485 mediumblob => \&_gen_blob,
487 longblob => \&_gen_blob,
492 my ($self, $params) = @_;
493 return int( rand(2) );
497 my ($self, $params) = @_;
498 my $data_type = $params->{info}->{data_type};
501 if( $data_type eq 'tinyint' ) {
504 elsif( $data_type eq 'smallint' ) {
507 elsif( $data_type eq 'mediumint' ) {
510 elsif( $data_type eq 'integer' ) {
513 elsif( $data_type eq 'bigint' ) {
514 $max = 9223372036854775807;
516 return int( rand($max+1) );
520 my ($self, $params) = @_;
522 if( defined( $params->{info}->{size} ) ) {
523 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
525 $max = 10 ** 5 if $max > 10 ** 5;
526 return sprintf("%.2f", rand($max-0.1));
530 my ($self, $params) = @_;
531 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
535 my ($self, $params) = @_;
536 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
540 my ($self, $params) = @_;
541 # From perldoc String::Random
542 my $size = $params->{info}{size} // 10;
543 $size -= alt_rand(0.5 * $size);
544 my $regex = $size > 1
545 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
547 my $random = String::Random->new( rand_gen => \&alt_rand );
548 # rand_gen is only supported from 0.27 onward
549 return $random->randregex($regex);
552 sub alt_rand { #Alternative randomizer
554 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
555 my $r = $random->irand / 2**32;
556 return int( $r * $max );
560 my ($self, $params) = @_;
561 return $params->{info}->{extra}->{list}->[0];
565 my ($self, $params) = @_;;
569 sub _gen_default_values {
577 gonenoaddress => undef,
582 password_expiration_date => undef,
591 more_subfields_xml => undef,
594 daterequested => dt_from_string(),
596 datearrived => undef,
597 datecancelled => undef,
603 more_subfields_xml => undef,
608 # Not X, used for statistics
609 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
610 min_password_length => undef,
611 require_strong_password => undef,
614 pickup_location => 0,
618 item_group_id => undef,
622 rentalcharge_daily => 0,
623 rentalcharge_hourly => 0,
624 defaultreplacecost => 0,
634 sort1_authcat => undef,
635 sort2_authcat => undef,
640 BorrowerAttributeType => {
644 suggesteddate => dt_from_string()->ymd,
648 issue_id => undef, # It should be a FK but we removed it
649 # We don't want to generate a random value
653 import_error => undef
661 closure_reason => undef,
662 renewal_priority => undef,
670 t::lib::TestBuilder.pm - Koha module to create test records
674 use t::lib::TestBuilder;
675 my $builder = t::lib::TestBuilder->new;
677 # The following call creates a patron, linked to branch CPL.
678 # Surname is provided, other columns are randomly generated.
679 # Branch CPL is created if it does not exist.
680 my $patron = $builder->build({
681 source => 'Borrower',
682 value => { surname => 'Jansen', branchcode => 'CPL' },
687 This module automatically creates database records for you.
688 If needed, records for foreign keys are created too.
689 Values will be randomly generated if not passed to TestBuilder.
690 Note that you should wrap these actions in a transaction yourself.
696 my $builder = t::lib::TestBuilder->new;
698 Constructor - Returns the object TestBuilder
702 my $schema = $builder->schema;
704 Getter - Returns the schema of DBIx::Class
710 records => $patron, # OR: records => [ $patron, ... ],
713 Delete individual records, created by builder.
714 Returns the number of delete attempts, or undef.
718 $builder->build({ source => $source_name, value => $value });
720 Create a test record in the table, represented by $source_name.
721 The name is required and must conform to the DBIx::Class schema.
722 Values may be specified by the optional $value hashref. Will be
723 randomized otherwise.
724 If needed, TestBuilder creates linked records for foreign keys.
725 Returns the values of the new record as a hashref, or undef if
726 the record could not be created.
728 Note that build also supports recursive hash references inside the
729 value hash for foreign key columns, like:
731 column1 => 'some_value',
733 columnA => 'another_value',
736 The hash for fk_col2 here means: create a linked record with build
737 where columnA has this value. In case of a composite FK the hashes
740 Realize that passing primary key values to build may result in undef
741 if a record with that primary key already exists.
745 Given a plural Koha::Object-derived class, it creates a random element, and
746 returns the corresponding Koha::Object.
748 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
752 Yohann Dufour <yohann.dufour@biblibre.com>
754 Koha Development Team
758 Copyright 2014 - Biblibre SARL
762 This file is part of Koha.
764 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
765 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
767 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.
769 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.