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             rentalcharge_daily => 0,
 550             rentalcharge_hourly => 0,
 551             defaultreplacecost => 0,
 552             processfee => 0,
 553         },
 554         Aqbookseller => {
 555             tax_rate => 0,
 556             discount => 0,
 557         },
 558         AuthHeader => {
 559             marcxml => '',
 560         },
 561         Accountline => {
 562             accountno => 0,
 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;