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 {
566 gonenoaddress => undef,
571 password_expiration_date => undef,
580 more_subfields_xml => undef,
585 # Not X, used for statistics
586 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
587 min_password_length => undef,
588 require_strong_password => undef,
591 pickup_location => 0,
598 rentalcharge_daily => 0,
599 rentalcharge_hourly => 0,
600 defaultreplacecost => 0,
610 sort1_authcat => undef,
611 sort2_authcat => undef,
616 BorrowerAttributeType => {
620 suggesteddate => dt_from_string()->ymd,
624 issue_id => undef, # It should be a FK but we removed it
625 # We don't want to generate a random value
629 import_error => undef
640 t::lib::TestBuilder.pm - Koha module to create test records
644 use t::lib::TestBuilder;
645 my $builder = t::lib::TestBuilder->new;
647 # The following call creates a patron, linked to branch CPL.
648 # Surname is provided, other columns are randomly generated.
649 # Branch CPL is created if it does not exist.
650 my $patron = $builder->build({
651 source => 'Borrower',
652 value => { surname => 'Jansen', branchcode => 'CPL' },
657 This module automatically creates database records for you.
658 If needed, records for foreign keys are created too.
659 Values will be randomly generated if not passed to TestBuilder.
660 Note that you should wrap these actions in a transaction yourself.
666 my $builder = t::lib::TestBuilder->new;
668 Constructor - Returns the object TestBuilder
672 my $schema = $builder->schema;
674 Getter - Returns the schema of DBIx::Class
680 records => $patron, # OR: records => [ $patron, ... ],
683 Delete individual records, created by builder.
684 Returns the number of delete attempts, or undef.
688 $builder->build({ source => $source_name, value => $value });
690 Create a test record in the table, represented by $source_name.
691 The name is required and must conform to the DBIx::Class schema.
692 Values may be specified by the optional $value hashref. Will be
693 randomized otherwise.
694 If needed, TestBuilder creates linked records for foreign keys.
695 Returns the values of the new record as a hashref, or undef if
696 the record could not be created.
698 Note that build also supports recursive hash references inside the
699 value hash for foreign key columns, like:
701 column1 => 'some_value',
703 columnA => 'another_value',
706 The hash for fk_col2 here means: create a linked record with build
707 where columnA has this value. In case of a composite FK the hashes
710 Realize that passing primary key values to build may result in undef
711 if a record with that primary key already exists.
715 Given a plural Koha::Object-derived class, it creates a random element, and
716 returns the corresponding Koha::Object.
718 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
722 Yohann Dufour <yohann.dufour@biblibre.com>
724 Koha Development Team
728 Copyright 2014 - Biblibre SARL
732 This file is part of Koha.
734 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
735 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
737 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.
739 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.