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,
128 # ------------------------------------------------------------------------------
129 # Internal helper routines
132 # returns undef for failure to create linked records
133 # otherwise returns hashref containing new column values for parent record
134 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
137 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
139 # First, collect all values for creating a linked record (if needed)
140 foreach my $fk ( @$keys ) {
141 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
142 if( ref( $value->{$col} ) eq 'HASH' ) {
143 # add all keys from the FK hash
144 $fk_value = { %{ $value->{$col} }, %$fk_value };
146 if( exists $col_values->{$col} ) {
147 # add specific value (this does not necessarily exclude some
148 # values from the hash in the preceding if)
149 $fk_value->{ $destcol } = $col_values->{ $col };
151 $cnt_null++ if !defined( $col_values->{$col} );
155 # If we saw all FK columns, first run the following checks
156 if( $cnt_scalar == @$keys ) {
157 # if one or more fk cols are null, the FK constraint will not be forced
158 return {} if $cnt_null > 0;
159 # does the record exist already?
160 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
162 # create record with a recursive build call
163 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
164 return if !$row; # failure
166 # Finally, only return the new values
168 foreach my $fk ( @$keys ) {
169 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
170 next if exists $col_values->{ $col };
171 $rv->{ $col } = $row->{ $destcol };
173 return $rv; # success
178 my $source = $params->{source} || return;
179 $source =~ s|(\w+)$|$1|;
183 sub _buildColumnValues {
184 my ($self, $params) = @_;
185 my $source = _formatSource( $params ) || return;
186 my $original_value = $params->{value};
189 my @columns = $self->schema->source($source)->columns;
190 my %unique_constraints = $self->schema->source($source)->unique_constraints();
193 # we try max $build_value times if there are unique constraints
194 BUILD_VALUE: while ( $build_value ) {
195 # generate random values for all columns
196 for my $col_name( @columns ) {
197 my $valref = $self->_buildColumnValue({
199 column_name => $col_name,
200 value => $original_value,
202 return if !$valref; # failure
203 if( @$valref ) { # could be empty
204 # there will be only one value, but it could be undef
205 $col_values->{$col_name} = $valref->[0];
209 # verify the data would respect each unique constraint
210 # note that this is INCOMPLETE since not all col_values are filled
211 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
214 my $constraint_columns = $unique_constraints{$constraint};
215 # loop through all constraint columns and build the condition
216 foreach my $constraint_column ( @$constraint_columns ) {
218 # if one column does not exist or is undef, skip it
219 # an insert with a null will not trigger the constraint
221 if !exists $col_values->{ $constraint_column } ||
222 !defined $col_values->{ $constraint_column };
223 $condition->{ $constraint_column } =
224 $col_values->{ $constraint_column };
226 my $count = $self->schema
227 ->resultset( $source )
228 ->search( $condition )
231 # no point checking more stuff, exit the loop
236 last; # you passed all tests
238 return $col_values if $build_value > 0;
240 # if you get here, we have a problem
241 warn "Violation of unique constraint in $source";
245 sub _getForeignKeys {
247 # Returns the following arrayref
248 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
249 # The array gives source name and keys for each FK constraint
251 my ($self, $params) = @_;
252 my $source = $self->schema->source( $params->{source} );
254 my ( @foreign_keys, $check_dupl );
255 my @relationships = $source->relationships;
256 for my $rel_name( @relationships ) {
257 my $rel_info = $source->relationship_info($rel_name);
258 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
259 $rel_info->{source} =~ s/^.*:://g;
260 my $rel = { source => $rel_info->{source} };
263 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
264 $col_name =~ s|self.(\w+)|$1|;
265 $col_fk_name =~ s|foreign.(\w+)|$1|;
267 col_name => $col_name,
268 col_fk_name => $col_fk_name,
271 # check if the combination table and keys is unique
272 # so skip double belongs_to relations (as in Biblioitem)
273 my $tag = $rel->{source}. ':'.
274 join ',', sort map { $_->{col_name} } @keys;
275 next if $check_dupl->{$tag};
276 $check_dupl->{$tag} = 1;
277 $rel->{keys} = \@keys;
278 push @foreign_keys, $rel;
281 return \@foreign_keys;
284 sub _storeColumnValues {
285 my ($self, $params) = @_;
286 my $source = $params->{source};
287 my $col_values = $params->{values};
288 my $new_row = $self->schema->resultset( $source )->create( $col_values );
289 return $new_row? { $new_row->get_columns }: {};
292 sub _buildColumnValue {
293 # returns an arrayref if all goes well
294 # an empty arrayref typically means: auto_incr column or fk column
295 # undef means failure
296 my ($self, $params) = @_;
297 my $source = $params->{source};
298 my $value = $params->{value};
299 my $col_name = $params->{column_name};
301 my $col_info = $self->schema->source($source)->column_info($col_name);
304 if( $col_info->{is_auto_increment} ) {
305 if( exists $value->{$col_name} ) {
306 warn "Value not allowed for auto_incr $col_name in $source";
309 # otherwise: no need to assign a value
310 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
311 if( exists $value->{$col_name} ) {
312 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
313 # This explicit undef is not allowed
314 warn "Null value for $col_name in $source not allowed";
317 if( ref( $value->{$col_name} ) ne 'HASH' ) {
318 push @$retvalue, $value->{$col_name};
320 # sub build will handle a passed hash value later on
322 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
323 # this is not allowed for a column that is not a FK
324 warn "Hash not allowed for $col_name in $source";
326 } elsif( exists $value->{$col_name} ) {
327 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
328 # This explicit undef is not allowed
329 warn "Null value for $col_name in $source not allowed";
332 push @$retvalue, $value->{$col_name};
333 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
334 push @$retvalue, $self->{default_values}{$source}{$col_name};
336 my $data_type = $col_info->{data_type};
337 $data_type =~ s| |_|;
338 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
339 push @$retvalue, &$hdlr( $self, { info => $col_info } );
341 warn "Unknown type $data_type for $col_name in $source";
349 # This sub is only needed for inconsistencies in the schema
350 # A column is not marked as FK, but a belongs_to relation is defined
351 my ( $source, $column ) = @_;
352 my $inconsistencies = {
353 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
355 return $inconsistencies->{ "$source.$column" };
360 tinyint => \&_gen_int,
361 smallint => \&_gen_int,
362 mediumint => \&_gen_int,
363 integer => \&_gen_int,
364 bigint => \&_gen_int,
366 float => \&_gen_real,
367 decimal => \&_gen_real,
368 double_precision => \&_gen_real,
370 timestamp => \&_gen_datetime,
371 datetime => \&_gen_datetime,
375 varchar => \&_gen_text,
376 tinytext => \&_gen_text,
378 mediumtext => \&_gen_text,
379 longtext => \&_gen_text,
381 set => \&_gen_set_enum,
382 enum => \&_gen_set_enum,
384 tinyblob => \&_gen_blob,
385 mediumblob => \&_gen_blob,
387 longblob => \&_gen_blob,
392 my ($self, $params) = @_;
393 my $data_type = $params->{info}->{data_type};
396 if( $data_type eq 'tinyint' ) {
399 elsif( $data_type eq 'smallint' ) {
402 elsif( $data_type eq 'mediumint' ) {
405 elsif( $data_type eq 'integer' ) {
408 elsif( $data_type eq 'bigint' ) {
409 $max = 9223372036854775807;
411 return int( rand($max+1) );
415 my ($self, $params) = @_;
417 if( defined( $params->{info}->{size} ) ) {
418 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
420 return sprintf("%.2f", rand($max)+1);
424 my ($self, $params) = @_;
425 return $self->schema->storage->datetime_parser->format_date(DateTime->now())
429 my ($self, $params) = @_;
430 return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
434 my ($self, $params) = @_;
435 # From perldoc String::Random
436 my $size = $params->{info}{size} // 10;
437 $size -= alt_rand(0.5 * $size);
438 my $regex = $size > 1
439 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
441 my $random = String::Random->new( rand_gen => \&alt_rand );
442 # rand_gen is only supported from 0.27 onward
443 return $random->randregex($regex);
446 sub alt_rand { #Alternative randomizer
448 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
449 my $r = $random->irand / 2**32;
450 return int( $r * $max );
454 my ($self, $params) = @_;
455 return $params->{info}->{extra}->{list}->[0];
459 my ($self, $params) = @_;;
463 sub _gen_default_values {
468 gonenoaddress => undef,
474 more_subfields_xml => undef,
498 t::lib::TestBuilder.pm - Koha module to create test records
502 use t::lib::TestBuilder;
503 my $builder = t::lib::TestBuilder->new;
505 # The following call creates a patron, linked to branch CPL.
506 # Surname is provided, other columns are randomly generated.
507 # Branch CPL is created if it does not exist.
508 my $patron = $builder->build({
509 source => 'Borrower',
510 value => { surname => 'Jansen', branchcode => 'CPL' },
515 This module automatically creates database records for you.
516 If needed, records for foreign keys are created too.
517 Values will be randomly generated if not passed to TestBuilder.
518 Note that you should wrap these actions in a transaction yourself.
524 my $builder = t::lib::TestBuilder->new;
526 Constructor - Returns the object TestBuilder
530 my $schema = $builder->schema;
532 Getter - Returns the schema of DBIx::Class
538 records => $patron, # OR: records => [ $patron, ... ],
541 Delete individual records, created by builder.
542 Returns the number of delete attempts, or undef.
546 $builder->build({ source => $source_name, value => $value });
548 Create a test record in the table, represented by $source_name.
549 The name is required and must conform to the DBIx::Class schema.
550 Values may be specified by the optional $value hashref. Will be
551 randomized otherwise.
552 If needed, TestBuilder creates linked records for foreign keys.
553 Returns the values of the new record as a hashref, or undef if
554 the record could not be created.
556 Note that build also supports recursive hash references inside the
557 value hash for foreign key columns, like:
559 column1 => 'some_value',
561 columnA => 'another_value',
564 The hash for fk_col2 here means: create a linked record with build
565 where columnA has this value. In case of a composite FK the hashes
568 Realize that passing primary key values to build may result in undef
569 if a record with that primary key already exists.
573 Given a plural Koha::Object-derived class, it creates a random element, and
574 returns the corresponding Koha::Object.
576 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
580 Yohann Dufour <yohann.dufour@biblibre.com>
582 Koha Development Team
586 Copyright 2014 - Biblibre SARL
590 This file is part of Koha.
592 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
593 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
595 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.
597 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.