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