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 $record->encoding( 'UTF-8' );
160 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
161 $record->append_fields(
162 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
165 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
166 $record->append_fields(
167 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
170 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
171 $record->append_fields(
172 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
175 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
176 return Koha::Biblios->find($biblio_id);
179 sub build_sample_item {
180 my ( $self, $args ) = @_;
183 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
184 my $library = delete $args->{library}
185 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
187 # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
189 my $barcode = delete $args->{barcode}
190 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
192 return Koha::Item->new(
194 biblionumber => $biblionumber,
195 homebranch => $library,
196 holdingbranch => $library,
200 )->store->get_from_storage;
203 # ------------------------------------------------------------------------------
204 # Internal helper routines
207 # returns undef for failure to create linked records
208 # otherwise returns hashref containing new column values for parent record
209 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
212 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
214 # First, collect all values for creating a linked record (if needed)
215 foreach my $fk ( @$keys ) {
216 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
217 if( ref( $value->{$col} ) eq 'HASH' ) {
218 # add all keys from the FK hash
219 $fk_value = { %{ $value->{$col} }, %$fk_value };
221 if( exists $col_values->{$col} ) {
222 # add specific value (this does not necessarily exclude some
223 # values from the hash in the preceding if)
224 $fk_value->{ $destcol } = $col_values->{ $col };
226 $cnt_null++ if !defined( $col_values->{$col} );
230 # If we saw all FK columns, first run the following checks
231 if( $cnt_scalar == @$keys ) {
232 # if one or more fk cols are null, the FK constraint will not be forced
233 return {} if $cnt_null > 0;
234 # does the record exist already?
235 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
237 # create record with a recursive build call
238 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
239 return if !$row; # failure
241 # Finally, only return the new values
243 foreach my $fk ( @$keys ) {
244 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
245 next if exists $col_values->{ $col };
246 $rv->{ $col } = $row->{ $destcol };
248 return $rv; # success
253 my $source = $params->{source} || return;
254 $source =~ s|(\w+)$|$1|;
258 sub _buildColumnValues {
259 my ($self, $params) = @_;
260 my $source = _formatSource( $params ) || return;
261 my $original_value = $params->{value};
264 my @columns = $self->schema->source($source)->columns;
265 my %unique_constraints = $self->schema->source($source)->unique_constraints();
268 # we try max $build_value times if there are unique constraints
269 BUILD_VALUE: while ( $build_value ) {
270 # generate random values for all columns
271 for my $col_name( @columns ) {
272 my $valref = $self->_buildColumnValue({
274 column_name => $col_name,
275 value => $original_value,
277 return if !$valref; # failure
278 if( @$valref ) { # could be empty
279 # there will be only one value, but it could be undef
280 $col_values->{$col_name} = $valref->[0];
284 # verify the data would respect each unique constraint
285 # note that this is INCOMPLETE since not all col_values are filled
286 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
289 my $constraint_columns = $unique_constraints{$constraint};
290 # loop through all constraint columns and build the condition
291 foreach my $constraint_column ( @$constraint_columns ) {
293 # if one column does not exist or is undef, skip it
294 # an insert with a null will not trigger the constraint
296 if !exists $col_values->{ $constraint_column } ||
297 !defined $col_values->{ $constraint_column };
298 $condition->{ $constraint_column } =
299 $col_values->{ $constraint_column };
301 my $count = $self->schema
302 ->resultset( $source )
303 ->search( $condition )
306 # no point checking more stuff, exit the loop
311 last; # you passed all tests
313 return $col_values if $build_value > 0;
315 # if you get here, we have a problem
316 warn "Violation of unique constraint in $source";
320 sub _getForeignKeys {
322 # Returns the following arrayref
323 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
324 # The array gives source name and keys for each FK constraint
326 my ($self, $params) = @_;
327 my $source = $self->schema->source( $params->{source} );
329 my ( @foreign_keys, $check_dupl );
330 my @relationships = $source->relationships;
331 for my $rel_name( @relationships ) {
332 my $rel_info = $source->relationship_info($rel_name);
333 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
334 $rel_info->{source} =~ s/^.*:://g;
335 my $rel = { source => $rel_info->{source} };
338 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
339 $col_name =~ s|self.(\w+)|$1|;
340 $col_fk_name =~ s|foreign.(\w+)|$1|;
342 col_name => $col_name,
343 col_fk_name => $col_fk_name,
346 # check if the combination table and keys is unique
347 # so skip double belongs_to relations (as in Biblioitem)
348 my $tag = $rel->{source}. ':'.
349 join ',', sort map { $_->{col_name} } @keys;
350 next if $check_dupl->{$tag};
351 $check_dupl->{$tag} = 1;
352 $rel->{keys} = \@keys;
353 push @foreign_keys, $rel;
356 return \@foreign_keys;
359 sub _storeColumnValues {
360 my ($self, $params) = @_;
361 my $source = $params->{source};
362 my $col_values = $params->{values};
363 my $new_row = $self->schema->resultset( $source )->create( $col_values );
364 return $new_row? { $new_row->get_columns }: {};
367 sub _buildColumnValue {
368 # returns an arrayref if all goes well
369 # an empty arrayref typically means: auto_incr column or fk column
370 # undef means failure
371 my ($self, $params) = @_;
372 my $source = $params->{source};
373 my $value = $params->{value};
374 my $col_name = $params->{column_name};
376 my $col_info = $self->schema->source($source)->column_info($col_name);
379 if( $col_info->{is_auto_increment} ) {
380 if( exists $value->{$col_name} ) {
381 warn "Value not allowed for auto_incr $col_name in $source";
384 # otherwise: no need to assign a value
385 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
386 if( exists $value->{$col_name} ) {
387 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
388 # This explicit undef is not allowed
389 warn "Null value for $col_name in $source not allowed";
392 if( ref( $value->{$col_name} ) ne 'HASH' ) {
393 push @$retvalue, $value->{$col_name};
395 # sub build will handle a passed hash value later on
397 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
398 # this is not allowed for a column that is not a FK
399 warn "Hash not allowed for $col_name in $source";
401 } elsif( exists $value->{$col_name} ) {
402 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
403 # This explicit undef is not allowed
404 warn "Null value for $col_name in $source not allowed";
407 push @$retvalue, $value->{$col_name};
408 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
409 my $v = $self->{default_values}{$source}{$col_name};
410 $v = &$v() if ref($v) eq 'CODE';
413 my $data_type = $col_info->{data_type};
414 $data_type =~ s| |_|;
415 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
416 push @$retvalue, &$hdlr( $self, { info => $col_info } );
418 warn "Unknown type $data_type for $col_name in $source";
426 # This sub is only needed for inconsistencies in the schema
427 # A column is not marked as FK, but a belongs_to relation is defined
428 my ( $source, $column ) = @_;
429 my $inconsistencies = {
430 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
432 return $inconsistencies->{ "$source.$column" };
437 tinyint => \&_gen_int,
438 smallint => \&_gen_int,
439 mediumint => \&_gen_int,
440 integer => \&_gen_int,
441 bigint => \&_gen_int,
443 float => \&_gen_real,
444 decimal => \&_gen_real,
445 double_precision => \&_gen_real,
447 timestamp => \&_gen_datetime,
448 datetime => \&_gen_datetime,
452 varchar => \&_gen_text,
453 tinytext => \&_gen_text,
455 mediumtext => \&_gen_text,
456 longtext => \&_gen_text,
458 set => \&_gen_set_enum,
459 enum => \&_gen_set_enum,
461 tinyblob => \&_gen_blob,
462 mediumblob => \&_gen_blob,
464 longblob => \&_gen_blob,
469 my ($self, $params) = @_;
470 my $data_type = $params->{info}->{data_type};
473 if( $data_type eq 'tinyint' ) {
476 elsif( $data_type eq 'smallint' ) {
479 elsif( $data_type eq 'mediumint' ) {
482 elsif( $data_type eq 'integer' ) {
485 elsif( $data_type eq 'bigint' ) {
486 $max = 9223372036854775807;
488 return int( rand($max+1) );
492 my ($self, $params) = @_;
494 if( defined( $params->{info}->{size} ) ) {
495 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
497 $max = 10 ** 5 if $max > 10 ** 5;
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,
558 more_subfields_xml => undef,
563 # Not X, used for statistics
564 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
565 min_password_length => undef,
566 require_strong_password => undef,
569 pickup_location => 0,
576 rentalcharge_daily => 0,
577 rentalcharge_hourly => 0,
578 defaultreplacecost => 0,
594 t::lib::TestBuilder.pm - Koha module to create test records
598 use t::lib::TestBuilder;
599 my $builder = t::lib::TestBuilder->new;
601 # The following call creates a patron, linked to branch CPL.
602 # Surname is provided, other columns are randomly generated.
603 # Branch CPL is created if it does not exist.
604 my $patron = $builder->build({
605 source => 'Borrower',
606 value => { surname => 'Jansen', branchcode => 'CPL' },
611 This module automatically creates database records for you.
612 If needed, records for foreign keys are created too.
613 Values will be randomly generated if not passed to TestBuilder.
614 Note that you should wrap these actions in a transaction yourself.
620 my $builder = t::lib::TestBuilder->new;
622 Constructor - Returns the object TestBuilder
626 my $schema = $builder->schema;
628 Getter - Returns the schema of DBIx::Class
634 records => $patron, # OR: records => [ $patron, ... ],
637 Delete individual records, created by builder.
638 Returns the number of delete attempts, or undef.
642 $builder->build({ source => $source_name, value => $value });
644 Create a test record in the table, represented by $source_name.
645 The name is required and must conform to the DBIx::Class schema.
646 Values may be specified by the optional $value hashref. Will be
647 randomized otherwise.
648 If needed, TestBuilder creates linked records for foreign keys.
649 Returns the values of the new record as a hashref, or undef if
650 the record could not be created.
652 Note that build also supports recursive hash references inside the
653 value hash for foreign key columns, like:
655 column1 => 'some_value',
657 columnA => 'another_value',
660 The hash for fk_col2 here means: create a linked record with build
661 where columnA has this value. In case of a composite FK the hashes
664 Realize that passing primary key values to build may result in undef
665 if a record with that primary key already exists.
669 Given a plural Koha::Object-derived class, it creates a random element, and
670 returns the corresponding Koha::Object.
672 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
676 Yohann Dufour <yohann.dufour@biblibre.com>
678 Koha Development Team
682 Copyright 2014 - Biblibre SARL
686 This file is part of Koha.
688 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
689 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
691 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.
693 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.