1 package t::lib::TestBuilder;
10 use Koha::DateUtils qw( dt_from_string );
12 use Bytes::Random::Secure;
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 } );
127 for my $fk ( @$foreign_keys ) {
128 # skip when FK points to itself: e.g. borrowers:guarantorid
129 next if $fk->{source} eq $source;
130 my $keys = $fk->{keys};
131 my $tbl = $fk->{source};
132 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
133 return if !$res; # failed: no need to go further
134 foreach( keys %$res ) { # save new values
135 $col_values->{$_} = $res->{$_};
139 # store this record and return hashref
140 return $self->_storeColumnValues({
142 values => $col_values,
146 sub build_sample_biblio {
147 my ( $self, $args ) = @_;
149 my $title = $args->{title} || 'Some boring read';
150 my $author = $args->{author} || 'Some boring author';
151 my $frameworkcode = $args->{frameworkcode} || '';
152 my $itemtype = $args->{itemtype}
153 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
155 my $marcflavour = C4::Context->preference('marcflavour');
157 my $record = MARC::Record->new();
158 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
159 $record->append_fields(
160 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
163 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
164 $record->append_fields(
165 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
168 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
169 $record->append_fields(
170 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
173 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
174 return Koha::Biblios->find($biblio_id);
177 sub build_sample_item {
178 my ( $self, $args ) = @_;
181 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
182 my $library = delete $args->{library}
183 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
185 my $itype = delete $args->{itype}
186 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
188 my $barcode = delete $args->{barcode}
189 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
191 my ( undef, undef, $itemnumber ) = C4::Items::AddItem(
193 homebranch => $library,
194 holdingbranch => $library,
201 return Koha::Items->find($itemnumber);
204 # ------------------------------------------------------------------------------
205 # Internal helper routines
208 # returns undef for failure to create linked records
209 # otherwise returns hashref containing new column values for parent record
210 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
213 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
215 # First, collect all values for creating a linked record (if needed)
216 foreach my $fk ( @$keys ) {
217 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
218 if( ref( $value->{$col} ) eq 'HASH' ) {
219 # add all keys from the FK hash
220 $fk_value = { %{ $value->{$col} }, %$fk_value };
222 if( exists $col_values->{$col} ) {
223 # add specific value (this does not necessarily exclude some
224 # values from the hash in the preceding if)
225 $fk_value->{ $destcol } = $col_values->{ $col };
227 $cnt_null++ if !defined( $col_values->{$col} );
231 # If we saw all FK columns, first run the following checks
232 if( $cnt_scalar == @$keys ) {
233 # if one or more fk cols are null, the FK constraint will not be forced
234 return {} if $cnt_null > 0;
235 # does the record exist already?
236 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
238 # create record with a recursive build call
239 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
240 return if !$row; # failure
242 # Finally, only return the new values
244 foreach my $fk ( @$keys ) {
245 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
246 next if exists $col_values->{ $col };
247 $rv->{ $col } = $row->{ $destcol };
249 return $rv; # success
254 my $source = $params->{source} || return;
255 $source =~ s|(\w+)$|$1|;
259 sub _buildColumnValues {
260 my ($self, $params) = @_;
261 my $source = _formatSource( $params ) || return;
262 my $original_value = $params->{value};
265 my @columns = $self->schema->source($source)->columns;
266 my %unique_constraints = $self->schema->source($source)->unique_constraints();
269 # we try max $build_value times if there are unique constraints
270 BUILD_VALUE: while ( $build_value ) {
271 # generate random values for all columns
272 for my $col_name( @columns ) {
273 my $valref = $self->_buildColumnValue({
275 column_name => $col_name,
276 value => $original_value,
278 return if !$valref; # failure
279 if( @$valref ) { # could be empty
280 # there will be only one value, but it could be undef
281 $col_values->{$col_name} = $valref->[0];
285 # verify the data would respect each unique constraint
286 # note that this is INCOMPLETE since not all col_values are filled
287 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
290 my $constraint_columns = $unique_constraints{$constraint};
291 # loop through all constraint columns and build the condition
292 foreach my $constraint_column ( @$constraint_columns ) {
294 # if one column does not exist or is undef, skip it
295 # an insert with a null will not trigger the constraint
297 if !exists $col_values->{ $constraint_column } ||
298 !defined $col_values->{ $constraint_column };
299 $condition->{ $constraint_column } =
300 $col_values->{ $constraint_column };
302 my $count = $self->schema
303 ->resultset( $source )
304 ->search( $condition )
307 # no point checking more stuff, exit the loop
312 last; # you passed all tests
314 return $col_values if $build_value > 0;
316 # if you get here, we have a problem
317 warn "Violation of unique constraint in $source";
321 sub _getForeignKeys {
323 # Returns the following arrayref
324 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
325 # The array gives source name and keys for each FK constraint
327 my ($self, $params) = @_;
328 my $source = $self->schema->source( $params->{source} );
330 my ( @foreign_keys, $check_dupl );
331 my @relationships = $source->relationships;
332 for my $rel_name( @relationships ) {
333 my $rel_info = $source->relationship_info($rel_name);
334 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
335 $rel_info->{source} =~ s/^.*:://g;
336 my $rel = { source => $rel_info->{source} };
339 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
340 $col_name =~ s|self.(\w+)|$1|;
341 $col_fk_name =~ s|foreign.(\w+)|$1|;
343 col_name => $col_name,
344 col_fk_name => $col_fk_name,
347 # check if the combination table and keys is unique
348 # so skip double belongs_to relations (as in Biblioitem)
349 my $tag = $rel->{source}. ':'.
350 join ',', sort map { $_->{col_name} } @keys;
351 next if $check_dupl->{$tag};
352 $check_dupl->{$tag} = 1;
353 $rel->{keys} = \@keys;
354 push @foreign_keys, $rel;
357 return \@foreign_keys;
360 sub _storeColumnValues {
361 my ($self, $params) = @_;
362 my $source = $params->{source};
363 my $col_values = $params->{values};
364 my $new_row = $self->schema->resultset( $source )->create( $col_values );
365 return $new_row? { $new_row->get_columns }: {};
368 sub _buildColumnValue {
369 # returns an arrayref if all goes well
370 # an empty arrayref typically means: auto_incr column or fk column
371 # undef means failure
372 my ($self, $params) = @_;
373 my $source = $params->{source};
374 my $value = $params->{value};
375 my $col_name = $params->{column_name};
377 my $col_info = $self->schema->source($source)->column_info($col_name);
380 if( $col_info->{is_auto_increment} ) {
381 if( exists $value->{$col_name} ) {
382 warn "Value not allowed for auto_incr $col_name in $source";
385 # otherwise: no need to assign a value
386 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
387 if( exists $value->{$col_name} ) {
388 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
389 # This explicit undef is not allowed
390 warn "Null value for $col_name in $source not allowed";
393 if( ref( $value->{$col_name} ) ne 'HASH' ) {
394 push @$retvalue, $value->{$col_name};
396 # sub build will handle a passed hash value later on
398 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
399 # this is not allowed for a column that is not a FK
400 warn "Hash not allowed for $col_name in $source";
402 } elsif( 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 push @$retvalue, $value->{$col_name};
409 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
410 my $v = $self->{default_values}{$source}{$col_name};
411 $v = &$v() if ref($v) eq 'CODE';
414 my $data_type = $col_info->{data_type};
415 $data_type =~ s| |_|;
416 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
417 push @$retvalue, &$hdlr( $self, { info => $col_info } );
419 warn "Unknown type $data_type for $col_name in $source";
427 # This sub is only needed for inconsistencies in the schema
428 # A column is not marked as FK, but a belongs_to relation is defined
429 my ( $source, $column ) = @_;
430 my $inconsistencies = {
431 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
433 return $inconsistencies->{ "$source.$column" };
438 tinyint => \&_gen_int,
439 smallint => \&_gen_int,
440 mediumint => \&_gen_int,
441 integer => \&_gen_int,
442 bigint => \&_gen_int,
444 float => \&_gen_real,
445 decimal => \&_gen_real,
446 double_precision => \&_gen_real,
448 timestamp => \&_gen_datetime,
449 datetime => \&_gen_datetime,
453 varchar => \&_gen_text,
454 tinytext => \&_gen_text,
456 mediumtext => \&_gen_text,
457 longtext => \&_gen_text,
459 set => \&_gen_set_enum,
460 enum => \&_gen_set_enum,
462 tinyblob => \&_gen_blob,
463 mediumblob => \&_gen_blob,
465 longblob => \&_gen_blob,
470 my ($self, $params) = @_;
471 my $data_type = $params->{info}->{data_type};
474 if( $data_type eq 'tinyint' ) {
477 elsif( $data_type eq 'smallint' ) {
480 elsif( $data_type eq 'mediumint' ) {
483 elsif( $data_type eq 'integer' ) {
486 elsif( $data_type eq 'bigint' ) {
487 $max = 9223372036854775807;
489 return int( rand($max+1) );
493 my ($self, $params) = @_;
495 if( defined( $params->{info}->{size} ) ) {
496 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
498 return sprintf("%.2f", rand($max-0.1));
502 my ($self, $params) = @_;
503 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
507 my ($self, $params) = @_;
508 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
512 my ($self, $params) = @_;
513 # From perldoc String::Random
514 my $size = $params->{info}{size} // 10;
515 $size -= alt_rand(0.5 * $size);
516 my $regex = $size > 1
517 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
519 my $random = String::Random->new( rand_gen => \&alt_rand );
520 # rand_gen is only supported from 0.27 onward
521 return $random->randregex($regex);
524 sub alt_rand { #Alternative randomizer
526 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
527 my $r = $random->irand / 2**32;
528 return int( $r * $max );
532 my ($self, $params) = @_;
533 return $params->{info}->{extra}->{list}->[0];
537 my ($self, $params) = @_;;
541 sub _gen_default_values {
546 gonenoaddress => undef,
557 more_subfields_xml => undef,
562 # Not X, used for statistics
563 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
567 rentalcharge_daily => 0,
568 rentalcharge_hourly => 0,
569 defaultreplacecost => 0,
580 RefundLostItemFeeRules => {
581 rule_name => 'refund',
588 t::lib::TestBuilder.pm - Koha module to create test records
592 use t::lib::TestBuilder;
593 my $builder = t::lib::TestBuilder->new;
595 # The following call creates a patron, linked to branch CPL.
596 # Surname is provided, other columns are randomly generated.
597 # Branch CPL is created if it does not exist.
598 my $patron = $builder->build({
599 source => 'Borrower',
600 value => { surname => 'Jansen', branchcode => 'CPL' },
605 This module automatically creates database records for you.
606 If needed, records for foreign keys are created too.
607 Values will be randomly generated if not passed to TestBuilder.
608 Note that you should wrap these actions in a transaction yourself.
614 my $builder = t::lib::TestBuilder->new;
616 Constructor - Returns the object TestBuilder
620 my $schema = $builder->schema;
622 Getter - Returns the schema of DBIx::Class
628 records => $patron, # OR: records => [ $patron, ... ],
631 Delete individual records, created by builder.
632 Returns the number of delete attempts, or undef.
636 $builder->build({ source => $source_name, value => $value });
638 Create a test record in the table, represented by $source_name.
639 The name is required and must conform to the DBIx::Class schema.
640 Values may be specified by the optional $value hashref. Will be
641 randomized otherwise.
642 If needed, TestBuilder creates linked records for foreign keys.
643 Returns the values of the new record as a hashref, or undef if
644 the record could not be created.
646 Note that build also supports recursive hash references inside the
647 value hash for foreign key columns, like:
649 column1 => 'some_value',
651 columnA => 'another_value',
654 The hash for fk_col2 here means: create a linked record with build
655 where columnA has this value. In case of a composite FK the hashes
658 Realize that passing primary key values to build may result in undef
659 if a record with that primary key already exists.
663 Given a plural Koha::Object-derived class, it creates a random element, and
664 returns the corresponding Koha::Object.
666 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
670 Yohann Dufour <yohann.dufour@biblibre.com>
672 Koha Development Team
676 Copyright 2014 - Biblibre SARL
680 This file is part of Koha.
682 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
683 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
685 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.
687 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.