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