1 package t::lib::TestBuilder;
11 use Bytes::Random::Secure;
17 SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
23 bless( $self, $class );
25 $self->schema( Koha::Database->new()->schema );
26 $self->schema->storage->sql_maker->quote_char('`');
28 $self->{gen_type} = _gen_type();
29 $self->{default_values} = _gen_default_values();
34 my ($self, $schema) = @_;
36 if( defined( $schema ) ) {
37 $self->{schema} = $schema;
39 return $self->{schema};
42 # sub clear has been obsoleted; use delete_all from the schema resultset
45 my ( $self, $params ) = @_;
46 my $source = $params->{source} || return;
47 my @recs = ref( $params->{records} ) eq 'ARRAY'?
48 @{$params->{records}}: ( $params->{records} // () );
49 # tables without PK are not supported
50 my @pk = $self->schema->source( $source )->primary_columns;
53 foreach my $rec ( @recs ) {
54 # delete only works when you supply full primary key values
55 # $cond does not include searches for undef (not allowed in PK)
56 my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
57 next if keys %$cond < @pk;
58 $self->schema->resultset( $source )->search( $cond )->delete;
59 # we clear the pk columns in the supplied hash
60 # this indirectly signals at least an attempt to delete
61 map { delete $rec->{$_}; } @pk;
68 my ( $self, $params ) = @_;
70 my $class = $params->{class};
71 my $value = $params->{value};
73 if ( not defined $class ) {
74 carp "Missing class param";
79 my $source = $class->_type;
80 my @pks = $self->schema->source( $class->_type )->primary_columns;
82 my $hashref = $self->build({ source => $source, value => $value });
85 foreach my $pk ( @pks ) {
86 push @ids, $hashref->{ $pk };
89 my $object = $class->find( @ids );
95 # build returns a hash of column values for a created record, or undef
96 # build does NOT update a record, or pass back values of an existing record
97 my ($self, $params) = @_;
98 my $source = $params->{source};
100 carp "Source parameter not specified!";
103 my $value = $params->{value};
105 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
106 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
108 my $col_values = $self->_buildColumnValues({
112 return if !$col_values; # did not meet unique constraints?
114 # loop thru all fk and create linked records if needed
115 # fills remaining entries in $col_values
116 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
117 for my $fk ( @$foreign_keys ) {
118 # skip when FK points to itself: e.g. borrowers:guarantorid
119 next if $fk->{source} eq $source;
120 my $keys = $fk->{keys};
121 my $tbl = $fk->{source};
122 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
123 return if !$res; # failed: no need to go further
124 foreach( keys %$res ) { # save new values
125 $col_values->{$_} = $res->{$_};
129 # store this record and return hashref
130 return $self->_storeColumnValues({
132 values => $col_values,
136 sub build_sample_biblio {
137 my ( $self, $args ) = @_;
139 my $title = $args->{title} || 'Some boring read';
140 my $author = $args->{author} || 'Some boring author';
141 my $frameworkcode = $args->{frameworkcode} || '';
142 my $itemtype = $args->{itemtype}
143 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
145 my $marcflavour = C4::Context->preference('marcflavour');
147 my $record = MARC::Record->new();
148 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
149 $record->append_fields(
150 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
153 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
154 $record->append_fields(
155 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
158 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
159 $record->append_fields(
160 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
163 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
164 return Koha::Biblios->find($biblio_id);
167 sub build_sample_item {
168 my ( $self, $args ) = @_;
171 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
172 my $library = delete $args->{library}
173 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
175 my $itype = delete $args->{itype}
176 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
178 my $barcode = delete $args->{barcode}
179 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
181 my ( undef, undef, $itemnumber ) = C4::Items::AddItem(
183 homebranch => $library,
184 holdingbranch => $library,
191 return Koha::Items->find($itemnumber);
194 # ------------------------------------------------------------------------------
195 # Internal helper routines
198 # returns undef for failure to create linked records
199 # otherwise returns hashref containing new column values for parent record
200 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
203 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
205 # First, collect all values for creating a linked record (if needed)
206 foreach my $fk ( @$keys ) {
207 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
208 if( ref( $value->{$col} ) eq 'HASH' ) {
209 # add all keys from the FK hash
210 $fk_value = { %{ $value->{$col} }, %$fk_value };
212 if( exists $col_values->{$col} ) {
213 # add specific value (this does not necessarily exclude some
214 # values from the hash in the preceding if)
215 $fk_value->{ $destcol } = $col_values->{ $col };
217 $cnt_null++ if !defined( $col_values->{$col} );
221 # If we saw all FK columns, first run the following checks
222 if( $cnt_scalar == @$keys ) {
223 # if one or more fk cols are null, the FK constraint will not be forced
224 return {} if $cnt_null > 0;
225 # does the record exist already?
226 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
228 # create record with a recursive build call
229 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
230 return if !$row; # failure
232 # Finally, only return the new values
234 foreach my $fk ( @$keys ) {
235 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
236 next if exists $col_values->{ $col };
237 $rv->{ $col } = $row->{ $destcol };
239 return $rv; # success
244 my $source = $params->{source} || return;
245 $source =~ s|(\w+)$|$1|;
249 sub _buildColumnValues {
250 my ($self, $params) = @_;
251 my $source = _formatSource( $params ) || return;
252 my $original_value = $params->{value};
255 my @columns = $self->schema->source($source)->columns;
256 my %unique_constraints = $self->schema->source($source)->unique_constraints();
259 # we try max $build_value times if there are unique constraints
260 BUILD_VALUE: while ( $build_value ) {
261 # generate random values for all columns
262 for my $col_name( @columns ) {
263 my $valref = $self->_buildColumnValue({
265 column_name => $col_name,
266 value => $original_value,
268 return if !$valref; # failure
269 if( @$valref ) { # could be empty
270 # there will be only one value, but it could be undef
271 $col_values->{$col_name} = $valref->[0];
275 # verify the data would respect each unique constraint
276 # note that this is INCOMPLETE since not all col_values are filled
277 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
280 my $constraint_columns = $unique_constraints{$constraint};
281 # loop through all constraint columns and build the condition
282 foreach my $constraint_column ( @$constraint_columns ) {
284 # if one column does not exist or is undef, skip it
285 # an insert with a null will not trigger the constraint
287 if !exists $col_values->{ $constraint_column } ||
288 !defined $col_values->{ $constraint_column };
289 $condition->{ $constraint_column } =
290 $col_values->{ $constraint_column };
292 my $count = $self->schema
293 ->resultset( $source )
294 ->search( $condition )
297 # no point checking more stuff, exit the loop
302 last; # you passed all tests
304 return $col_values if $build_value > 0;
306 # if you get here, we have a problem
307 warn "Violation of unique constraint in $source";
311 sub _getForeignKeys {
313 # Returns the following arrayref
314 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
315 # The array gives source name and keys for each FK constraint
317 my ($self, $params) = @_;
318 my $source = $self->schema->source( $params->{source} );
320 my ( @foreign_keys, $check_dupl );
321 my @relationships = $source->relationships;
322 for my $rel_name( @relationships ) {
323 my $rel_info = $source->relationship_info($rel_name);
324 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
325 $rel_info->{source} =~ s/^.*:://g;
326 my $rel = { source => $rel_info->{source} };
329 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
330 $col_name =~ s|self.(\w+)|$1|;
331 $col_fk_name =~ s|foreign.(\w+)|$1|;
333 col_name => $col_name,
334 col_fk_name => $col_fk_name,
337 # check if the combination table and keys is unique
338 # so skip double belongs_to relations (as in Biblioitem)
339 my $tag = $rel->{source}. ':'.
340 join ',', sort map { $_->{col_name} } @keys;
341 next if $check_dupl->{$tag};
342 $check_dupl->{$tag} = 1;
343 $rel->{keys} = \@keys;
344 push @foreign_keys, $rel;
347 return \@foreign_keys;
350 sub _storeColumnValues {
351 my ($self, $params) = @_;
352 my $source = $params->{source};
353 my $col_values = $params->{values};
354 my $new_row = $self->schema->resultset( $source )->create( $col_values );
355 return $new_row? { $new_row->get_columns }: {};
358 sub _buildColumnValue {
359 # returns an arrayref if all goes well
360 # an empty arrayref typically means: auto_incr column or fk column
361 # undef means failure
362 my ($self, $params) = @_;
363 my $source = $params->{source};
364 my $value = $params->{value};
365 my $col_name = $params->{column_name};
367 my $col_info = $self->schema->source($source)->column_info($col_name);
370 if( $col_info->{is_auto_increment} ) {
371 if( exists $value->{$col_name} ) {
372 warn "Value not allowed for auto_incr $col_name in $source";
375 # otherwise: no need to assign a value
376 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
377 if( exists $value->{$col_name} ) {
378 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
379 # This explicit undef is not allowed
380 warn "Null value for $col_name in $source not allowed";
383 if( ref( $value->{$col_name} ) ne 'HASH' ) {
384 push @$retvalue, $value->{$col_name};
386 # sub build will handle a passed hash value later on
388 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
389 # this is not allowed for a column that is not a FK
390 warn "Hash not allowed for $col_name in $source";
392 } elsif( exists $value->{$col_name} ) {
393 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
394 # This explicit undef is not allowed
395 warn "Null value for $col_name in $source not allowed";
398 push @$retvalue, $value->{$col_name};
399 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
400 push @$retvalue, $self->{default_values}{$source}{$col_name};
402 my $data_type = $col_info->{data_type};
403 $data_type =~ s| |_|;
404 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
405 push @$retvalue, &$hdlr( $self, { info => $col_info } );
407 warn "Unknown type $data_type for $col_name in $source";
415 # This sub is only needed for inconsistencies in the schema
416 # A column is not marked as FK, but a belongs_to relation is defined
417 my ( $source, $column ) = @_;
418 my $inconsistencies = {
419 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
421 return $inconsistencies->{ "$source.$column" };
426 tinyint => \&_gen_int,
427 smallint => \&_gen_int,
428 mediumint => \&_gen_int,
429 integer => \&_gen_int,
430 bigint => \&_gen_int,
432 float => \&_gen_real,
433 decimal => \&_gen_real,
434 double_precision => \&_gen_real,
436 timestamp => \&_gen_datetime,
437 datetime => \&_gen_datetime,
441 varchar => \&_gen_text,
442 tinytext => \&_gen_text,
444 mediumtext => \&_gen_text,
445 longtext => \&_gen_text,
447 set => \&_gen_set_enum,
448 enum => \&_gen_set_enum,
450 tinyblob => \&_gen_blob,
451 mediumblob => \&_gen_blob,
453 longblob => \&_gen_blob,
458 my ($self, $params) = @_;
459 my $data_type = $params->{info}->{data_type};
462 if( $data_type eq 'tinyint' ) {
465 elsif( $data_type eq 'smallint' ) {
468 elsif( $data_type eq 'mediumint' ) {
471 elsif( $data_type eq 'integer' ) {
474 elsif( $data_type eq 'bigint' ) {
475 $max = 9223372036854775807;
477 return int( rand($max+1) );
481 my ($self, $params) = @_;
483 if( defined( $params->{info}->{size} ) ) {
484 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
486 return sprintf("%.2f", rand($max-0.1));
490 my ($self, $params) = @_;
491 return $self->schema->storage->datetime_parser->format_date(DateTime->now())
495 my ($self, $params) = @_;
496 return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
500 my ($self, $params) = @_;
501 # From perldoc String::Random
502 my $size = $params->{info}{size} // 10;
503 $size -= alt_rand(0.5 * $size);
504 my $regex = $size > 1
505 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
507 my $random = String::Random->new( rand_gen => \&alt_rand );
508 # rand_gen is only supported from 0.27 onward
509 return $random->randregex($regex);
512 sub alt_rand { #Alternative randomizer
514 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
515 my $r = $random->irand / 2**32;
516 return int( $r * $max );
520 my ($self, $params) = @_;
521 return $params->{info}->{extra}->{list}->[0];
525 my ($self, $params) = @_;;
529 sub _gen_default_values {
534 gonenoaddress => undef,
544 more_subfields_xml => undef,
552 rentalcharge_daily => 0,
553 rentalcharge_hourly => 0,
554 defaultreplacecost => 0,
569 t::lib::TestBuilder.pm - Koha module to create test records
573 use t::lib::TestBuilder;
574 my $builder = t::lib::TestBuilder->new;
576 # The following call creates a patron, linked to branch CPL.
577 # Surname is provided, other columns are randomly generated.
578 # Branch CPL is created if it does not exist.
579 my $patron = $builder->build({
580 source => 'Borrower',
581 value => { surname => 'Jansen', branchcode => 'CPL' },
586 This module automatically creates database records for you.
587 If needed, records for foreign keys are created too.
588 Values will be randomly generated if not passed to TestBuilder.
589 Note that you should wrap these actions in a transaction yourself.
595 my $builder = t::lib::TestBuilder->new;
597 Constructor - Returns the object TestBuilder
601 my $schema = $builder->schema;
603 Getter - Returns the schema of DBIx::Class
609 records => $patron, # OR: records => [ $patron, ... ],
612 Delete individual records, created by builder.
613 Returns the number of delete attempts, or undef.
617 $builder->build({ source => $source_name, value => $value });
619 Create a test record in the table, represented by $source_name.
620 The name is required and must conform to the DBIx::Class schema.
621 Values may be specified by the optional $value hashref. Will be
622 randomized otherwise.
623 If needed, TestBuilder creates linked records for foreign keys.
624 Returns the values of the new record as a hashref, or undef if
625 the record could not be created.
627 Note that build also supports recursive hash references inside the
628 value hash for foreign key columns, like:
630 column1 => 'some_value',
632 columnA => 'another_value',
635 The hash for fk_col2 here means: create a linked record with build
636 where columnA has this value. In case of a composite FK the hashes
639 Realize that passing primary key values to build may result in undef
640 if a record with that primary key already exists.
644 Given a plural Koha::Object-derived class, it creates a random element, and
645 returns the corresponding Koha::Object.
647 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
651 Yohann Dufour <yohann.dufour@biblibre.com>
653 Koha Development Team
657 Copyright 2014 - Biblibre SARL
661 This file is part of Koha.
663 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
664 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
666 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.
668 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.