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