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