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