|
Lines 4-71
use Modern::Perl;
Link Here
|
| 4 |
use Koha::Database; |
4 |
use Koha::Database; |
| 5 |
use String::Random; |
5 |
use String::Random; |
| 6 |
|
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 { |
7 |
sub new { |
| 70 |
my ($class) = @_; |
8 |
my ($class) = @_; |
| 71 |
my $self = {}; |
9 |
my $self = {}; |
|
Lines 74-79
sub new {
Link Here
|
| 74 |
$self->schema( Koha::Database->new()->schema ); |
12 |
$self->schema( Koha::Database->new()->schema ); |
| 75 |
$self->schema->storage->sql_maker->quote_char('`'); |
13 |
$self->schema->storage->sql_maker->quote_char('`'); |
| 76 |
|
14 |
|
|
|
15 |
$self->{gen_type} = _gen_type(); |
| 77 |
return $self; |
16 |
return $self; |
| 78 |
} |
17 |
} |
| 79 |
|
18 |
|
|
Lines 86-236
sub schema {
Link Here
|
| 86 |
return $self->{schema}; |
25 |
return $self->{schema}; |
| 87 |
} |
26 |
} |
| 88 |
|
27 |
|
| 89 |
sub clear { |
28 |
# sub clear has been obsoleted; use delete_all from the schema resultset |
| 90 |
my ($self, $params) = @_; |
29 |
|
| 91 |
my $source = $self->schema->resultset( $params->{source} ); |
30 |
sub delete { |
| 92 |
return $source->delete_all(); |
31 |
my ( $self, $params ) = @_; |
|
|
32 |
my $source = $params->{source} || return; |
| 33 |
my @recs = ref( $params->{records} ) eq 'ARRAY'? |
| 34 |
@{$params->{records}}: ( $params->{records} // () ); |
| 35 |
# tables without PK are not supported |
| 36 |
my @pk = $self->schema->source( $source )->primary_columns; |
| 37 |
return if !@pk; |
| 38 |
my $rv = 0; |
| 39 |
foreach my $rec ( @recs ) { |
| 40 |
# delete only works when you supply full primary key values |
| 41 |
# $cond does not include searches for undef (not allowed in PK) |
| 42 |
my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk }; |
| 43 |
next if keys %$cond < @pk; |
| 44 |
$self->schema->resultset( $source )->search( $cond )->delete; |
| 45 |
# we clear the pk columns in the supplied hash |
| 46 |
# this indirectly signals at least an attempt to delete |
| 47 |
map { delete $rec->{$_}; } @pk; |
| 48 |
$rv++; |
| 49 |
} |
| 50 |
return $rv; |
| 93 |
} |
51 |
} |
| 94 |
|
52 |
|
| 95 |
sub build { |
53 |
sub build { |
|
|
54 |
# build returns a hash of column values for a created record, or undef |
| 55 |
# build does NOT update a record, or pass back values of an existing record |
| 96 |
my ($self, $params) = @_; |
56 |
my ($self, $params) = @_; |
| 97 |
my $source = $params->{source} || return; |
57 |
my $source = $params->{source} || return; |
| 98 |
my $value = $params->{value}; |
58 |
my $value = $params->{value}; |
| 99 |
my $only_fk = $params->{only_fk} || 0; |
|
|
| 100 |
|
59 |
|
| 101 |
my $col_values = $self->_buildColumnValues({ |
60 |
my $col_values = $self->_buildColumnValues({ |
| 102 |
source => $source, |
61 |
source => $source, |
| 103 |
value => $value, |
62 |
value => $value, |
| 104 |
}); |
63 |
}); |
|
|
64 |
return if !$col_values; # did not meet unique constraints? |
| 105 |
|
65 |
|
| 106 |
my $data; |
66 |
# loop thru all fk and create linked records if needed |
|
|
67 |
# fills remaining entries in $col_values |
| 107 |
my $foreign_keys = $self->_getForeignKeys( { source => $source } ); |
68 |
my $foreign_keys = $self->_getForeignKeys( { source => $source } ); |
| 108 |
for my $fk ( @$foreign_keys ) { |
69 |
for my $fk ( @$foreign_keys ) { |
| 109 |
my $fk_value; |
70 |
# skip when FK points to itself: e.g. borrowers:guarantorid |
| 110 |
my $col_name = $fk->{keys}->[0]->{col_name}; |
71 |
next if $fk->{source} eq $source; |
| 111 |
if( ref( $col_values->{$col_name} ) eq 'HASH' ) { |
72 |
my $keys = $fk->{keys}; |
| 112 |
$fk_value = $col_values->{$col_name}; |
73 |
my $tbl = $fk->{source}; |
| 113 |
} |
74 |
my $res = $self->_create_links( $tbl, $keys, $col_values, $value ); |
| 114 |
elsif( defined( $col_values->{$col_name} ) ) { |
75 |
return if !$res; # failed: no need to go further |
| 115 |
next; |
76 |
foreach( keys %$res ) { # save new values |
|
|
77 |
$col_values->{$_} = $res->{$_}; |
| 116 |
} |
78 |
} |
|
|
79 |
} |
| 117 |
|
80 |
|
| 118 |
my $fk_row = $self->build({ |
81 |
# store this record and return hashref |
| 119 |
source => $fk->{source}, |
82 |
return $self->_storeColumnValues({ |
| 120 |
value => $fk_value, |
83 |
source => $source, |
| 121 |
}); |
84 |
values => $col_values, |
|
|
85 |
}); |
| 86 |
} |
| 122 |
|
87 |
|
| 123 |
my $keys = $fk->{keys}; |
88 |
# ------------------------------------------------------------------------------ |
| 124 |
for my $key( @$keys ) { |
89 |
# Internal helper routines |
| 125 |
$col_values->{ $key->{col_name} } = $fk_row->{ $key->{col_fk_name} }; |
90 |
|
| 126 |
$data->{ $key->{col_name} } = $fk_row; |
91 |
sub _create_links { |
|
|
92 |
# returns undef for failure to create linked records |
| 93 |
# otherwise returns hashref containing new column values for parent record |
| 94 |
my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_; |
| 95 |
|
| 96 |
my $fk_value = {}; |
| 97 |
my ( $cnt_scalar, $cnt_null ) = ( 0, 0 ); |
| 98 |
|
| 99 |
# First, collect all values for creating a linked record (if needed) |
| 100 |
foreach my $fk ( @$keys ) { |
| 101 |
my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} ); |
| 102 |
if( ref( $value->{$col} ) eq 'HASH' ) { |
| 103 |
# add all keys from the FK hash |
| 104 |
$fk_value = { %{ $value->{$col} }, %$fk_value }; |
| 105 |
} |
| 106 |
if( exists $col_values->{$col} ) { |
| 107 |
# add specific value (this does not necessarily exclude some |
| 108 |
# values from the hash in the preceding if) |
| 109 |
$fk_value->{ $destcol } = $col_values->{ $col }; |
| 110 |
$cnt_scalar++; |
| 111 |
$cnt_null++ if !defined( $col_values->{$col} ); |
| 127 |
} |
112 |
} |
| 128 |
} |
113 |
} |
| 129 |
|
114 |
|
| 130 |
my $new_row; |
115 |
# If we saw all FK columns, first run the following checks |
| 131 |
if( $only_fk ) { |
116 |
if( $cnt_scalar == @$keys ) { |
| 132 |
$new_row = $col_values; |
117 |
# if one or more fk cols are null, the FK constraint will not be forced |
|
|
118 |
return {} if $cnt_null > 0; |
| 119 |
# does the record exist already? |
| 120 |
return {} if $self->schema->resultset($linked_tbl)->find( $fk_value ); |
| 133 |
} |
121 |
} |
| 134 |
else { |
122 |
# create record with a recursive build call |
| 135 |
$new_row = $self->_storeColumnValues({ |
123 |
my $row = $self->build({ source => $linked_tbl, value => $fk_value }); |
| 136 |
source => $source, |
124 |
return if !$row; # failure |
| 137 |
values => $col_values, |
125 |
|
| 138 |
}); |
126 |
# Finally, only return the new values |
|
|
127 |
my $rv = {}; |
| 128 |
foreach my $fk ( @$keys ) { |
| 129 |
my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} ); |
| 130 |
next if exists $col_values->{ $col }; |
| 131 |
$rv->{ $col } = $row->{ $destcol }; |
| 139 |
} |
132 |
} |
| 140 |
$new_row->{_fk} = $data if( defined( $data ) ); |
133 |
return $rv; # success |
| 141 |
return $new_row; |
|
|
| 142 |
} |
134 |
} |
| 143 |
|
135 |
|
| 144 |
sub _formatSource { |
136 |
sub _formatSource { |
| 145 |
my ($params) = @_; |
137 |
my ($params) = @_; |
| 146 |
my $source = $params->{source}; |
138 |
my $source = $params->{source} || return; |
| 147 |
$source =~ s|(\w+)$|$1|; |
139 |
$source =~ s|(\w+)$|$1|; |
| 148 |
return $source; |
140 |
return $source; |
| 149 |
} |
141 |
} |
| 150 |
|
142 |
|
| 151 |
sub _buildColumnValues { |
143 |
sub _buildColumnValues { |
| 152 |
my ($self, $params) = @_; |
144 |
my ($self, $params) = @_; |
| 153 |
my $source = _formatSource( { source => $params->{source} } ); |
145 |
my $source = _formatSource( $params ) || return; |
| 154 |
my $original_value = $params->{value}; |
146 |
my $original_value = $params->{value}; |
| 155 |
|
147 |
|
| 156 |
my $col_values; |
148 |
my $col_values = {}; |
| 157 |
my @columns = $self->schema->source($source)->columns; |
149 |
my @columns = $self->schema->source($source)->columns; |
| 158 |
my %unique_constraints = $self->schema->source($source)->unique_constraints(); |
150 |
my %unique_constraints = $self->schema->source($source)->unique_constraints(); |
| 159 |
|
151 |
|
| 160 |
my $build_value = 1; |
152 |
my $build_value = 3; |
|
|
153 |
# we try max three times if there are unique constraints |
| 161 |
BUILD_VALUE: while ( $build_value ) { |
154 |
BUILD_VALUE: while ( $build_value ) { |
| 162 |
# generate random values for all columns |
155 |
# generate random values for all columns |
| 163 |
for my $col_name( @columns ) { |
156 |
for my $col_name( @columns ) { |
| 164 |
my $col_value = $self->_buildColumnValue({ |
157 |
my $valref = $self->_buildColumnValue({ |
| 165 |
source => $source, |
158 |
source => $source, |
| 166 |
column_name => $col_name, |
159 |
column_name => $col_name, |
| 167 |
value => $original_value, |
160 |
value => $original_value, |
| 168 |
}); |
161 |
}); |
| 169 |
$col_values->{$col_name} = $col_value if( defined( $col_value ) ); |
162 |
return if !$valref; # failure |
|
|
163 |
if( @$valref ) { # could be empty |
| 164 |
# there will be only one value, but it could be undef |
| 165 |
$col_values->{$col_name} = $valref->[0]; |
| 166 |
} |
| 170 |
} |
167 |
} |
| 171 |
$build_value = 0; |
|
|
| 172 |
|
168 |
|
| 173 |
# If default values are set, maybe the data exist in the DB |
169 |
# verify the data would respect each unique constraint |
| 174 |
# But no need to wait for another value |
170 |
# note that this is INCOMPLETE since not all col_values are filled |
| 175 |
# FIXME this can be wrong if a default value is defined for a field |
171 |
CONSTRAINTS: foreach my $constraint (keys %unique_constraints) { |
| 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 |
|
172 |
|
| 187 |
my $condition; |
173 |
my $condition; |
| 188 |
my $constraint_columns = $unique_constraints{$constraint}; |
174 |
my $constraint_columns = $unique_constraints{$constraint}; |
| 189 |
# loop through all constraint columns and build the condition |
175 |
# loop through all constraint columns and build the condition |
| 190 |
foreach my $constraint_column ( @$constraint_columns ) { |
176 |
foreach my $constraint_column ( @$constraint_columns ) { |
| 191 |
# build the filter |
177 |
# build the filter |
|
|
178 |
# if one column does not exist or is undef, skip it |
| 179 |
# an insert with a null will not trigger the constraint |
| 180 |
next CONSTRAINTS |
| 181 |
if !exists $col_values->{ $constraint_column } || |
| 182 |
!defined $col_values->{ $constraint_column }; |
| 192 |
$condition->{ $constraint_column } = |
183 |
$condition->{ $constraint_column } = |
| 193 |
$col_values->{ $constraint_column }; |
184 |
$col_values->{ $constraint_column }; |
| 194 |
} |
185 |
} |
| 195 |
|
|
|
| 196 |
my $count = $self->schema |
186 |
my $count = $self->schema |
| 197 |
->resultset( $source ) |
187 |
->resultset( $source ) |
| 198 |
->search( $condition ) |
188 |
->search( $condition ) |
| 199 |
->count(); |
189 |
->count(); |
| 200 |
if ( $count > 0 ) { |
190 |
if ( $count > 0 ) { |
| 201 |
# no point checking more stuff, exit the loop |
191 |
# no point checking more stuff, exit the loop |
| 202 |
$build_value = 1; |
192 |
$build_value--; |
| 203 |
last CONSTRAINTS; |
193 |
next BUILD_VALUE; |
| 204 |
} |
194 |
} |
| 205 |
} |
|
|
| 206 |
} |
195 |
} |
|
|
196 |
last; # you passed all tests |
| 207 |
} |
197 |
} |
| 208 |
return $col_values; |
198 |
return $col_values if $build_value > 0; |
|
|
199 |
|
| 200 |
# if you get here, we have a problem |
| 201 |
warn "Violation of unique constraint in $source"; |
| 202 |
return; |
| 209 |
} |
203 |
} |
| 210 |
|
204 |
|
| 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 { |
205 |
sub _getForeignKeys { |
|
|
206 |
|
| 207 |
# Returns the following arrayref |
| 208 |
# [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ] |
| 209 |
# The array gives source name and keys for each FK constraint |
| 210 |
|
| 220 |
my ($self, $params) = @_; |
211 |
my ($self, $params) = @_; |
| 221 |
my $source = $self->schema->source( $params->{source} ); |
212 |
my $source = $self->schema->source( $params->{source} ); |
| 222 |
|
213 |
|
| 223 |
my @foreign_keys = (); |
214 |
my ( @foreign_keys, $check_dupl ); |
| 224 |
my @relationships = $source->relationships; |
215 |
my @relationships = $source->relationships; |
| 225 |
for my $rel_name( @relationships ) { |
216 |
for my $rel_name( @relationships ) { |
| 226 |
my $rel_info = $source->relationship_info($rel_name); |
217 |
my $rel_info = $source->relationship_info($rel_name); |
| 227 |
if( $rel_info->{attrs}->{is_foreign_key_constraint} ) { |
218 |
if( $rel_info->{attrs}->{is_foreign_key_constraint} ) { |
| 228 |
my $rel = { |
219 |
$rel_info->{source} =~ s/^.*:://g; |
| 229 |
rel_name => $rel_name, |
220 |
my $rel = { source => $rel_info->{source} }; |
| 230 |
source => $rel_info->{source}, |
|
|
| 231 |
}; |
| 232 |
|
221 |
|
| 233 |
my @keys = (); |
222 |
my @keys; |
| 234 |
while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) { |
223 |
while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) { |
| 235 |
$col_name =~ s|self.(\w+)|$1|; |
224 |
$col_name =~ s|self.(\w+)|$1|; |
| 236 |
$col_fk_name =~ s|foreign.(\w+)|$1|; |
225 |
$col_fk_name =~ s|foreign.(\w+)|$1|; |
|
Lines 239-246
sub _getForeignKeys {
Link Here
|
| 239 |
col_fk_name => $col_fk_name, |
228 |
col_fk_name => $col_fk_name, |
| 240 |
}; |
229 |
}; |
| 241 |
} |
230 |
} |
|
|
231 |
# check if the combination table and keys is unique |
| 232 |
# so skip double belongs_to relations (as in Biblioitem) |
| 233 |
my $tag = $rel->{source}. ':'. |
| 234 |
join ',', sort map { $_->{col_name} } @keys; |
| 235 |
next if $check_dupl->{$tag}; |
| 236 |
$check_dupl->{$tag} = 1; |
| 242 |
$rel->{keys} = \@keys; |
237 |
$rel->{keys} = \@keys; |
| 243 |
|
|
|
| 244 |
push @foreign_keys, $rel; |
238 |
push @foreign_keys, $rel; |
| 245 |
} |
239 |
} |
| 246 |
} |
240 |
} |
|
Lines 251-295
sub _storeColumnValues {
Link Here
|
| 251 |
my ($self, $params) = @_; |
245 |
my ($self, $params) = @_; |
| 252 |
my $source = $params->{source}; |
246 |
my $source = $params->{source}; |
| 253 |
my $col_values = $params->{values}; |
247 |
my $col_values = $params->{values}; |
| 254 |
|
248 |
my $new_row = $self->schema->resultset( $source )->create( $col_values ); |
| 255 |
my $new_row; |
249 |
return $new_row? { $new_row->get_columns }: {}; |
| 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 |
} |
250 |
} |
| 267 |
|
251 |
|
| 268 |
sub _buildColumnValue { |
252 |
sub _buildColumnValue { |
|
|
253 |
# returns an arrayref if all goes well |
| 254 |
# an empty arrayref typically means: auto_incr column or fk column |
| 255 |
# undef means failure |
| 269 |
my ($self, $params) = @_; |
256 |
my ($self, $params) = @_; |
| 270 |
my $source = $params->{source}; |
257 |
my $source = $params->{source}; |
| 271 |
my $value = $params->{value}; |
258 |
my $value = $params->{value}; |
| 272 |
my $col_name = $params->{column_name}; |
259 |
my $col_name = $params->{column_name}; |
|
|
260 |
|
| 273 |
my $col_info = $self->schema->source($source)->column_info($col_name); |
261 |
my $col_info = $self->schema->source($source)->column_info($col_name); |
| 274 |
|
262 |
|
| 275 |
my $col_value; |
263 |
my $retvalue = []; |
| 276 |
if( exists( $value->{$col_name} ) ) { |
264 |
if( $col_info->{is_auto_increment} ) { |
| 277 |
$col_value = $value->{$col_name}; |
265 |
if( exists $value->{$col_name} ) { |
| 278 |
} |
266 |
warn "Value not allowed for auto_incr $col_name in $source"; |
| 279 |
elsif( exists $default_value->{$source} and exists $default_value->{$source}->{$col_name} ) { |
267 |
return; |
| 280 |
$col_value = $default_value->{$source}->{$col_name}; |
268 |
} |
| 281 |
} |
269 |
# otherwise: no need to assign a value |
| 282 |
elsif( not $col_info->{default_value} and not $col_info->{is_auto_increment} and not $col_info->{is_foreign_key} ) { |
270 |
} elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) { |
| 283 |
eval { |
271 |
if( exists $value->{$col_name} ) { |
| 284 |
my $data_type = $col_info->{data_type}; |
272 |
if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) { |
| 285 |
$data_type =~ s| |_|; |
273 |
# This explicit undef is not allowed |
| 286 |
$col_value = $gen_type->{$data_type}->( $self, { info => $col_info } ); |
274 |
warn "Null value for $col_name in $source not allowed"; |
| 287 |
}; |
275 |
return; |
| 288 |
die "The type $col_info->{data_type} is not defined\n" if ($@); |
276 |
} |
|
|
277 |
if( ref( $value->{$col_name} ) ne 'HASH' ) { |
| 278 |
push @$retvalue, $value->{$col_name}; |
| 279 |
} |
| 280 |
# sub build will handle a passed hash value later on |
| 281 |
} |
| 282 |
} elsif( ref( $value->{$col_name} ) eq 'HASH' ) { |
| 283 |
# this is not allowed for a column that is not a FK |
| 284 |
warn "Hash not allowed for $col_name in $source"; |
| 285 |
return; |
| 286 |
} elsif( exists $value->{$col_name} ) { |
| 287 |
if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) { |
| 288 |
# This explicit undef is not allowed |
| 289 |
warn "Null value for $col_name in $source not allowed"; |
| 290 |
return; |
| 291 |
} |
| 292 |
push @$retvalue, $value->{$col_name}; |
| 293 |
} else { |
| 294 |
my $data_type = $col_info->{data_type}; |
| 295 |
$data_type =~ s| |_|; |
| 296 |
if( my $hdlr = $self->{gen_type}->{$data_type} ) { |
| 297 |
push @$retvalue, &$hdlr( $self, { info => $col_info } ); |
| 298 |
} else { |
| 299 |
warn "Unknown type $data_type for $col_name in $source"; |
| 300 |
return; |
| 301 |
} |
| 289 |
} |
302 |
} |
| 290 |
return $col_value; |
303 |
return $retvalue; |
| 291 |
} |
304 |
} |
| 292 |
|
305 |
|
|
|
306 |
sub _should_be_fk { |
| 307 |
# This sub is only needed for inconsistencies in the schema |
| 308 |
# A column is not marked as FK, but a belongs_to relation is defined |
| 309 |
my ( $source, $column ) = @_; |
| 310 |
my $inconsistencies = { |
| 311 |
'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK |
| 312 |
}; |
| 313 |
return $inconsistencies->{ "$source.$column" }; |
| 314 |
} |
| 315 |
|
| 316 |
sub _gen_type { |
| 317 |
return { |
| 318 |
tinyint => \&_gen_int, |
| 319 |
smallint => \&_gen_int, |
| 320 |
mediumint => \&_gen_int, |
| 321 |
integer => \&_gen_int, |
| 322 |
bigint => \&_gen_int, |
| 323 |
|
| 324 |
float => \&_gen_real, |
| 325 |
decimal => \&_gen_real, |
| 326 |
double_precision => \&_gen_real, |
| 327 |
|
| 328 |
timestamp => \&_gen_date, |
| 329 |
datetime => \&_gen_date, |
| 330 |
date => \&_gen_date, |
| 331 |
|
| 332 |
char => \&_gen_text, |
| 333 |
varchar => \&_gen_text, |
| 334 |
tinytext => \&_gen_text, |
| 335 |
text => \&_gen_text, |
| 336 |
mediumtext => \&_gen_text, |
| 337 |
longtext => \&_gen_text, |
| 338 |
|
| 339 |
set => \&_gen_set_enum, |
| 340 |
enum => \&_gen_set_enum, |
| 341 |
|
| 342 |
tinyblob => \&_gen_blob, |
| 343 |
mediumblob => \&_gen_blob, |
| 344 |
blob => \&_gen_blob, |
| 345 |
longblob => \&_gen_blob, |
| 346 |
}; |
| 347 |
}; |
| 293 |
|
348 |
|
| 294 |
sub _gen_int { |
349 |
sub _gen_int { |
| 295 |
my ($self, $params) = @_; |
350 |
my ($self, $params) = @_; |
|
Lines 356-427
sub _gen_blob {
Link Here
|
| 356 |
|
411 |
|
| 357 |
=head1 NAME |
412 |
=head1 NAME |
| 358 |
|
413 |
|
| 359 |
t::lib::TestBuilder.pm - Koha module to simplify the writing of tests |
414 |
t::lib::TestBuilder.pm - Koha module to create test records |
| 360 |
|
415 |
|
| 361 |
=head1 SYNOPSIS |
416 |
=head1 SYNOPSIS |
| 362 |
|
417 |
|
| 363 |
use t::lib::TestBuilder; |
418 |
use t::lib::TestBuilder; |
| 364 |
|
419 |
my $builder = t::lib::TestBuilder->new; |
| 365 |
Koha module to insert the foreign keys automatically for the tests |
420 |
|
|
|
421 |
# The following call creates a patron, linked to branch CPL. |
| 422 |
# Surname is provided, other columns are randomly generated. |
| 423 |
# Branch CPL is created if it does not exist. |
| 424 |
my $patron = $builder->build({ |
| 425 |
source => 'Borrower', |
| 426 |
value => { surname => 'Jansen', branchcode => 'CPL' }, |
| 427 |
}); |
| 366 |
|
428 |
|
| 367 |
=head1 DESCRIPTION |
429 |
=head1 DESCRIPTION |
| 368 |
|
430 |
|
| 369 |
This module allows to insert automatically an entry in the database. All the database changes are wrapped in a transaction. |
431 |
This module automatically creates database records for you. |
| 370 |
The foreign keys are created according to the DBIx::Class schema. |
432 |
If needed, records for foreign keys are created too. |
| 371 |
The taken values are the values by default if it is possible or randomly generated. |
433 |
Values will be randomly generated if not passed to TestBuilder. |
|
|
434 |
Note that you should wrap these actions in a transaction yourself. |
| 372 |
|
435 |
|
| 373 |
=head1 FUNCTIONS |
436 |
=head1 METHODS |
| 374 |
|
437 |
|
| 375 |
=head2 new |
438 |
=head2 new |
| 376 |
|
439 |
|
| 377 |
$builder = t::lib::TestBuilder->new() |
440 |
my $builder = t::lib::TestBuilder->new; |
| 378 |
|
441 |
|
| 379 |
Constructor - Begins a transaction and returns the object TestBuilder |
442 |
Constructor - Returns the object TestBuilder |
| 380 |
|
443 |
|
| 381 |
=head2 schema |
444 |
=head2 schema |
| 382 |
|
445 |
|
| 383 |
$schema = $builder->schema |
446 |
my $schema = $builder->schema; |
| 384 |
|
|
|
| 385 |
Getter - Returns the schema of DBIx::Class |
| 386 |
|
| 387 |
=head2 clear |
| 388 |
|
447 |
|
| 389 |
$builder->clear({ source => $source_name }) |
448 |
Getter - Returns the schema of DBIx::Class |
| 390 |
|
449 |
|
| 391 |
=over |
450 |
=head2 delete |
| 392 |
|
451 |
|
| 393 |
=item C<$source_name> is the name of the source in the DBIx::Class schema (required) |
452 |
$builder->delete({ |
| 394 |
|
453 |
source => $source, |
| 395 |
=back |
454 |
records => $patron, # OR: records => [ $patron, ... ], |
|
|
455 |
}); |
| 396 |
|
456 |
|
| 397 |
Clears all the data of this source (database table) |
457 |
Delete individual records, created by builder. |
|
|
458 |
Returns the number of delete attempts, or undef. |
| 398 |
|
459 |
|
| 399 |
=head2 build |
460 |
=head2 build |
| 400 |
|
461 |
|
| 401 |
$builder->build({ |
462 |
$builder->build({ source => $source_name, value => $value }); |
| 402 |
source => $source_name, |
463 |
|
| 403 |
value => $value, |
464 |
Create a test record in the table, represented by $source_name. |
| 404 |
only_fk => $only_fk, |
465 |
The name is required and must conform to the DBIx::Class schema. |
| 405 |
}) |
466 |
Values may be specified by the optional $value hashref. Will be |
| 406 |
|
467 |
randomized otherwise. |
| 407 |
=over |
468 |
If needed, TestBuilder creates linked records for foreign keys. |
| 408 |
|
469 |
Returns the values of the new record as a hashref, or undef if |
| 409 |
=item C<$source_name> is the name of the source in the DBIx::Class schema (required) |
470 |
the record could not be created. |
| 410 |
|
471 |
|
| 411 |
=item C<$value> is the values for the entry (optional) |
472 |
Note that build also supports recursive hash references inside the |
| 412 |
|
473 |
value hash for foreign key columns, like: |
| 413 |
=item C<$only_fk> is a boolean to indicate if only the foreign keys are created (optional) |
474 |
value => { |
| 414 |
|
475 |
column1 => 'some_value', |
| 415 |
=back |
476 |
fk_col2 => { |
|
|
477 |
columnA => 'another_value', |
| 478 |
} |
| 479 |
} |
| 480 |
The hash for fk_col2 here means: create a linked record with build |
| 481 |
where columnA has this value. In case of a composite FK the hashes |
| 482 |
are merged. |
| 416 |
|
483 |
|
| 417 |
Inserts an entry in the database by instanciating all the foreign keys. |
484 |
Realize that passing primary key values to build may result in undef |
| 418 |
The values can be specified, the values which are not given are default values if they exists or generated randomly. |
485 |
if a record with that primary key already exists. |
| 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 |
|
486 |
|
| 421 |
=head1 AUTHOR |
487 |
=head1 AUTHOR |
| 422 |
|
488 |
|
| 423 |
Yohann Dufour <yohann.dufour@biblibre.com> |
489 |
Yohann Dufour <yohann.dufour@biblibre.com> |
| 424 |
|
490 |
|
|
|
491 |
Koha Development Team |
| 492 |
|
| 425 |
=head1 COPYRIGHT |
493 |
=head1 COPYRIGHT |
| 426 |
|
494 |
|
| 427 |
Copyright 2014 - Biblibre SARL |
495 |
Copyright 2014 - Biblibre SARL |
| 428 |
- |
|
|