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->txn_begin();
  76     $self->schema->storage->sql_maker->quote_char('`');
  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
 358 sub DESTROY {
 359     my $self = shift;
 360     $self->schema->txn_rollback();
 361 }
 362
 363
 364 =head1 NAME
 365
 366 t::lib::TestBuilder.pm - Koha module to simplify the writing of tests
 367
 368 =head1 SYNOPSIS
 369
 370     use t::lib::TestBuilder;
 371
 372 Koha module to insert the foreign keys automatically for the tests
 373
 374 =head1 DESCRIPTION
 375
 376 This module allows to insert automatically an entry in the database. All the database changes are wrapped in a transaction.
 377 The foreign keys are created according to the DBIx::Class schema.
 378 The taken values are the values by default if it is possible or randomly generated.
 379
 380 =head1 FUNCTIONS
 381
 382 =head2 new
 383
 384     $builder = t::lib::TestBuilder->new()
 385
 386 Constructor - Begins a transaction and returns the object TestBuilder
 387
 388 =head2 schema
 389
 390     $schema = $builder->schema
 391
 392 Getter - Returns the schema of DBIx::Class
 393
 394 =head2 clear
 395
 396     $builder->clear({ source => $source_name })
 397
 398 =over
 399
 400 =item C<$source_name> is the name of the source in the DBIx::Class schema (required)
 401
 402 =back
 403
 404 Clears all the data of this source (database table)
 405
 406 =head2 build
 407
 408     $builder->build({
 409         source  => $source_name,
 410         value   => $value,
 411         only_fk => $only_fk,
 412     })
 413
 414 =over
 415
 416 =item C<$source_name> is the name of the source in the DBIx::Class schema (required)
 417
 418 =item C<$value> is the values for the entry (optional)
 419
 420 =item C<$only_fk> is a boolean to indicate if only the foreign keys are created (optional)
 421
 422 =back
 423
 424 Inserts an entry in the database by instanciating all the foreign keys.
 425 The values can be specified, the values which are not given are default values if they exists or generated randomly.
 426 Returns the values of the entry as a hashref with an extra key : _fk which contains all the values of the generated foreign keys.
 427
 428 =head1 AUTHOR
 429
 430 Yohann Dufour <yohann.dufour@biblibre.com>
 431
 432 =head1 COPYRIGHT
 433
 434 Copyright 2014 - Biblibre SARL
 435
 436 =head1 LICENSE
 437
 438 This file is part of Koha.
 439
 440 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 441 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 442
 443 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.
 444
 445 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 446
 447 =cut
 448
 449 1;