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         push @$retvalue, $self->{default_values}{$source}{$col_name};
 405     } else {
 406         my $data_type = $col_info->{data_type};
 407         $data_type =~ s| |_|;
 408         if( my $hdlr = $self->{gen_type}->{$data_type} ) {
 409             push @$retvalue, &$hdlr( $self, { info => $col_info } );
 410         } else {
 411             warn "Unknown type $data_type for $col_name in $source";
 412             return;
 413         }
 414     }
 415     return $retvalue;
 416 }
 417
 418 sub _should_be_fk {
 419 # This sub is only needed for inconsistencies in the schema
 420 # A column is not marked as FK, but a belongs_to relation is defined
 421     my ( $source, $column ) = @_;
 422     my $inconsistencies = {
 423         'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
 424     };
 425     return $inconsistencies->{ "$source.$column" };
 426 }
 427
 428 sub _gen_type {
 429     return {
 430         tinyint   => \&_gen_int,
 431         smallint  => \&_gen_int,
 432         mediumint => \&_gen_int,
 433         integer   => \&_gen_int,
 434         bigint    => \&_gen_int,
 435
 436         float            => \&_gen_real,
 437         decimal          => \&_gen_real,
 438         double_precision => \&_gen_real,
 439
 440         timestamp => \&_gen_datetime,
 441         datetime  => \&_gen_datetime,
 442         date      => \&_gen_date,
 443
 444         char       => \&_gen_text,
 445         varchar    => \&_gen_text,
 446         tinytext   => \&_gen_text,
 447         text       => \&_gen_text,
 448         mediumtext => \&_gen_text,
 449         longtext   => \&_gen_text,
 450
 451         set  => \&_gen_set_enum,
 452         enum => \&_gen_set_enum,
 453
 454         tinyblob   => \&_gen_blob,
 455         mediumblob => \&_gen_blob,
 456         blob       => \&_gen_blob,
 457         longblob   => \&_gen_blob,
 458     };
 459 };
 460
 461 sub _gen_int {
 462     my ($self, $params) = @_;
 463     my $data_type = $params->{info}->{data_type};
 464
 465     my $max = 1;
 466     if( $data_type eq 'tinyint' ) {
 467         $max = 127;
 468     }
 469     elsif( $data_type eq 'smallint' ) {
 470         $max = 32767;
 471     }
 472     elsif( $data_type eq 'mediumint' ) {
 473         $max = 8388607;
 474     }
 475     elsif( $data_type eq 'integer' ) {
 476         $max = 2147483647;
 477     }
 478     elsif( $data_type eq 'bigint' ) {
 479         $max = 9223372036854775807;
 480     }
 481     return int( rand($max+1) );
 482 }
 483
 484 sub _gen_real {
 485     my ($self, $params) = @_;
 486     my $max = 10 ** 38;
 487     if( defined( $params->{info}->{size} ) ) {
 488         $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
 489     }
 490     return sprintf("%.2f", rand($max-0.1));
 491 }
 492
 493 sub _gen_date {
 494     my ($self, $params) = @_;
 495     return $self->schema->storage->datetime_parser->format_date(dt_from_string)
 496 }
 497
 498 sub _gen_datetime {
 499     my ($self, $params) = @_;
 500     return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
 501 }
 502
 503 sub _gen_text {
 504     my ($self, $params) = @_;
 505     # From perldoc String::Random
 506     my $size = $params->{info}{size} // 10;
 507     $size -= alt_rand(0.5 * $size);
 508     my $regex = $size > 1
 509         ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
 510         : '[A-Za-z]';
 511     my $random = String::Random->new( rand_gen => \&alt_rand );
 512     # rand_gen is only supported from 0.27 onward
 513     return $random->randregex($regex);
 514 }
 515
 516 sub alt_rand { #Alternative randomizer
 517     my ($max) = @_;
 518     my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
 519     my $r = $random->irand / 2**32;
 520     return int( $r * $max );
 521 }
 522
 523 sub _gen_set_enum {
 524     my ($self, $params) = @_;
 525     return $params->{info}->{extra}->{list}->[0];
 526 }
 527
 528 sub _gen_blob {
 529     my ($self, $params) = @_;;
 530     return 'b';
 531 }
 532
 533 sub _gen_default_values {
 534     my ($self) = @_;
 535     return {
 536         Borrower => {
 537             login_attempts => 0,
 538             gonenoaddress  => undef,
 539             lost           => undef,
 540             debarred       => undef,
 541             borrowernotes  => '',
 542         },
 543         Item => {
 544             notforloan         => 0,
 545             itemlost           => 0,
 546             withdrawn          => 0,
 547             restricted         => 0,
 548             more_subfields_xml => undef,
 549         },
 550         Category => {
 551             enrolmentfee => 0,
 552             reservefee   => 0,
 553         },
 554         Itemtype => {
 555             rentalcharge => 0,
 556             rentalcharge_daily => 0,
 557             rentalcharge_hourly => 0,
 558             defaultreplacecost => 0,
 559             processfee => 0,
 560             notforloan => 0,
 561         },
 562         Aqbookseller => {
 563             tax_rate => 0,
 564             discount => 0,
 565         },
 566         AuthHeader => {
 567             marcxml => '',
 568         },
 569         RefundLostItemFeeRules => {
 570             rule_name => 'refund',
 571         },
 572     };
 573 }
 574
 575 =head1 NAME
 576
 577 t::lib::TestBuilder.pm - Koha module to create test records
 578
 579 =head1 SYNOPSIS
 580
 581     use t::lib::TestBuilder;
 582     my $builder = t::lib::TestBuilder->new;
 583
 584     # The following call creates a patron, linked to branch CPL.
 585     # Surname is provided, other columns are randomly generated.
 586     # Branch CPL is created if it does not exist.
 587     my $patron = $builder->build({
 588         source => 'Borrower',
 589         value  => { surname => 'Jansen', branchcode => 'CPL' },
 590     });
 591
 592 =head1 DESCRIPTION
 593
 594 This module automatically creates database records for you.
 595 If needed, records for foreign keys are created too.
 596 Values will be randomly generated if not passed to TestBuilder.
 597 Note that you should wrap these actions in a transaction yourself.
 598
 599 =head1 METHODS
 600
 601 =head2 new
 602
 603     my $builder = t::lib::TestBuilder->new;
 604
 605     Constructor - Returns the object TestBuilder
 606
 607 =head2 schema
 608
 609     my $schema = $builder->schema;
 610
 611     Getter - Returns the schema of DBIx::Class
 612
 613 =head2 delete
 614
 615     $builder->delete({
 616         source => $source,
 617         records => $patron, # OR: records => [ $patron, ... ],
 618     });
 619
 620     Delete individual records, created by builder.
 621     Returns the number of delete attempts, or undef.
 622
 623 =head2 build
 624
 625     $builder->build({ source  => $source_name, value => $value });
 626
 627     Create a test record in the table, represented by $source_name.
 628     The name is required and must conform to the DBIx::Class schema.
 629     Values may be specified by the optional $value hashref. Will be
 630     randomized otherwise.
 631     If needed, TestBuilder creates linked records for foreign keys.
 632     Returns the values of the new record as a hashref, or undef if
 633     the record could not be created.
 634
 635     Note that build also supports recursive hash references inside the
 636     value hash for foreign key columns, like:
 637         value => {
 638             column1 => 'some_value',
 639             fk_col2 => {
 640                 columnA => 'another_value',
 641             }
 642         }
 643     The hash for fk_col2 here means: create a linked record with build
 644     where columnA has this value. In case of a composite FK the hashes
 645     are merged.
 646
 647     Realize that passing primary key values to build may result in undef
 648     if a record with that primary key already exists.
 649
 650 =head2 build_object
 651
 652 Given a plural Koha::Object-derived class, it creates a random element, and
 653 returns the corresponding Koha::Object.
 654
 655     my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
 656
 657 =head1 AUTHOR
 658
 659 Yohann Dufour <yohann.dufour@biblibre.com>
 660
 661 Koha Development Team
 662
 663 =head1 COPYRIGHT
 664
 665 Copyright 2014 - Biblibre SARL
 666
 667 =head1 LICENSE
 668
 669 This file is part of Koha.
 670
 671 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 672 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 673
 674 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.
 675
 676 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 677
 678 =cut
 679
 680 1;