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;
235 # does the record exist already?
236 my @pks = $self->schema->source( $linked_tbl )->primary_columns;
239 $fk_pk_value{$_} = $fk_value->{$_} if defined $fk_value->{$_};
241 return {} if !(keys %fk_pk_value);
242 return {} if $self->schema->resultset($linked_tbl)->find( \%fk_pk_value );
244 # create record with a recursive build call
245 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
246 return if !$row; # failure
248 # Finally, only return the new values
250 foreach my $fk ( @$keys ) {
251 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
252 next if exists $col_values->{ $col };
253 $rv->{ $col } = $row->{ $destcol };
255 return $rv; # success
260 my $source = $params->{source} || return;
261 $source =~ s|(\w+)$|$1|;
265 sub _buildColumnValues {
266 my ($self, $params) = @_;
267 my $source = _formatSource( $params ) || return;
268 my $original_value = $params->{value};
271 my @columns = $self->schema->source($source)->columns;
272 my %unique_constraints = $self->schema->source($source)->unique_constraints();
275 # we try max $build_value times if there are unique constraints
276 BUILD_VALUE: while ( $build_value ) {
277 # generate random values for all columns
278 for my $col_name( @columns ) {
279 my $valref = $self->_buildColumnValue({
281 column_name => $col_name,
282 value => $original_value,
284 return if !$valref; # failure
285 if( @$valref ) { # could be empty
286 # there will be only one value, but it could be undef
287 $col_values->{$col_name} = $valref->[0];
291 # verify the data would respect each unique constraint
292 # note that this is INCOMPLETE since not all col_values are filled
293 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
296 my $constraint_columns = $unique_constraints{$constraint};
297 # loop through all constraint columns and build the condition
298 foreach my $constraint_column ( @$constraint_columns ) {
300 # if one column does not exist or is undef, skip it
301 # an insert with a null will not trigger the constraint
303 if !exists $col_values->{ $constraint_column } ||
304 !defined $col_values->{ $constraint_column };
305 $condition->{ $constraint_column } =
306 $col_values->{ $constraint_column };
308 my $count = $self->schema
309 ->resultset( $source )
310 ->search( $condition )
313 # no point checking more stuff, exit the loop
318 last; # you passed all tests
320 return $col_values if $build_value > 0;
322 # if you get here, we have a problem
323 warn "Violation of unique constraint in $source";
327 sub _getForeignKeys {
329 # Returns the following arrayref
330 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
331 # The array gives source name and keys for each FK constraint
333 my ($self, $params) = @_;
334 my $source = $self->schema->source( $params->{source} );
336 my ( @foreign_keys, $check_dupl );
337 my @relationships = $source->relationships;
338 for my $rel_name( @relationships ) {
339 my $rel_info = $source->relationship_info($rel_name);
340 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
341 $rel_info->{source} =~ s/^.*:://g;
342 my $rel = { source => $rel_info->{source} };
345 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
346 $col_name =~ s|self.(\w+)|$1|;
347 $col_fk_name =~ s|foreign.(\w+)|$1|;
349 col_name => $col_name,
350 col_fk_name => $col_fk_name,
353 # check if the combination table and keys is unique
354 # so skip double belongs_to relations (as in Biblioitem)
355 my $tag = $rel->{source}. ':'.
356 join ',', sort map { $_->{col_name} } @keys;
357 next if $check_dupl->{$tag};
358 $check_dupl->{$tag} = 1;
359 $rel->{keys} = \@keys;
360 push @foreign_keys, $rel;
363 return \@foreign_keys;
366 sub _storeColumnValues {
367 my ($self, $params) = @_;
368 my $source = $params->{source};
369 my $col_values = $params->{values};
370 my $new_row = $self->schema->resultset( $source )->create( $col_values );
371 return $new_row? { $new_row->get_columns }: {};
374 sub _buildColumnValue {
375 # returns an arrayref if all goes well
376 # an empty arrayref typically means: auto_incr column or fk column
377 # undef means failure
378 my ($self, $params) = @_;
379 my $source = $params->{source};
380 my $value = $params->{value};
381 my $col_name = $params->{column_name};
383 my $col_info = $self->schema->source($source)->column_info($col_name);
386 if( $col_info->{is_auto_increment} ) {
387 if( exists $value->{$col_name} ) {
388 warn "Value not allowed for auto_incr $col_name in $source";
391 # otherwise: no need to assign a value
392 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
393 if( exists $value->{$col_name} ) {
394 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
395 # This explicit undef is not allowed
396 warn "Null value for $col_name in $source not allowed";
399 if( ref( $value->{$col_name} ) ne 'HASH' ) {
400 push @$retvalue, $value->{$col_name};
402 # sub build will handle a passed hash value later on
404 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
405 # this is not allowed for a column that is not a FK
406 warn "Hash not allowed for $col_name in $source";
408 } elsif( exists $value->{$col_name} ) {
409 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
410 # This explicit undef is not allowed
411 warn "Null value for $col_name in $source not allowed";
414 push @$retvalue, $value->{$col_name};
415 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
416 my $v = $self->{default_values}{$source}{$col_name};
417 $v = &$v() if ref($v) eq 'CODE';
420 my $data_type = $col_info->{data_type};
421 $data_type =~ s| |_|;
422 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
423 push @$retvalue, &$hdlr( $self, { info => $col_info } );
425 warn "Unknown type $data_type for $col_name in $source";
433 # This sub is only needed for inconsistencies in the schema
434 # A column is not marked as FK, but a belongs_to relation is defined
435 my ( $source, $column ) = @_;
436 my $inconsistencies = {
437 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
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,
565 more_subfields_xml => undef,
570 # Not X, used for statistics
571 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
572 min_password_length => undef,
573 require_strong_password => undef,
576 pickup_location => 0,
583 rentalcharge_daily => 0,
584 rentalcharge_hourly => 0,
585 defaultreplacecost => 0,
601 t::lib::TestBuilder.pm - Koha module to create test records
605 use t::lib::TestBuilder;
606 my $builder = t::lib::TestBuilder->new;
608 # The following call creates a patron, linked to branch CPL.
609 # Surname is provided, other columns are randomly generated.
610 # Branch CPL is created if it does not exist.
611 my $patron = $builder->build({
612 source => 'Borrower',
613 value => { surname => 'Jansen', branchcode => 'CPL' },
618 This module automatically creates database records for you.
619 If needed, records for foreign keys are created too.
620 Values will be randomly generated if not passed to TestBuilder.
621 Note that you should wrap these actions in a transaction yourself.
627 my $builder = t::lib::TestBuilder->new;
629 Constructor - Returns the object TestBuilder
633 my $schema = $builder->schema;
635 Getter - Returns the schema of DBIx::Class
641 records => $patron, # OR: records => [ $patron, ... ],
644 Delete individual records, created by builder.
645 Returns the number of delete attempts, or undef.
649 $builder->build({ source => $source_name, value => $value });
651 Create a test record in the table, represented by $source_name.
652 The name is required and must conform to the DBIx::Class schema.
653 Values may be specified by the optional $value hashref. Will be
654 randomized otherwise.
655 If needed, TestBuilder creates linked records for foreign keys.
656 Returns the values of the new record as a hashref, or undef if
657 the record could not be created.
659 Note that build also supports recursive hash references inside the
660 value hash for foreign key columns, like:
662 column1 => 'some_value',
664 columnA => 'another_value',
667 The hash for fk_col2 here means: create a linked record with build
668 where columnA has this value. In case of a composite FK the hashes
671 Realize that passing primary key values to build may result in undef
672 if a record with that primary key already exists.
676 Given a plural Koha::Object-derived class, it creates a random element, and
677 returns the corresponding Koha::Object.
679 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
683 Yohann Dufour <yohann.dufour@biblibre.com>
685 Koha Development Team
689 Copyright 2014 - Biblibre SARL
693 This file is part of Koha.
695 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
696 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
698 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.
700 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.