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_datetime,
 329         datetime  => \&_gen_datetime,
 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_date(DateTime->now())
 384 }
 385
 386 sub _gen_datetime {
 387     my ($self, $params) = @_;
 388     return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
 389 }
 390
 391 sub _gen_text {
 392     my ($self, $params) = @_;
 393     # From perldoc String::Random
 394     # max: specify the maximum number of characters to return for * and other
 395     # regular expression patters that don't return a fixed number of characters
 396     my $regex = '[A-Za-z][A-Za-z0-9_]*';
 397     my $size = $params->{info}{size};
 398     if ( defined $size and $size > 1 ) {
 399         $size--;
 400     } elsif ( defined $size and $size == 1 ) {
 401         $regex = '[A-Za-z]';
 402     }
 403     my $random = String::Random->new( max => $size );
 404     return $random->randregex($regex);
 405 }
 406
 407 sub _gen_set_enum {
 408     my ($self, $params) = @_;
 409     return $params->{info}->{extra}->{list}->[0];
 410 }
 411
 412 sub _gen_blob {
 413     my ($self, $params) = @_;;
 414     return 'b';
 415 }
 416
 417 =head1 NAME
 418
 419 t::lib::TestBuilder.pm - Koha module to create test records
 420
 421 =head1 SYNOPSIS
 422
 423     use t::lib::TestBuilder;
 424     my $builder = t::lib::TestBuilder->new;
 425
 426     # The following call creates a patron, linked to branch CPL.
 427     # Surname is provided, other columns are randomly generated.
 428     # Branch CPL is created if it does not exist.
 429     my $patron = $builder->build({
 430         source => 'Borrower',
 431         value  => { surname => 'Jansen', branchcode => 'CPL' },
 432     });
 433
 434 =head1 DESCRIPTION
 435
 436 This module automatically creates database records for you.
 437 If needed, records for foreign keys are created too.
 438 Values will be randomly generated if not passed to TestBuilder.
 439 Note that you should wrap these actions in a transaction yourself.
 440
 441 =head1 METHODS
 442
 443 =head2 new
 444
 445     my $builder = t::lib::TestBuilder->new;
 446
 447     Constructor - Returns the object TestBuilder
 448
 449 =head2 schema
 450
 451     my $schema = $builder->schema;
 452
 453     Getter - Returns the schema of DBIx::Class
 454
 455 =head2 delete
 456
 457     $builder->delete({
 458         source => $source,
 459         records => $patron, # OR: records => [ $patron, ... ],
 460     });
 461
 462     Delete individual records, created by builder.
 463     Returns the number of delete attempts, or undef.
 464
 465 =head2 build
 466
 467     $builder->build({ source  => $source_name, value => $value });
 468
 469     Create a test record in the table, represented by $source_name.
 470     The name is required and must conform to the DBIx::Class schema.
 471     Values may be specified by the optional $value hashref. Will be
 472     randomized otherwise.
 473     If needed, TestBuilder creates linked records for foreign keys.
 474     Returns the values of the new record as a hashref, or undef if
 475     the record could not be created.
 476
 477     Note that build also supports recursive hash references inside the
 478     value hash for foreign key columns, like:
 479         value => {
 480             column1 => 'some_value',
 481             fk_col2 => {
 482                 columnA => 'another_value',
 483             }
 484         }
 485     The hash for fk_col2 here means: create a linked record with build
 486     where columnA has this value. In case of a composite FK the hashes
 487     are merged.
 488
 489     Realize that passing primary key values to build may result in undef
 490     if a record with that primary key already exists.
 491
 492 =head1 AUTHOR
 493
 494 Yohann Dufour <yohann.dufour@biblibre.com>
 495
 496 Koha Development Team
 497
 498 =head1 COPYRIGHT
 499
 500 Copyright 2014 - Biblibre SARL
 501
 502 =head1 LICENSE
 503
 504 This file is part of Koha.
 505
 506 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 507 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 508
 509 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.
 510
 511 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 512
 513 =cut
 514
 515 1;