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 |
- |
|
|