t/lib/TestBuilder.pm

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