t/lib/TestBuilder.pm

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