t/lib/TestBuilder.pm

   1 package t::lib::TestBuilder;
   2
   3 use Modern::Perl;
   4 use Koha::Database;
   5 use String::Random;
   6
   7
   8 my $gen_type = {
   9     tinyint   => \&_gen_int,
  10     smallint  => \&_gen_int,
  11     mediumint => \&_gen_int,
  12     integer   => \&_gen_int,
  13     bigint    => \&_gen_int,
  14
  15     float            => \&_gen_real,
  16     decimal          => \&_gen_real,
  17     double_precision => \&_gen_real,
  18
  19     timestamp => \&_gen_date,
  20     datetime  => \&_gen_date,
  21     date      => \&_gen_date,
  22
  23     char       => \&_gen_text,
  24     varchar    => \&_gen_text,
  25     tinytext   => \&_gen_text,
  26     text       => \&_gen_text,
  27     mediumtext => \&_gen_text,
  28     longtext   => \&_gen_text,
  29
  30     set  => \&_gen_set_enum,
  31     enum => \&_gen_set_enum,
  32
  33     tinyblob   => \&_gen_blob,
  34     mediumblob => \&_gen_blob,
  35     blob       => \&_gen_blob,
  36     longblob   => \&_gen_blob,
  37 };
  38
  39 our $default_value = {
  40     UserPermission => {
  41         borrowernumber => {
  42             surname => 'my surname',
  43             address => 'my adress',
  44             city    => 'my city',
  45             branchcode => {
  46                 branchcode => 'cB',
  47                 branchname => 'my branchname',
  48             },
  49             categorycode => {
  50                 categorycode    => 'cC',
  51                 hidelostitems   => 0,
  52                 category_type   => 'A',
  53                 default_privacy => 'default',
  54             },
  55             privacy => 1,
  56         },
  57         module_bit => {
  58             module_bit => {
  59                 bit => '10',
  60             },
  61             code => 'my code',
  62         },
  63         code => undef,
  64     },
  65 };
  66 $default_value->{UserPermission}->{code} = $default_value->{UserPermission}->{module_bit};
  67
  68
  69 sub new {
  70     my ($class) = @_;
  71     my $self = {};
  72     bless( $self, $class );
  73
  74     $self->schema( Koha::Database->new()->schema );
  75     $self->schema->storage->sql_maker->quote_char('`');
  76
  77     return $self;
  78 }
  79
  80 sub schema {
  81     my ($self, $schema) = @_;
  82
  83     if( defined( $schema ) ) {
  84         $self->{schema} = $schema;
  85     }
  86     return $self->{schema};
  87 }
  88
  89 sub clear {
  90     my ($self, $params) = @_;
  91     my $source = $self->schema->resultset( $params->{source} );
  92     return $source->delete_all();
  93 }
  94
  95 sub build {
  96     my ($self, $params) = @_;
  97     my $source  = $params->{source} || return;
  98     my $value   = $params->{value};
  99     my $only_fk = $params->{only_fk} || 0;
 100
 101     my $col_values = $self->_buildColumnValues({
 102         source  => $source,
 103         value   => $value,
 104     });
 105
 106     my $data;
 107     my $foreign_keys = $self->_getForeignKeys( { source => $source } );
 108     for my $fk ( @$foreign_keys ) {
 109         my $fk_value;
 110         my $col_name = $fk->{keys}->[0]->{col_name};
 111         if( ref( $col_values->{$col_name} ) eq 'HASH' ) {
 112             $fk_value = $col_values->{$col_name};
 113         }
 114         elsif( defined( $col_values->{$col_name} ) ) {
 115             next;
 116         }
 117
 118         my $fk_row = $self->build({
 119             source => $fk->{source},
 120             value  => $fk_value,
 121         });
 122
 123         my $keys = $fk->{keys};
 124         for my $key( @$keys )  {
 125             $col_values->{ $key->{col_name} } = $fk_row->{ $key->{col_fk_name} };
 126             $data->{ $key->{col_name} } = $fk_row;
 127         }
 128     }
 129
 130     my $new_row;
 131     if( $only_fk ) {
 132         $new_row = $col_values;
 133     }
 134     else {
 135         $new_row = $self->_storeColumnValues({
 136             source => $source,
 137             values => $col_values,
 138         });
 139     }
 140     $new_row->{_fk} = $data if( defined( $data ) );
 141     return $new_row;
 142 }
 143
 144 sub _formatSource {
 145     my ($params) = @_;
 146     my $source = $params->{source};
 147     $source =~ s|(\w+)$|$1|;
 148     return $source;
 149 }
 150
 151 sub _buildColumnValues {
 152     my ($self, $params) = @_;
 153     my $source = _formatSource( { source => $params->{source} } );
 154     my $original_value = $params->{value};
 155
 156     my $col_values;
 157     my @columns = $self->schema->source($source)->columns;
 158     my %unique_constraints = $self->schema->source($source)->unique_constraints();
 159
 160     my $build_value = 1;
 161     BUILD_VALUE: while ( $build_value ) {
 162         # generate random values for all columns
 163         for my $col_name( @columns ) {
 164             my $col_value = $self->_buildColumnValue({
 165                 source      => $source,
 166                 column_name => $col_name,
 167                 value       => $original_value,
 168             });
 169             $col_values->{$col_name} = $col_value if( defined( $col_value ) );
 170         }
 171         $build_value = 0;
 172
 173         # If default values are set, maybe the data exist in the DB
 174         # But no need to wait for another value
 175         # FIXME this can be wrong if a default value is defined for a field
 176         # which is not a constraint and that the generated value for the
 177         # constraint already exists.
 178         last BUILD_VALUE if exists( $default_value->{$source} );
 179
 180         # If there is no original value given and unique constraints exist,
 181         # check if the generated values do not exist yet.
 182         if ( not defined $original_value and scalar keys %unique_constraints > 0 ) {
 183
 184             # verify the data would respect each unique constraint
 185             CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
 186
 187                 my $condition;
 188                 my $constraint_columns = $unique_constraints{$constraint};
 189                 # loop through all constraint columns and build the condition
 190                 foreach my $constraint_column ( @$constraint_columns ) {
 191                     # build the filter
 192                     $condition->{ $constraint_column } =
 193                             $col_values->{ $constraint_column };
 194                 }
 195
 196                 my $count = $self->schema
 197                                  ->resultset( $source )
 198                                  ->search( $condition )
 199                                  ->count();
 200                 if ( $count > 0 ) {
 201                     # no point checking more stuff, exit the loop
 202                     $build_value = 1;
 203                     last CONSTRAINTS;
 204                 }
 205             }
 206         }
 207     }
 208     return $col_values;
 209 }
 210
 211 # Returns [ {
 212 #   rel_name => $rel_name,
 213 #   source => $table_name,
 214 #   keys => [ {
 215 #       col_name => $col_name,
 216 #       col_fk_name => $col_fk_name,
 217 #   }, ... ]
 218 # }, ... ]
 219 sub _getForeignKeys {
 220     my ($self, $params) = @_;
 221     my $source = $self->schema->source( $params->{source} );
 222
 223     my @foreign_keys = ();
 224     my @relationships = $source->relationships;
 225     for my $rel_name( @relationships ) {
 226         my $rel_info = $source->relationship_info($rel_name);
 227         if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
 228             my $rel = {
 229                 rel_name => $rel_name,
 230                 source   => $rel_info->{source},
 231             };
 232
 233             my @keys = ();
 234             while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
 235                 $col_name    =~ s|self.(\w+)|$1|;
 236                 $col_fk_name =~ s|foreign.(\w+)|$1|;
 237                 push @keys, {
 238                     col_name    => $col_name,
 239                     col_fk_name => $col_fk_name,
 240                 };
 241             }
 242             $rel->{keys} = \@keys;
 243
 244             push @foreign_keys, $rel;
 245         }
 246     }
 247     return \@foreign_keys;
 248 }
 249
 250 sub _storeColumnValues {
 251     my ($self, $params) = @_;
 252     my $source      = $params->{source};
 253     my $col_values  = $params->{values};
 254
 255     my $new_row;
 256     eval {
 257         $new_row = $self->schema->resultset($source)->update_or_create($col_values);
 258     };
 259     die "$source - $@\n" if ($@);
 260
 261     eval {
 262         $new_row = { $new_row->get_columns };
 263     };
 264     warn "$source - $@\n" if ($@);
 265     return $new_row;
 266 }
 267
 268 sub _buildColumnValue {
 269     my ($self, $params) = @_;
 270     my $source    = $params->{source};
 271     my $value     = $params->{value};
 272     my $col_name  = $params->{column_name};
 273     my $col_info  = $self->schema->source($source)->column_info($col_name);
 274
 275     my $col_value;
 276     if( exists( $value->{$col_name} ) ) {
 277         $col_value = $value->{$col_name};
 278     }
 279     elsif( exists $default_value->{$source} and exists $default_value->{$source}->{$col_name} ) {
 280         $col_value = $default_value->{$source}->{$col_name};
 281     }
 282     elsif( not $col_info->{default_value} and not $col_info->{is_auto_increment} and not $col_info->{is_foreign_key} ) {
 283         eval {
 284             my $data_type = $col_info->{data_type};
 285             $data_type =~ s| |_|;
 286             $col_value = $gen_type->{$data_type}->( $self, { info => $col_info } );
 287         };
 288         die "The type $col_info->{data_type} is not defined\n" if ($@);
 289     }
 290     return $col_value;
 291 }
 292
 293
 294 sub _gen_int {
 295     my ($self, $params) = @_;
 296     my $data_type = $params->{info}->{data_type};
 297
 298     my $max = 1;
 299     if( $data_type eq 'tinyint' ) {
 300         $max = 127;
 301     }
 302     elsif( $data_type eq 'smallint' ) {
 303         $max = 32767;
 304     }
 305     elsif( $data_type eq 'mediumint' ) {
 306         $max = 8388607;
 307     }
 308     elsif( $data_type eq 'integer' ) {
 309         $max = 2147483647;
 310     }
 311     elsif( $data_type eq 'bigint' ) {
 312         $max = 9223372036854775807;
 313     }
 314     return int( rand($max+1) );
 315 }
 316
 317 sub _gen_real {
 318     my ($self, $params) = @_;
 319     my $max = 10 ** 38;
 320     if( defined( $params->{info}->{size} ) ) {
 321         $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
 322     }
 323     return rand($max) + 1;
 324 }
 325
 326 sub _gen_date {
 327     my ($self, $params) = @_;
 328     return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
 329 }
 330
 331 sub _gen_text {
 332     my ($self, $params) = @_;
 333     # From perldoc String::Random
 334     # max: specify the maximum number of characters to return for * and other
 335     # regular expression patters that don't return a fixed number of characters
 336     my $regex = '[A-Za-z][A-Za-z0-9_]*';
 337     my $size = $params->{info}{size};
 338     if ( defined $size and $size > 1 ) {
 339         $size--;
 340     } elsif ( defined $size and $size == 1 ) {
 341         $regex = '[A-Za-z]';
 342     }
 343     my $random = String::Random->new( max => $size );
 344     return $random->randregex($regex);
 345 }
 346
 347 sub _gen_set_enum {
 348     my ($self, $params) = @_;
 349     return $params->{info}->{extra}->{list}->[0];
 350 }
 351
 352 sub _gen_blob {
 353     my ($self, $params) = @_;;
 354     return 'b';
 355 }
 356
 357 =head1 NAME
 358
 359 t::lib::TestBuilder.pm - Koha module to simplify the writing of tests
 360
 361 =head1 SYNOPSIS
 362
 363     use t::lib::TestBuilder;
 364
 365 Koha module to insert the foreign keys automatically for the tests
 366
 367 =head1 DESCRIPTION
 368
 369 This module allows to insert automatically an entry in the database. All the database changes are wrapped in a transaction.
 370 The foreign keys are created according to the DBIx::Class schema.
 371 The taken values are the values by default if it is possible or randomly generated.
 372
 373 =head1 FUNCTIONS
 374
 375 =head2 new
 376
 377     $builder = t::lib::TestBuilder->new()
 378
 379 Constructor - Begins a transaction and returns the object TestBuilder
 380
 381 =head2 schema
 382
 383     $schema = $builder->schema
 384
 385 Getter - Returns the schema of DBIx::Class
 386
 387 =head2 clear
 388
 389     $builder->clear({ source => $source_name })
 390
 391 =over
 392
 393 =item C<$source_name> is the name of the source in the DBIx::Class schema (required)
 394
 395 =back
 396
 397 Clears all the data of this source (database table)
 398
 399 =head2 build
 400
 401     $builder->build({
 402         source  => $source_name,
 403         value   => $value,
 404         only_fk => $only_fk,
 405     })
 406
 407 =over
 408
 409 =item C<$source_name> is the name of the source in the DBIx::Class schema (required)
 410
 411 =item C<$value> is the values for the entry (optional)
 412
 413 =item C<$only_fk> is a boolean to indicate if only the foreign keys are created (optional)
 414
 415 =back
 416
 417 Inserts an entry in the database by instanciating all the foreign keys.
 418 The values can be specified, the values which are not given are default values if they exists or generated randomly.
 419 Returns the values of the entry as a hashref with an extra key : _fk which contains all the values of the generated foreign keys.
 420
 421 =head1 AUTHOR
 422
 423 Yohann Dufour <yohann.dufour@biblibre.com>
 424
 425 =head1 COPYRIGHT
 426
 427 Copyright 2014 - Biblibre SARL
 428
 429 =head1 LICENSE
 430
 431 This file is part of Koha.
 432
 433 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 434 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 435
 436 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.
 437
 438 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 439
 440 =cut
 441
 442 1;