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