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 );
17 SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
23 bless( $self, $class );
25 $self->schema( Koha::Database->new()->schema );
26 $self->schema->storage->sql_maker->quote_char('`');
28 $self->{gen_type} = _gen_type();
29 $self->{default_values} = _gen_default_values();
34 my ($self, $schema) = @_;
36 if( defined( $schema ) ) {
37 $self->{schema} = $schema;
39 return $self->{schema};
42 # sub clear has been obsoleted; use delete_all from the schema resultset
45 my ( $self, $params ) = @_;
46 my $source = $params->{source} || return;
47 my @recs = ref( $params->{records} ) eq 'ARRAY'?
48 @{$params->{records}}: ( $params->{records} // () );
49 # tables without PK are not supported
50 my @pk = $self->schema->source( $source )->primary_columns;
53 foreach my $rec ( @recs ) {
54 # delete only works when you supply full primary key values
55 # $cond does not include searches for undef (not allowed in PK)
56 my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
57 next if keys %$cond < @pk;
58 $self->schema->resultset( $source )->search( $cond )->delete;
59 # we clear the pk columns in the supplied hash
60 # this indirectly signals at least an attempt to delete
61 map { delete $rec->{$_}; } @pk;
68 my ( $self, $params ) = @_;
70 my $class = $params->{class};
71 my $value = $params->{value};
73 if ( not defined $class ) {
74 carp "Missing class param";
78 my @unknowns = grep( !/^(class|value)$/, keys %{ $params });
79 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
82 my $source = $class->_type;
84 my $hashref = $self->build({ source => $source, value => $value });
86 if ( $class eq 'Koha::Old::Patrons' ) {
87 $object = $class->search({ borrowernumber => $hashref->{borrowernumber} })->next;
88 } elsif ( $class eq 'Koha::Statistics' ) {
89 $object = $class->search({ datetime => $hashref->{datetime} })->next;
92 my @pks = $self->schema->source( $class->_type )->primary_columns;
93 foreach my $pk ( @pks ) {
94 push @ids, $hashref->{ $pk };
97 $object = $class->find( @ids );
104 # build returns a hash of column values for a created record, or undef
105 # build does NOT update a record, or pass back values of an existing record
106 my ($self, $params) = @_;
107 my $source = $params->{source};
109 carp "Source parameter not specified!";
112 my $value = $params->{value};
114 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
115 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
117 my $col_values = $self->_buildColumnValues({
121 return if !$col_values; # did not meet unique constraints?
123 # loop thru all fk and create linked records if needed
124 # fills remaining entries in $col_values
125 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
127 for my $fk ( @$foreign_keys ) {
128 # skip when FK points to itself: e.g. borrowers:guarantorid
129 next if $fk->{source} eq $source;
131 # If we have more than one FK on the same column, we only generate values for the first one
133 if scalar @{ $fk->{keys} } == 1
134 && exists $col_names->{ $fk->{keys}->[0]->{col_name} };
136 my $keys = $fk->{keys};
137 my $tbl = $fk->{source};
138 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
139 return if !$res; # failed: no need to go further
140 foreach( keys %$res ) { # save new values
141 $col_values->{$_} = $res->{$_};
144 $col_names->{ $fk->{keys}->[0]->{col_name} } = 1
145 if scalar @{ $fk->{keys} } == 1
148 # store this record and return hashref
149 return $self->_storeColumnValues({
151 values => $col_values,
155 sub build_sample_biblio {
156 my ( $self, $args ) = @_;
158 my $title = $args->{title} || 'Some boring read';
159 my $author = $args->{author} || 'Some boring author';
160 my $frameworkcode = $args->{frameworkcode} || '';
161 my $itemtype = $args->{itemtype}
162 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
164 my $marcflavour = C4::Context->preference('marcflavour');
166 my $record = MARC::Record->new();
167 $record->encoding( 'UTF-8' );
169 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
170 $record->append_fields(
171 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
174 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
175 $record->append_fields(
176 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
179 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
180 $record->append_fields(
181 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
184 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
185 return Koha::Biblios->find($biblio_id);
188 sub build_sample_item {
189 my ( $self, $args ) = @_;
192 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
193 my $library = delete $args->{library}
194 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
196 # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
198 my $barcode = delete $args->{barcode}
199 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
201 return Koha::Item->new(
203 biblionumber => $biblionumber,
204 homebranch => $library,
205 holdingbranch => $library,
209 )->store->get_from_storage;
212 # ------------------------------------------------------------------------------
213 # Internal helper routines
216 # returns undef for failure to create linked records
217 # otherwise returns hashref containing new column values for parent record
218 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
221 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
223 # First, collect all values for creating a linked record (if needed)
224 foreach my $fk ( @$keys ) {
225 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
226 if( ref( $value->{$col} ) eq 'HASH' ) {
227 # add all keys from the FK hash
228 $fk_value = { %{ $value->{$col} }, %$fk_value };
230 if( exists $col_values->{$col} ) {
231 # add specific value (this does not necessarily exclude some
232 # values from the hash in the preceding if)
233 $fk_value->{ $destcol } = $col_values->{ $col };
235 $cnt_null++ if !defined( $col_values->{$col} );
239 # If we saw all FK columns, first run the following checks
240 if( $cnt_scalar == @$keys ) {
241 # if one or more fk cols are null, the FK constraint will not be forced
242 return {} if $cnt_null > 0;
244 # does the record exist already?
245 my @pks = $self->schema->source( $linked_tbl )->primary_columns;
248 $fk_pk_value{$_} = $fk_value->{$_} if defined $fk_value->{$_};
250 return {} if !(keys %fk_pk_value);
251 return {} if $self->schema->resultset($linked_tbl)->find( \%fk_pk_value );
253 # create record with a recursive build call
254 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
255 return if !$row; # failure
257 # Finally, only return the new values
259 foreach my $fk ( @$keys ) {
260 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
261 next if exists $col_values->{ $col };
262 $rv->{ $col } = $row->{ $destcol };
264 return $rv; # success
269 my $source = $params->{source} || return;
270 $source =~ s|(\w+)$|$1|;
274 sub _buildColumnValues {
275 my ($self, $params) = @_;
276 my $source = _formatSource( $params ) || return;
277 my $original_value = $params->{value};
280 my @columns = $self->schema->source($source)->columns;
281 my %unique_constraints = $self->schema->source($source)->unique_constraints();
284 # we try max $build_value times if there are unique constraints
285 BUILD_VALUE: while ( $build_value ) {
286 # generate random values for all columns
287 for my $col_name( @columns ) {
288 my $valref = $self->_buildColumnValue({
290 column_name => $col_name,
291 value => $original_value,
293 return if !$valref; # failure
294 if( @$valref ) { # could be empty
295 # there will be only one value, but it could be undef
296 $col_values->{$col_name} = $valref->[0];
300 # verify the data would respect each unique constraint
301 # note that this is INCOMPLETE since not all col_values are filled
302 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
305 my $constraint_columns = $unique_constraints{$constraint};
306 # loop through all constraint columns and build the condition
307 foreach my $constraint_column ( @$constraint_columns ) {
309 # if one column does not exist or is undef, skip it
310 # an insert with a null will not trigger the constraint
312 if !exists $col_values->{ $constraint_column } ||
313 !defined $col_values->{ $constraint_column };
314 $condition->{ $constraint_column } =
315 $col_values->{ $constraint_column };
317 my $count = $self->schema
318 ->resultset( $source )
319 ->search( $condition )
322 # no point checking more stuff, exit the loop
327 last; # you passed all tests
329 return $col_values if $build_value > 0;
331 # if you get here, we have a problem
332 warn "Violation of unique constraint in $source";
336 sub _getForeignKeys {
338 # Returns the following arrayref
339 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
340 # The array gives source name and keys for each FK constraint
342 my ($self, $params) = @_;
343 my $source = $self->schema->source( $params->{source} );
345 my ( @foreign_keys, $check_dupl );
346 my @relationships = $source->relationships;
347 for my $rel_name( @relationships ) {
348 my $rel_info = $source->relationship_info($rel_name);
349 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
350 $rel_info->{source} =~ s/^.*:://g;
351 my $rel = { source => $rel_info->{source} };
354 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
355 $col_name =~ s|self.(\w+)|$1|;
356 $col_fk_name =~ s|foreign.(\w+)|$1|;
358 col_name => $col_name,
359 col_fk_name => $col_fk_name,
362 # check if the combination table and keys is unique
363 # so skip double belongs_to relations (as in Biblioitem)
364 my $tag = $rel->{source}. ':'.
365 join ',', sort map { $_->{col_name} } @keys;
366 next if $check_dupl->{$tag};
367 $check_dupl->{$tag} = 1;
368 $rel->{keys} = \@keys;
369 push @foreign_keys, $rel;
372 return \@foreign_keys;
375 sub _storeColumnValues {
376 my ($self, $params) = @_;
377 my $source = $params->{source};
378 my $col_values = $params->{values};
379 my $new_row = $self->schema->resultset( $source )->create( $col_values );
380 return $new_row? { $new_row->get_columns }: {};
383 sub _buildColumnValue {
384 # returns an arrayref if all goes well
385 # an empty arrayref typically means: auto_incr column or fk column
386 # undef means failure
387 my ($self, $params) = @_;
388 my $source = $params->{source};
389 my $value = $params->{value};
390 my $col_name = $params->{column_name};
392 my $col_info = $self->schema->source($source)->column_info($col_name);
395 if( $col_info->{is_auto_increment} ) {
396 if( exists $value->{$col_name} ) {
397 warn "Value not allowed for auto_incr $col_name in $source";
400 # otherwise: no need to assign a value
401 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
402 if( exists $value->{$col_name} ) {
403 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
404 # This explicit undef is not allowed
405 warn "Null value for $col_name in $source not allowed";
408 if( ref( $value->{$col_name} ) ne 'HASH' ) {
409 push @$retvalue, $value->{$col_name};
411 # sub build will handle a passed hash value later on
413 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
414 # this is not allowed for a column that is not a FK
415 warn "Hash not allowed for $col_name in $source";
417 } elsif( exists $value->{$col_name} ) {
418 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
419 # This explicit undef is not allowed
420 warn "Null value for $col_name in $source not allowed";
423 push @$retvalue, $value->{$col_name};
424 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
425 my $v = $self->{default_values}{$source}{$col_name};
426 $v = &$v() if ref($v) eq 'CODE';
429 my $data_type = $col_info->{data_type};
430 $data_type =~ s| |_|;
431 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
432 push @$retvalue, &$hdlr( $self, { info => $col_info } );
434 warn "Unknown type $data_type for $col_name in $source";
442 # This sub is only needed for inconsistencies in the schema
443 # A column is not marked as FK, but a belongs_to relation is defined
444 my ( $source, $column ) = @_;
445 my $inconsistencies = {
446 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
447 'CheckoutRenewal.checkout_id' => 1, #FIXME: Please remove when issues and old_issues are merged
449 return $inconsistencies->{ "$source.$column" };
454 tinyint => \&_gen_bool,
455 smallint => \&_gen_int,
456 mediumint => \&_gen_int,
457 integer => \&_gen_int,
458 bigint => \&_gen_int,
460 float => \&_gen_real,
461 decimal => \&_gen_real,
462 double_precision => \&_gen_real,
464 timestamp => \&_gen_datetime,
465 datetime => \&_gen_datetime,
469 varchar => \&_gen_text,
470 tinytext => \&_gen_text,
472 mediumtext => \&_gen_text,
473 longtext => \&_gen_text,
475 set => \&_gen_set_enum,
476 enum => \&_gen_set_enum,
478 tinyblob => \&_gen_blob,
479 mediumblob => \&_gen_blob,
481 longblob => \&_gen_blob,
486 my ($self, $params) = @_;
487 return int( rand(2) );
491 my ($self, $params) = @_;
492 my $data_type = $params->{info}->{data_type};
495 if( $data_type eq 'tinyint' ) {
498 elsif( $data_type eq 'smallint' ) {
501 elsif( $data_type eq 'mediumint' ) {
504 elsif( $data_type eq 'integer' ) {
507 elsif( $data_type eq 'bigint' ) {
508 $max = 9223372036854775807;
510 return int( rand($max+1) );
514 my ($self, $params) = @_;
516 if( defined( $params->{info}->{size} ) ) {
517 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
519 $max = 10 ** 5 if $max > 10 ** 5;
520 return sprintf("%.2f", rand($max-0.1));
524 my ($self, $params) = @_;
525 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
529 my ($self, $params) = @_;
530 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
534 my ($self, $params) = @_;
535 # From perldoc String::Random
536 my $size = $params->{info}{size} // 10;
537 $size -= alt_rand(0.5 * $size);
538 my $regex = $size > 1
539 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
541 my $random = String::Random->new( rand_gen => \&alt_rand );
542 # rand_gen is only supported from 0.27 onward
543 return $random->randregex($regex);
546 sub alt_rand { #Alternative randomizer
548 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
549 my $r = $random->irand / 2**32;
550 return int( $r * $max );
554 my ($self, $params) = @_;
555 return $params->{info}->{extra}->{list}->[0];
559 my ($self, $params) = @_;;
563 sub _gen_default_values {
571 gonenoaddress => undef,
576 password_expiration_date => undef,
585 more_subfields_xml => undef,
590 # Not X, used for statistics
591 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
592 min_password_length => undef,
593 require_strong_password => undef,
596 pickup_location => 0,
603 rentalcharge_daily => 0,
604 rentalcharge_hourly => 0,
605 defaultreplacecost => 0,
615 sort1_authcat => undef,
616 sort2_authcat => undef,
621 BorrowerAttributeType => {
625 suggesteddate => dt_from_string()->ymd,
629 issue_id => undef, # It should be a FK but we removed it
630 # We don't want to generate a random value
634 import_error => undef
645 t::lib::TestBuilder.pm - Koha module to create test records
649 use t::lib::TestBuilder;
650 my $builder = t::lib::TestBuilder->new;
652 # The following call creates a patron, linked to branch CPL.
653 # Surname is provided, other columns are randomly generated.
654 # Branch CPL is created if it does not exist.
655 my $patron = $builder->build({
656 source => 'Borrower',
657 value => { surname => 'Jansen', branchcode => 'CPL' },
662 This module automatically creates database records for you.
663 If needed, records for foreign keys are created too.
664 Values will be randomly generated if not passed to TestBuilder.
665 Note that you should wrap these actions in a transaction yourself.
671 my $builder = t::lib::TestBuilder->new;
673 Constructor - Returns the object TestBuilder
677 my $schema = $builder->schema;
679 Getter - Returns the schema of DBIx::Class
685 records => $patron, # OR: records => [ $patron, ... ],
688 Delete individual records, created by builder.
689 Returns the number of delete attempts, or undef.
693 $builder->build({ source => $source_name, value => $value });
695 Create a test record in the table, represented by $source_name.
696 The name is required and must conform to the DBIx::Class schema.
697 Values may be specified by the optional $value hashref. Will be
698 randomized otherwise.
699 If needed, TestBuilder creates linked records for foreign keys.
700 Returns the values of the new record as a hashref, or undef if
701 the record could not be created.
703 Note that build also supports recursive hash references inside the
704 value hash for foreign key columns, like:
706 column1 => 'some_value',
708 columnA => 'another_value',
711 The hash for fk_col2 here means: create a linked record with build
712 where columnA has this value. In case of a composite FK the hashes
715 Realize that passing primary key values to build may result in undef
716 if a record with that primary key already exists.
720 Given a plural Koha::Object-derived class, it creates a random element, and
721 returns the corresponding Koha::Object.
723 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
727 Yohann Dufour <yohann.dufour@biblibre.com>
729 Koha Development Team
733 Copyright 2014 - Biblibre SARL
737 This file is part of Koha.
739 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
740 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
742 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.
744 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.