1 package t
::lib
::TestBuilder
;
14 bless( $self, $class );
16 $self->schema( Koha
::Database
->new()->schema );
17 $self->schema->storage->sql_maker->quote_char('`');
19 $self->{gen_type
} = _gen_type
();
20 $self->{default_values
} = _gen_default_values
();
25 my ($self, $schema) = @_;
27 if( defined( $schema ) ) {
28 $self->{schema
} = $schema;
30 return $self->{schema
};
33 # sub clear has been obsoleted; use delete_all from the schema resultset
36 my ( $self, $params ) = @_;
37 my $source = $params->{source
} || return;
38 my @recs = ref( $params->{records
} ) eq 'ARRAY'?
39 @
{$params->{records
}}: ( $params->{records
} // () );
40 # tables without PK are not supported
41 my @pk = $self->schema->source( $source )->primary_columns;
44 foreach my $rec ( @recs ) {
45 # delete only works when you supply full primary key values
46 # $cond does not include searches for undef (not allowed in PK)
47 my $cond = { map { defined $rec->{$_}?
($_, $rec->{$_}): (); } @pk };
48 next if keys %$cond < @pk;
49 $self->schema->resultset( $source )->search( $cond )->delete;
50 # we clear the pk columns in the supplied hash
51 # this indirectly signals at least an attempt to delete
52 map { delete $rec->{$_}; } @pk;
59 my ( $self, $params ) = @_;
61 my $class = $params->{class};
62 my $value = $params->{value
};
64 if ( not defined $class ) {
65 carp
"Missing class param";
70 my $source = $class->_type;
71 my @pks = $self->schema->source( $class->_type )->primary_columns;
73 my $hashref = $self->build({ source
=> $source, value
=> $value });
76 foreach my $pk ( @pks ) {
77 push @ids, { $pk => $hashref->{ $pk } };
80 my $object = $class->find( @ids );
86 # build returns a hash of column values for a created record, or undef
87 # build does NOT update a record, or pass back values of an existing record
88 my ($self, $params) = @_;
89 my $source = $params->{source
} || return;
90 my $value = $params->{value
};
92 my $col_values = $self->_buildColumnValues({
96 return if !$col_values; # did not meet unique constraints?
98 # loop thru all fk and create linked records if needed
99 # fills remaining entries in $col_values
100 my $foreign_keys = $self->_getForeignKeys( { source
=> $source } );
101 for my $fk ( @
$foreign_keys ) {
102 # skip when FK points to itself: e.g. borrowers:guarantorid
103 next if $fk->{source
} eq $source;
104 my $keys = $fk->{keys};
105 my $tbl = $fk->{source
};
106 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
107 return if !$res; # failed: no need to go further
108 foreach( keys %$res ) { # save new values
109 $col_values->{$_} = $res->{$_};
113 # store this record and return hashref
114 return $self->_storeColumnValues({
116 values => $col_values,
120 # ------------------------------------------------------------------------------
121 # Internal helper routines
124 # returns undef for failure to create linked records
125 # otherwise returns hashref containing new column values for parent record
126 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
129 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
131 # First, collect all values for creating a linked record (if needed)
132 foreach my $fk ( @
$keys ) {
133 my ( $col, $destcol ) = ( $fk->{col_name
}, $fk->{col_fk_name
} );
134 if( ref( $value->{$col} ) eq 'HASH' ) {
135 # add all keys from the FK hash
136 $fk_value = { %{ $value->{$col} }, %$fk_value };
138 if( exists $col_values->{$col} ) {
139 # add specific value (this does not necessarily exclude some
140 # values from the hash in the preceding if)
141 $fk_value->{ $destcol } = $col_values->{ $col };
143 $cnt_null++ if !defined( $col_values->{$col} );
147 # If we saw all FK columns, first run the following checks
148 if( $cnt_scalar == @
$keys ) {
149 # if one or more fk cols are null, the FK constraint will not be forced
150 return {} if $cnt_null > 0;
151 # does the record exist already?
152 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
154 # create record with a recursive build call
155 my $row = $self->build({ source
=> $linked_tbl, value
=> $fk_value });
156 return if !$row; # failure
158 # Finally, only return the new values
160 foreach my $fk ( @
$keys ) {
161 my ( $col, $destcol ) = ( $fk->{col_name
}, $fk->{col_fk_name
} );
162 next if exists $col_values->{ $col };
163 $rv->{ $col } = $row->{ $destcol };
165 return $rv; # success
170 my $source = $params->{source
} || return;
171 $source =~ s
|(\w
+)$|$1|;
175 sub _buildColumnValues
{
176 my ($self, $params) = @_;
177 my $source = _formatSource
( $params ) || return;
178 my $original_value = $params->{value
};
181 my @columns = $self->schema->source($source)->columns;
182 my %unique_constraints = $self->schema->source($source)->unique_constraints();
185 # we try max three times if there are unique constraints
186 BUILD_VALUE
: while ( $build_value ) {
187 # generate random values for all columns
188 for my $col_name( @columns ) {
189 my $valref = $self->_buildColumnValue({
191 column_name
=> $col_name,
192 value
=> $original_value,
194 return if !$valref; # failure
195 if( @
$valref ) { # could be empty
196 # there will be only one value, but it could be undef
197 $col_values->{$col_name} = $valref->[0];
201 # verify the data would respect each unique constraint
202 # note that this is INCOMPLETE since not all col_values are filled
203 CONSTRAINTS
: foreach my $constraint (keys %unique_constraints) {
206 my $constraint_columns = $unique_constraints{$constraint};
207 # loop through all constraint columns and build the condition
208 foreach my $constraint_column ( @
$constraint_columns ) {
210 # if one column does not exist or is undef, skip it
211 # an insert with a null will not trigger the constraint
213 if !exists $col_values->{ $constraint_column } ||
214 !defined $col_values->{ $constraint_column };
215 $condition->{ $constraint_column } =
216 $col_values->{ $constraint_column };
218 my $count = $self->schema
219 ->resultset( $source )
220 ->search( $condition )
223 # no point checking more stuff, exit the loop
228 last; # you passed all tests
230 return $col_values if $build_value > 0;
232 # if you get here, we have a problem
233 warn "Violation of unique constraint in $source";
237 sub _getForeignKeys
{
239 # Returns the following arrayref
240 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
241 # The array gives source name and keys for each FK constraint
243 my ($self, $params) = @_;
244 my $source = $self->schema->source( $params->{source
} );
246 my ( @foreign_keys, $check_dupl );
247 my @relationships = $source->relationships;
248 for my $rel_name( @relationships ) {
249 my $rel_info = $source->relationship_info($rel_name);
250 if( $rel_info->{attrs
}->{is_foreign_key_constraint
} ) {
251 $rel_info->{source
} =~ s/^.*:://g;
252 my $rel = { source
=> $rel_info->{source
} };
255 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond
}}) ) {
256 $col_name =~ s
|self
.(\w
+)|$1|;
257 $col_fk_name =~ s
|foreign
.(\w
+)|$1|;
259 col_name
=> $col_name,
260 col_fk_name
=> $col_fk_name,
263 # check if the combination table and keys is unique
264 # so skip double belongs_to relations (as in Biblioitem)
265 my $tag = $rel->{source
}. ':'.
266 join ',', sort map { $_->{col_name
} } @keys;
267 next if $check_dupl->{$tag};
268 $check_dupl->{$tag} = 1;
269 $rel->{keys} = \
@keys;
270 push @foreign_keys, $rel;
273 return \
@foreign_keys;
276 sub _storeColumnValues
{
277 my ($self, $params) = @_;
278 my $source = $params->{source
};
279 my $col_values = $params->{values};
280 my $new_row = $self->schema->resultset( $source )->create( $col_values );
281 return $new_row?
{ $new_row->get_columns }: {};
284 sub _buildColumnValue
{
285 # returns an arrayref if all goes well
286 # an empty arrayref typically means: auto_incr column or fk column
287 # undef means failure
288 my ($self, $params) = @_;
289 my $source = $params->{source
};
290 my $value = $params->{value
};
291 my $col_name = $params->{column_name
};
293 my $col_info = $self->schema->source($source)->column_info($col_name);
296 if( $col_info->{is_auto_increment
} ) {
297 if( exists $value->{$col_name} ) {
298 warn "Value not allowed for auto_incr $col_name in $source";
301 # otherwise: no need to assign a value
302 } elsif( $col_info->{is_foreign_key
} || _should_be_fk
($source,$col_name) ) {
303 if( exists $value->{$col_name} ) {
304 if( !defined $value->{$col_name} && !$col_info->{is_nullable
} ) {
305 # This explicit undef is not allowed
306 warn "Null value for $col_name in $source not allowed";
309 if( ref( $value->{$col_name} ) ne 'HASH' ) {
310 push @
$retvalue, $value->{$col_name};
312 # sub build will handle a passed hash value later on
314 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
315 # this is not allowed for a column that is not a FK
316 warn "Hash not allowed for $col_name in $source";
318 } elsif( exists $value->{$col_name} ) {
319 if( !defined $value->{$col_name} && !$col_info->{is_nullable
} ) {
320 # This explicit undef is not allowed
321 warn "Null value for $col_name in $source not allowed";
324 push @
$retvalue, $value->{$col_name};
325 } elsif( exists $self->{default_values
}{$source}{$col_name} ) {
326 push @
$retvalue, $self->{default_values
}{$source}{$col_name};
328 my $data_type = $col_info->{data_type
};
329 $data_type =~ s
| |_
|;
330 if( my $hdlr = $self->{gen_type
}->{$data_type} ) {
331 push @
$retvalue, &$hdlr( $self, { info
=> $col_info } );
333 warn "Unknown type $data_type for $col_name in $source";
341 # This sub is only needed for inconsistencies in the schema
342 # A column is not marked as FK, but a belongs_to relation is defined
343 my ( $source, $column ) = @_;
344 my $inconsistencies = {
345 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
347 return $inconsistencies->{ "$source.$column" };
352 tinyint
=> \
&_gen_int
,
353 smallint
=> \
&_gen_int
,
354 mediumint
=> \
&_gen_int
,
355 integer
=> \
&_gen_int
,
356 bigint
=> \
&_gen_int
,
358 float
=> \
&_gen_real
,
359 decimal
=> \
&_gen_real
,
360 double_precision
=> \
&_gen_real
,
362 timestamp
=> \
&_gen_datetime
,
363 datetime
=> \
&_gen_datetime
,
367 varchar
=> \
&_gen_text
,
368 tinytext
=> \
&_gen_text
,
370 mediumtext
=> \
&_gen_text
,
371 longtext
=> \
&_gen_text
,
373 set
=> \
&_gen_set_enum
,
374 enum
=> \
&_gen_set_enum
,
376 tinyblob
=> \
&_gen_blob
,
377 mediumblob
=> \
&_gen_blob
,
379 longblob
=> \
&_gen_blob
,
384 my ($self, $params) = @_;
385 my $data_type = $params->{info
}->{data_type
};
388 if( $data_type eq 'tinyint' ) {
391 elsif( $data_type eq 'smallint' ) {
394 elsif( $data_type eq 'mediumint' ) {
397 elsif( $data_type eq 'integer' ) {
400 elsif( $data_type eq 'bigint' ) {
401 $max = 9223372036854775807;
403 return int( rand($max+1) );
407 my ($self, $params) = @_;
409 if( defined( $params->{info
}->{size
} ) ) {
410 $max = 10 ** ($params->{info
}->{size
}->[0] - $params->{info
}->{size
}->[1]);
412 return rand($max) + 1;
416 my ($self, $params) = @_;
417 return $self->schema->storage->datetime_parser->format_date(DateTime
->now())
421 my ($self, $params) = @_;
422 return $self->schema->storage->datetime_parser->format_datetime(DateTime
->now());
426 my ($self, $params) = @_;
427 # From perldoc String::Random
428 # max: specify the maximum number of characters to return for * and other
429 # regular expression patters that don't return a fixed number of characters
430 my $regex = '[A-Za-z][A-Za-z0-9_]*';
431 my $size = $params->{info
}{size
};
432 if ( defined $size and $size > 1 ) {
434 } elsif ( defined $size and $size == 1 ) {
437 my $random = String
::Random
->new( max
=> $size );
438 return $random->randregex($regex);
442 my ($self, $params) = @_;
443 return $params->{info
}->{extra
}->{list
}->[0];
447 my ($self, $params) = @_;;
451 sub _gen_default_values
{
455 more_subfields_xml
=> undef,
462 t::lib::TestBuilder.pm - Koha module to create test records
466 use t::lib::TestBuilder;
467 my $builder = t::lib::TestBuilder->new;
469 # The following call creates a patron, linked to branch CPL.
470 # Surname is provided, other columns are randomly generated.
471 # Branch CPL is created if it does not exist.
472 my $patron = $builder->build({
473 source => 'Borrower',
474 value => { surname => 'Jansen', branchcode => 'CPL' },
479 This module automatically creates database records for you.
480 If needed, records for foreign keys are created too.
481 Values will be randomly generated if not passed to TestBuilder.
482 Note that you should wrap these actions in a transaction yourself.
488 my $builder = t::lib::TestBuilder->new;
490 Constructor - Returns the object TestBuilder
494 my $schema = $builder->schema;
496 Getter - Returns the schema of DBIx::Class
502 records => $patron, # OR: records => [ $patron, ... ],
505 Delete individual records, created by builder.
506 Returns the number of delete attempts, or undef.
510 $builder->build({ source => $source_name, value => $value });
512 Create a test record in the table, represented by $source_name.
513 The name is required and must conform to the DBIx::Class schema.
514 Values may be specified by the optional $value hashref. Will be
515 randomized otherwise.
516 If needed, TestBuilder creates linked records for foreign keys.
517 Returns the values of the new record as a hashref, or undef if
518 the record could not be created.
520 Note that build also supports recursive hash references inside the
521 value hash for foreign key columns, like:
523 column1 => 'some_value',
525 columnA => 'another_value',
528 The hash for fk_col2 here means: create a linked record with build
529 where columnA has this value. In case of a composite FK the hashes
532 Realize that passing primary key values to build may result in undef
533 if a record with that primary key already exists.
537 Given a plural Koha::Object-derived class, it creates a random element, and
538 returns the corresponding Koha::Object.
540 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
544 Yohann Dufour <yohann.dufour@biblibre.com>
546 Koha Development Team
550 Copyright 2014 - Biblibre SARL
554 This file is part of Koha.
556 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
557 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
559 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.
561 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.