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             notforloan         => 0,
 475             itemlost           => 0,
 476             withdrawn          => 0,
 477             restricted         => 0,
 478             more_subfields_xml => undef,
 479         },
 480     };
 481 }
 482
 483 =head1 NAME
 484
 485 t::lib::TestBuilder.pm - Koha module to create test records
 486
 487 =head1 SYNOPSIS
 488
 489     use t::lib::TestBuilder;
 490     my $builder = t::lib::TestBuilder->new;
 491
 492     # The following call creates a patron, linked to branch CPL.
 493     # Surname is provided, other columns are randomly generated.
 494     # Branch CPL is created if it does not exist.
 495     my $patron = $builder->build({
 496         source => 'Borrower',
 497         value  => { surname => 'Jansen', branchcode => 'CPL' },
 498     });
 499
 500 =head1 DESCRIPTION
 501
 502 This module automatically creates database records for you.
 503 If needed, records for foreign keys are created too.
 504 Values will be randomly generated if not passed to TestBuilder.
 505 Note that you should wrap these actions in a transaction yourself.
 506
 507 =head1 METHODS
 508
 509 =head2 new
 510
 511     my $builder = t::lib::TestBuilder->new;
 512
 513     Constructor - Returns the object TestBuilder
 514
 515 =head2 schema
 516
 517     my $schema = $builder->schema;
 518
 519     Getter - Returns the schema of DBIx::Class
 520
 521 =head2 delete
 522
 523     $builder->delete({
 524         source => $source,
 525         records => $patron, # OR: records => [ $patron, ... ],
 526     });
 527
 528     Delete individual records, created by builder.
 529     Returns the number of delete attempts, or undef.
 530
 531 =head2 build
 532
 533     $builder->build({ source  => $source_name, value => $value });
 534
 535     Create a test record in the table, represented by $source_name.
 536     The name is required and must conform to the DBIx::Class schema.
 537     Values may be specified by the optional $value hashref. Will be
 538     randomized otherwise.
 539     If needed, TestBuilder creates linked records for foreign keys.
 540     Returns the values of the new record as a hashref, or undef if
 541     the record could not be created.
 542
 543     Note that build also supports recursive hash references inside the
 544     value hash for foreign key columns, like:
 545         value => {
 546             column1 => 'some_value',
 547             fk_col2 => {
 548                 columnA => 'another_value',
 549             }
 550         }
 551     The hash for fk_col2 here means: create a linked record with build
 552     where columnA has this value. In case of a composite FK the hashes
 553     are merged.
 554
 555     Realize that passing primary key values to build may result in undef
 556     if a record with that primary key already exists.
 557
 558 =head2 build_object
 559
 560 Given a plural Koha::Object-derived class, it creates a random element, and
 561 returns the corresponding Koha::Object.
 562
 563     my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
 564
 565 =head1 AUTHOR
 566
 567 Yohann Dufour <yohann.dufour@biblibre.com>
 568
 569 Koha Development Team
 570
 571 =head1 COPYRIGHT
 572
 573 Copyright 2014 - Biblibre SARL
 574
 575 =head1 LICENSE
 576
 577 This file is part of Koha.
 578
 579 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 580 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 581
 582 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.
 583
 584 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 585
 586 =cut
 587
 588 1;