t/lib/TestBuilder.pm

   1 package t::lib::TestBuilder;
   2
   3 use Modern::Perl;
   4 use Koha::Database;
   5 use String::Random;
   6
   7 sub new {
   8     my ($class) = @_;
   9     my $self = {};
  10     bless( $self, $class );
  11
  12     $self->schema( Koha::Database->new()->schema );
  13     $self->schema->storage->sql_maker->quote_char('`');
  14
  15     $self->{gen_type} = _gen_type();
  16     return $self;
  17 }
  18
  19 sub schema {
  20     my ($self, $schema) = @_;
  21
  22     if( defined( $schema ) ) {
  23         $self->{schema} = $schema;
  24     }
  25     return $self->{schema};
  26 }
  27
  28 # sub clear has been obsoleted; use delete_all from the schema resultset
  29
  30 sub delete {
  31     my ( $self, $params ) = @_;
  32     my $source = $params->{source} || return;
  33     my @recs = ref( $params->{records} ) eq 'ARRAY'?
  34         @{$params->{records}}: ( $params->{records} // () );
  35     # tables without PK are not supported
  36     my @pk = $self->schema->source( $source )->primary_columns;
  37     return if !@pk;
  38     my $rv = 0;
  39     foreach my $rec ( @recs ) {
  40     # delete only works when you supply full primary key values
  41     # $cond does not include searches for undef (not allowed in PK)
  42         my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
  43         next if keys %$cond < @pk;
  44         $self->schema->resultset( $source )->search( $cond )->delete;
  45         # we clear the pk columns in the supplied hash
  46         # this indirectly signals at least an attempt to delete
  47         map { delete $rec->{$_}; } @pk;
  48         $rv++;
  49     }
  50     return $rv;
  51 }
  52
  53 sub build {
  54 # build returns a hash of column values for a created record, or undef
  55 # build does NOT update a record, or pass back values of an existing record
  56     my ($self, $params) = @_;
  57     my $source  = $params->{source} || return;
  58     my $value   = $params->{value};
  59
  60     my $col_values = $self->_buildColumnValues({
  61         source  => $source,
  62         value   => $value,
  63     });
  64     return if !$col_values; # did not meet unique constraints?
  65
  66     # loop thru all fk and create linked records if needed
  67     # fills remaining entries in $col_values
  68     my $foreign_keys = $self->_getForeignKeys( { source => $source } );
  69     for my $fk ( @$foreign_keys ) {
  70         # skip when FK points to itself: e.g. borrowers:guarantorid
  71         next if $fk->{source} eq $source;
  72         my $keys = $fk->{keys};
  73         my $tbl = $fk->{source};
  74         my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
  75         return if !$res; # failed: no need to go further
  76         foreach( keys %$res ) { # save new values
  77             $col_values->{$_} = $res->{$_};
  78         }
  79     }
  80
  81     # store this record and return hashref
  82     return $self->_storeColumnValues({
  83         source => $source,
  84         values => $col_values,
  85     });
  86 }
  87
  88 # ------------------------------------------------------------------------------
  89 # Internal helper routines
  90
  91 sub _create_links {
  92 # returns undef for failure to create linked records
  93 # otherwise returns hashref containing new column values for parent record
  94     my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
  95
  96     my $fk_value = {};
  97     my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
  98
  99     # First, collect all values for creating a linked record (if needed)
 100     foreach my $fk ( @$keys ) {
 101         my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
 102         if( ref( $value->{$col} ) eq 'HASH' ) {
 103             # add all keys from the FK hash
 104             $fk_value = { %{ $value->{$col} }, %$fk_value };
 105         }
 106         if( exists $col_values->{$col} ) {
 107             # add specific value (this does not necessarily exclude some
 108             # values from the hash in the preceding if)
 109             $fk_value->{ $destcol } = $col_values->{ $col };
 110             $cnt_scalar++;
 111             $cnt_null++ if !defined( $col_values->{$col} );
 112         }
 113     }
 114
 115     # If we saw all FK columns, first run the following checks
 116     if( $cnt_scalar == @$keys ) {
 117         # if one or more fk cols are null, the FK constraint will not be forced
 118         return {} if $cnt_null > 0;
 119         # does the record exist already?
 120         return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
 121     }
 122     # create record with a recursive build call
 123     my $row = $self->build({ source => $linked_tbl, value => $fk_value });
 124     return if !$row; # failure
 125
 126     # Finally, only return the new values
 127     my $rv = {};
 128     foreach my $fk ( @$keys ) {
 129         my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
 130         next if exists $col_values->{ $col };
 131         $rv->{ $col } = $row->{ $destcol };
 132     }
 133     return $rv; # success
 134 }
 135
 136 sub _formatSource {
 137     my ($params) = @_;
 138     my $source = $params->{source} || return;
 139     $source =~ s|(\w+)$|$1|;
 140     return $source;
 141 }
 142
 143 sub _buildColumnValues {
 144     my ($self, $params) = @_;
 145     my $source = _formatSource( $params ) || return;
 146     my $original_value = $params->{value};
 147
 148     my $col_values = {};
 149     my @columns = $self->schema->source($source)->columns;
 150     my %unique_constraints = $self->schema->source($source)->unique_constraints();
 151
 152     my $build_value = 3;
 153     # we try max three times if there are unique constraints
 154     BUILD_VALUE: while ( $build_value ) {
 155         # generate random values for all columns
 156         for my $col_name( @columns ) {
 157             my $valref = $self->_buildColumnValue({
 158                 source      => $source,
 159                 column_name => $col_name,
 160                 value       => $original_value,
 161             });
 162             return if !$valref; # failure
 163             if( @$valref ) { # could be empty
 164                 # there will be only one value, but it could be undef
 165                 $col_values->{$col_name} = $valref->[0];
 166             }
 167         }
 168
 169         # verify the data would respect each unique constraint
 170         # note that this is INCOMPLETE since not all col_values are filled
 171         CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
 172
 173                 my $condition;
 174                 my $constraint_columns = $unique_constraints{$constraint};
 175                 # loop through all constraint columns and build the condition
 176                 foreach my $constraint_column ( @$constraint_columns ) {
 177                     # build the filter
 178                     # if one column does not exist or is undef, skip it
 179                     # an insert with a null will not trigger the constraint
 180                     next CONSTRAINTS
 181                         if !exists $col_values->{ $constraint_column } ||
 182                         !defined $col_values->{ $constraint_column };
 183                     $condition->{ $constraint_column } =
 184                             $col_values->{ $constraint_column };
 185                 }
 186                 my $count = $self->schema
 187                                  ->resultset( $source )
 188                                  ->search( $condition )
 189                                  ->count();
 190                 if ( $count > 0 ) {
 191                     # no point checking more stuff, exit the loop
 192                     $build_value--;
 193                     next BUILD_VALUE;
 194                 }
 195         }
 196         last; # you passed all tests
 197     }
 198     return $col_values if $build_value > 0;
 199
 200     # if you get here, we have a problem
 201     warn "Violation of unique constraint in $source";
 202     return;
 203 }
 204
 205 sub _getForeignKeys {
 206
 207 # Returns the following arrayref
 208 #   [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
 209 # The array gives source name and keys for each FK constraint
 210
 211     my ($self, $params) = @_;
 212     my $source = $self->schema->source( $params->{source} );
 213
 214     my ( @foreign_keys, $check_dupl );
 215     my @relationships = $source->relationships;
 216     for my $rel_name( @relationships ) {
 217         my $rel_info = $source->relationship_info($rel_name);
 218         if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
 219             $rel_info->{source} =~ s/^.*:://g;
 220             my $rel = { source => $rel_info->{source} };
 221
 222             my @keys;
 223             while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
 224                 $col_name    =~ s|self.(\w+)|$1|;
 225                 $col_fk_name =~ s|foreign.(\w+)|$1|;
 226                 push @keys, {
 227                     col_name    => $col_name,
 228                     col_fk_name => $col_fk_name,
 229                 };
 230             }
 231             # check if the combination table and keys is unique
 232             # so skip double belongs_to relations (as in Biblioitem)
 233             my $tag = $rel->{source}. ':'.
 234                 join ',', sort map { $_->{col_name} } @keys;
 235             next if $check_dupl->{$tag};
 236             $check_dupl->{$tag} = 1;
 237             $rel->{keys} = \@keys;
 238             push @foreign_keys, $rel;
 239         }
 240     }
 241     return \@foreign_keys;
 242 }
 243
 244 sub _storeColumnValues {
 245     my ($self, $params) = @_;
 246     my $source      = $params->{source};
 247     my $col_values  = $params->{values};
 248     my $new_row = $self->schema->resultset( $source )->create( $col_values );
 249     return $new_row? { $new_row->get_columns }: {};
 250 }
 251
 252 sub _buildColumnValue {
 253 # returns an arrayref if all goes well
 254 # an empty arrayref typically means: auto_incr column or fk column
 255 # undef means failure
 256     my ($self, $params) = @_;
 257     my $source    = $params->{source};
 258     my $value     = $params->{value};
 259     my $col_name  = $params->{column_name};
 260
 261     my $col_info  = $self->schema->source($source)->column_info($col_name);
 262
 263     my $retvalue = [];
 264     if( $col_info->{is_auto_increment} ) {
 265         if( exists $value->{$col_name} ) {
 266             warn "Value not allowed for auto_incr $col_name in $source";
 267             return;
 268         }
 269         # otherwise: no need to assign a value
 270     } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
 271         if( exists $value->{$col_name} ) {
 272             if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
 273                 # This explicit undef is not allowed
 274                 warn "Null value for $col_name in $source not allowed";
 275                 return;
 276             }
 277             if( ref( $value->{$col_name} ) ne 'HASH' ) {
 278                 push @$retvalue, $value->{$col_name};
 279             }
 280             # sub build will handle a passed hash value later on
 281         }
 282     } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
 283         # this is not allowed for a column that is not a FK
 284         warn "Hash not allowed for $col_name in $source";
 285         return;
 286     } elsif( exists $value->{$col_name} ) {
 287         if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
 288             # This explicit undef is not allowed
 289             warn "Null value for $col_name in $source not allowed";
 290             return;
 291         }
 292         push @$retvalue, $value->{$col_name};
 293     } else {
 294         my $data_type = $col_info->{data_type};
 295         $data_type =~ s| |_|;
 296         if( my $hdlr = $self->{gen_type}->{$data_type} ) {
 297             push @$retvalue, &$hdlr( $self, { info => $col_info } );
 298         } else {
 299             warn "Unknown type $data_type for $col_name in $source";
 300             return;
 301         }
 302     }
 303     return $retvalue;
 304 }
 305
 306 sub _should_be_fk {
 307 # This sub is only needed for inconsistencies in the schema
 308 # A column is not marked as FK, but a belongs_to relation is defined
 309     my ( $source, $column ) = @_;
 310     my $inconsistencies = {
 311         'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
 312     };
 313     return $inconsistencies->{ "$source.$column" };
 314 }
 315
 316 sub _gen_type {
 317     return {
 318         tinyint   => \&_gen_int,
 319         smallint  => \&_gen_int,
 320         mediumint => \&_gen_int,
 321         integer   => \&_gen_int,
 322         bigint    => \&_gen_int,
 323
 324         float            => \&_gen_real,
 325         decimal          => \&_gen_real,
 326         double_precision => \&_gen_real,
 327
 328         timestamp => \&_gen_date,
 329         datetime  => \&_gen_date,
 330         date      => \&_gen_date,
 331
 332         char       => \&_gen_text,
 333         varchar    => \&_gen_text,
 334         tinytext   => \&_gen_text,
 335         text       => \&_gen_text,
 336         mediumtext => \&_gen_text,
 337         longtext   => \&_gen_text,
 338
 339         set  => \&_gen_set_enum,
 340         enum => \&_gen_set_enum,
 341
 342         tinyblob   => \&_gen_blob,
 343         mediumblob => \&_gen_blob,
 344         blob       => \&_gen_blob,
 345         longblob   => \&_gen_blob,
 346     };
 347 };
 348
 349 sub _gen_int {
 350     my ($self, $params) = @_;
 351     my $data_type = $params->{info}->{data_type};
 352
 353     my $max = 1;
 354     if( $data_type eq 'tinyint' ) {
 355         $max = 127;
 356     }
 357     elsif( $data_type eq 'smallint' ) {
 358         $max = 32767;
 359     }
 360     elsif( $data_type eq 'mediumint' ) {
 361         $max = 8388607;
 362     }
 363     elsif( $data_type eq 'integer' ) {
 364         $max = 2147483647;
 365     }
 366     elsif( $data_type eq 'bigint' ) {
 367         $max = 9223372036854775807;
 368     }
 369     return int( rand($max+1) );
 370 }
 371
 372 sub _gen_real {
 373     my ($self, $params) = @_;
 374     my $max = 10 ** 38;
 375     if( defined( $params->{info}->{size} ) ) {
 376         $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
 377     }
 378     return rand($max) + 1;
 379 }
 380
 381 sub _gen_date {
 382     my ($self, $params) = @_;
 383     return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
 384 }
 385
 386 sub _gen_text {
 387     my ($self, $params) = @_;
 388     # From perldoc String::Random
 389     # max: specify the maximum number of characters to return for * and other
 390     # regular expression patters that don't return a fixed number of characters
 391     my $regex = '[A-Za-z][A-Za-z0-9_]*';
 392     my $size = $params->{info}{size};
 393     if ( defined $size and $size > 1 ) {
 394         $size--;
 395     } elsif ( defined $size and $size == 1 ) {
 396         $regex = '[A-Za-z]';
 397     }
 398     my $random = String::Random->new( max => $size );
 399     return $random->randregex($regex);
 400 }
 401
 402 sub _gen_set_enum {
 403     my ($self, $params) = @_;
 404     return $params->{info}->{extra}->{list}->[0];
 405 }
 406
 407 sub _gen_blob {
 408     my ($self, $params) = @_;;
 409     return 'b';
 410 }
 411
 412 =head1 NAME
 413
 414 t::lib::TestBuilder.pm - Koha module to create test records
 415
 416 =head1 SYNOPSIS
 417
 418     use t::lib::TestBuilder;
 419     my $builder = t::lib::TestBuilder->new;
 420
 421     # The following call creates a patron, linked to branch CPL.
 422     # Surname is provided, other columns are randomly generated.
 423     # Branch CPL is created if it does not exist.
 424     my $patron = $builder->build({
 425         source => 'Borrower',
 426         value  => { surname => 'Jansen', branchcode => 'CPL' },
 427     });
 428
 429 =head1 DESCRIPTION
 430
 431 This module automatically creates database records for you.
 432 If needed, records for foreign keys are created too.
 433 Values will be randomly generated if not passed to TestBuilder.
 434 Note that you should wrap these actions in a transaction yourself.
 435
 436 =head1 METHODS
 437
 438 =head2 new
 439
 440     my $builder = t::lib::TestBuilder->new;
 441
 442     Constructor - Returns the object TestBuilder
 443
 444 =head2 schema
 445
 446     my $schema = $builder->schema;
 447
 448     Getter - Returns the schema of DBIx::Class
 449
 450 =head2 delete
 451
 452     $builder->delete({
 453         source => $source,
 454         records => $patron, # OR: records => [ $patron, ... ],
 455     });
 456
 457     Delete individual records, created by builder.
 458     Returns the number of delete attempts, or undef.
 459
 460 =head2 build
 461
 462     $builder->build({ source  => $source_name, value => $value });
 463
 464     Create a test record in the table, represented by $source_name.
 465     The name is required and must conform to the DBIx::Class schema.
 466     Values may be specified by the optional $value hashref. Will be
 467     randomized otherwise.
 468     If needed, TestBuilder creates linked records for foreign keys.
 469     Returns the values of the new record as a hashref, or undef if
 470     the record could not be created.
 471
 472     Note that build also supports recursive hash references inside the
 473     value hash for foreign key columns, like:
 474         value => {
 475             column1 => 'some_value',
 476             fk_col2 => {
 477                 columnA => 'another_value',
 478             }
 479         }
 480     The hash for fk_col2 here means: create a linked record with build
 481     where columnA has this value. In case of a composite FK the hashes
 482     are merged.
 483
 484     Realize that passing primary key values to build may result in undef
 485     if a record with that primary key already exists.
 486
 487 =head1 AUTHOR
 488
 489 Yohann Dufour <yohann.dufour@biblibre.com>
 490
 491 Koha Development Team
 492
 493 =head1 COPYRIGHT
 494
 495 Copyright 2014 - Biblibre SARL
 496
 497 =head1 LICENSE
 498
 499 This file is part of Koha.
 500
 501 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 502 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 503
 504 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.
 505
 506 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 507
 508 =cut
 509
 510 1;