1 package t
::lib
::TestBuilder
;
10 bless( $self, $class );
12 $self->schema( Koha
::Database
->new()->schema );
13 $self->schema->storage->sql_maker->quote_char('`');
15 $self->{gen_type
} = _gen_type
();
20 my ($self, $schema) = @_;
22 if( defined( $schema ) ) {
23 $self->{schema
} = $schema;
25 return $self->{schema
};
28 # sub clear has been obsoleted; use delete_all from the schema resultset
31 my ( $self, $params ) = @_;
32 my $source = $params->{source
} || return;
33 my @recs = ref( $params->{records
} ) eq 'ARRAY'?
34 @
{$params->{records
}}: ( $params->{records
} // () );
35 # tables without PK are not supported
36 my @pk = $self->schema->source( $source )->primary_columns;
39 foreach my $rec ( @recs ) {
40 # delete only works when you supply full primary key values
41 # $cond does not include searches for undef (not allowed in PK)
42 my $cond = { map { defined $rec->{$_}?
($_, $rec->{$_}): (); } @pk };
43 next if keys %$cond < @pk;
44 $self->schema->resultset( $source )->search( $cond )->delete;
45 # we clear the pk columns in the supplied hash
46 # this indirectly signals at least an attempt to delete
47 map { delete $rec->{$_}; } @pk;
54 # build returns a hash of column values for a created record, or undef
55 # build does NOT update a record, or pass back values of an existing record
56 my ($self, $params) = @_;
57 my $source = $params->{source
} || return;
58 my $value = $params->{value
};
60 my $col_values = $self->_buildColumnValues({
64 return if !$col_values; # did not meet unique constraints?
66 # loop thru all fk and create linked records if needed
67 # fills remaining entries in $col_values
68 my $foreign_keys = $self->_getForeignKeys( { source
=> $source } );
69 for my $fk ( @
$foreign_keys ) {
70 # skip when FK points to itself: e.g. borrowers:guarantorid
71 next if $fk->{source
} eq $source;
72 my $keys = $fk->{keys};
73 my $tbl = $fk->{source
};
74 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
75 return if !$res; # failed: no need to go further
76 foreach( keys %$res ) { # save new values
77 $col_values->{$_} = $res->{$_};
81 # store this record and return hashref
82 return $self->_storeColumnValues({
84 values => $col_values,
88 # ------------------------------------------------------------------------------
89 # Internal helper routines
92 # returns undef for failure to create linked records
93 # otherwise returns hashref containing new column values for parent record
94 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
97 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
99 # First, collect all values for creating a linked record (if needed)
100 foreach my $fk ( @
$keys ) {
101 my ( $col, $destcol ) = ( $fk->{col_name
}, $fk->{col_fk_name
} );
102 if( ref( $value->{$col} ) eq 'HASH' ) {
103 # add all keys from the FK hash
104 $fk_value = { %{ $value->{$col} }, %$fk_value };
106 if( exists $col_values->{$col} ) {
107 # add specific value (this does not necessarily exclude some
108 # values from the hash in the preceding if)
109 $fk_value->{ $destcol } = $col_values->{ $col };
111 $cnt_null++ if !defined( $col_values->{$col} );
115 # If we saw all FK columns, first run the following checks
116 if( $cnt_scalar == @
$keys ) {
117 # if one or more fk cols are null, the FK constraint will not be forced
118 return {} if $cnt_null > 0;
119 # does the record exist already?
120 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
122 # create record with a recursive build call
123 my $row = $self->build({ source
=> $linked_tbl, value
=> $fk_value });
124 return if !$row; # failure
126 # Finally, only return the new values
128 foreach my $fk ( @
$keys ) {
129 my ( $col, $destcol ) = ( $fk->{col_name
}, $fk->{col_fk_name
} );
130 next if exists $col_values->{ $col };
131 $rv->{ $col } = $row->{ $destcol };
133 return $rv; # success
138 my $source = $params->{source
} || return;
139 $source =~ s
|(\w
+)$|$1|;
143 sub _buildColumnValues
{
144 my ($self, $params) = @_;
145 my $source = _formatSource
( $params ) || return;
146 my $original_value = $params->{value
};
149 my @columns = $self->schema->source($source)->columns;
150 my %unique_constraints = $self->schema->source($source)->unique_constraints();
153 # we try max three times if there are unique constraints
154 BUILD_VALUE
: while ( $build_value ) {
155 # generate random values for all columns
156 for my $col_name( @columns ) {
157 my $valref = $self->_buildColumnValue({
159 column_name
=> $col_name,
160 value
=> $original_value,
162 return if !$valref; # failure
163 if( @
$valref ) { # could be empty
164 # there will be only one value, but it could be undef
165 $col_values->{$col_name} = $valref->[0];
169 # verify the data would respect each unique constraint
170 # note that this is INCOMPLETE since not all col_values are filled
171 CONSTRAINTS
: foreach my $constraint (keys %unique_constraints) {
174 my $constraint_columns = $unique_constraints{$constraint};
175 # loop through all constraint columns and build the condition
176 foreach my $constraint_column ( @
$constraint_columns ) {
178 # if one column does not exist or is undef, skip it
179 # an insert with a null will not trigger the constraint
181 if !exists $col_values->{ $constraint_column } ||
182 !defined $col_values->{ $constraint_column };
183 $condition->{ $constraint_column } =
184 $col_values->{ $constraint_column };
186 my $count = $self->schema
187 ->resultset( $source )
188 ->search( $condition )
191 # no point checking more stuff, exit the loop
196 last; # you passed all tests
198 return $col_values if $build_value > 0;
200 # if you get here, we have a problem
201 warn "Violation of unique constraint in $source";
205 sub _getForeignKeys
{
207 # Returns the following arrayref
208 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
209 # The array gives source name and keys for each FK constraint
211 my ($self, $params) = @_;
212 my $source = $self->schema->source( $params->{source
} );
214 my ( @foreign_keys, $check_dupl );
215 my @relationships = $source->relationships;
216 for my $rel_name( @relationships ) {
217 my $rel_info = $source->relationship_info($rel_name);
218 if( $rel_info->{attrs
}->{is_foreign_key_constraint
} ) {
219 $rel_info->{source
} =~ s/^.*:://g;
220 my $rel = { source
=> $rel_info->{source
} };
223 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond
}}) ) {
224 $col_name =~ s
|self
.(\w
+)|$1|;
225 $col_fk_name =~ s
|foreign
.(\w
+)|$1|;
227 col_name
=> $col_name,
228 col_fk_name
=> $col_fk_name,
231 # check if the combination table and keys is unique
232 # so skip double belongs_to relations (as in Biblioitem)
233 my $tag = $rel->{source
}. ':'.
234 join ',', sort map { $_->{col_name
} } @keys;
235 next if $check_dupl->{$tag};
236 $check_dupl->{$tag} = 1;
237 $rel->{keys} = \
@keys;
238 push @foreign_keys, $rel;
241 return \
@foreign_keys;
244 sub _storeColumnValues
{
245 my ($self, $params) = @_;
246 my $source = $params->{source
};
247 my $col_values = $params->{values};
248 my $new_row = $self->schema->resultset( $source )->create( $col_values );
249 return $new_row?
{ $new_row->get_columns }: {};
252 sub _buildColumnValue
{
253 # returns an arrayref if all goes well
254 # an empty arrayref typically means: auto_incr column or fk column
255 # undef means failure
256 my ($self, $params) = @_;
257 my $source = $params->{source
};
258 my $value = $params->{value
};
259 my $col_name = $params->{column_name
};
261 my $col_info = $self->schema->source($source)->column_info($col_name);
264 if( $col_info->{is_auto_increment
} ) {
265 if( exists $value->{$col_name} ) {
266 warn "Value not allowed for auto_incr $col_name in $source";
269 # otherwise: no need to assign a value
270 } elsif( $col_info->{is_foreign_key
} || _should_be_fk
($source,$col_name) ) {
271 if( exists $value->{$col_name} ) {
272 if( !defined $value->{$col_name} && !$col_info->{is_nullable
} ) {
273 # This explicit undef is not allowed
274 warn "Null value for $col_name in $source not allowed";
277 if( ref( $value->{$col_name} ) ne 'HASH' ) {
278 push @
$retvalue, $value->{$col_name};
280 # sub build will handle a passed hash value later on
282 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
283 # this is not allowed for a column that is not a FK
284 warn "Hash not allowed for $col_name in $source";
286 } elsif( exists $value->{$col_name} ) {
287 if( !defined $value->{$col_name} && !$col_info->{is_nullable
} ) {
288 # This explicit undef is not allowed
289 warn "Null value for $col_name in $source not allowed";
292 push @
$retvalue, $value->{$col_name};
294 my $data_type = $col_info->{data_type
};
295 $data_type =~ s
| |_
|;
296 if( my $hdlr = $self->{gen_type
}->{$data_type} ) {
297 push @
$retvalue, &$hdlr( $self, { info
=> $col_info } );
299 warn "Unknown type $data_type for $col_name in $source";
307 # This sub is only needed for inconsistencies in the schema
308 # A column is not marked as FK, but a belongs_to relation is defined
309 my ( $source, $column ) = @_;
310 my $inconsistencies = {
311 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
313 return $inconsistencies->{ "$source.$column" };
318 tinyint
=> \
&_gen_int
,
319 smallint
=> \
&_gen_int
,
320 mediumint
=> \
&_gen_int
,
321 integer
=> \
&_gen_int
,
322 bigint
=> \
&_gen_int
,
324 float
=> \
&_gen_real
,
325 decimal
=> \
&_gen_real
,
326 double_precision
=> \
&_gen_real
,
328 timestamp
=> \
&_gen_datetime
,
329 datetime
=> \
&_gen_datetime
,
333 varchar
=> \
&_gen_text
,
334 tinytext
=> \
&_gen_text
,
336 mediumtext
=> \
&_gen_text
,
337 longtext
=> \
&_gen_text
,
339 set
=> \
&_gen_set_enum
,
340 enum
=> \
&_gen_set_enum
,
342 tinyblob
=> \
&_gen_blob
,
343 mediumblob
=> \
&_gen_blob
,
345 longblob
=> \
&_gen_blob
,
350 my ($self, $params) = @_;
351 my $data_type = $params->{info
}->{data_type
};
354 if( $data_type eq 'tinyint' ) {
357 elsif( $data_type eq 'smallint' ) {
360 elsif( $data_type eq 'mediumint' ) {
363 elsif( $data_type eq 'integer' ) {
366 elsif( $data_type eq 'bigint' ) {
367 $max = 9223372036854775807;
369 return int( rand($max+1) );
373 my ($self, $params) = @_;
375 if( defined( $params->{info
}->{size
} ) ) {
376 $max = 10 ** ($params->{info
}->{size
}->[0] - $params->{info
}->{size
}->[1]);
378 return rand($max) + 1;
382 my ($self, $params) = @_;
383 return $self->schema->storage->datetime_parser->format_date(DateTime
->now())
387 my ($self, $params) = @_;
388 return $self->schema->storage->datetime_parser->format_datetime(DateTime
->now());
392 my ($self, $params) = @_;
393 # From perldoc String::Random
394 # max: specify the maximum number of characters to return for * and other
395 # regular expression patters that don't return a fixed number of characters
396 my $regex = '[A-Za-z][A-Za-z0-9_]*';
397 my $size = $params->{info
}{size
};
398 if ( defined $size and $size > 1 ) {
400 } elsif ( defined $size and $size == 1 ) {
403 my $random = String
::Random
->new( max
=> $size );
404 return $random->randregex($regex);
408 my ($self, $params) = @_;
409 return $params->{info
}->{extra
}->{list
}->[0];
413 my ($self, $params) = @_;;
419 t::lib::TestBuilder.pm - Koha module to create test records
423 use t::lib::TestBuilder;
424 my $builder = t::lib::TestBuilder->new;
426 # The following call creates a patron, linked to branch CPL.
427 # Surname is provided, other columns are randomly generated.
428 # Branch CPL is created if it does not exist.
429 my $patron = $builder->build({
430 source => 'Borrower',
431 value => { surname => 'Jansen', branchcode => 'CPL' },
436 This module automatically creates database records for you.
437 If needed, records for foreign keys are created too.
438 Values will be randomly generated if not passed to TestBuilder.
439 Note that you should wrap these actions in a transaction yourself.
445 my $builder = t::lib::TestBuilder->new;
447 Constructor - Returns the object TestBuilder
451 my $schema = $builder->schema;
453 Getter - Returns the schema of DBIx::Class
459 records => $patron, # OR: records => [ $patron, ... ],
462 Delete individual records, created by builder.
463 Returns the number of delete attempts, or undef.
467 $builder->build({ source => $source_name, value => $value });
469 Create a test record in the table, represented by $source_name.
470 The name is required and must conform to the DBIx::Class schema.
471 Values may be specified by the optional $value hashref. Will be
472 randomized otherwise.
473 If needed, TestBuilder creates linked records for foreign keys.
474 Returns the values of the new record as a hashref, or undef if
475 the record could not be created.
477 Note that build also supports recursive hash references inside the
478 value hash for foreign key columns, like:
480 column1 => 'some_value',
482 columnA => 'another_value',
485 The hash for fk_col2 here means: create a linked record with build
486 where columnA has this value. In case of a composite FK the hashes
489 Realize that passing primary key values to build may result in undef
490 if a record with that primary key already exists.
494 Yohann Dufour <yohann.dufour@biblibre.com>
496 Koha Development Team
500 Copyright 2014 - Biblibre SARL
504 This file is part of Koha.
506 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
507 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
509 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.
511 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.