1 package t::lib::TestBuilder;
10 use Koha::DateUtils qw( dt_from_string );
12 use Bytes::Random::Secure;
18 SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
24 bless( $self, $class );
26 $self->schema( Koha::Database->new()->schema );
27 $self->schema->storage->sql_maker->quote_char('`');
29 $self->{gen_type} = _gen_type();
30 $self->{default_values} = _gen_default_values();
35 my ($self, $schema) = @_;
37 if( defined( $schema ) ) {
38 $self->{schema} = $schema;
40 return $self->{schema};
43 # sub clear has been obsoleted; use delete_all from the schema resultset
46 my ( $self, $params ) = @_;
47 my $source = $params->{source} || return;
48 my @recs = ref( $params->{records} ) eq 'ARRAY'?
49 @{$params->{records}}: ( $params->{records} // () );
50 # tables without PK are not supported
51 my @pk = $self->schema->source( $source )->primary_columns;
54 foreach my $rec ( @recs ) {
55 # delete only works when you supply full primary key values
56 # $cond does not include searches for undef (not allowed in PK)
57 my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
58 next if keys %$cond < @pk;
59 $self->schema->resultset( $source )->search( $cond )->delete;
60 # we clear the pk columns in the supplied hash
61 # this indirectly signals at least an attempt to delete
62 map { delete $rec->{$_}; } @pk;
69 my ( $self, $params ) = @_;
71 my $class = $params->{class};
72 my $value = $params->{value};
74 if ( not defined $class ) {
75 carp "Missing class param";
79 my @unknowns = grep( !/^(class|value)$/, keys %{ $params });
80 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
83 my $source = $class->_type;
84 my @pks = $self->schema->source( $class->_type )->primary_columns;
86 my $hashref = $self->build({ source => $source, value => $value });
89 foreach my $pk ( @pks ) {
90 push @ids, $hashref->{ $pk };
93 my $object = $class->find( @ids );
99 # build returns a hash of column values for a created record, or undef
100 # build does NOT update a record, or pass back values of an existing record
101 my ($self, $params) = @_;
102 my $source = $params->{source};
104 carp "Source parameter not specified!";
107 my $value = $params->{value};
109 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
110 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
112 my $col_values = $self->_buildColumnValues({
116 return if !$col_values; # did not meet unique constraints?
118 # loop thru all fk and create linked records if needed
119 # fills remaining entries in $col_values
120 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
121 for my $fk ( @$foreign_keys ) {
122 # skip when FK points to itself: e.g. borrowers:guarantorid
123 next if $fk->{source} eq $source;
124 my $keys = $fk->{keys};
125 my $tbl = $fk->{source};
126 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
127 return if !$res; # failed: no need to go further
128 foreach( keys %$res ) { # save new values
129 $col_values->{$_} = $res->{$_};
133 # store this record and return hashref
134 return $self->_storeColumnValues({
136 values => $col_values,
140 sub build_sample_biblio {
141 my ( $self, $args ) = @_;
143 my $title = $args->{title} || 'Some boring read';
144 my $author = $args->{author} || 'Some boring author';
145 my $frameworkcode = $args->{frameworkcode} || '';
146 my $itemtype = $args->{itemtype}
147 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
149 my $marcflavour = C4::Context->preference('marcflavour');
151 my $record = MARC::Record->new();
152 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
153 $record->append_fields(
154 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
157 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
158 $record->append_fields(
159 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
162 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
163 $record->append_fields(
164 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
167 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
168 return Koha::Biblios->find($biblio_id);
171 sub build_sample_item {
172 my ( $self, $args ) = @_;
175 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
176 my $library = delete $args->{library}
177 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
179 my $itype = delete $args->{itype}
180 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
182 my $barcode = delete $args->{barcode}
183 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
185 my ( undef, undef, $itemnumber ) = C4::Items::AddItem(
187 homebranch => $library,
188 holdingbranch => $library,
195 return Koha::Items->find($itemnumber);
198 # ------------------------------------------------------------------------------
199 # Internal helper routines
202 # returns undef for failure to create linked records
203 # otherwise returns hashref containing new column values for parent record
204 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
207 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
209 # First, collect all values for creating a linked record (if needed)
210 foreach my $fk ( @$keys ) {
211 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
212 if( ref( $value->{$col} ) eq 'HASH' ) {
213 # add all keys from the FK hash
214 $fk_value = { %{ $value->{$col} }, %$fk_value };
216 if( exists $col_values->{$col} ) {
217 # add specific value (this does not necessarily exclude some
218 # values from the hash in the preceding if)
219 $fk_value->{ $destcol } = $col_values->{ $col };
221 $cnt_null++ if !defined( $col_values->{$col} );
225 # If we saw all FK columns, first run the following checks
226 if( $cnt_scalar == @$keys ) {
227 # if one or more fk cols are null, the FK constraint will not be forced
228 return {} if $cnt_null > 0;
229 # does the record exist already?
230 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
232 # create record with a recursive build call
233 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
234 return if !$row; # failure
236 # Finally, only return the new values
238 foreach my $fk ( @$keys ) {
239 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
240 next if exists $col_values->{ $col };
241 $rv->{ $col } = $row->{ $destcol };
243 return $rv; # success
248 my $source = $params->{source} || return;
249 $source =~ s|(\w+)$|$1|;
253 sub _buildColumnValues {
254 my ($self, $params) = @_;
255 my $source = _formatSource( $params ) || return;
256 my $original_value = $params->{value};
259 my @columns = $self->schema->source($source)->columns;
260 my %unique_constraints = $self->schema->source($source)->unique_constraints();
263 # we try max $build_value times if there are unique constraints
264 BUILD_VALUE: while ( $build_value ) {
265 # generate random values for all columns
266 for my $col_name( @columns ) {
267 my $valref = $self->_buildColumnValue({
269 column_name => $col_name,
270 value => $original_value,
272 return if !$valref; # failure
273 if( @$valref ) { # could be empty
274 # there will be only one value, but it could be undef
275 $col_values->{$col_name} = $valref->[0];
279 # verify the data would respect each unique constraint
280 # note that this is INCOMPLETE since not all col_values are filled
281 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
284 my $constraint_columns = $unique_constraints{$constraint};
285 # loop through all constraint columns and build the condition
286 foreach my $constraint_column ( @$constraint_columns ) {
288 # if one column does not exist or is undef, skip it
289 # an insert with a null will not trigger the constraint
291 if !exists $col_values->{ $constraint_column } ||
292 !defined $col_values->{ $constraint_column };
293 $condition->{ $constraint_column } =
294 $col_values->{ $constraint_column };
296 my $count = $self->schema
297 ->resultset( $source )
298 ->search( $condition )
301 # no point checking more stuff, exit the loop
306 last; # you passed all tests
308 return $col_values if $build_value > 0;
310 # if you get here, we have a problem
311 warn "Violation of unique constraint in $source";
315 sub _getForeignKeys {
317 # Returns the following arrayref
318 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
319 # The array gives source name and keys for each FK constraint
321 my ($self, $params) = @_;
322 my $source = $self->schema->source( $params->{source} );
324 my ( @foreign_keys, $check_dupl );
325 my @relationships = $source->relationships;
326 for my $rel_name( @relationships ) {
327 my $rel_info = $source->relationship_info($rel_name);
328 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
329 $rel_info->{source} =~ s/^.*:://g;
330 my $rel = { source => $rel_info->{source} };
333 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
334 $col_name =~ s|self.(\w+)|$1|;
335 $col_fk_name =~ s|foreign.(\w+)|$1|;
337 col_name => $col_name,
338 col_fk_name => $col_fk_name,
341 # check if the combination table and keys is unique
342 # so skip double belongs_to relations (as in Biblioitem)
343 my $tag = $rel->{source}. ':'.
344 join ',', sort map { $_->{col_name} } @keys;
345 next if $check_dupl->{$tag};
346 $check_dupl->{$tag} = 1;
347 $rel->{keys} = \@keys;
348 push @foreign_keys, $rel;
351 return \@foreign_keys;
354 sub _storeColumnValues {
355 my ($self, $params) = @_;
356 my $source = $params->{source};
357 my $col_values = $params->{values};
358 my $new_row = $self->schema->resultset( $source )->create( $col_values );
359 return $new_row? { $new_row->get_columns }: {};
362 sub _buildColumnValue {
363 # returns an arrayref if all goes well
364 # an empty arrayref typically means: auto_incr column or fk column
365 # undef means failure
366 my ($self, $params) = @_;
367 my $source = $params->{source};
368 my $value = $params->{value};
369 my $col_name = $params->{column_name};
371 my $col_info = $self->schema->source($source)->column_info($col_name);
374 if( $col_info->{is_auto_increment} ) {
375 if( exists $value->{$col_name} ) {
376 warn "Value not allowed for auto_incr $col_name in $source";
379 # otherwise: no need to assign a value
380 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
381 if( exists $value->{$col_name} ) {
382 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
383 # This explicit undef is not allowed
384 warn "Null value for $col_name in $source not allowed";
387 if( ref( $value->{$col_name} ) ne 'HASH' ) {
388 push @$retvalue, $value->{$col_name};
390 # sub build will handle a passed hash value later on
392 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
393 # this is not allowed for a column that is not a FK
394 warn "Hash not allowed for $col_name in $source";
396 } elsif( exists $value->{$col_name} ) {
397 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
398 # This explicit undef is not allowed
399 warn "Null value for $col_name in $source not allowed";
402 push @$retvalue, $value->{$col_name};
403 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
404 my $v = $self->{default_values}{$source}{$col_name};
405 $v = &$v() if ref($v) eq 'CODE';
408 my $data_type = $col_info->{data_type};
409 $data_type =~ s| |_|;
410 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
411 push @$retvalue, &$hdlr( $self, { info => $col_info } );
413 warn "Unknown type $data_type for $col_name in $source";
421 # This sub is only needed for inconsistencies in the schema
422 # A column is not marked as FK, but a belongs_to relation is defined
423 my ( $source, $column ) = @_;
424 my $inconsistencies = {
425 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
427 return $inconsistencies->{ "$source.$column" };
432 tinyint => \&_gen_int,
433 smallint => \&_gen_int,
434 mediumint => \&_gen_int,
435 integer => \&_gen_int,
436 bigint => \&_gen_int,
438 float => \&_gen_real,
439 decimal => \&_gen_real,
440 double_precision => \&_gen_real,
442 timestamp => \&_gen_datetime,
443 datetime => \&_gen_datetime,
447 varchar => \&_gen_text,
448 tinytext => \&_gen_text,
450 mediumtext => \&_gen_text,
451 longtext => \&_gen_text,
453 set => \&_gen_set_enum,
454 enum => \&_gen_set_enum,
456 tinyblob => \&_gen_blob,
457 mediumblob => \&_gen_blob,
459 longblob => \&_gen_blob,
464 my ($self, $params) = @_;
465 my $data_type = $params->{info}->{data_type};
468 if( $data_type eq 'tinyint' ) {
471 elsif( $data_type eq 'smallint' ) {
474 elsif( $data_type eq 'mediumint' ) {
477 elsif( $data_type eq 'integer' ) {
480 elsif( $data_type eq 'bigint' ) {
481 $max = 9223372036854775807;
483 return int( rand($max+1) );
487 my ($self, $params) = @_;
489 if( defined( $params->{info}->{size} ) ) {
490 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
492 return sprintf("%.2f", rand($max-0.1));
496 my ($self, $params) = @_;
497 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
501 my ($self, $params) = @_;
502 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
506 my ($self, $params) = @_;
507 # From perldoc String::Random
508 my $size = $params->{info}{size} // 10;
509 $size -= alt_rand(0.5 * $size);
510 my $regex = $size > 1
511 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
513 my $random = String::Random->new( rand_gen => \&alt_rand );
514 # rand_gen is only supported from 0.27 onward
515 return $random->randregex($regex);
518 sub alt_rand { #Alternative randomizer
520 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
521 my $r = $random->irand / 2**32;
522 return int( $r * $max );
526 my ($self, $params) = @_;
527 return $params->{info}->{extra}->{list}->[0];
531 my ($self, $params) = @_;;
535 sub _gen_default_values {
540 gonenoaddress => undef,
550 more_subfields_xml => undef,
555 # Not X, used for statistics
556 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
560 rentalcharge_daily => 0,
561 rentalcharge_hourly => 0,
562 defaultreplacecost => 0,
573 RefundLostItemFeeRules => {
574 rule_name => 'refund',
581 t::lib::TestBuilder.pm - Koha module to create test records
585 use t::lib::TestBuilder;
586 my $builder = t::lib::TestBuilder->new;
588 # The following call creates a patron, linked to branch CPL.
589 # Surname is provided, other columns are randomly generated.
590 # Branch CPL is created if it does not exist.
591 my $patron = $builder->build({
592 source => 'Borrower',
593 value => { surname => 'Jansen', branchcode => 'CPL' },
598 This module automatically creates database records for you.
599 If needed, records for foreign keys are created too.
600 Values will be randomly generated if not passed to TestBuilder.
601 Note that you should wrap these actions in a transaction yourself.
607 my $builder = t::lib::TestBuilder->new;
609 Constructor - Returns the object TestBuilder
613 my $schema = $builder->schema;
615 Getter - Returns the schema of DBIx::Class
621 records => $patron, # OR: records => [ $patron, ... ],
624 Delete individual records, created by builder.
625 Returns the number of delete attempts, or undef.
629 $builder->build({ source => $source_name, value => $value });
631 Create a test record in the table, represented by $source_name.
632 The name is required and must conform to the DBIx::Class schema.
633 Values may be specified by the optional $value hashref. Will be
634 randomized otherwise.
635 If needed, TestBuilder creates linked records for foreign keys.
636 Returns the values of the new record as a hashref, or undef if
637 the record could not be created.
639 Note that build also supports recursive hash references inside the
640 value hash for foreign key columns, like:
642 column1 => 'some_value',
644 columnA => 'another_value',
647 The hash for fk_col2 here means: create a linked record with build
648 where columnA has this value. In case of a composite FK the hashes
651 Realize that passing primary key values to build may result in undef
652 if a record with that primary key already exists.
656 Given a plural Koha::Object-derived class, it creates a random element, and
657 returns the corresponding Koha::Object.
659 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
663 Yohann Dufour <yohann.dufour@biblibre.com>
665 Koha Development Team
669 Copyright 2014 - Biblibre SARL
673 This file is part of Koha.
675 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
676 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
678 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.
680 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.