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