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;
85 my $hashref = $self->build({ source => $source, value => $value });
87 if ( $class eq 'Koha::Old::Patrons' ) {
88 $object = $class->search({ borrowernumber => $hashref->{borrowernumber} })->next;
91 my @pks = $self->schema->source( $class->_type )->primary_columns;
92 foreach my $pk ( @pks ) {
93 push @ids, $hashref->{ $pk };
96 $object = $class->find( @ids );
103 # build returns a hash of column values for a created record, or undef
104 # build does NOT update a record, or pass back values of an existing record
105 my ($self, $params) = @_;
106 my $source = $params->{source};
108 carp "Source parameter not specified!";
111 my $value = $params->{value};
113 my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
114 carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
116 my $col_values = $self->_buildColumnValues({
120 return if !$col_values; # did not meet unique constraints?
122 # loop thru all fk and create linked records if needed
123 # fills remaining entries in $col_values
124 my $foreign_keys = $self->_getForeignKeys( { source => $source } );
125 for my $fk ( @$foreign_keys ) {
126 # skip when FK points to itself: e.g. borrowers:guarantorid
127 next if $fk->{source} eq $source;
128 my $keys = $fk->{keys};
129 my $tbl = $fk->{source};
130 my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
131 return if !$res; # failed: no need to go further
132 foreach( keys %$res ) { # save new values
133 $col_values->{$_} = $res->{$_};
137 # store this record and return hashref
138 return $self->_storeColumnValues({
140 values => $col_values,
144 sub build_sample_biblio {
145 my ( $self, $args ) = @_;
147 my $title = $args->{title} || 'Some boring read';
148 my $author = $args->{author} || 'Some boring author';
149 my $frameworkcode = $args->{frameworkcode} || '';
150 my $itemtype = $args->{itemtype}
151 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
153 my $marcflavour = C4::Context->preference('marcflavour');
155 my $record = MARC::Record->new();
156 my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
157 $record->append_fields(
158 MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
161 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
162 $record->append_fields(
163 MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
166 ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
167 $record->append_fields(
168 MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
171 my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
172 return Koha::Biblios->find($biblio_id);
175 sub build_sample_item {
176 my ( $self, $args ) = @_;
179 delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
180 my $library = delete $args->{library}
181 || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
183 my $itype = delete $args->{itype}
184 || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
186 my $barcode = delete $args->{barcode}
187 || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
189 my ( undef, undef, $itemnumber ) = C4::Items::AddItem(
191 homebranch => $library,
192 holdingbranch => $library,
199 return Koha::Items->find($itemnumber);
202 # ------------------------------------------------------------------------------
203 # Internal helper routines
206 # returns undef for failure to create linked records
207 # otherwise returns hashref containing new column values for parent record
208 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
211 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
213 # First, collect all values for creating a linked record (if needed)
214 foreach my $fk ( @$keys ) {
215 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
216 if( ref( $value->{$col} ) eq 'HASH' ) {
217 # add all keys from the FK hash
218 $fk_value = { %{ $value->{$col} }, %$fk_value };
220 if( exists $col_values->{$col} ) {
221 # add specific value (this does not necessarily exclude some
222 # values from the hash in the preceding if)
223 $fk_value->{ $destcol } = $col_values->{ $col };
225 $cnt_null++ if !defined( $col_values->{$col} );
229 # If we saw all FK columns, first run the following checks
230 if( $cnt_scalar == @$keys ) {
231 # if one or more fk cols are null, the FK constraint will not be forced
232 return {} if $cnt_null > 0;
233 # does the record exist already?
234 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
236 # create record with a recursive build call
237 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
238 return if !$row; # failure
240 # Finally, only return the new values
242 foreach my $fk ( @$keys ) {
243 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
244 next if exists $col_values->{ $col };
245 $rv->{ $col } = $row->{ $destcol };
247 return $rv; # success
252 my $source = $params->{source} || return;
253 $source =~ s|(\w+)$|$1|;
257 sub _buildColumnValues {
258 my ($self, $params) = @_;
259 my $source = _formatSource( $params ) || return;
260 my $original_value = $params->{value};
263 my @columns = $self->schema->source($source)->columns;
264 my %unique_constraints = $self->schema->source($source)->unique_constraints();
267 # we try max $build_value times if there are unique constraints
268 BUILD_VALUE: while ( $build_value ) {
269 # generate random values for all columns
270 for my $col_name( @columns ) {
271 my $valref = $self->_buildColumnValue({
273 column_name => $col_name,
274 value => $original_value,
276 return if !$valref; # failure
277 if( @$valref ) { # could be empty
278 # there will be only one value, but it could be undef
279 $col_values->{$col_name} = $valref->[0];
283 # verify the data would respect each unique constraint
284 # note that this is INCOMPLETE since not all col_values are filled
285 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
288 my $constraint_columns = $unique_constraints{$constraint};
289 # loop through all constraint columns and build the condition
290 foreach my $constraint_column ( @$constraint_columns ) {
292 # if one column does not exist or is undef, skip it
293 # an insert with a null will not trigger the constraint
295 if !exists $col_values->{ $constraint_column } ||
296 !defined $col_values->{ $constraint_column };
297 $condition->{ $constraint_column } =
298 $col_values->{ $constraint_column };
300 my $count = $self->schema
301 ->resultset( $source )
302 ->search( $condition )
305 # no point checking more stuff, exit the loop
310 last; # you passed all tests
312 return $col_values if $build_value > 0;
314 # if you get here, we have a problem
315 warn "Violation of unique constraint in $source";
319 sub _getForeignKeys {
321 # Returns the following arrayref
322 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
323 # The array gives source name and keys for each FK constraint
325 my ($self, $params) = @_;
326 my $source = $self->schema->source( $params->{source} );
328 my ( @foreign_keys, $check_dupl );
329 my @relationships = $source->relationships;
330 for my $rel_name( @relationships ) {
331 my $rel_info = $source->relationship_info($rel_name);
332 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
333 $rel_info->{source} =~ s/^.*:://g;
334 my $rel = { source => $rel_info->{source} };
337 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
338 $col_name =~ s|self.(\w+)|$1|;
339 $col_fk_name =~ s|foreign.(\w+)|$1|;
341 col_name => $col_name,
342 col_fk_name => $col_fk_name,
345 # check if the combination table and keys is unique
346 # so skip double belongs_to relations (as in Biblioitem)
347 my $tag = $rel->{source}. ':'.
348 join ',', sort map { $_->{col_name} } @keys;
349 next if $check_dupl->{$tag};
350 $check_dupl->{$tag} = 1;
351 $rel->{keys} = \@keys;
352 push @foreign_keys, $rel;
355 return \@foreign_keys;
358 sub _storeColumnValues {
359 my ($self, $params) = @_;
360 my $source = $params->{source};
361 my $col_values = $params->{values};
362 my $new_row = $self->schema->resultset( $source )->create( $col_values );
363 return $new_row? { $new_row->get_columns }: {};
366 sub _buildColumnValue {
367 # returns an arrayref if all goes well
368 # an empty arrayref typically means: auto_incr column or fk column
369 # undef means failure
370 my ($self, $params) = @_;
371 my $source = $params->{source};
372 my $value = $params->{value};
373 my $col_name = $params->{column_name};
375 my $col_info = $self->schema->source($source)->column_info($col_name);
378 if( $col_info->{is_auto_increment} ) {
379 if( exists $value->{$col_name} ) {
380 warn "Value not allowed for auto_incr $col_name in $source";
383 # otherwise: no need to assign a value
384 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
385 if( exists $value->{$col_name} ) {
386 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
387 # This explicit undef is not allowed
388 warn "Null value for $col_name in $source not allowed";
391 if( ref( $value->{$col_name} ) ne 'HASH' ) {
392 push @$retvalue, $value->{$col_name};
394 # sub build will handle a passed hash value later on
396 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
397 # this is not allowed for a column that is not a FK
398 warn "Hash not allowed for $col_name in $source";
400 } elsif( exists $value->{$col_name} ) {
401 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
402 # This explicit undef is not allowed
403 warn "Null value for $col_name in $source not allowed";
406 push @$retvalue, $value->{$col_name};
407 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
408 my $v = $self->{default_values}{$source}{$col_name};
409 $v = &$v() if ref($v) eq 'CODE';
412 my $data_type = $col_info->{data_type};
413 $data_type =~ s| |_|;
414 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
415 push @$retvalue, &$hdlr( $self, { info => $col_info } );
417 warn "Unknown type $data_type for $col_name in $source";
425 # This sub is only needed for inconsistencies in the schema
426 # A column is not marked as FK, but a belongs_to relation is defined
427 my ( $source, $column ) = @_;
428 my $inconsistencies = {
429 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
431 return $inconsistencies->{ "$source.$column" };
436 tinyint => \&_gen_int,
437 smallint => \&_gen_int,
438 mediumint => \&_gen_int,
439 integer => \&_gen_int,
440 bigint => \&_gen_int,
442 float => \&_gen_real,
443 decimal => \&_gen_real,
444 double_precision => \&_gen_real,
446 timestamp => \&_gen_datetime,
447 datetime => \&_gen_datetime,
451 varchar => \&_gen_text,
452 tinytext => \&_gen_text,
454 mediumtext => \&_gen_text,
455 longtext => \&_gen_text,
457 set => \&_gen_set_enum,
458 enum => \&_gen_set_enum,
460 tinyblob => \&_gen_blob,
461 mediumblob => \&_gen_blob,
463 longblob => \&_gen_blob,
468 my ($self, $params) = @_;
469 my $data_type = $params->{info}->{data_type};
472 if( $data_type eq 'tinyint' ) {
475 elsif( $data_type eq 'smallint' ) {
478 elsif( $data_type eq 'mediumint' ) {
481 elsif( $data_type eq 'integer' ) {
484 elsif( $data_type eq 'bigint' ) {
485 $max = 9223372036854775807;
487 return int( rand($max+1) );
491 my ($self, $params) = @_;
493 if( defined( $params->{info}->{size} ) ) {
494 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
496 return sprintf("%.2f", rand($max-0.1));
500 my ($self, $params) = @_;
501 return $self->schema->storage->datetime_parser->format_date(dt_from_string)
505 my ($self, $params) = @_;
506 return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
510 my ($self, $params) = @_;
511 # From perldoc String::Random
512 my $size = $params->{info}{size} // 10;
513 $size -= alt_rand(0.5 * $size);
514 my $regex = $size > 1
515 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
517 my $random = String::Random->new( rand_gen => \&alt_rand );
518 # rand_gen is only supported from 0.27 onward
519 return $random->randregex($regex);
522 sub alt_rand { #Alternative randomizer
524 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
525 my $r = $random->irand / 2**32;
526 return int( $r * $max );
530 my ($self, $params) = @_;
531 return $params->{info}->{extra}->{list}->[0];
535 my ($self, $params) = @_;;
539 sub _gen_default_values {
544 gonenoaddress => undef,
554 more_subfields_xml => undef,
559 # Not X, used for statistics
560 category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
564 rentalcharge_daily => 0,
565 rentalcharge_hourly => 0,
566 defaultreplacecost => 0,
577 RefundLostItemFeeRules => {
578 rule_name => 'refund',
585 t::lib::TestBuilder.pm - Koha module to create test records
589 use t::lib::TestBuilder;
590 my $builder = t::lib::TestBuilder->new;
592 # The following call creates a patron, linked to branch CPL.
593 # Surname is provided, other columns are randomly generated.
594 # Branch CPL is created if it does not exist.
595 my $patron = $builder->build({
596 source => 'Borrower',
597 value => { surname => 'Jansen', branchcode => 'CPL' },
602 This module automatically creates database records for you.
603 If needed, records for foreign keys are created too.
604 Values will be randomly generated if not passed to TestBuilder.
605 Note that you should wrap these actions in a transaction yourself.
611 my $builder = t::lib::TestBuilder->new;
613 Constructor - Returns the object TestBuilder
617 my $schema = $builder->schema;
619 Getter - Returns the schema of DBIx::Class
625 records => $patron, # OR: records => [ $patron, ... ],
628 Delete individual records, created by builder.
629 Returns the number of delete attempts, or undef.
633 $builder->build({ source => $source_name, value => $value });
635 Create a test record in the table, represented by $source_name.
636 The name is required and must conform to the DBIx::Class schema.
637 Values may be specified by the optional $value hashref. Will be
638 randomized otherwise.
639 If needed, TestBuilder creates linked records for foreign keys.
640 Returns the values of the new record as a hashref, or undef if
641 the record could not be created.
643 Note that build also supports recursive hash references inside the
644 value hash for foreign key columns, like:
646 column1 => 'some_value',
648 columnA => 'another_value',
651 The hash for fk_col2 here means: create a linked record with build
652 where columnA has this value. In case of a composite FK the hashes
655 Realize that passing primary key values to build may result in undef
656 if a record with that primary key already exists.
660 Given a plural Koha::Object-derived class, it creates a random element, and
661 returns the corresponding Koha::Object.
663 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
667 Yohann Dufour <yohann.dufour@biblibre.com>
669 Koha Development Team
673 Copyright 2014 - Biblibre SARL
677 This file is part of Koha.
679 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
680 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
682 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.
684 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.