t/lib/TestBuilder.pm

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