package t::lib::TestBuilder;
use Modern::Perl;
-use Koha::Database;
+
+use Koha::Database qw( schema );
+use C4::Biblio qw( AddBiblio );
+use Koha::Biblios qw( _type );
+use Koha::Items qw( _type );
+use Koha::DateUtils qw( dt_from_string );
+
+use Bytes::Random::Secure;
+use Carp qw( carp );
+use Module::Load qw( load );
use String::Random;
+use constant {
+ SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
+};
+
sub new {
my ($class) = @_;
my $self = {};
return $rv;
}
+sub build_object {
+ my ( $self, $params ) = @_;
+
+ my $class = $params->{class};
+ my $value = $params->{value};
+
+ if ( not defined $class ) {
+ carp "Missing class param";
+ return;
+ }
+
+ my @unknowns = grep( !/^(class|value)$/, keys %{ $params });
+ carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
+
+ load $class;
+ my $source = $class->_type;
+
+ my $hashref = $self->build({ source => $source, value => $value });
+ my $object;
+ if ( $class eq 'Koha::Old::Patrons' ) {
+ $object = $class->search({ borrowernumber => $hashref->{borrowernumber} })->next;
+ } elsif ( $class eq 'Koha::Statistics' ) {
+ $object = $class->search({ datetime => $hashref->{datetime} })->next;
+ } else {
+ my @ids;
+ my @pks = $self->schema->source( $class->_type )->primary_columns;
+ foreach my $pk ( @pks ) {
+ push @ids, $hashref->{ $pk };
+ }
+
+ $object = $class->find( @ids );
+ }
+
+ return $object;
+}
+
sub build {
# build returns a hash of column values for a created record, or undef
# build does NOT update a record, or pass back values of an existing record
my ($self, $params) = @_;
- my $source = $params->{source} || return;
+ my $source = $params->{source};
+ if( !$source ) {
+ carp "Source parameter not specified!";
+ return;
+ }
my $value = $params->{value};
+ my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
+ carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
+
my $col_values = $self->_buildColumnValues({
source => $source,
value => $value,
});
}
+sub build_sample_biblio {
+ my ( $self, $args ) = @_;
+
+ my $title = $args->{title} || 'Some boring read';
+ my $author = $args->{author} || 'Some boring author';
+ my $frameworkcode = $args->{frameworkcode} || '';
+ my $itemtype = $args->{itemtype}
+ || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
+
+ my $marcflavour = C4::Context->preference('marcflavour');
+
+ my $record = MARC::Record->new();
+ $record->encoding( 'UTF-8' );
+
+ my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
+ $record->append_fields(
+ MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
+ );
+
+ ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
+ $record->append_fields(
+ MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
+ );
+
+ ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
+ $record->append_fields(
+ MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
+ );
+
+ my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
+ return Koha::Biblios->find($biblio_id);
+}
+
+sub build_sample_item {
+ my ( $self, $args ) = @_;
+
+ my $biblionumber =
+ delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
+ my $library = delete $args->{library}
+ || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
+
+ # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
+
+ my $barcode = delete $args->{barcode}
+ || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
+
+ return Koha::Item->new(
+ {
+ biblionumber => $biblionumber,
+ homebranch => $library,
+ holdingbranch => $library,
+ barcode => $barcode,
+ %$args,
+ }
+ )->store->get_from_storage;
+}
+
# ------------------------------------------------------------------------------
# Internal helper routines
if( $cnt_scalar == @$keys ) {
# if one or more fk cols are null, the FK constraint will not be forced
return {} if $cnt_null > 0;
+
# does the record exist already?
- return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
+ my @pks = $self->schema->source( $linked_tbl )->primary_columns;
+ my %fk_pk_value;
+ for (@pks) {
+ $fk_pk_value{$_} = $fk_value->{$_} if defined $fk_value->{$_};
+ }
+ return {} if !(keys %fk_pk_value);
+ return {} if $self->schema->resultset($linked_tbl)->find( \%fk_pk_value );
}
# create record with a recursive build call
my $row = $self->build({ source => $linked_tbl, value => $fk_value });
my @columns = $self->schema->source($source)->columns;
my %unique_constraints = $self->schema->source($source)->unique_constraints();
- my $build_value = 3;
- # we try max three times if there are unique constraints
+ my $build_value = 5;
+ # we try max $build_value times if there are unique constraints
BUILD_VALUE: while ( $build_value ) {
# generate random values for all columns
for my $col_name( @columns ) {
}
push @$retvalue, $value->{$col_name};
} elsif( exists $self->{default_values}{$source}{$col_name} ) {
- push @$retvalue, $self->{default_values}{$source}{$col_name};
+ my $v = $self->{default_values}{$source}{$col_name};
+ $v = &$v() if ref($v) eq 'CODE';
+ push @$retvalue, $v;
} else {
my $data_type = $col_info->{data_type};
$data_type =~ s| |_|;
if( defined( $params->{info}->{size} ) ) {
$max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
}
- return rand($max) + 1;
+ $max = 10 ** 5 if $max > 10 ** 5;
+ return sprintf("%.2f", rand($max-0.1));
}
sub _gen_date {
my ($self, $params) = @_;
- return $self->schema->storage->datetime_parser->format_date(DateTime->now())
+ return $self->schema->storage->datetime_parser->format_date(dt_from_string)
}
sub _gen_datetime {
my ($self, $params) = @_;
- return $self->schema->storage->datetime_parser->format_datetime(DateTime->now());
+ return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
}
sub _gen_text {
my ($self, $params) = @_;
# From perldoc String::Random
- # max: specify the maximum number of characters to return for * and other
- # regular expression patters that don't return a fixed number of characters
- my $regex = '[A-Za-z][A-Za-z0-9_]*';
- my $size = $params->{info}{size};
- if ( defined $size and $size > 1 ) {
- $size--;
- } elsif ( defined $size and $size == 1 ) {
- $regex = '[A-Za-z]';
- }
- my $random = String::Random->new( max => $size );
+ my $size = $params->{info}{size} // 10;
+ $size -= alt_rand(0.5 * $size);
+ my $regex = $size > 1
+ ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
+ : '[A-Za-z]';
+ my $random = String::Random->new( rand_gen => \&alt_rand );
+ # rand_gen is only supported from 0.27 onward
return $random->randregex($regex);
}
+sub alt_rand { #Alternative randomizer
+ my ($max) = @_;
+ my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
+ my $r = $random->irand / 2**32;
+ return int( $r * $max );
+}
+
sub _gen_set_enum {
my ($self, $params) = @_;
return $params->{info}->{extra}->{list}->[0];
sub _gen_default_values {
my ($self) = @_;
return {
+ Borrower => {
+ login_attempts => 0,
+ gonenoaddress => undef,
+ lost => undef,
+ debarred => undef,
+ borrowernotes => '',
+ secret => undef,
+ },
Item => {
+ notforloan => 0,
+ itemlost => 0,
+ withdrawn => 0,
+ restricted => 0,
+ damaged => 0,
+ materials => undef,
more_subfields_xml => undef,
},
+ Category => {
+ enrolmentfee => 0,
+ reservefee => 0,
+ # Not X, used for statistics
+ category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
+ min_password_length => undef,
+ require_strong_password => undef,
+ },
+ Branch => {
+ pickup_location => 0,
+ },
+ Reserve => {
+ non_priority => 0,
+ },
+ Itemtype => {
+ rentalcharge => 0,
+ rentalcharge_daily => 0,
+ rentalcharge_hourly => 0,
+ defaultreplacecost => 0,
+ processfee => 0,
+ notforloan => 0,
+ },
+ Aqbookseller => {
+ tax_rate => 0,
+ discount => 0,
+ },
+ AuthHeader => {
+ marcxml => '',
+ },
+ BorrowerAttributeType => {
+ mandatory => 0,
+ },
+ Suggestion => {
+ suggesteddate => dt_from_string()->ymd,
+ STATUS => 'ASKED'
+ },
+ ReturnClaim => {
+ issue_id => undef, # It should be a FK but we removed it
+ # We don't want to generate a random value
+ },
};
}
Realize that passing primary key values to build may result in undef
if a record with that primary key already exists.
+=head2 build_object
+
+Given a plural Koha::Object-derived class, it creates a random element, and
+returns the corresponding Koha::Object.
+
+ my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
+
=head1 AUTHOR
Yohann Dufour <yohann.dufour@biblibre.com>
projects / koha-ffzg.git / blobdiff