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 ( undef, undef, $itemnumber ) = C4::Items::AddItem(
180 homebranch => $library,
181 holdingbranch => $library,
182 barcode => $self->_gen_text( { info => { size => SIZE_BARCODE } } ),
188 return Koha::Items->find($itemnumber);
191 # ------------------------------------------------------------------------------
192 # Internal helper routines
195 # returns undef for failure to create linked records
196 # otherwise returns hashref containing new column values for parent record
197 my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
200 my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
202 # First, collect all values for creating a linked record (if needed)
203 foreach my $fk ( @$keys ) {
204 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
205 if( ref( $value->{$col} ) eq 'HASH' ) {
206 # add all keys from the FK hash
207 $fk_value = { %{ $value->{$col} }, %$fk_value };
209 if( exists $col_values->{$col} ) {
210 # add specific value (this does not necessarily exclude some
211 # values from the hash in the preceding if)
212 $fk_value->{ $destcol } = $col_values->{ $col };
214 $cnt_null++ if !defined( $col_values->{$col} );
218 # If we saw all FK columns, first run the following checks
219 if( $cnt_scalar == @$keys ) {
220 # if one or more fk cols are null, the FK constraint will not be forced
221 return {} if $cnt_null > 0;
222 # does the record exist already?
223 return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
225 # create record with a recursive build call
226 my $row = $self->build({ source => $linked_tbl, value => $fk_value });
227 return if !$row; # failure
229 # Finally, only return the new values
231 foreach my $fk ( @$keys ) {
232 my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
233 next if exists $col_values->{ $col };
234 $rv->{ $col } = $row->{ $destcol };
236 return $rv; # success
241 my $source = $params->{source} || return;
242 $source =~ s|(\w+)$|$1|;
246 sub _buildColumnValues {
247 my ($self, $params) = @_;
248 my $source = _formatSource( $params ) || return;
249 my $original_value = $params->{value};
252 my @columns = $self->schema->source($source)->columns;
253 my %unique_constraints = $self->schema->source($source)->unique_constraints();
256 # we try max $build_value times if there are unique constraints
257 BUILD_VALUE: while ( $build_value ) {
258 # generate random values for all columns
259 for my $col_name( @columns ) {
260 my $valref = $self->_buildColumnValue({
262 column_name => $col_name,
263 value => $original_value,
265 return if !$valref; # failure
266 if( @$valref ) { # could be empty
267 # there will be only one value, but it could be undef
268 $col_values->{$col_name} = $valref->[0];
272 # verify the data would respect each unique constraint
273 # note that this is INCOMPLETE since not all col_values are filled
274 CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
277 my $constraint_columns = $unique_constraints{$constraint};
278 # loop through all constraint columns and build the condition
279 foreach my $constraint_column ( @$constraint_columns ) {
281 # if one column does not exist or is undef, skip it
282 # an insert with a null will not trigger the constraint
284 if !exists $col_values->{ $constraint_column } ||
285 !defined $col_values->{ $constraint_column };
286 $condition->{ $constraint_column } =
287 $col_values->{ $constraint_column };
289 my $count = $self->schema
290 ->resultset( $source )
291 ->search( $condition )
294 # no point checking more stuff, exit the loop
299 last; # you passed all tests
301 return $col_values if $build_value > 0;
303 # if you get here, we have a problem
304 warn "Violation of unique constraint in $source";
308 sub _getForeignKeys {
310 # Returns the following arrayref
311 # [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
312 # The array gives source name and keys for each FK constraint
314 my ($self, $params) = @_;
315 my $source = $self->schema->source( $params->{source} );
317 my ( @foreign_keys, $check_dupl );
318 my @relationships = $source->relationships;
319 for my $rel_name( @relationships ) {
320 my $rel_info = $source->relationship_info($rel_name);
321 if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
322 $rel_info->{source} =~ s/^.*:://g;
323 my $rel = { source => $rel_info->{source} };
326 while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
327 $col_name =~ s|self.(\w+)|$1|;
328 $col_fk_name =~ s|foreign.(\w+)|$1|;
330 col_name => $col_name,
331 col_fk_name => $col_fk_name,
334 # check if the combination table and keys is unique
335 # so skip double belongs_to relations (as in Biblioitem)
336 my $tag = $rel->{source}. ':'.
337 join ',', sort map { $_->{col_name} } @keys;
338 next if $check_dupl->{$tag};
339 $check_dupl->{$tag} = 1;
340 $rel->{keys} = \@keys;
341 push @foreign_keys, $rel;
344 return \@foreign_keys;
347 sub _storeColumnValues {
348 my ($self, $params) = @_;
349 my $source = $params->{source};
350 my $col_values = $params->{values};
351 my $new_row = $self->schema->resultset( $source )->create( $col_values );
352 return $new_row? { $new_row->get_columns }: {};
355 sub _buildColumnValue {
356 # returns an arrayref if all goes well
357 # an empty arrayref typically means: auto_incr column or fk column
358 # undef means failure
359 my ($self, $params) = @_;
360 my $source = $params->{source};
361 my $value = $params->{value};
362 my $col_name = $params->{column_name};
364 my $col_info = $self->schema->source($source)->column_info($col_name);
367 if( $col_info->{is_auto_increment} ) {
368 if( exists $value->{$col_name} ) {
369 warn "Value not allowed for auto_incr $col_name in $source";
372 # otherwise: no need to assign a value
373 } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
374 if( exists $value->{$col_name} ) {
375 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
376 # This explicit undef is not allowed
377 warn "Null value for $col_name in $source not allowed";
380 if( ref( $value->{$col_name} ) ne 'HASH' ) {
381 push @$retvalue, $value->{$col_name};
383 # sub build will handle a passed hash value later on
385 } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
386 # this is not allowed for a column that is not a FK
387 warn "Hash not allowed for $col_name in $source";
389 } elsif( exists $value->{$col_name} ) {
390 if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
391 # This explicit undef is not allowed
392 warn "Null value for $col_name in $source not allowed";
395 push @$retvalue, $value->{$col_name};
396 } elsif( exists $self->{default_values}{$source}{$col_name} ) {
397 push @$retvalue, $self->{default_values}{$source}{$col_name};
399 my $data_type = $col_info->{data_type};
400 $data_type =~ s| |_|;
401 if( my $hdlr = $self->{gen_type}->{$data_type} ) {
402 push @$retvalue, &$hdlr( $self, { info => $col_info } );
404 warn "Unknown type $data_type for $col_name in $source";
412 # This sub is only needed for inconsistencies in the schema
413 # A column is not marked as FK, but a belongs_to relation is defined
414 my ( $source, $column ) = @_;
415 my $inconsistencies = {
416 'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
418 return $inconsistencies->{ "$source.$column" };
423 tinyint => \&_gen_int,
424 smallint => \&_gen_int,
425 mediumint => \&_gen_int,
426 integer => \&_gen_int,
427 bigint => \&_gen_int,
429 float => \&_gen_real,
430 decimal => \&_gen_real,
431 double_precision => \&_gen_real,
433 timestamp => \&_gen_datetime,
434 datetime => \&_gen_datetime,
438 varchar => \&_gen_text,
439 tinytext => \&_gen_text,
441 mediumtext => \&_gen_text,
442 longtext => \&_gen_text,
444 set => \&_gen_set_enum,
445 enum => \&_gen_set_enum,
447 tinyblob => \&_gen_blob,
448 mediumblob => \&_gen_blob,
450 longblob => \&_gen_blob,
455 my ($self, $params) = @_;
456 my $data_type = $params->{info}->{data_type};
459 if( $data_type eq 'tinyint' ) {
462 elsif( $data_type eq 'smallint' ) {
465 elsif( $data_type eq 'mediumint' ) {
468 elsif( $data_type eq 'integer' ) {
471 elsif( $data_type eq 'bigint' ) {
472 $max = 9223372036854775807;
474 return int( rand($max+1) );
478 my ($self, $params) = @_;
480 if( defined( $params->{info}->{size} ) ) {
481 $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
483 return sprintf("%.2f", rand($max-0.1));
487 my ($self, $params) = @_;
488 return $self->schema->storage->datetime_parser->format_date(DateTime->now())
492 my ($self, $params) = @_;
493 return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
497 my ($self, $params) = @_;
498 # From perldoc String::Random
499 my $size = $params->{info}{size} // 10;
500 $size -= alt_rand(0.5 * $size);
501 my $regex = $size > 1
502 ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
504 my $random = String::Random->new( rand_gen => \&alt_rand );
505 # rand_gen is only supported from 0.27 onward
506 return $random->randregex($regex);
509 sub alt_rand { #Alternative randomizer
511 my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
512 my $r = $random->irand / 2**32;
513 return int( $r * $max );
517 my ($self, $params) = @_;
518 return $params->{info}->{extra}->{list}->[0];
522 my ($self, $params) = @_;;
526 sub _gen_default_values {
531 gonenoaddress => undef,
541 more_subfields_xml => undef,
549 defaultreplacecost => 0,
567 t::lib::TestBuilder.pm - Koha module to create test records
571 use t::lib::TestBuilder;
572 my $builder = t::lib::TestBuilder->new;
574 # The following call creates a patron, linked to branch CPL.
575 # Surname is provided, other columns are randomly generated.
576 # Branch CPL is created if it does not exist.
577 my $patron = $builder->build({
578 source => 'Borrower',
579 value => { surname => 'Jansen', branchcode => 'CPL' },
584 This module automatically creates database records for you.
585 If needed, records for foreign keys are created too.
586 Values will be randomly generated if not passed to TestBuilder.
587 Note that you should wrap these actions in a transaction yourself.
593 my $builder = t::lib::TestBuilder->new;
595 Constructor - Returns the object TestBuilder
599 my $schema = $builder->schema;
601 Getter - Returns the schema of DBIx::Class
607 records => $patron, # OR: records => [ $patron, ... ],
610 Delete individual records, created by builder.
611 Returns the number of delete attempts, or undef.
615 $builder->build({ source => $source_name, value => $value });
617 Create a test record in the table, represented by $source_name.
618 The name is required and must conform to the DBIx::Class schema.
619 Values may be specified by the optional $value hashref. Will be
620 randomized otherwise.
621 If needed, TestBuilder creates linked records for foreign keys.
622 Returns the values of the new record as a hashref, or undef if
623 the record could not be created.
625 Note that build also supports recursive hash references inside the
626 value hash for foreign key columns, like:
628 column1 => 'some_value',
630 columnA => 'another_value',
633 The hash for fk_col2 here means: create a linked record with build
634 where columnA has this value. In case of a composite FK the hashes
637 Realize that passing primary key values to build may result in undef
638 if a record with that primary key already exists.
642 Given a plural Koha::Object-derived class, it creates a random element, and
643 returns the corresponding Koha::Object.
645 my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
649 Yohann Dufour <yohann.dufour@biblibre.com>
651 Koha Development Team
655 Copyright 2014 - Biblibre SARL
659 This file is part of Koha.
661 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
662 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
664 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.
666 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.