1 package t::lib::TestBuilder;
7 use Bytes::Random::Secure;
15 bless( $self, $class );
17 $self->schema( Koha::Database->new()->schema );
18 $self->schema->storage->sql_maker->quote_char('`');
20 $self->{gen_type} = _gen_type();
21 $self->{default_values} = _gen_default_values();
26 my ($self, $schema) = @_;
28 if( defined( $schema ) ) {
29 $self->{schema} = $schema;
31 return $self->{schema};
34 # sub clear has been obsoleted; use delete_all from the schema resultset
37 my ( $self, $params ) = @_;
38 my $source = $params->{source} || return;
39 my @recs = ref( $params->{records} ) eq 'ARRAY'?
40 @{$params->{records}}: ( $params->{records} // () );
41 # tables without PK are not supported
42 my @pk = $self->schema->source( $source )->primary_columns;
45 foreach my $rec ( @recs ) {
46 # delete only works when you supply full primary key values
47 # $cond does not include searches for undef (not allowed in PK)
48 my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
49 next if keys %$cond < @pk;
50 $self->schema->resultset( $source )->search( $cond )->delete;
51 # we clear the pk columns in the supplied hash
52 # this indirectly signals at least an attempt to delete
53 map { delete $rec->{$_}; } @pk;
60 my ( $self, $params ) = @_;
62 my $class = $params->{class};
63 my $value = $params->{value};
65 if ( not defined $class ) {
66 carp "Missing class param";
71 my $source = $class->_type;
72 my @pks = $self->schema->source( $class->_type )->primary_columns;
74 my $hashref = $self->build({ source => $source, value => $value });
77 foreach my $pk ( @pks ) {
78 push @ids, $hashref->{ $pk };
81 my $object = $class->find( @ids );
87 # build returns a hash of column values for a created record, or undef
88 # build does NOT update a record, or pass back values of an existing record
89 my ($self, $params) = @_;
90 my $source = $params->{source};
92 carp "Source parameter not specified!";
95 my $value = $params->{value};
97 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
98 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
100 my $col_values = $self->_buildColumnValues({
104 return if !$col_values; # did not meet unique constraints?
106 # loop thru all fk and create linked records if needed
107 # fills remaining entries in $col_values
108 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
109 for my $fk ( @$foreign_keys ) {
110 # skip when FK points to itself: e.g. borrowers:guarantorid
111 next if $fk->{source} eq $source;
112 my $keys = $fk->{keys};
113 my $tbl = $fk->{source};
114 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
115 return if !$res; # failed: no need to go further
116 foreach( keys %$res ) { # save new values
117 $col_values->{$_} = $res->{$_};
121 # store this record and return hashref
122 return $self->_storeColumnValues({
124 values => $col_values,
129 my ( $self, $args ) = @_;
131 my $itemtype = $args->{itemtype} || $self->build_object({ class => 'Koha::ItemTypes' })->itemtype;
132 my $title = $args->{title} || 'Some boring read';
134 my $record = MARC::Record->new();
135 $record->append_fields(
136 MARC::Field->new( '245', ' ', ' ', a => $title ),
137 MARC::Field->new( '942', ' ', ' ', c => $itemtype )
140 my ($biblio_id) = AddBiblio( $record, '' );
141 return Koha::Biblios->find($biblio_id);
144 # ------------------------------------------------------------------------------
145 # Internal helper routines
148 # returns undef for failure to create linked records
149 # otherwise returns hashref containing new column values for parent record
150 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
153 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
155 # First, collect all values for creating a linked record (if needed)
156 foreach my $fk ( @$keys ) {
157 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
158 if( ref( $value->{$col} ) eq 'HASH' ) {
159 # add all keys from the FK hash
160 $fk_value = { %{ $value->{$col} }, %$fk_value };
162 if( exists $col_values->{$col} ) {
163 # add specific value (this does not necessarily exclude some
164 # values from the hash in the preceding if)
165 $fk_value->{ $destcol } = $col_values->{ $col };
167 $cnt_null++ if !defined( $col_values->{$col} );
171 # If we saw all FK columns, first run the following checks
172 if( $cnt_scalar == @$keys ) {
173 # if one or more fk cols are null, the FK constraint will not be forced
174 return {} if $cnt_null > 0;
175 # does the record exist already?
176 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
178 # create record with a recursive build call
179 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
180 return if !$row; # failure
182 # Finally, only return the new values
184 foreach my $fk ( @$keys ) {
185 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
186 next if exists $col_values->{ $col };
187 $rv->{ $col } = $row->{ $destcol };
189 return $rv; # success
194 my $source = $params->{source} || return;
195 $source =~ s|(\w+)$|$1|;
199 sub _buildColumnValues {
200 my ($self, $params) = @_;
201 my $source = _formatSource( $params ) || return;
202 my $original_value = $params->{value};
205 my @columns = $self->schema->source($source)->columns;
206 my %unique_constraints = $self->schema->source($source)->unique_constraints();
209 # we try max $build_value times if there are unique constraints
210 BUILD_VALUE: while ( $build_value ) {
211 # generate random values for all columns
212 for my $col_name( @columns ) {
213 my $valref = $self->_buildColumnValue({
215 column_name => $col_name,
216 value => $original_value,
218 return if !$valref; # failure
219 if( @$valref ) { # could be empty
220 # there will be only one value, but it could be undef
221 $col_values->{$col_name} = $valref->[0];
225 # verify the data would respect each unique constraint
226 # note that this is INCOMPLETE since not all col_values are filled
227 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
230 my $constraint_columns = $unique_constraints{$constraint};
231 # loop through all constraint columns and build the condition
232 foreach my $constraint_column ( @$constraint_columns ) {
234 # if one column does not exist or is undef, skip it
235 # an insert with a null will not trigger the constraint
237 if !exists $col_values->{ $constraint_column } ||
238 !defined $col_values->{ $constraint_column };
239 $condition->{ $constraint_column } =
240 $col_values->{ $constraint_column };
242 my $count = $self->schema
243 ->resultset( $source )
244 ->search( $condition )
247 # no point checking more stuff, exit the loop
252 last; # you passed all tests
254 return $col_values if $build_value > 0;
256 # if you get here, we have a problem
257 warn "Violation of unique constraint in $source";
261 sub _getForeignKeys {
263 # Returns the following arrayref
264 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
265 # The array gives source name and keys for each FK constraint
267 my ($self, $params) = @_;
268 my $source = $self->schema->source( $params->{source} );
270 my ( @foreign_keys, $check_dupl );
271 my @relationships = $source->relationships;
272 for my $rel_name( @relationships ) {
273 my $rel_info = $source->relationship_info($rel_name);
274 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
275 $rel_info->{source} =~ s/^.*:://g;
276 my $rel = { source => $rel_info->{source} };
279 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
280 $col_name =~ s|self.(\w+)|$1|;
281 $col_fk_name =~ s|foreign.(\w+)|$1|;
283 col_name => $col_name,
284 col_fk_name => $col_fk_name,
287 # check if the combination table and keys is unique
288 # so skip double belongs_to relations (as in Biblioitem)
289 my $tag = $rel->{source}. ':'.
290 join ',', sort map { $_->{col_name} } @keys;
291 next if $check_dupl->{$tag};
292 $check_dupl->{$tag} = 1;
293 $rel->{keys} = \@keys;
294 push @foreign_keys, $rel;
297 return \@foreign_keys;
300 sub _storeColumnValues {
301 my ($self, $params) = @_;
302 my $source = $params->{source};
303 my $col_values = $params->{values};
304 my $new_row = $self->schema->resultset( $source )->create( $col_values );
305 return $new_row? { $new_row->get_columns }: {};
308 sub _buildColumnValue {
309 # returns an arrayref if all goes well
310 # an empty arrayref typically means: auto_incr column or fk column
311 # undef means failure
312 my ($self, $params) = @_;
313 my $source = $params->{source};
314 my $value = $params->{value};
315 my $col_name = $params->{column_name};
317 my $col_info = $self->schema->source($source)->column_info($col_name);
320 if( $col_info->{is_auto_increment} ) {
321 if( exists $value->{$col_name} ) {
322 warn "Value not allowed for auto_incr $col_name in $source";
325 # otherwise: no need to assign a value
326 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
327 if( exists $value->{$col_name} ) {
328 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
329 # This explicit undef is not allowed
330 warn "Null value for $col_name in $source not allowed";
333 if( ref( $value->{$col_name} ) ne 'HASH' ) {
334 push @$retvalue, $value->{$col_name};
336 # sub build will handle a passed hash value later on
338 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
339 # this is not allowed for a column that is not a FK
340 warn "Hash not allowed for $col_name in $source";
342 } elsif( exists $value->{$col_name} ) {
343 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
344 # This explicit undef is not allowed
345 warn "Null value for $col_name in $source not allowed";
348 push @$retvalue, $value->{$col_name};
349 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
350 push @$retvalue, $self->{default_values}{$source}{$col_name};
352 my $data_type = $col_info->{data_type};
353 $data_type =~ s| |_|;
354 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
355 push @$retvalue, &$hdlr( $self, { info => $col_info } );
357 warn "Unknown type $data_type for $col_name in $source";
365 # This sub is only needed for inconsistencies in the schema
366 # A column is not marked as FK, but a belongs_to relation is defined
367 my ( $source, $column ) = @_;
368 my $inconsistencies = {
369 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
371 return $inconsistencies->{ "$source.$column" };
376 tinyint => \&_gen_int,
377 smallint => \&_gen_int,
378 mediumint => \&_gen_int,
379 integer => \&_gen_int,
380 bigint => \&_gen_int,
382 float => \&_gen_real,
383 decimal => \&_gen_real,
384 double_precision => \&_gen_real,
386 timestamp => \&_gen_datetime,
387 datetime => \&_gen_datetime,
391 varchar => \&_gen_text,
392 tinytext => \&_gen_text,
394 mediumtext => \&_gen_text,
395 longtext => \&_gen_text,
397 set => \&_gen_set_enum,
398 enum => \&_gen_set_enum,
400 tinyblob => \&_gen_blob,
401 mediumblob => \&_gen_blob,
403 longblob => \&_gen_blob,
408 my ($self, $params) = @_;
409 my $data_type = $params->{info}->{data_type};
412 if( $data_type eq 'tinyint' ) {
415 elsif( $data_type eq 'smallint' ) {
418 elsif( $data_type eq 'mediumint' ) {
421 elsif( $data_type eq 'integer' ) {
424 elsif( $data_type eq 'bigint' ) {
425 $max = 9223372036854775807;
427 return int( rand($max+1) );
431 my ($self, $params) = @_;
433 if( defined( $params->{info}->{size} ) ) {
434 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
436 return sprintf("%.2f", rand($max-0.1));
440 my ($self, $params) = @_;
441 return $self->schema->storage->datetime_parser->format_date(DateTime->now())
445 my ($self, $params) = @_;
446 return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
450 my ($self, $params) = @_;
451 # From perldoc String::Random
452 my $size = $params->{info}{size} // 10;
453 $size -= alt_rand(0.5 * $size);
454 my $regex = $size > 1
455 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
457 my $random = String::Random->new( rand_gen => \&alt_rand );
458 # rand_gen is only supported from 0.27 onward
459 return $random->randregex($regex);
462 sub alt_rand { #Alternative randomizer
464 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
465 my $r = $random->irand / 2**32;
466 return int( $r * $max );
470 my ($self, $params) = @_;
471 return $params->{info}->{extra}->{list}->[0];
475 my ($self, $params) = @_;;
479 sub _gen_default_values {
484 gonenoaddress => undef,
494 more_subfields_xml => undef,
502 defaultreplacecost => 0,
520 t::lib::TestBuilder.pm - Koha module to create test records
524 use t::lib::TestBuilder;
525 my $builder = t::lib::TestBuilder->new;
527 # The following call creates a patron, linked to branch CPL.
528 # Surname is provided, other columns are randomly generated.
529 # Branch CPL is created if it does not exist.
530 my $patron = $builder->build({
531 source => 'Borrower',
532 value => { surname => 'Jansen', branchcode => 'CPL' },
537 This module automatically creates database records for you.
538 If needed, records for foreign keys are created too.
539 Values will be randomly generated if not passed to TestBuilder.
540 Note that you should wrap these actions in a transaction yourself.
546 my $builder = t::lib::TestBuilder->new;
548 Constructor - Returns the object TestBuilder
552 my $schema = $builder->schema;
554 Getter - Returns the schema of DBIx::Class
560 records => $patron, # OR: records => [ $patron, ... ],
563 Delete individual records, created by builder.
564 Returns the number of delete attempts, or undef.
568 $builder->build({ source => $source_name, value => $value });
570 Create a test record in the table, represented by $source_name.
571 The name is required and must conform to the DBIx::Class schema.
572 Values may be specified by the optional $value hashref. Will be
573 randomized otherwise.
574 If needed, TestBuilder creates linked records for foreign keys.
575 Returns the values of the new record as a hashref, or undef if
576 the record could not be created.
578 Note that build also supports recursive hash references inside the
579 value hash for foreign key columns, like:
581 column1 => 'some_value',
583 columnA => 'another_value',
586 The hash for fk_col2 here means: create a linked record with build
587 where columnA has this value. In case of a composite FK the hashes
590 Realize that passing primary key values to build may result in undef
591 if a record with that primary key already exists.
595 Given a plural Koha::Object-derived class, it creates a random element, and
596 returns the corresponding Koha::Object.
598 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
602 Yohann Dufour <yohann.dufour@biblibre.com>
604 Koha Development Team
608 Copyright 2014 - Biblibre SARL
612 This file is part of Koha.
614 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
615 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
617 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.
619 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.