t/lib/TestBuilder.pm

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