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( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
407 if( exists $value->{$col_name} ) {
408 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
409 # This explicit undef is not allowed
410 warn "Null value for $col_name in $source not allowed";
413 if( ref( $value->{$col_name} ) ne 'HASH' ) {
414 push @$retvalue, $value->{$col_name};
416 # sub build will handle a passed hash value later on
418 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
419 # this is not allowed for a column that is not a FK
420 warn "Hash not allowed for $col_name in $source";
422 } elsif( exists $value->{$col_name} ) {
423 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
424 # This explicit undef is not allowed
425 warn "Null value for $col_name in $source not allowed";
428 push @$retvalue, $value->{$col_name};
429 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
430 my $v = $self->{default_values}{$source}{$col_name};
431 $v = &$v() if ref($v) eq 'CODE';
434 my $data_type = $col_info->{data_type};
435 $data_type =~ s| |_|;
436 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
437 push @$retvalue, &$hdlr( $self, { info => $col_info } );
439 warn "Unknown type $data_type for $col_name in $source";
447 # This sub is only needed for inconsistencies in the schema
448 # A column is not marked as FK, but a belongs_to relation is defined
449 my ( $source, $column ) = @_;
450 my $inconsistencies = {
451 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
452 'CheckoutRenewal.checkout_id' => 1, #FIXME: Please remove when issues and old_issues are merged
454 return $inconsistencies->{ "$source.$column" };
459 tinyint => \&_gen_bool,
460 smallint => \&_gen_int,
461 mediumint => \&_gen_int,
462 integer => \&_gen_int,
463 bigint => \&_gen_int,
465 float => \&_gen_real,
466 decimal => \&_gen_real,
467 double_precision => \&_gen_real,
469 timestamp => \&_gen_datetime,
470 datetime => \&_gen_datetime,
474 varchar => \&_gen_text,
475 tinytext => \&_gen_text,
477 mediumtext => \&_gen_text,
478 longtext => \&_gen_text,
480 set => \&_gen_set_enum,
481 enum => \&_gen_set_enum,
483 tinyblob => \&_gen_blob,
484 mediumblob => \&_gen_blob,
486 longblob => \&_gen_blob,
491 my ($self, $params) = @_;
492 return int( rand(2) );
496 my ($self, $params) = @_;
497 my $data_type = $params->{info}->{data_type};
500 if( $data_type eq 'tinyint' ) {
503 elsif( $data_type eq 'smallint' ) {
506 elsif( $data_type eq 'mediumint' ) {
509 elsif( $data_type eq 'integer' ) {
512 elsif( $data_type eq 'bigint' ) {
513 $max = 9223372036854775807;
515 return int( rand($max+1) );
519 my ($self, $params) = @_;
521 if( defined( $params->{info}->{size} ) ) {
522 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
524 $max = 10 ** 5 if $max > 10 ** 5;
525 return sprintf("%.2f", rand($max-0.1));
529 my ($self, $params) = @_;
530 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
534 my ($self, $params) = @_;
535 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
539 my ($self, $params) = @_;
540 # From perldoc String::Random
541 my $size = $params->{info}{size} // 10;
542 $size -= alt_rand(0.5 * $size);
543 my $regex = $size > 1
544 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
546 my $random = String::Random->new( rand_gen => \&alt_rand );
547 # rand_gen is only supported from 0.27 onward
548 return $random->randregex($regex);
551 sub alt_rand { #Alternative randomizer
553 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
554 my $r = $random->irand / 2**32;
555 return int( $r * $max );
559 my ($self, $params) = @_;
560 return $params->{info}->{extra}->{list}->[0];
564 my ($self, $params) = @_;;
568 sub _gen_default_values {
576 gonenoaddress => undef,
581 password_expiration_date => undef,
590 more_subfields_xml => undef,
595 # Not X, used for statistics
596 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
597 min_password_length => undef,
598 require_strong_password => undef,
601 pickup_location => 0,
608 rentalcharge_daily => 0,
609 rentalcharge_hourly => 0,
610 defaultreplacecost => 0,
620 sort1_authcat => undef,
621 sort2_authcat => undef,
626 BorrowerAttributeType => {
630 suggesteddate => dt_from_string()->ymd,
634 issue_id => undef, # It should be a FK but we removed it
635 # We don't want to generate a random value
639 import_error => undef
647 closure_reason => undef,
648 renewal_priority => undef,
656 t::lib::TestBuilder.pm - Koha module to create test records
660 use t::lib::TestBuilder;
661 my $builder = t::lib::TestBuilder->new;
663 # The following call creates a patron, linked to branch CPL.
664 # Surname is provided, other columns are randomly generated.
665 # Branch CPL is created if it does not exist.
666 my $patron = $builder->build({
667 source => 'Borrower',
668 value => { surname => 'Jansen', branchcode => 'CPL' },
673 This module automatically creates database records for you.
674 If needed, records for foreign keys are created too.
675 Values will be randomly generated if not passed to TestBuilder.
676 Note that you should wrap these actions in a transaction yourself.
682 my $builder = t::lib::TestBuilder->new;
684 Constructor - Returns the object TestBuilder
688 my $schema = $builder->schema;
690 Getter - Returns the schema of DBIx::Class
696 records => $patron, # OR: records => [ $patron, ... ],
699 Delete individual records, created by builder.
700 Returns the number of delete attempts, or undef.
704 $builder->build({ source => $source_name, value => $value });
706 Create a test record in the table, represented by $source_name.
707 The name is required and must conform to the DBIx::Class schema.
708 Values may be specified by the optional $value hashref. Will be
709 randomized otherwise.
710 If needed, TestBuilder creates linked records for foreign keys.
711 Returns the values of the new record as a hashref, or undef if
712 the record could not be created.
714 Note that build also supports recursive hash references inside the
715 value hash for foreign key columns, like:
717 column1 => 'some_value',
719 columnA => 'another_value',
722 The hash for fk_col2 here means: create a linked record with build
723 where columnA has this value. In case of a composite FK the hashes
726 Realize that passing primary key values to build may result in undef
727 if a record with that primary key already exists.
731 Given a plural Koha::Object-derived class, it creates a random element, and
732 returns the corresponding Koha::Object.
734 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
738 Yohann Dufour <yohann.dufour@biblibre.com>
740 Koha Development Team
744 Copyright 2014 - Biblibre SARL
748 This file is part of Koha.
750 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
751 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
753 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.
755 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.