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 } );
126 for my $fk ( @$foreign_keys ) {
127 # skip when FK points to itself: e.g. borrowers:guarantorid
128 next if $fk->{source} eq $source;
129 my $keys = $fk->{keys};
130 my $tbl = $fk->{source};
131 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
132 return if !$res; # failed: no need to go further
133 foreach( keys %$res ) { # save new values
134 $col_values->{$_} = $res->{$_};
138 # store this record and return hashref
139 return $self->_storeColumnValues({
141 values => $col_values,
145 sub build_sample_biblio {
146 my ( $self, $args ) = @_;
148 my $title = $args->{title} || 'Some boring read';
149 my $author = $args->{author} || 'Some boring author';
150 my $frameworkcode = $args->{frameworkcode} || '';
151 my $itemtype = $args->{itemtype}
152 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
154 my $marcflavour = C4::Context->preference('marcflavour');
156 my $record = MARC::Record->new();
157 $record->encoding( 'UTF-8' );
159 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
160 $record->append_fields(
161 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
164 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
165 $record->append_fields(
166 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
169 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
170 $record->append_fields(
171 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
174 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
175 return Koha::Biblios->find($biblio_id);
178 sub build_sample_item {
179 my ( $self, $args ) = @_;
182 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
183 my $library = delete $args->{library}
184 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
186 # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
188 my $barcode = delete $args->{barcode}
189 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
191 return Koha::Item->new(
193 biblionumber => $biblionumber,
194 homebranch => $library,
195 holdingbranch => $library,
199 )->store->get_from_storage;
202 # ------------------------------------------------------------------------------
203 # Internal helper routines
206 # returns undef for failure to create linked records
207 # otherwise returns hashref containing new column values for parent record
208 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
211 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
213 # First, collect all values for creating a linked record (if needed)
214 foreach my $fk ( @$keys ) {
215 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
216 if( ref( $value->{$col} ) eq 'HASH' ) {
217 # add all keys from the FK hash
218 $fk_value = { %{ $value->{$col} }, %$fk_value };
220 if( exists $col_values->{$col} ) {
221 # add specific value (this does not necessarily exclude some
222 # values from the hash in the preceding if)
223 $fk_value->{ $destcol } = $col_values->{ $col };
225 $cnt_null++ if !defined( $col_values->{$col} );
229 # If we saw all FK columns, first run the following checks
230 if( $cnt_scalar == @$keys ) {
231 # if one or more fk cols are null, the FK constraint will not be forced
232 return {} if $cnt_null > 0;
234 # does the record exist already?
235 my @pks = $self->schema->source( $linked_tbl )->primary_columns;
238 $fk_pk_value{$_} = $fk_value->{$_} if defined $fk_value->{$_};
240 return {} if !(keys %fk_pk_value);
241 return {} if $self->schema->resultset($linked_tbl)->find( \%fk_pk_value );
243 # create record with a recursive build call
244 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
245 return if !$row; # failure
247 # Finally, only return the new values
249 foreach my $fk ( @$keys ) {
250 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
251 next if exists $col_values->{ $col };
252 $rv->{ $col } = $row->{ $destcol };
254 return $rv; # success
259 my $source = $params->{source} || return;
260 $source =~ s|(\w+)$|$1|;
264 sub _buildColumnValues {
265 my ($self, $params) = @_;
266 my $source = _formatSource( $params ) || return;
267 my $original_value = $params->{value};
270 my @columns = $self->schema->source($source)->columns;
271 my %unique_constraints = $self->schema->source($source)->unique_constraints();
274 # we try max $build_value times if there are unique constraints
275 BUILD_VALUE: while ( $build_value ) {
276 # generate random values for all columns
277 for my $col_name( @columns ) {
278 my $valref = $self->_buildColumnValue({
280 column_name => $col_name,
281 value => $original_value,
283 return if !$valref; # failure
284 if( @$valref ) { # could be empty
285 # there will be only one value, but it could be undef
286 $col_values->{$col_name} = $valref->[0];
290 # verify the data would respect each unique constraint
291 # note that this is INCOMPLETE since not all col_values are filled
292 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
295 my $constraint_columns = $unique_constraints{$constraint};
296 # loop through all constraint columns and build the condition
297 foreach my $constraint_column ( @$constraint_columns ) {
299 # if one column does not exist or is undef, skip it
300 # an insert with a null will not trigger the constraint
302 if !exists $col_values->{ $constraint_column } ||
303 !defined $col_values->{ $constraint_column };
304 $condition->{ $constraint_column } =
305 $col_values->{ $constraint_column };
307 my $count = $self->schema
308 ->resultset( $source )
309 ->search( $condition )
312 # no point checking more stuff, exit the loop
317 last; # you passed all tests
319 return $col_values if $build_value > 0;
321 # if you get here, we have a problem
322 warn "Violation of unique constraint in $source";
326 sub _getForeignKeys {
328 # Returns the following arrayref
329 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
330 # The array gives source name and keys for each FK constraint
332 my ($self, $params) = @_;
333 my $source = $self->schema->source( $params->{source} );
335 my ( @foreign_keys, $check_dupl );
336 my @relationships = $source->relationships;
337 for my $rel_name( @relationships ) {
338 my $rel_info = $source->relationship_info($rel_name);
339 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
340 $rel_info->{source} =~ s/^.*:://g;
341 my $rel = { source => $rel_info->{source} };
344 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
345 $col_name =~ s|self.(\w+)|$1|;
346 $col_fk_name =~ s|foreign.(\w+)|$1|;
348 col_name => $col_name,
349 col_fk_name => $col_fk_name,
352 # check if the combination table and keys is unique
353 # so skip double belongs_to relations (as in Biblioitem)
354 my $tag = $rel->{source}. ':'.
355 join ',', sort map { $_->{col_name} } @keys;
356 next if $check_dupl->{$tag};
357 $check_dupl->{$tag} = 1;
358 $rel->{keys} = \@keys;
359 push @foreign_keys, $rel;
362 return \@foreign_keys;
365 sub _storeColumnValues {
366 my ($self, $params) = @_;
367 my $source = $params->{source};
368 my $col_values = $params->{values};
369 my $new_row = $self->schema->resultset( $source )->create( $col_values );
370 return $new_row? { $new_row->get_columns }: {};
373 sub _buildColumnValue {
374 # returns an arrayref if all goes well
375 # an empty arrayref typically means: auto_incr column or fk column
376 # undef means failure
377 my ($self, $params) = @_;
378 my $source = $params->{source};
379 my $value = $params->{value};
380 my $col_name = $params->{column_name};
382 my $col_info = $self->schema->source($source)->column_info($col_name);
385 if( $col_info->{is_auto_increment} ) {
386 if( exists $value->{$col_name} ) {
387 warn "Value not allowed for auto_incr $col_name in $source";
390 # otherwise: no need to assign a value
391 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
392 if( exists $value->{$col_name} ) {
393 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
394 # This explicit undef is not allowed
395 warn "Null value for $col_name in $source not allowed";
398 if( ref( $value->{$col_name} ) ne 'HASH' ) {
399 push @$retvalue, $value->{$col_name};
401 # sub build will handle a passed hash value later on
403 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
404 # this is not allowed for a column that is not a FK
405 warn "Hash not allowed for $col_name in $source";
407 } elsif( 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 push @$retvalue, $value->{$col_name};
414 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
415 my $v = $self->{default_values}{$source}{$col_name};
416 $v = &$v() if ref($v) eq 'CODE';
419 my $data_type = $col_info->{data_type};
420 $data_type =~ s| |_|;
421 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
422 push @$retvalue, &$hdlr( $self, { info => $col_info } );
424 warn "Unknown type $data_type for $col_name in $source";
432 # This sub is only needed for inconsistencies in the schema
433 # A column is not marked as FK, but a belongs_to relation is defined
434 my ( $source, $column ) = @_;
435 my $inconsistencies = {
436 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
437 'CheckoutRenewal.checkout_id' => 1, #FIXME: Please remove when issues and old_issues are merged
439 return $inconsistencies->{ "$source.$column" };
444 tinyint => \&_gen_int,
445 smallint => \&_gen_int,
446 mediumint => \&_gen_int,
447 integer => \&_gen_int,
448 bigint => \&_gen_int,
450 float => \&_gen_real,
451 decimal => \&_gen_real,
452 double_precision => \&_gen_real,
454 timestamp => \&_gen_datetime,
455 datetime => \&_gen_datetime,
459 varchar => \&_gen_text,
460 tinytext => \&_gen_text,
462 mediumtext => \&_gen_text,
463 longtext => \&_gen_text,
465 set => \&_gen_set_enum,
466 enum => \&_gen_set_enum,
468 tinyblob => \&_gen_blob,
469 mediumblob => \&_gen_blob,
471 longblob => \&_gen_blob,
476 my ($self, $params) = @_;
477 my $data_type = $params->{info}->{data_type};
480 if( $data_type eq 'tinyint' ) {
483 elsif( $data_type eq 'smallint' ) {
486 elsif( $data_type eq 'mediumint' ) {
489 elsif( $data_type eq 'integer' ) {
492 elsif( $data_type eq 'bigint' ) {
493 $max = 9223372036854775807;
495 return int( rand($max+1) );
499 my ($self, $params) = @_;
501 if( defined( $params->{info}->{size} ) ) {
502 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
504 $max = 10 ** 5 if $max > 10 ** 5;
505 return sprintf("%.2f", rand($max-0.1));
509 my ($self, $params) = @_;
510 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
514 my ($self, $params) = @_;
515 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
519 my ($self, $params) = @_;
520 # From perldoc String::Random
521 my $size = $params->{info}{size} // 10;
522 $size -= alt_rand(0.5 * $size);
523 my $regex = $size > 1
524 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
526 my $random = String::Random->new( rand_gen => \&alt_rand );
527 # rand_gen is only supported from 0.27 onward
528 return $random->randregex($regex);
531 sub alt_rand { #Alternative randomizer
533 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
534 my $r = $random->irand / 2**32;
535 return int( $r * $max );
539 my ($self, $params) = @_;
540 return $params->{info}->{extra}->{list}->[0];
544 my ($self, $params) = @_;;
548 sub _gen_default_values {
553 gonenoaddress => undef,
558 password_expiration_date => undef,
567 more_subfields_xml => undef,
572 # Not X, used for statistics
573 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
574 min_password_length => undef,
575 require_strong_password => undef,
578 pickup_location => 0,
585 rentalcharge_daily => 0,
586 rentalcharge_hourly => 0,
587 defaultreplacecost => 0,
598 BorrowerAttributeType => {
602 suggesteddate => dt_from_string()->ymd,
606 issue_id => undef, # It should be a FK but we removed it
607 # We don't want to generate a random value
611 import_error => undef
618 t::lib::TestBuilder.pm - Koha module to create test records
622 use t::lib::TestBuilder;
623 my $builder = t::lib::TestBuilder->new;
625 # The following call creates a patron, linked to branch CPL.
626 # Surname is provided, other columns are randomly generated.
627 # Branch CPL is created if it does not exist.
628 my $patron = $builder->build({
629 source => 'Borrower',
630 value => { surname => 'Jansen', branchcode => 'CPL' },
635 This module automatically creates database records for you.
636 If needed, records for foreign keys are created too.
637 Values will be randomly generated if not passed to TestBuilder.
638 Note that you should wrap these actions in a transaction yourself.
644 my $builder = t::lib::TestBuilder->new;
646 Constructor - Returns the object TestBuilder
650 my $schema = $builder->schema;
652 Getter - Returns the schema of DBIx::Class
658 records => $patron, # OR: records => [ $patron, ... ],
661 Delete individual records, created by builder.
662 Returns the number of delete attempts, or undef.
666 $builder->build({ source => $source_name, value => $value });
668 Create a test record in the table, represented by $source_name.
669 The name is required and must conform to the DBIx::Class schema.
670 Values may be specified by the optional $value hashref. Will be
671 randomized otherwise.
672 If needed, TestBuilder creates linked records for foreign keys.
673 Returns the values of the new record as a hashref, or undef if
674 the record could not be created.
676 Note that build also supports recursive hash references inside the
677 value hash for foreign key columns, like:
679 column1 => 'some_value',
681 columnA => 'another_value',
684 The hash for fk_col2 here means: create a linked record with build
685 where columnA has this value. In case of a composite FK the hashes
688 Realize that passing primary key values to build may result in undef
689 if a record with that primary key already exists.
693 Given a plural Koha::Object-derived class, it creates a random element, and
694 returns the corresponding Koha::Object.
696 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
700 Yohann Dufour <yohann.dufour@biblibre.com>
702 Koha Development Team
706 Copyright 2014 - Biblibre SARL
710 This file is part of Koha.
712 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
713 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
715 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.
717 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.