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, $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};
91 carp "Source parameter not specified!";
94 my $value = $params->{value};
96 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
97 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
99 my $col_values = $self->_buildColumnValues({
103 return if !$col_values; # did not meet unique constraints?
105 # loop thru all fk and create linked records if needed
106 # fills remaining entries in $col_values
107 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
108 for my $fk ( @$foreign_keys ) {
109 # skip when FK points to itself: e.g. borrowers:guarantorid
110 next if $fk->{source} eq $source;
111 my $keys = $fk->{keys};
112 my $tbl = $fk->{source};
113 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
114 return if !$res; # failed: no need to go further
115 foreach( keys %$res ) { # save new values
116 $col_values->{$_} = $res->{$_};
120 # store this record and return hashref
121 return $self->_storeColumnValues({
123 values => $col_values,
127 # ------------------------------------------------------------------------------
128 # Internal helper routines
131 # returns undef for failure to create linked records
132 # otherwise returns hashref containing new column values for parent record
133 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
136 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
138 # First, collect all values for creating a linked record (if needed)
139 foreach my $fk ( @$keys ) {
140 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
141 if( ref( $value->{$col} ) eq 'HASH' ) {
142 # add all keys from the FK hash
143 $fk_value = { %{ $value->{$col} }, %$fk_value };
145 if( exists $col_values->{$col} ) {
146 # add specific value (this does not necessarily exclude some
147 # values from the hash in the preceding if)
148 $fk_value->{ $destcol } = $col_values->{ $col };
150 $cnt_null++ if !defined( $col_values->{$col} );
154 # If we saw all FK columns, first run the following checks
155 if( $cnt_scalar == @$keys ) {
156 # if one or more fk cols are null, the FK constraint will not be forced
157 return {} if $cnt_null > 0;
158 # does the record exist already?
159 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
161 # create record with a recursive build call
162 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
163 return if !$row; # failure
165 # Finally, only return the new values
167 foreach my $fk ( @$keys ) {
168 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
169 next if exists $col_values->{ $col };
170 $rv->{ $col } = $row->{ $destcol };
172 return $rv; # success
177 my $source = $params->{source} || return;
178 $source =~ s|(\w+)$|$1|;
182 sub _buildColumnValues {
183 my ($self, $params) = @_;
184 my $source = _formatSource( $params ) || return;
185 my $original_value = $params->{value};
188 my @columns = $self->schema->source($source)->columns;
189 my %unique_constraints = $self->schema->source($source)->unique_constraints();
192 # we try max three times if there are unique constraints
193 BUILD_VALUE: while ( $build_value ) {
194 # generate random values for all columns
195 for my $col_name( @columns ) {
196 my $valref = $self->_buildColumnValue({
198 column_name => $col_name,
199 value => $original_value,
201 return if !$valref; # failure
202 if( @$valref ) { # could be empty
203 # there will be only one value, but it could be undef
204 $col_values->{$col_name} = $valref->[0];
208 # verify the data would respect each unique constraint
209 # note that this is INCOMPLETE since not all col_values are filled
210 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
213 my $constraint_columns = $unique_constraints{$constraint};
214 # loop through all constraint columns and build the condition
215 foreach my $constraint_column ( @$constraint_columns ) {
217 # if one column does not exist or is undef, skip it
218 # an insert with a null will not trigger the constraint
220 if !exists $col_values->{ $constraint_column } ||
221 !defined $col_values->{ $constraint_column };
222 $condition->{ $constraint_column } =
223 $col_values->{ $constraint_column };
225 my $count = $self->schema
226 ->resultset( $source )
227 ->search( $condition )
230 # no point checking more stuff, exit the loop
235 last; # you passed all tests
237 return $col_values if $build_value > 0;
239 # if you get here, we have a problem
240 warn "Violation of unique constraint in $source";
244 sub _getForeignKeys {
246 # Returns the following arrayref
247 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
248 # The array gives source name and keys for each FK constraint
250 my ($self, $params) = @_;
251 my $source = $self->schema->source( $params->{source} );
253 my ( @foreign_keys, $check_dupl );
254 my @relationships = $source->relationships;
255 for my $rel_name( @relationships ) {
256 my $rel_info = $source->relationship_info($rel_name);
257 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
258 $rel_info->{source} =~ s/^.*:://g;
259 my $rel = { source => $rel_info->{source} };
262 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
263 $col_name =~ s|self.(\w+)|$1|;
264 $col_fk_name =~ s|foreign.(\w+)|$1|;
266 col_name => $col_name,
267 col_fk_name => $col_fk_name,
270 # check if the combination table and keys is unique
271 # so skip double belongs_to relations (as in Biblioitem)
272 my $tag = $rel->{source}. ':'.
273 join ',', sort map { $_->{col_name} } @keys;
274 next if $check_dupl->{$tag};
275 $check_dupl->{$tag} = 1;
276 $rel->{keys} = \@keys;
277 push @foreign_keys, $rel;
280 return \@foreign_keys;
283 sub _storeColumnValues {
284 my ($self, $params) = @_;
285 my $source = $params->{source};
286 my $col_values = $params->{values};
287 my $new_row = $self->schema->resultset( $source )->create( $col_values );
288 return $new_row? { $new_row->get_columns }: {};
291 sub _buildColumnValue {
292 # returns an arrayref if all goes well
293 # an empty arrayref typically means: auto_incr column or fk column
294 # undef means failure
295 my ($self, $params) = @_;
296 my $source = $params->{source};
297 my $value = $params->{value};
298 my $col_name = $params->{column_name};
300 my $col_info = $self->schema->source($source)->column_info($col_name);
303 if( $col_info->{is_auto_increment} ) {
304 if( exists $value->{$col_name} ) {
305 warn "Value not allowed for auto_incr $col_name in $source";
308 # otherwise: no need to assign a value
309 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
310 if( exists $value->{$col_name} ) {
311 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
312 # This explicit undef is not allowed
313 warn "Null value for $col_name in $source not allowed";
316 if( ref( $value->{$col_name} ) ne 'HASH' ) {
317 push @$retvalue, $value->{$col_name};
319 # sub build will handle a passed hash value later on
321 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
322 # this is not allowed for a column that is not a FK
323 warn "Hash not allowed for $col_name in $source";
325 } elsif( exists $value->{$col_name} ) {
326 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
327 # This explicit undef is not allowed
328 warn "Null value for $col_name in $source not allowed";
331 push @$retvalue, $value->{$col_name};
332 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
333 push @$retvalue, $self->{default_values}{$source}{$col_name};
335 my $data_type = $col_info->{data_type};
336 $data_type =~ s| |_|;
337 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
338 push @$retvalue, &$hdlr( $self, { info => $col_info } );
340 warn "Unknown type $data_type for $col_name in $source";
348 # This sub is only needed for inconsistencies in the schema
349 # A column is not marked as FK, but a belongs_to relation is defined
350 my ( $source, $column ) = @_;
351 my $inconsistencies = {
352 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
354 return $inconsistencies->{ "$source.$column" };
359 tinyint => \&_gen_int,
360 smallint => \&_gen_int,
361 mediumint => \&_gen_int,
362 integer => \&_gen_int,
363 bigint => \&_gen_int,
365 float => \&_gen_real,
366 decimal => \&_gen_real,
367 double_precision => \&_gen_real,
369 timestamp => \&_gen_datetime,
370 datetime => \&_gen_datetime,
374 varchar => \&_gen_text,
375 tinytext => \&_gen_text,
377 mediumtext => \&_gen_text,
378 longtext => \&_gen_text,
380 set => \&_gen_set_enum,
381 enum => \&_gen_set_enum,
383 tinyblob => \&_gen_blob,
384 mediumblob => \&_gen_blob,
386 longblob => \&_gen_blob,
391 my ($self, $params) = @_;
392 my $data_type = $params->{info}->{data_type};
395 if( $data_type eq 'tinyint' ) {
398 elsif( $data_type eq 'smallint' ) {
401 elsif( $data_type eq 'mediumint' ) {
404 elsif( $data_type eq 'integer' ) {
407 elsif( $data_type eq 'bigint' ) {
408 $max = 9223372036854775807;
410 return int( rand($max+1) );
414 my ($self, $params) = @_;
416 if( defined( $params->{info}->{size} ) ) {
417 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
419 return rand($max) + 1;
423 my ($self, $params) = @_;
424 return $self->schema->storage->datetime_parser->format_date(DateTime->now())
428 my ($self, $params) = @_;
429 return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
433 my ($self, $params) = @_;
434 # From perldoc String::Random
435 # max: specify the maximum number of characters to return for * and other
436 # regular expression patters that don't return a fixed number of characters
437 my $regex = '[A-Za-z][A-Za-z0-9_]*';
438 my $size = $params->{info}{size};
439 if ( defined $size and $size > 1 ) {
441 } elsif ( defined $size and $size == 1 ) {
444 my $random = String::Random->new( max => $size );
445 return $random->randregex($regex);
449 my ($self, $params) = @_;
450 return $params->{info}->{extra}->{list}->[0];
454 my ($self, $params) = @_;;
458 sub _gen_default_values {
465 more_subfields_xml => undef,
472 t::lib::TestBuilder.pm - Koha module to create test records
476 use t::lib::TestBuilder;
477 my $builder = t::lib::TestBuilder->new;
479 # The following call creates a patron, linked to branch CPL.
480 # Surname is provided, other columns are randomly generated.
481 # Branch CPL is created if it does not exist.
482 my $patron = $builder->build({
483 source => 'Borrower',
484 value => { surname => 'Jansen', branchcode => 'CPL' },
489 This module automatically creates database records for you.
490 If needed, records for foreign keys are created too.
491 Values will be randomly generated if not passed to TestBuilder.
492 Note that you should wrap these actions in a transaction yourself.
498 my $builder = t::lib::TestBuilder->new;
500 Constructor - Returns the object TestBuilder
504 my $schema = $builder->schema;
506 Getter - Returns the schema of DBIx::Class
512 records => $patron, # OR: records => [ $patron, ... ],
515 Delete individual records, created by builder.
516 Returns the number of delete attempts, or undef.
520 $builder->build({ source => $source_name, value => $value });
522 Create a test record in the table, represented by $source_name.
523 The name is required and must conform to the DBIx::Class schema.
524 Values may be specified by the optional $value hashref. Will be
525 randomized otherwise.
526 If needed, TestBuilder creates linked records for foreign keys.
527 Returns the values of the new record as a hashref, or undef if
528 the record could not be created.
530 Note that build also supports recursive hash references inside the
531 value hash for foreign key columns, like:
533 column1 => 'some_value',
535 columnA => 'another_value',
538 The hash for fk_col2 here means: create a linked record with build
539 where columnA has this value. In case of a composite FK the hashes
542 Realize that passing primary key values to build may result in undef
543 if a record with that primary key already exists.
547 Given a plural Koha::Object-derived class, it creates a random element, and
548 returns the corresponding Koha::Object.
550 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
554 Yohann Dufour <yohann.dufour@biblibre.com>
556 Koha Development Team
560 Copyright 2014 - Biblibre SARL
564 This file is part of Koha.
566 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
567 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
569 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.
571 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.