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_int,
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 my $data_type = $params->{info}->{data_type};
490 if( $data_type eq 'tinyint' ) {
493 elsif( $data_type eq 'smallint' ) {
496 elsif( $data_type eq 'mediumint' ) {
499 elsif( $data_type eq 'integer' ) {
502 elsif( $data_type eq 'bigint' ) {
503 $max = 9223372036854775807;
505 return int( rand($max+1) );
509 my ($self, $params) = @_;
511 if( defined( $params->{info}->{size} ) ) {
512 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
514 $max = 10 ** 5 if $max > 10 ** 5;
515 return sprintf("%.2f", rand($max-0.1));
519 my ($self, $params) = @_;
520 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
524 my ($self, $params) = @_;
525 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
529 my ($self, $params) = @_;
530 # From perldoc String::Random
531 my $size = $params->{info}{size} // 10;
532 $size -= alt_rand(0.5 * $size);
533 my $regex = $size > 1
534 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
536 my $random = String::Random->new( rand_gen => \&alt_rand );
537 # rand_gen is only supported from 0.27 onward
538 return $random->randregex($regex);
541 sub alt_rand { #Alternative randomizer
543 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
544 my $r = $random->irand / 2**32;
545 return int( $r * $max );
549 my ($self, $params) = @_;
550 return $params->{info}->{extra}->{list}->[0];
554 my ($self, $params) = @_;;
558 sub _gen_default_values {
563 gonenoaddress => undef,
568 password_expiration_date => undef,
577 more_subfields_xml => undef,
582 # Not X, used for statistics
583 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
584 min_password_length => undef,
585 require_strong_password => undef,
588 pickup_location => 0,
595 rentalcharge_daily => 0,
596 rentalcharge_hourly => 0,
597 defaultreplacecost => 0,
607 sort1_authcat => undef,
608 sort2_authcat => undef,
613 BorrowerAttributeType => {
617 suggesteddate => dt_from_string()->ymd,
621 issue_id => undef, # It should be a FK but we removed it
622 # We don't want to generate a random value
626 import_error => undef
633 t::lib::TestBuilder.pm - Koha module to create test records
637 use t::lib::TestBuilder;
638 my $builder = t::lib::TestBuilder->new;
640 # The following call creates a patron, linked to branch CPL.
641 # Surname is provided, other columns are randomly generated.
642 # Branch CPL is created if it does not exist.
643 my $patron = $builder->build({
644 source => 'Borrower',
645 value => { surname => 'Jansen', branchcode => 'CPL' },
650 This module automatically creates database records for you.
651 If needed, records for foreign keys are created too.
652 Values will be randomly generated if not passed to TestBuilder.
653 Note that you should wrap these actions in a transaction yourself.
659 my $builder = t::lib::TestBuilder->new;
661 Constructor - Returns the object TestBuilder
665 my $schema = $builder->schema;
667 Getter - Returns the schema of DBIx::Class
673 records => $patron, # OR: records => [ $patron, ... ],
676 Delete individual records, created by builder.
677 Returns the number of delete attempts, or undef.
681 $builder->build({ source => $source_name, value => $value });
683 Create a test record in the table, represented by $source_name.
684 The name is required and must conform to the DBIx::Class schema.
685 Values may be specified by the optional $value hashref. Will be
686 randomized otherwise.
687 If needed, TestBuilder creates linked records for foreign keys.
688 Returns the values of the new record as a hashref, or undef if
689 the record could not be created.
691 Note that build also supports recursive hash references inside the
692 value hash for foreign key columns, like:
694 column1 => 'some_value',
696 columnA => 'another_value',
699 The hash for fk_col2 here means: create a linked record with build
700 where columnA has this value. In case of a composite FK the hashes
703 Realize that passing primary key values to build may result in undef
704 if a record with that primary key already exists.
708 Given a plural Koha::Object-derived class, it creates a random element, and
709 returns the corresponding Koha::Object.
711 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
715 Yohann Dufour <yohann.dufour@biblibre.com>
717 Koha Development Team
721 Copyright 2014 - Biblibre SARL
725 This file is part of Koha.
727 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
728 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
730 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.
732 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.