File Coverage

blib/lib/Rose/DB/Object/MakeMethods/Generic.pm
Criterion Covered Total %
statement 922 2957 31.1
branch 222 1794 12.3
condition 100 841 11.8
subroutine 189 241 78.4
pod 12 12 100.0
total 1445 5845 24.7


line stmt bran cond sub pod time code
1             package Rose::DB::Object::MakeMethods::Generic;
2              
3 61     61   448 use strict;
  61         148  
  61         2070  
4              
5 61     61   365 use Bit::Vector::Overload;
  61         139  
  61         2829  
6              
7 61     61   371 use Carp();
  61         194  
  61         1449  
8 61     61   415 use Scalar::Util qw(weaken refaddr);
  61         154  
  61         3593  
9              
10 61     61   546 use Rose::Object::MakeMethods;
  61         178  
  61         571  
11             our @ISA = qw(Rose::Object::MakeMethods);
12              
13 61     61   69920 use Rose::DB::Object::Manager;
  61         185  
  61         2558  
14 61     61   521 use Rose::DB::Constants qw(IN_TRANSACTION);
  61         149  
  61         4652  
15             use Rose::DB::Object::Constants
16 61         4964 qw(PRIVATE_PREFIX FLAG_DB_IS_PRIVATE STATE_IN_DB STATE_LOADING
17             STATE_SAVING ON_SAVE_ATTR_NAME MODIFIED_COLUMNS MODIFIED_NP_COLUMNS
18 61     61   458 SET_COLUMNS EXCEPTION_CODE_NO_KEY);
  61         154  
19              
20 61     61   424 use Rose::DB::Object::Helpers();
  61         158  
  61         1255  
21 61     61   338 use Rose::DB::Object::Util qw(column_value_formatted_key);
  61         146  
  61         24396  
22              
23             our $VERSION = '0.812';
24              
25             our $Debug = 0;
26              
27             sub scalar
28             {
29 191     191 1 12302 my($class, $name, $args) = @_;
30              
31 191   66     566 my $key = $args->{'hash_key'} || $name;
32 191   100     516 my $interface = $args->{'interface'} || 'get_set';
33 191   100     628 my $length = $args->{'length'} || 0;
34 191         359 my $overflow = $args->{'overflow'};
35 191         345 my $default = $args->{'default'};
36 191         353 my $check_in = $args->{'check_in'};
37 191         327 my $smart = $args->{'smart_modification'};
38 191   100     573 my $type = $args->{'_method_type'} || 'scalar';
39              
40 191 100       639 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
41              
42 191 100       519 $length = undef if($type eq 'integer'); # don't limit integers by length
43              
44 191         303 my $init_method;
45              
46 191 50 33     750 if(exists $args->{'with_init'} || exists $args->{'init_method'})
47             {
48 0   0     0 $init_method = $args->{'init_method'} || "init_$name";
49             }
50              
51 191         358 my $undef_overrides_default = $args->{'undef_overrides_default'};
52              
53             ##
54             ## Build code snippets
55             ##
56              
57 191         345 my $qkey = $key;
58 191         411 $qkey =~ s/'/\\'/g;
59 191         285 my $qname = $name;
60 191         300 $qname =~ s/"/\\"/g;
61              
62 191         287 my $col_name_escaped = $column_name;
63 191         296 $col_name_escaped =~ s/'/\\'/g;
64              
65 191 100       473 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
66             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
67              
68 191 50       1379 my $dont_use_default_code = !$undef_overrides_default ? qq(defined \$self->{'$qkey'}) :
69             qq(defined \$self->{'$qkey'} || ) .
70             qq((\$self->{STATE_IN_DB()} && !(\$self->{SET_COLUMNS()}{'$col_name_escaped'} || \$self->{'$mod_columns_key'}{'$col_name_escaped'})) || ) .
71             qq(\$self->{SET_COLUMNS()}{'$col_name_escaped'} || ) .
72             qq(\$self->{'$mod_columns_key'}{'$col_name_escaped'});
73              
74             #
75             # check_in code
76             #
77              
78 191         397 my $check_in_code = '';
79 191         290 my %check;
80              
81 191 50       414 if($check_in)
82             {
83 0 0       0 $check_in = [ $check_in ] unless(ref $check_in);
84 0         0 %check = map { $_ => 1 } @$check_in;
  0         0  
85              
86 0         0 $check_in_code=<<"EOF";
87             if(defined \$value)
88             {
89             Carp::croak "Invalid $name: '\$value'" unless(exists \$check{\$value});
90             }
91              
92             EOF
93             }
94              
95             #
96             # length check code
97             #
98              
99 191         341 my $length_check_code = '';
100              
101 191 100       388 if($length)
102             {
103 8 50       48 unless($length =~ /^\d+$/)
104             {
105 0         0 Carp::croak "Invalid length for $type column $qname: '$length'";
106             }
107              
108 61     61   609 no warnings 'uninitialized';
  61         157  
  61         80011  
109 8 100       29 if($overflow eq 'fatal')
    50          
    100          
    50          
110             {
111 2         8 $length_check_code =<<"EOF";
112             no warnings 'uninitialized';
113             if(length(\$value) > $length)
114             {
115             Carp::croak ref(\$self), ": Value for $qname() is too long. Maximum ",
116 2 50       9 "length is $length character@{[ $length == 1 ? '' : 's' ]}. ",
117             "Value is ", length(\$value), " characters: \$value";
118             }
119              
120             EOF
121             }
122             elsif($overflow eq 'warn')
123             {
124 0         0 $length_check_code =<<"EOF";
125             no warnings 'uninitialized';
126             if(length(\$value) > $length)
127             {
128             Carp::carp ref(\$self), ": WARNING: Value for $qname() is too long. ",
129 0 0       0 "Maximum length is $length character@{[ $length == 1 ? '' : 's' ]}. ",
130             "Value is ", length(\$value), " characters: \$value";
131             }
132             EOF
133             }
134             elsif($overflow eq 'truncate')
135             {
136 2         4 $length_check_code =<<"EOF";
137             no warnings 'uninitialized';
138             if(length(\$value) > $length)
139             {
140             \$value = substr(\$value, 0, $length);
141             }
142              
143             EOF
144             }
145             elsif(defined $overflow)
146             {
147 0         0 Carp::croak "Invalid overflow value: $overflow";
148             }
149             }
150              
151             #
152             # set code
153             #
154              
155 191         310 my $set_code;
156              
157 191 100       386 if($type eq 'character')
158             {
159 4         9 $set_code = qq(\$self->{'$qkey'} = defined \$value ? sprintf("%-${length}s", \$value) : undef;);
160             }
161             else
162             {
163 187         422 $set_code = qq(\$self->{'$qkey'} = \$value;);
164             }
165              
166             #
167             # column modified code
168             #
169              
170 191         468 my $column_modified_code =
171             qq(\$self->{'$mod_columns_key'}{'$col_name_escaped'} = 1);
172              
173             #
174             # return code
175             #
176              
177 191         314 my $return_code = '';
178 191         306 my $return_code_get = '';
179 191         339 my $return_code_shift = '';
180              
181 191 100       439 if(defined $default)
    50          
182             {
183 2 50       6 if($type eq 'character')
184             {
185 0         0 $return_code_get=<<"EOF";
186             return ($dont_use_default_code) ? \$self->{'$qkey'} :
187             (\$self->{'$qkey'} = sprintf("%-${length}s", \$default));
188             EOF
189              
190 0         0 $return_code=<<"EOF";
191             return ($dont_use_default_code) ? \$self->{'$qkey'} :
192             (scalar($column_modified_code,
193             \$self->{'$qkey'} = sprintf("%-${length}s", \$default)));
194             EOF
195             }
196             else
197             {
198 2         26 $return_code_get=<<"EOF";
199             return ($dont_use_default_code) ? \$self->{'$qkey'} :
200             (\$self->{'$qkey'} = \$default);
201             EOF
202              
203 2         9 $return_code=<<"EOF";
204             return ($dont_use_default_code) ? \$self->{'$qkey'} :
205             (scalar($column_modified_code,
206             \$self->{'$qkey'} = \$default));
207             EOF
208             }
209             }
210             elsif(defined $init_method)
211             {
212 0 0       0 if($type eq 'character')
213             {
214 0         0 $return_code_get=<<"EOF";
215             return (defined \$self->{'$qkey'}) ? \$self->{'$qkey'} :
216             (\$self->{'$qkey'} = sprintf("%-${length}s", \$self->$init_method()));
217             EOF
218              
219 0         0 $return_code=<<"EOF";
220             return (defined \$self->{'$qkey'}) ? \$self->{'$qkey'} :
221             (scalar($column_modified_code,
222             \$self->{'$qkey'} = sprintf("%-${length}s", \$self->$init_method())));
223             EOF
224             }
225             else
226             {
227 0         0 $return_code_get=<<"EOF";
228             return (defined \$self->{'$qkey'}) ? \$self->{'$qkey'} :
229             (\$self->{'$qkey'} = \$self->$init_method());
230             EOF
231              
232 0         0 $return_code=<<"EOF";
233             return (defined \$self->{'$qkey'}) ? \$self->{'$qkey'} :
234             (scalar($column_modified_code,
235             \$self->{'$qkey'} = \$self->$init_method()));
236             EOF
237             }
238             }
239             else
240             {
241 189         368 $return_code = qq(return \$self->{'$qkey'};);
242 189         354 $return_code_shift = qq(return shift->{'$qkey'};);
243             }
244              
245 191   66     792 $return_code_get ||= $return_code;
246 191   66     429 $return_code_shift ||= $return_code;
247              
248 191 50       420 my $save_old_val_code = $smart ?
249             qq(no warnings 'uninitialized';\nmy \$old_val = \$self->{'$qkey'};) : '';
250              
251 191 50       398 my $was_set_code = $smart ?
252             qq(\$self->{SET_COLUMNS()}{'$col_name_escaped'} = 1;) : '';
253              
254 191         275 my $mod_cond_code;
255              
256 191 50       352 if($smart)
257             {
258 0 0       0 $mod_cond_code = ($type eq 'integer') ?
259             qq(unless(\$self->{STATE_LOADING()} || (!defined \$old_val && !defined \$self->{'$qkey'}) || (\$old_val == \$self->{'$qkey'} && length \$old_val && length \$self->{'$qkey'}));) :
260             qq(unless(\$self->{STATE_LOADING()} || (!defined \$old_val && !defined \$self->{'$qkey'}) || \$old_val eq \$self->{'$qkey'}););
261             }
262             else
263             {
264 191         355 $mod_cond_code = qq(unless(\$self->{STATE_LOADING()}););
265             }
266              
267 191         297 my $mod_cond_pre_set_code;
268              
269 191 50       318 if($smart)
270             {
271 0 0       0 $mod_cond_pre_set_code = ($type eq 'integer') ?
272             qq(unless(\$self->{STATE_LOADING()} || (!defined \$value && !defined \$self->{'$qkey'}) || (\$value == \$self->{'$qkey'} && length \$value && length \$self->{'$qkey'}));) :
273             qq(unless(\$self->{STATE_LOADING()} || (!defined \$value && !defined \$self->{'$qkey'}) || \$value eq \$self->{'$qkey'}););
274             }
275             else
276             {
277 191         306 $mod_cond_pre_set_code = qq(unless(\$self->{STATE_LOADING()}););
278             }
279              
280 191         298 my %methods;
281              
282 191 100       423 if($interface eq 'get_set')
    100          
    50          
283             {
284 185         285 my $code;
285              
286             # I can't help myself...
287 185 100 66     584 if(defined $default || defined $init_method)
288             {
289 2         21 $code=<<"EOF";
290             sub
291             {
292             my \$self = shift;
293              
294             if(\@_)
295             {
296             my \$value = shift;
297              
298             no warnings;
299             $check_in_code
300             $length_check_code
301             $save_old_val_code
302             $set_code
303             $column_modified_code $mod_cond_code
304             $was_set_code
305             $return_code
306             }
307              
308             $return_code_get
309             };
310             EOF
311             }
312             else
313             {
314 183         630 $code=<<"EOF";
315             sub
316             {
317             if(\@_ > 1)
318             {
319             my \$self = shift;
320             my \$value = shift;
321              
322             no warnings;
323             $check_in_code
324             $length_check_code
325             $column_modified_code $mod_cond_pre_set_code
326             $was_set_code
327             return $set_code
328             }
329              
330             $return_code_shift
331             };
332             EOF
333             }
334              
335 185         296 my $error;
336              
337             TRY:
338             {
339 185         281 local $@;
  185         290  
340 185 50       381 $Debug && warn "sub $name = ", $code;
341 185     5   22622 $methods{$name} = eval $code;
  5     4   43  
  5     4   13  
  5     4   552  
  4     4   37  
  4     5   9  
  4     4   341  
  4     4   29  
  4     4   9  
  4     3   492  
  4     2   33  
  4     2   19  
  4     1   338  
  4     1   40  
  4     1   8  
  4     1   440  
  5     1   49  
  5     1   11  
  5     1   540  
  4     1   29  
  4     1   9  
  4     1   403  
  4     1   35  
  4     1   9  
  4     1   344  
  4     1   31  
  4     1   18  
  4     1   433  
  3     1   27  
  3     1   7  
  3     1   318  
  2     1   16  
  2     1   5  
  2     1   209  
  2     1   27  
  2     1   6  
  2     1   221  
  1     1   8  
  1     1   2  
  1     1   97  
  1     1   9  
  1     1   3  
  1     1   108  
  1     1   8  
  1     1   2  
  1     1   111  
  1     1   11  
  1     1   12  
  1     1   136  
  1     1   7  
  1     1   3  
  1     1   102  
  1     1   9  
  1     1   2  
  1     1   101  
  1     1   8  
  1     1   3  
  1     1   112  
  1     1   9  
  1     1   2  
  1     1   102  
  1     1   20  
  1     1   2  
  1     1   139  
  1     1   8  
  1     1   3  
  1     1   114  
  1     1   14  
  1     1   2  
  1     1   98  
  1     1   33  
  1     1   3  
  1     1   118  
  1     1   8  
  1     1   5  
  1     1   147  
  1     1   9  
  1     1   2  
  1     1   104  
  1     1   8  
  1     1   3  
  1     1   116  
  1     1   12  
  1     1   3  
  1     1   110  
  1     1   13  
  1     1   3  
  1     1   110  
  1     1   18  
  1     1   3  
  1     1   114  
  1     1   13  
  1     1   2  
  1     1   121  
  1     1   9  
  1     1   3  
  1     1   108  
  1     1   19  
  1     1   5  
  1     1   106  
  1     1   20  
  1     1   3  
  1     1   108  
  1     1   13  
  1     1   2  
  1     1   104  
  1     1   13  
  1     1   9  
  1     1   113  
  1     1   8  
  1     1   3  
  1     1   113  
  1     1   8  
  1     1   5  
  1     1   105  
  1     1   8  
  1     1   3  
  1     1   113  
  1     1   9  
  1     1   2  
  1     1   108  
  1     1   8  
  1     1   2  
  1     1   108  
  1     1   9  
  1     1   2  
  1     1   114  
  1     1   8  
  1     1   3  
  1     1   98  
  1     1   9  
  1     1   2  
  1     1   132  
  1     1   8  
  1     1   6  
  1     1   113  
  1     1   7  
  1     1   3  
  1     1   105  
  1     1   8  
  1     1   2  
  1     1   133  
  1     1   8  
  1     1   2  
  1     1   122  
  1     1   15  
  1     1   8  
  1     1   112  
  1     1   10  
  1     1   9  
  1     1   116  
  1     1   8  
  1     1   3  
  1     1   104  
  1     1   8  
  1     1   3  
  1     1   111  
  1     1   9  
  1     1   4  
  1         102  
  1         8  
  1         2  
  1         108  
  1         8  
  1         3  
  1         100  
  1         8  
  1         5  
  1         113  
  1         9  
  1         3  
  1         97  
  1         17  
  1         4  
  1         107  
  1         16  
  1         3  
  1         117  
  1         9  
  1         2  
  1         195  
  1         15  
  1         3  
  1         119  
  1         10  
  1         3  
  1         124  
  1         8  
  1         2  
  1         109  
  1         9  
  1         3  
  1         113  
  1         8  
  1         18  
  1         108  
  1         12  
  1         2  
  1         106  
  1         19  
  1         3  
  1         98  
  1         8  
  1         3  
  1         111  
  1         9  
  1         2  
  1         118  
  1         8  
  1         3  
  1         104  
  1         10  
  1         2  
  1         102  
  1         7  
  1         2  
  1         98  
  1         8  
  1         3  
  1         99  
  1         8  
  1         2  
  1         106  
  1         8  
  1         3  
  1         97  
  1         12  
  1         3  
  1         122  
  1         9  
  1         2  
  1         145  
  1         11  
  1         3  
  1         160  
  1         8  
  1         3  
  1         114  
  1         9  
  1         2  
  1         107  
  1         15  
  1         2  
  1         108  
  1         9  
  1         3  
  1         108  
  1         8  
  1         4  
  1         104  
  1         7  
  1         4  
  1         102  
  1         8  
  1         10  
  1         114  
  1         18  
  1         3  
  1         114  
  1         8  
  1         2  
  1         100  
  1         24  
  1         4  
  1         96  
  1         8  
  1         3  
  1         100  
  1         8  
  1         3  
  1         115  
  1         8  
  1         5  
  1         109  
  1         8  
  1         4  
  1         112  
  1         9  
  1         4  
  1         135  
  1         12  
  1         2  
  1         107  
  1         9  
  1         5  
  1         131  
  1         8  
  1         5  
  1         101  
  1         13  
  1         3  
  1         133  
  1         18  
  1         5  
  1         101  
  1         9  
  1         2  
  1         104  
  1         8  
  1         3  
  1         99  
  1         7  
  1         3  
  1         100  
  1         11  
  1         6  
  1         109  
  1         10  
  1         2  
  1         100  
  1         8  
  1         3  
  1         103  
  1         9  
  1         3  
  1         112  
  1         10  
  1         18  
  1         107  
  1         8  
  1         2  
  1         104  
  1         7  
  1         4  
  1         105  
  1         9  
  1         2  
  1         119  
  1         16  
  1         4  
  1         100  
  1         12  
  1         2  
  1         106  
  1         9  
  1         3  
  1         103  
  1         8  
  1         5  
  1         103  
  1         9  
  1         4  
  1         106  
  1         8  
  1         2  
  1         104  
  1         10  
  1         2  
  1         106  
  1         9  
  1         5  
  1         101  
  1         8  
  1         4  
  1         100  
  1         7  
  1         2  
  1         98  
  1         8  
  1         11  
  1         101  
  1         9  
  1         2  
  1         97  
  1         8  
  1         2  
  1         97  
  1         9  
  1         16  
  1         106  
  1         8  
  1         2  
  1         104  
  1         8  
  1         3  
  1         101  
  1         8  
  1         3  
  1         107  
  1         8  
  1         3  
  1         116  
  1         8  
  1         3  
  1         118  
  1         8  
  1         3  
  1         112  
  1         8  
  1         3  
  1         106  
  1         8  
  1         2  
  1         103  
  1         8  
  1         12  
  1         120  
  1         8  
  1         3  
  1         107  
  1         8  
  1         3  
  1         98  
  1         9  
  1         3  
  1         100  
  1         8  
  1         3  
  1         101  
  1         9  
  1         2  
  1         122  
  1         14  
  1         2  
  1         97  
  1         14  
  1         3  
  1         102  
  1         8  
  1         3  
  1         106  
  1         7  
  1         3  
  1         102  
  1         9  
  1         2  
  1         109  
  1         8  
  1         3  
  1         110  
  1         9  
  1         2  
  1         114  
  1         8  
  1         4  
  1         100  
  1         8  
  1         2  
  1         103  
  1         8  
  1         2  
  1         105  
  1         8  
  1         3  
  1         100  
  1         8  
  1         5  
  1         102  
  1         9  
  1         2  
  1         108  
  1         15  
  1         3  
  1         103  
  1         10  
  1         2  
  1         118  
  1         10  
  1         2  
  1         102  
  1         13  
  1         3  
  1         97  
  1         8  
  1         3  
  1         110  
  1         7  
  1         4  
  1         106  
  1         9  
  1         7  
  1         99  
  1         8  
  1         3  
  1         142  
  1         10  
  1         2  
  1         100  
342 185         645 $error = $@;
343             }
344              
345 185 50       617 if($error)
346             {
347 0         0 Carp::croak "Error in generated code for method $name - $error\n",
348             "Code was: $code";
349             }
350             }
351             elsif($interface eq 'get')
352             {
353 3         5 my $code;
354              
355             # I can't help myself...
356 3 50 33     10 if(defined $default || defined $init_method)
357             {
358 0         0 $code = qq(sub { my \$self = shift; $return_code };);
359             }
360             else
361             {
362 3         15 $code = qq(sub { shift->{'$qkey'} });
363             }
364              
365 3         5 my $error;
366              
367             TRY:
368             {
369 3         4 local $@;
  3         3  
370 3 50       7 $Debug && warn "sub $name = ", $code;
371 3         226 $methods{$name} = eval $code;
372 3         7 $error = $@;
373             }
374              
375 3 50       9 if($error)
376             {
377 0         0 Carp::croak "Error in generated code for method $name - $error\n",
378             "Code was: $code";
379             }
380             }
381             elsif($interface eq 'set')
382             {
383 3         9 my $arg_check_code =
384             qq(Carp::croak ref(\$_[0]), ": Missing argument in call to $qname" unless(\@_ > 1););
385              
386 3         12 my $code=<<"EOF";
387             sub
388             {
389             $arg_check_code
390             my \$self = shift;
391             my \$value = shift;
392              
393             no warnings;
394             $check_in_code
395             $length_check_code
396             $save_old_val_code
397             $set_code
398             $column_modified_code $mod_cond_code
399             $was_set_code
400             $return_code
401             };
402             EOF
403              
404 3         5 my $error;
405              
406             TRY:
407             {
408 3         3 local $@;
  3         5  
409 3 50       5 $Debug && warn "sub $name = ", $code;
410 3         304 $methods{$name} = eval $code;
411 3         7 $error = $@;
412             }
413              
414 3 50       9 if($error)
415             {
416 0         0 Carp::croak "Error in generated code for method $name - $error\n",
417             "Code was: $code";
418             }
419             }
420 0         0 else { Carp::croak "Unknown interface: $interface" }
421              
422 191         1067 return \%methods;
423             }
424              
425             sub enum
426             {
427 1     1 1 5 my($class, $name, $args) = @_;
428              
429 1   0     3 my $key = $args->{'hash_key'} || $name;
430 1   0     2 my $interface = $args->{'interface'} || 'get_set';
431              
432 1 50       4 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
433              
434 1   0     83 my $undef_overrides_default = $args->{'undef_overrides_default'} || 0;
435              
436 0   0     0 my $values = $args->{'values'} || $args->{'check_in'};
437              
438 0 0 0     0 unless(ref $values && @$values)
439             {
440 0         0 Carp::croak "Missing list of valid values for enum column '$name'";
441             }
442              
443 2         633 my %values = map { $_ => 1 } @$values;
  1         3  
444              
445 1         2 my $default = $args->{'default'};
446              
447             # Good-old MySQL and its empty-string defaults for NOT NULL columns...
448 61     61   563 no warnings 'uninitialized';
  61         197  
  61         92737  
449 1 0 0     5 delete $args->{'default'} if($default eq '' && !$values{$default});
450              
451 1 50       6 if(exists $args->{'default'})
452             {
453 1 50       5 unless(exists $values{$default})
454             {
455 1         8 Carp::croak "Illegal default value for enum column '$name' - '$default'";
456             }
457             }
458              
459 1 100       3 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
460             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
461              
462 1         3 my %methods;
463              
464 1 0       4 if($interface eq 'get_set')
    0          
    0          
465             {
466 1 50 0     78 if(exists $args->{'default'})
    100          
467             {
468             $methods{$name} = sub
469             {
470 0     1   0 my($self) = shift;
471              
472 0 50       0 if(@_)
473             {
474 2 0 0     9 Carp::croak "Invalid $name: '$_[0]'" unless(!defined $_[0] || exists $values{$_[0]});
475 1 50       3 $self->{MODIFIED_COLUMNS()}{$column_name} = 1 unless($self->{STATE_LOADING()});
476 1         2 return $self->{$key} = $_[0];
477             }
478              
479 1 50 0     4 if(defined $self->{$key} || ($undef_overrides_default && ($self->{MODIFIED_COLUMNS()}{$column_name} ||
      0        
      0        
480             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
481             {
482 1         3 return $self->{$key};
483             }
484             else
485             {
486 1         7 $self->{$mod_columns_key}{$column_name} = 1;
487 1         9 return $self->{$key} = $default;
488             }
489 0         0 };
490             }
491             elsif(exists $args->{'with_init'} || exists $args->{'init_method'})
492             {
493 1   0     6 my $init_method = $args->{'init_method'} || "init_$name";
494              
495             $methods{$name} = sub
496             {
497 1     2   4 my($self) = shift;
498              
499 1 100       2 if(@_)
500             {
501 1 50 0     5 Carp::croak "Invalid $name: '$_[0]'" unless(!defined $_[0] || exists $values{$_[0]});
502 1         4 $self->{$mod_columns_key}{$column_name} = 1;
503 1         5 return $self->{$key} = $_[0];
504             }
505              
506 1 50 0     5 if(defined $self->{$key} || ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
      0        
      0        
507             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
508             {
509 1         14 return $self->{$key};
510             }
511             else
512             {
513 1         306 $self->{$mod_columns_key}{$column_name} = 1;
514 1         325 return $self->{$key} = $self->$init_method();
515             }
516 2         19 };
517             }
518             else
519             {
520             $methods{$name} = sub
521             {
522 2     0   190 my($self) = shift;
523              
524 1 100       2 if(@_)
525             {
526 1 50 0     3 Carp::croak "Invalid $name: '$_[0]'" unless(!defined $_[0] || exists $values{$_[0]});
527 1 100       2 $self->{$mod_columns_key}{$column_name} = 1 unless($self->{STATE_LOADING()});
528 1         5 return $self->{$key} = $_[0];
529             }
530              
531 1         5 return $self->{$key};
532 1         317 };
533             }
534             }
535             elsif($interface eq 'set')
536             {
537             $methods{$name} = sub
538             {
539 1     0   3 my($self) = shift;
540              
541 1 50       2 Carp::croak "Missing argument in call to $name" unless(@_);
542 1 50 0     7 Carp::croak "Invalid $name: '$_[0]'" unless(!defined $_[0] || exists $values{$_[0]});
543 1 100       5 $self->{$mod_columns_key}{$column_name} = 1 unless($self->{STATE_LOADING()});
544 1         5 return $self->{$key} = $_[0];
545 2         417 };
546             }
547             elsif($interface eq 'get')
548             {
549 2 0 0     401 if(exists $args->{'default'})
    0          
550             {
551             $methods{$name} = sub
552             {
553 1     0   3 my($self) = shift;
554              
555 1 50 0     41 if(defined $self->{$key} || ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
      0        
      0        
556             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
557             {
558 1         7 return $self->{$key};
559             }
560             else
561             {
562 1         6 $self->{$mod_columns_key}{$column_name} = 1;
563 0         0 return $self->{$key} = $default;
564             }
565 1         3 };
566             }
567             elsif(exists $args->{'with_init'} || exists $args->{'init_method'})
568             {
569 0   0     0 my $init_method = $args->{'init_method'} || "init_$name";
570              
571             $methods{$name} = sub
572             {
573 0     0   0 my($self) = shift;
574             return (defined $self->{$key}) ? $self->{$key} :
575             (scalar($self->{$mod_columns_key}{$column_name} = 1,
576 0 0       0 $self->{$key} = $self->$init_method()));
577 0         0 };
578             }
579             else
580             {
581 0     0   0 $methods{$name} = sub { shift->{$key} };
  0         0  
582             }
583             }
584 0         0 else { Carp::croak "Unknown interface: $interface" }
585              
586 0 0       0 if($Debug > 1)
587             {
588 0         0 require Data::Dumper;
589 0         0 warn Data::Dumper::Dumper(\%methods);
590             }
591              
592 0         0 return \%methods;
593             }
594              
595             sub character
596             {
597 4     4 1 118 my($class, $name, $args) = @_;
598 4         18 $args->{'_method_type'} = 'character';
599 4         9 $class->scalar($name, $args);
600             }
601              
602             sub varchar
603             {
604 5     5 1 228 my($class, $name, $args) = @_;
605 5         13 $args->{'_method_type'} = 'varchar';
606 5         16 $class->scalar($name, $args);
607             }
608              
609             sub integer
610             {
611 13     13 1 1063 my($class, $name, $args) = @_;
612 13         36 $args->{'_method_type'} = 'integer';
613 13         57 $class->scalar($name, $args);
614             }
615              
616             sub boolean
617             {
618 10     10 1 438 my($class, $name, $args) = @_;
619              
620 10   66     27 my $key = $args->{'hash_key'} || $name;
621 10   100     29 my $interface = $args->{'interface'} || 'get_set';
622              
623 10 100       30 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
624              
625 10         28 my $formatted_key = column_value_formatted_key($key);
626              
627 10   50     49 my $undef_overrides_default = $args->{'undef_overrides_default'} || 0;
628              
629 10 100       27 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
630             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
631              
632 10         44 my %methods;
633              
634 10 100       40 if($interface eq 'get_set')
    100          
    50          
635             {
636 8         15 my $default = $args->{'default'};
637              
638 8 100       18 if(defined $default)
639             {
640 3 50       34 $default = ($default =~ /^(?:0(?:\.0*)?|f(?:alse)?|no?)$/) ? 0 : $default ? 1 : 0;
    50          
641              
642             $methods{$name} = sub
643             {
644 0     0   0 my $self = shift;
645              
646 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
647 0   0     0 my $driver = $db->driver || 'unknown';
648              
649 0 0       0 if(@_)
650             {
651 61     61   2490 no warnings 'uninitialized';
  61         186  
  61         38236  
652 0         0 my $value = $_[0];
653              
654 0 0       0 if($self->{STATE_LOADING()})
655             {
656 0         0 $self->{$key} = undef;
657 0         0 return $self->{$formatted_key,$driver} = $value;
658             }
659             else
660             {
661 0 0       0 if($value =~ /^(?:1(?:\.0*)?|t(?:rue)?|y(?:es)?)$/i)
    0          
    0          
662             {
663 0         0 $self->{$formatted_key,$driver} = undef;
664 0         0 $self->{$mod_columns_key}{$column_name} = 1;
665 0         0 return $self->{$key} = 1;
666             }
667             elsif($value =~ /^(?:0(?:\.0*)?|f(?:alse)?|no?)$/i)
668             {
669 0         0 $self->{$formatted_key,$driver} = undef;
670 0         0 $self->{$mod_columns_key}{$column_name} = 1;
671 0         0 return $self->{$key} = 0;
672             }
673             elsif($value)
674             {
675 0         0 my $value = $db->parse_boolean($value);
676 0 0       0 Carp::croak($db->error) unless(defined $value);
677 0         0 $self->{$formatted_key,$driver} = undef;
678 0         0 $self->{$mod_columns_key}{$column_name} = 1;
679 0         0 return $self->{$key} = $value;
680             }
681             else
682             {
683 0         0 $self->{$formatted_key,$driver} = undef;
684 0         0 $self->{$mod_columns_key}{$column_name} = 1;
685 0 0       0 return $self->{$key} = defined($value) ? 0 : undef;
686             }
687             }
688             }
689              
690             # Pull default through if necessary
691 0 0 0     0 unless(defined $self->{$key} || defined $self->{$formatted_key,$driver} ||
      0        
      0        
      0        
692             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
693             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
694             {
695 0         0 $self->{$mod_columns_key}{$column_name} = 1;
696 0         0 $self->{$key} = $default;
697             }
698              
699 0 0       0 if($self->{STATE_SAVING()})
700             {
701             $self->{$formatted_key,$driver} = $db->format_boolean($self->{$key})
702 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
703              
704 0         0 return $self->{$formatted_key,$driver};
705             }
706              
707 0 0 0     0 if(!defined $self->{$key} && defined $self->{$formatted_key,$driver})
708             {
709 0         0 return $self->{$key} = $db->parse_boolean($self->{$formatted_key,$driver});
710             }
711              
712 0 0 0     0 if(defined $self->{$key} || ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
      0        
      0        
713             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
714             {
715 0         0 return $self->{$key};
716             }
717             else
718             {
719 0         0 return $self->{$key} = $default;
720             }
721             }
722 3         22 }
723             else
724             {
725             $methods{$name} = sub
726             {
727 0     0   0 my $self = shift;
728              
729 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
730 0   0     0 my $driver = $db->driver || 'unknown';
731              
732 0 0       0 if(@_)
733             {
734 61     61   636 no warnings 'uninitialized';
  61         176  
  61         1162327  
735 0         0 my $value = $_[0];
736              
737 0 0       0 if($self->{STATE_LOADING()})
738             {
739 0         0 $self->{$key} = undef;
740 0         0 return $self->{$formatted_key,$driver} = $value;
741             }
742             else
743             {
744 0 0       0 if($value =~ /^(?:1(?:\.0*)?|t(?:rue)?|y(?:es)?)$/i)
    0          
    0          
745             {
746 0         0 $self->{$formatted_key,$driver} = undef;
747 0         0 $self->{$mod_columns_key}{$column_name} = 1;
748 0         0 return $self->{$key} = 1;
749             }
750             elsif($value =~ /^(?:0(?:\.0*)?|f(?:alse)?|no?)$/i)
751             {
752 0         0 $self->{$formatted_key,$driver} = undef;
753 0         0 $self->{$mod_columns_key}{$column_name} = 1;
754 0         0 return $self->{$key} = 0;
755             }
756             elsif($value)
757             {
758 0         0 my $value = $db->parse_boolean($value);
759 0 0       0 Carp::croak($db->error) unless(defined $value);
760 0         0 $self->{$formatted_key,$driver} = undef;
761 0         0 $self->{$mod_columns_key}{$column_name} = 1;
762 0         0 return $self->{$key} = $value;
763             }
764             else
765             {
766 0         0 $self->{$formatted_key,$driver} = undef;
767 0         0 $self->{$mod_columns_key}{$column_name} = 1;
768 0 0       0 return $self->{$key} = defined($value) ? 0 : undef;
769             }
770             }
771              
772 0         0 $self->{$formatted_key,$driver} = undef;
773 0         0 $self->{$mod_columns_key}{$column_name} = 1;
774 0 0       0 return $self->{$key} = defined $_[0] ? 0 : undef;
775             }
776              
777 0 0       0 if($self->{STATE_SAVING()})
778             {
779             $self->{$formatted_key,$driver} = $db->format_boolean($self->{$key})
780 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
781              
782 0         0 return $self->{$formatted_key,$driver};
783             }
784              
785 0 0 0     0 if(!defined $self->{$key} && defined $self->{$formatted_key,$driver})
786             {
787 0         0 return $self->{$key} = $db->parse_boolean($self->{$formatted_key,$driver});
788             }
789              
790 0         0 return $self->{$key};
791             }
792 5         36 }
793             }
794             elsif($interface eq 'get')
795             {
796 1         4 my $default = $args->{'default'};
797              
798 1 50       12 if(defined $default)
799             {
800 0 0       0 $default = ($default =~ /^(?:0(?:\.0*)?|f(?:alse)?|no?)$/) ? 0 : $default ? 1 : 0;
    0          
801              
802             $methods{$name} = sub
803             {
804 0     0   0 my $self = shift;
805              
806 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
807 0   0     0 my $driver = $db->driver || 'unknown';
808              
809             # Pull default through if necessary
810 0 0 0     0 unless(defined $self->{$key} || defined $self->{$formatted_key,$driver} ||
      0        
      0        
      0        
811             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
812             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
813             {
814 0         0 $self->{$mod_columns_key}{$column_name} = 1;
815 0         0 $self->{$key} = $default;
816             }
817              
818 0 0       0 if($self->{STATE_SAVING()})
819             {
820             $self->{$formatted_key,$driver} = $db->format_boolean($self->{$key})
821 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
822              
823 0         0 return $self->{$formatted_key,$driver};
824             }
825              
826 0 0 0     0 if(!defined $self->{$key} && defined $self->{$formatted_key,$driver})
827             {
828 0         0 return $self->{$key} = $db->parse_boolean($self->{$formatted_key,$driver});
829             }
830              
831 0 0 0     0 if(defined $self->{$key} || ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
      0        
      0        
832             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
833             {
834 0         0 return $self->{$key};
835             }
836             else
837             {
838 0         0 return $self->{$key} = $default;
839             }
840             }
841 0         0 }
842             else
843             {
844             $methods{$name} = sub
845             {
846 0     0   0 my $self = shift;
847              
848 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
849 0   0     0 my $driver = $db->driver || 'unknown';
850              
851 0 0       0 if($self->{STATE_SAVING()})
852             {
853             $self->{$formatted_key,$driver} = $db->format_boolean($self->{$key})
854 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
855              
856 0         0 return $self->{$formatted_key,$driver};
857             }
858              
859 0 0 0     0 if(!defined $self->{$key} && defined $self->{$formatted_key,$driver})
860             {
861 0         0 return $self->{$key} = $db->parse_boolean($self->{$formatted_key,$driver});
862             }
863              
864 0         0 return $self->{$key};
865             }
866 1         9 }
867             }
868             elsif($interface eq 'set')
869             {
870             $methods{$name} = sub
871             {
872 0     0   0 my $self = shift;
873              
874 0 0       0 Carp::croak "Missing argument in call to $name" unless(@_);
875 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
876 0   0     0 my $driver = $db->driver || 'unknown';
877              
878 0         0 my $value = shift;
879              
880 0 0       0 if($self->{STATE_LOADING()})
881             {
882 0         0 $self->{$key} = undef;
883 0         0 return $self->{$formatted_key,$driver} = $value;
884             }
885             else
886             {
887 0 0       0 if($value =~ /^(?:1(?:\.0*)?|t(?:rue)?|y(?:es)?)$/i)
    0          
    0          
888             {
889 0         0 $self->{$formatted_key,$driver} = undef;
890 0         0 $self->{$mod_columns_key}{$column_name} = 1;
891 0         0 return $self->{$key} = 1;
892             }
893             elsif($value =~ /^(?:0(?:\.0*)?|f(?:alse)?|no?)$/i)
894             {
895 0         0 $self->{$formatted_key,$driver} = undef;
896 0         0 $self->{$mod_columns_key}{$column_name} = 1;
897 0         0 return $self->{$key} = 0;
898             }
899             elsif($value)
900             {
901 0         0 my $value = $db->parse_boolean($value);
902 0 0       0 Carp::croak($db->error) unless(defined $value);
903 0         0 $self->{$formatted_key,$driver} = undef;
904 0         0 $self->{$mod_columns_key}{$column_name} = 1;
905 0         0 return $self->{$key} = $value;
906             }
907             else
908             {
909 0         0 $self->{$formatted_key,$driver} = undef;
910 0         0 $self->{$mod_columns_key}{$column_name} = 1;
911 0 0       0 return $self->{$key} = defined($value) ? 0 : undef;
912             }
913             }
914             }
915 1         5 }
916 0         0 else { Carp::croak "Unknown interface: $interface" }
917              
918 10         31 return \%methods;
919             }
920              
921             sub bitfield
922             {
923 8     8 1 325 my($class, $name, $args) = @_;
924              
925 8   66     32 my $key = $args->{'hash_key'} || $name;
926 8   100     22 my $interface = $args->{'interface'} || 'get_set';
927              
928 8 100       22 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
929              
930 8   50     35 my $undef_overrides_default = $args->{'undef_overrides_default'} || 0;
931              
932 8 100       17 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
933             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
934              
935 8         35 my %methods;
936              
937 8 100       28 if($interface eq 'get_set')
    100          
    50          
938             {
939 6   100     23 my $size = $args->{'bits'} ||= 32;
940              
941 6         11 my $default = $args->{'default'};
942 6         17 my $formatted_key = column_value_formatted_key($key);
943              
944 6 100       27 if(defined $default)
945             {
946             $methods{$name} = sub
947             {
948 0     0   0 my $self = shift;
949              
950 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
951 0   0     0 my $driver = $db->driver || 'unknown';
952              
953 0 0       0 if(@_)
954             {
955 0 0       0 if($self->{STATE_LOADING()})
956             {
957 0         0 $self->{$key} = undef;
958 0         0 $self->{$formatted_key,$driver} = $_[0];
959             }
960             else
961             {
962 0         0 $self->{$key} = $db->parse_bitfield($_[0], $size);
963              
964 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
965             {
966 0         0 $self->{$formatted_key,$driver} = undef;
967 0         0 $self->{$mod_columns_key}{$column_name} = 1;
968             }
969             else
970             {
971 0         0 Carp::croak $self->error($db->error);
972             }
973             }
974             }
975              
976 0 0       0 return unless(defined wantarray);
977              
978             # Pull default through if necessary
979 0 0 0     0 unless(defined $self->{$key} || defined $self->{$formatted_key,$driver} ||
      0        
      0        
      0        
980             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
981             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
982             {
983 0         0 $self->{$key} = $db->parse_bitfield($default, $size);
984              
985 0 0 0     0 if(!defined $default || defined $self->{$key})
986             {
987 0         0 $self->{$mod_columns_key}{$column_name} = 1;
988             }
989             else
990             {
991 0         0 Carp::croak $self->error($db->error);
992             }
993             }
994              
995 0 0       0 if($self->{STATE_SAVING()})
996             {
997             $self->{$formatted_key,$driver} = $db->format_bitfield($self->{$key}, $size)
998 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
999              
1000 0         0 return $self->{$formatted_key,$driver};
1001             }
1002              
1003 0 0       0 if(defined $self->{$key})
1004             {
1005 0         0 $self->{$formatted_key,$driver} = undef;
1006 0         0 return $self->{$key};
1007             }
1008              
1009 0 0       0 if(defined $self->{$formatted_key,$driver})
1010             {
1011 0         0 $self->{$key} = $db->parse_bitfield($self->{$formatted_key,$driver}, $size, 1);
1012 0         0 $self->{$formatted_key,$driver} = undef;
1013 0         0 return $self->{$key};
1014             }
1015              
1016 0         0 return undef;
1017 2         31 };
1018             }
1019             else
1020             {
1021             $methods{$name} = sub
1022             {
1023 0     0   0 my $self = shift;
1024              
1025 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1026 0   0     0 my $driver = $db->driver || 'unknown';
1027              
1028 0 0       0 if(@_)
1029             {
1030 0 0       0 if($self->{STATE_LOADING()})
1031             {
1032 0         0 $self->{$key} = undef;
1033 0         0 $self->{$formatted_key,$driver} = $_[0];
1034             }
1035             else
1036             {
1037 0         0 $self->{$key} = $db->parse_bitfield($_[0], $size);
1038              
1039 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1040             {
1041 0         0 $self->{$formatted_key,$driver} = undef;
1042 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1043             }
1044             else
1045             {
1046 0         0 Carp::croak $self->error($db->error);
1047             }
1048             }
1049             }
1050              
1051 0 0       0 if($self->{STATE_SAVING()})
1052             {
1053 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1054              
1055             $self->{$formatted_key,$driver} = $db->format_bitfield($self->{$key}, $size)
1056 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1057              
1058 0         0 return $self->{$formatted_key,$driver};
1059             }
1060              
1061 0 0       0 return unless(defined wantarray);
1062              
1063 0 0       0 if(defined $self->{$key})
1064             {
1065 0         0 $self->{$formatted_key,$driver} = undef;
1066 0         0 return $self->{$key};
1067             }
1068              
1069 0 0       0 if(defined $self->{$formatted_key,$driver})
1070             {
1071 0         0 $self->{$key} = $db->parse_bitfield($self->{$formatted_key,$driver}, $size, 1);
1072 0         0 $self->{$formatted_key,$driver} = undef;
1073 0         0 return $self->{$key};
1074             }
1075              
1076 0         0 return undef;
1077 4         32 };
1078              
1079 4 100       15 if($args->{'with_intersects'})
1080             {
1081 1   33     6 my $method = $args->{'intersects'} || $name . '_intersects';
1082              
1083             $methods{$method} = sub
1084             {
1085 0     0   0 my($self, $vec) = @_;
1086              
1087 0 0       0 my $val = $self->{$key} or return undef;
1088              
1089 0 0       0 unless(ref $vec)
1090             {
1091 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1092 0         0 $vec = $db->parse_bitfield($vec, $size);
1093 0 0       0 Carp::croak $self->error($db->error) unless(defined $vec);
1094             }
1095              
1096 0 0       0 $vec = Bit::Vector->new_Bin($size, $vec->to_Bin) if($vec->Size != $size);
1097              
1098 0         0 my $test = Bit::Vector->new($size);
1099 0         0 $test->Intersection($val, $vec);
1100 0 0       0 return ($test->to_Bin > 0) ? 1 : 0;
1101 1         6 };
1102             }
1103             }
1104             }
1105             elsif($interface eq 'get')
1106             {
1107 1   50     18 my $size = $args->{'bits'} ||= 32;
1108              
1109 1         3 my $default = $args->{'default'};
1110 1         3 my $formatted_key = column_value_formatted_key($key);
1111              
1112 1 50       4 if(defined $default)
1113             {
1114             $methods{$name} = sub
1115             {
1116 0     0   0 my $self = shift;
1117              
1118 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1119 0   0     0 my $driver = $db->driver || 'unknown';
1120              
1121 0 0 0     0 unless(defined $self->{$key} || defined $self->{$formatted_key,$driver} ||
      0        
      0        
      0        
1122             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
1123             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
1124             {
1125 0         0 $self->{$key} = $db->parse_bitfield($default, $size);
1126              
1127 0 0 0     0 if(!defined $default || defined $self->{$key})
1128             {
1129 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1130             }
1131             else
1132             {
1133 0         0 Carp::croak $self->error($db->error);
1134             }
1135             }
1136              
1137 0 0       0 if($self->{STATE_SAVING()})
1138             {
1139             $self->{$formatted_key,$driver} = $db->format_bitfield($self->{$key}, $size)
1140 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1141              
1142 0         0 return $self->{$formatted_key,$driver};
1143             }
1144              
1145 0 0       0 return unless(defined wantarray);
1146              
1147 0 0       0 if(defined $self->{$key})
1148             {
1149 0         0 $self->{$formatted_key,$driver} = undef;
1150 0         0 return $self->{$key};
1151             }
1152              
1153 0 0       0 if(defined $self->{$formatted_key,$driver})
1154             {
1155 0         0 $self->{$key} = $db->parse_bitfield($self->{$formatted_key,$driver}, $size, 1);
1156 0         0 $self->{$formatted_key,$driver} = undef;
1157 0         0 return $self->{$key};
1158             }
1159              
1160 0         0 return undef;
1161 0         0 };
1162             }
1163             else
1164             {
1165             $methods{$name} = sub
1166             {
1167 0     0   0 my $self = shift;
1168              
1169 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1170 0   0     0 my $driver = $db->driver || 'unknown';
1171              
1172 0 0       0 if($self->{STATE_SAVING()})
1173             {
1174 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1175              
1176             $self->{$formatted_key,$driver} = $db->format_bitfield($self->{$key}, $size)
1177 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1178              
1179 0         0 return $self->{$formatted_key,$driver};
1180             }
1181              
1182 0 0       0 return unless(defined wantarray);
1183              
1184 0 0       0 if(defined $self->{$key})
1185             {
1186 0         0 $self->{$formatted_key,$driver} = undef;
1187 0         0 return $self->{$key};
1188             }
1189              
1190 0 0       0 if(defined $self->{$formatted_key,$driver})
1191             {
1192 0         0 $self->{$key} = $db->parse_bitfield($self->{$formatted_key,$driver}, $size, 1);
1193 0         0 $self->{$formatted_key,$driver} = undef;
1194 0         0 return $self->{$key};
1195             }
1196              
1197 0         0 return undef;
1198 1         7 };
1199             }
1200             }
1201             elsif($interface eq 'set')
1202             {
1203 1   50     4 my $size = $args->{'bits'} ||= 32;
1204              
1205 1         5 my $formatted_key = column_value_formatted_key($key);
1206              
1207             $methods{$name} = sub
1208             {
1209 0     0   0 my $self = shift;
1210              
1211 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1212 0   0     0 my $driver = $db->driver || 'unknown';
1213              
1214 0 0       0 Carp::croak "Missing argument in call to $name" unless(@_);
1215              
1216 0 0       0 if($self->{STATE_LOADING()})
1217             {
1218 0         0 $self->{$key} = undef;
1219 0         0 $self->{$formatted_key,$driver} = $_[0];
1220             }
1221             else
1222             {
1223 0         0 $self->{$key} = $db->parse_bitfield($_[0], $size);
1224              
1225 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1226             {
1227 0         0 $self->{$formatted_key,$driver} = undef;
1228 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1229             }
1230             else
1231             {
1232 0         0 Carp::croak $self->error($db->error);
1233             }
1234             }
1235              
1236 0 0       0 if($self->{STATE_SAVING()})
1237             {
1238 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1239              
1240             $self->{$formatted_key,$driver} = $db->format_bitfield($self->{$key}, $size)
1241 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1242              
1243 0         0 return $self->{$formatted_key,$driver};
1244             }
1245              
1246 0 0       0 if(defined $self->{$key})
1247             {
1248 0         0 $self->{$formatted_key,$driver} = undef;
1249 0         0 return $self->{$key};
1250             }
1251              
1252 0 0       0 if(defined $self->{$formatted_key,$driver})
1253             {
1254 0         0 $self->{$key} = $db->parse_bitfield($self->{$formatted_key,$driver}, $size, 1);
1255 0         0 $self->{$formatted_key,$driver} = undef;
1256 0         0 return $self->{$key};
1257             }
1258              
1259 0         0 return undef;
1260 1         5 };
1261             }
1262 0         0 else { Carp::croak "Unknown interface: $interface" }
1263              
1264 8         26 return \%methods;
1265             }
1266              
1267             sub array
1268             {
1269 5     5 1 184 my($class, $name, $args) = @_;
1270              
1271 5   66     34 my $key = $args->{'hash_key'} || $name;
1272 5   100     32 my $interface = $args->{'interface'} || 'get_set';
1273              
1274 5 100       15 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
1275              
1276 5         15 my $formatted_key = column_value_formatted_key($key);
1277              
1278 5   50     34 my $undef_overrides_default = $args->{'undef_overrides_default'} || 0;
1279              
1280 5 100       10 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
1281             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
1282              
1283 5         18 my %methods;
1284              
1285 5 100       19 if($interface eq 'get_set')
    100          
    50          
1286             {
1287 3         8 my $default = $args->{'default'};
1288              
1289 3 50       7 if(defined $default)
1290             {
1291             $methods{$name} = sub
1292             {
1293 0     0   0 my $self = shift;
1294              
1295 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1296 0   0     0 my $driver = $db->driver || 'unknown';
1297              
1298 0 0       0 if(@_)
    0          
1299             {
1300 0 0       0 if($self->{STATE_LOADING()})
1301             {
1302 0 0       0 if(ref $_[0] eq 'ARRAY')
1303             {
1304 0         0 $self->{$key} = $_[0];
1305 0         0 $self->{$formatted_key,$driver} = undef;
1306             }
1307             else
1308             {
1309 0         0 $self->{$key} = undef;
1310 0         0 $self->{$formatted_key,$driver} = $_[0];
1311             }
1312             }
1313             else
1314             {
1315 0         0 $self->{$key} = $db->parse_array(@_);
1316              
1317 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1318             {
1319 0         0 $self->{$formatted_key,$driver} = undef;
1320 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1321             }
1322             else
1323             {
1324 0         0 Carp::croak $self->error($db->error);
1325             }
1326             }
1327             }
1328             elsif(!defined $self->{$key})
1329             {
1330 0 0 0     0 unless(!defined $self->{$formatted_key,$driver} &&
      0        
      0        
1331             $undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
1332             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name}))))
1333             {
1334             $self->{$key} = $db->parse_array(defined $self->{$formatted_key,$driver} ?
1335 0 0       0 $self->{$formatted_key,$driver} : $default);
1336              
1337 0 0 0     0 if(!defined $default || defined $self->{$key})
1338             {
1339 0         0 $self->{$formatted_key,$driver} = undef;
1340 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1341             }
1342             else
1343             {
1344 0         0 Carp::croak $self->error($db->error);
1345             }
1346             }
1347             }
1348              
1349 0 0       0 return unless(defined wantarray);
1350              
1351             # Pull default through if necessary
1352 0 0 0     0 unless(defined $self->{$key} || defined $self->{$formatted_key,$driver} ||
      0        
      0        
      0        
1353             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
1354             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
1355             {
1356 0         0 $self->{$key} = $db->parse_array($default);
1357              
1358 0 0 0     0 if(!defined $default || defined $self->{$key})
1359             {
1360 0         0 $self->{$formatted_key,$driver} = undef;
1361 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1362             }
1363             else
1364             {
1365 0         0 Carp::croak $self->error($db->error);
1366             }
1367             }
1368              
1369 0 0       0 if($self->{STATE_SAVING()})
1370             {
1371             $self->{$formatted_key,$driver} = $db->format_array($self->{$key})
1372 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1373              
1374 0         0 return $self->{$formatted_key,$driver};
1375             }
1376              
1377 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1378             }
1379 0         0 }
1380             else
1381             {
1382             $methods{$name} = sub
1383             {
1384 0     0   0 my $self = shift;
1385              
1386 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1387 0   0     0 my $driver = $db->driver || 'unknown';
1388              
1389 0 0       0 if(@_)
1390             {
1391 0 0       0 if($self->{STATE_LOADING()})
1392             {
1393 0 0       0 if(ref $_[0] eq 'ARRAY')
1394             {
1395 0         0 $self->{$key} = $_[0];
1396 0         0 $self->{$formatted_key,$driver} = undef;
1397             }
1398             else
1399             {
1400 0         0 $self->{$key} = undef;
1401 0         0 $self->{$formatted_key,$driver} = $_[0];
1402             }
1403             }
1404             else
1405             {
1406 0         0 $self->{$key} = $db->parse_array(@_);
1407              
1408 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1409             {
1410 0         0 $self->{$formatted_key,$driver} = undef;
1411 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1412             }
1413             else
1414             {
1415 0         0 Carp::croak $self->error($db->error);
1416             }
1417             }
1418             }
1419              
1420 0 0       0 if($self->{STATE_SAVING()})
1421             {
1422 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1423              
1424             $self->{$formatted_key,$driver} = $db->format_array($self->{$key})
1425 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1426              
1427 0         0 return $self->{$formatted_key,$driver};
1428             }
1429              
1430 0 0       0 return unless(defined wantarray);
1431              
1432 0 0       0 if(defined $self->{$key})
1433             {
1434 0         0 $self->{$formatted_key,$driver} = undef;
1435 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1436             }
1437              
1438 0 0       0 if(defined $self->{$formatted_key,$driver})
1439             {
1440 0         0 $self->{$key} = $db->parse_array($self->{$formatted_key,$driver});
1441 0         0 $self->{$formatted_key,$driver} = undef;
1442              
1443 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1444             }
1445              
1446 0         0 return undef;
1447             }
1448 3         50 }
1449             }
1450             elsif($interface eq 'get')
1451             {
1452 1         2 my $default = $args->{'default'};
1453              
1454 1 50       4 if(defined $default)
1455             {
1456             $methods{$name} = sub
1457             {
1458 0     0   0 my $self = shift;
1459              
1460 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1461 0   0     0 my $driver = $db->driver || 'unknown';
1462              
1463 0 0 0     0 if(!defined $self->{$key} && (!$self->{STATE_SAVING()} || !defined $self->{$formatted_key,$driver}))
      0        
1464             {
1465 0 0 0     0 unless(!defined $default || ($undef_overrides_default &&
      0        
      0        
1466             ($self->{$mod_columns_key}{$column_name} || ($self->{STATE_IN_DB()} &&
1467             !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
1468             {
1469 0         0 $self->{$key} = $db->parse_array($default);
1470              
1471 0 0 0     0 if(!defined $default || defined $self->{$key})
1472             {
1473 0         0 $self->{$formatted_key,$driver} = undef;
1474 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1475             }
1476             else
1477             {
1478 0         0 Carp::croak $self->error($db->error);
1479             }
1480             }
1481             }
1482              
1483 0 0       0 if($self->{STATE_SAVING()})
1484             {
1485             $self->{$formatted_key,$driver} = $db->format_array($self->{$key})
1486 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1487              
1488 0         0 return $self->{$formatted_key,$driver};
1489             }
1490              
1491 0 0       0 return unless(defined wantarray);
1492              
1493 0 0       0 if(defined $self->{$key})
1494             {
1495 0         0 $self->{$formatted_key,$driver} = undef;
1496 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1497             }
1498              
1499 0 0       0 if(defined $self->{$formatted_key,$driver})
1500             {
1501 0         0 $self->{$key} = $db->parse_array($self->{$formatted_key,$driver});
1502 0         0 $self->{$formatted_key,$driver} = undef;
1503              
1504 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1505             }
1506              
1507 0         0 return undef;
1508             }
1509 0         0 }
1510             else
1511             {
1512             $methods{$name} = sub
1513             {
1514 0     0   0 my $self = shift;
1515              
1516 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1517 0   0     0 my $driver = $db->driver || 'unknown';
1518              
1519 0 0       0 if($self->{STATE_SAVING()})
1520             {
1521 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1522              
1523             $self->{$formatted_key,$driver} = $db->format_array($self->{$key})
1524 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1525              
1526 0         0 return $self->{$formatted_key,$driver};
1527             }
1528              
1529 0 0       0 return unless(defined wantarray);
1530              
1531 0 0       0 if(defined $self->{$key})
1532             {
1533 0         0 $self->{$formatted_key,$driver} = undef;
1534 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1535             }
1536              
1537 0 0       0 if(defined $self->{$formatted_key,$driver})
1538             {
1539 0         0 $self->{$key} = $db->parse_array($self->{$formatted_key,$driver});
1540 0         0 $self->{$formatted_key,$driver} = undef;
1541              
1542 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1543             }
1544              
1545 0         0 return undef;
1546             }
1547 1         5 }
1548             }
1549             elsif($interface eq 'set')
1550             {
1551             $methods{$name} = sub
1552             {
1553 0     0   0 my $self = shift;
1554              
1555 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1556 0   0     0 my $driver = $db->driver || 'unknown';
1557              
1558 0 0       0 Carp::croak "Missing argument in call to $name" unless(@_);
1559              
1560 0 0       0 if($self->{STATE_LOADING()})
1561             {
1562 0 0       0 if(ref $_[0] eq 'ARRAY')
1563             {
1564 0         0 $self->{$key} = $_[0];
1565 0         0 $self->{$formatted_key,$driver} = undef;
1566             }
1567             else
1568             {
1569 0         0 $self->{$key} = undef;
1570 0         0 $self->{$formatted_key,$driver} = $_[0];
1571             }
1572             }
1573             else
1574             {
1575 0         0 $self->{$key} = $db->parse_array($_[0]);
1576              
1577 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1578             {
1579 0         0 $self->{$formatted_key,$driver} = undef;
1580 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1581             }
1582             else
1583             {
1584 0         0 Carp::croak $self->error($db->error);
1585             }
1586             }
1587              
1588 0 0       0 if($self->{STATE_SAVING()})
1589             {
1590 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1591              
1592             $self->{$formatted_key,$driver} = $db->format_array($self->{$key})
1593 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1594              
1595 0         0 return $self->{$formatted_key,$driver};
1596             }
1597              
1598 0 0       0 if(defined $self->{$key})
1599             {
1600 0         0 $self->{$formatted_key,$driver} = undef;
1601 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1602             }
1603              
1604 0 0       0 if(defined $self->{$formatted_key,$driver})
1605             {
1606 0         0 $self->{$key} = $db->parse_array($self->{$formatted_key,$driver});
1607 0         0 $self->{$formatted_key,$driver} = undef;
1608              
1609 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1610             }
1611              
1612 0         0 return undef;
1613             }
1614 1         20 }
1615 0         0 else { Carp::croak "Unknown interface: $interface" }
1616              
1617 5         17 return \%methods;
1618             }
1619              
1620             sub set
1621             {
1622 3     3 1 82 my($class, $name, $args) = @_;
1623              
1624 3   66     19 my $key = $args->{'hash_key'} || $name;
1625 3   100     10 my $interface = $args->{'interface'} || 'get_set';
1626              
1627 3 50       7 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
1628 3   33     10 my $choices = $args->{'choices'} || $args->{'check_in'};
1629 3 50       6 my %choices = $choices ? (map { $_ => 1 } @$choices) : ();
  0         0  
1630              
1631 3         13 my $formatted_key = column_value_formatted_key($key);
1632              
1633 3   50     17 my $value_type = $args->{'value_type'} || 'scalar';
1634              
1635 3   50     8 my $undef_overrides_default = $args->{'undef_overrides_default'} || 0;
1636              
1637 3 50       14 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
1638             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
1639              
1640 3         4 my %methods;
1641              
1642 3 100       10 if($interface eq 'get_set')
    100          
    50          
1643             {
1644 1         2 my $default = $args->{'default'};
1645              
1646 1 50       3 if(defined $default)
1647             {
1648             $methods{$name} = sub
1649             {
1650 0     0   0 my $self = shift;
1651              
1652 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1653 0   0     0 my $driver = $db->driver || 'unknown';
1654              
1655 0 0       0 if(@_)
    0          
1656             {
1657 0 0       0 if($self->{STATE_LOADING()})
1658             {
1659 0         0 $self->{$key} = undef;
1660 0         0 $self->{$formatted_key,$driver} = $_[0];
1661             }
1662             else
1663             {
1664 0         0 my $set = $db->parse_set(@_, { value_type => $value_type });
1665              
1666 0 0       0 if($choices)
1667             {
1668 0         0 foreach my $val (@$set)
1669             {
1670             Carp::croak "Invalid value for set $key - '$val'"
1671 0 0       0 unless(exists $choices{$val});
1672             }
1673             }
1674              
1675 0         0 $self->{$key} = $set;
1676              
1677 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1678             {
1679 0         0 $self->{$formatted_key,$driver} = undef;
1680 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1681             }
1682             else
1683             {
1684 0         0 Carp::croak $self->error($db->error);
1685             }
1686             }
1687             }
1688             elsif(!defined $self->{$key})
1689             {
1690 0 0 0     0 unless(!defined $self->{$formatted_key,$driver} &&
      0        
      0        
1691             $undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
1692             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name}))))
1693             {
1694             my $set = $db->parse_set((defined $self->{$formatted_key,$driver} ?
1695 0 0       0 $self->{$formatted_key,$driver} : $default),
1696             { value_type => $value_type });
1697              
1698 0 0       0 if($choices)
1699             {
1700 0         0 foreach my $val (@$set)
1701             {
1702             Carp::croak "Invalid default value for set $key - '$val'"
1703 0 0       0 unless(exists $choices{$val});
1704             }
1705             }
1706              
1707 0         0 $self->{$key} = $set;
1708              
1709 0 0 0     0 if(!defined $default || defined $self->{$key})
1710             {
1711 0         0 $self->{$formatted_key,$driver} = undef;
1712             }
1713             else
1714             {
1715 0         0 Carp::croak $self->error($db->error);
1716             }
1717             }
1718             }
1719              
1720 0 0       0 return unless(defined wantarray);
1721              
1722             # Pull default through if necessary
1723 0 0 0     0 unless(defined $self->{$key} || defined $self->{$formatted_key,$driver} ||
      0        
      0        
      0        
1724             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
1725             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
1726             {
1727 0         0 $self->{$key} = $db->parse_set($default, { value_type => $value_type });
1728              
1729 0 0 0     0 if(!defined $default || defined $self->{$key})
1730             {
1731 0         0 $self->{$formatted_key,$driver} = undef;
1732 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1733             }
1734             else
1735             {
1736 0         0 Carp::croak $self->error($db->error);
1737             }
1738             }
1739              
1740 0 0       0 if($self->{STATE_SAVING()})
1741             {
1742             $self->{$formatted_key,$driver} = $db->format_set($self->{$key})
1743 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1744              
1745 0         0 return $self->{$formatted_key,$driver};
1746             }
1747              
1748 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1749             }
1750 0         0 }
1751             else
1752             {
1753             $methods{$name} = sub
1754             {
1755 0     0   0 my $self = shift;
1756              
1757 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1758 0   0     0 my $driver = $db->driver || 'unknown';
1759              
1760 0 0       0 if(@_)
1761             {
1762 0 0       0 if($self->{STATE_LOADING()})
1763             {
1764 0         0 $self->{$key} = undef;
1765 0         0 $self->{$formatted_key,$driver} = $_[0];
1766             }
1767             else
1768             {
1769 0         0 my $set = $db->parse_set(@_, { value_type => $value_type });
1770              
1771 0 0       0 if($choices)
1772             {
1773 0         0 foreach my $val (@$set)
1774             {
1775             Carp::croak "Invalid value for set $key - '$val'"
1776 0 0       0 unless(exists $choices{$val});
1777             }
1778             }
1779              
1780 0         0 $self->{$key} = $set;
1781              
1782 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1783             {
1784 0         0 $self->{$formatted_key,$driver} = undef;
1785 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1786             }
1787             else
1788             {
1789 0         0 Carp::croak $self->error($db->error);
1790             }
1791             }
1792             }
1793              
1794 0 0       0 if($self->{STATE_SAVING()})
1795             {
1796 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1797              
1798             $self->{$formatted_key,$driver} = $db->format_set($self->{$key})
1799 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1800              
1801 0         0 return $self->{$formatted_key,$driver};
1802             }
1803              
1804 0 0       0 return unless(defined wantarray);
1805              
1806 0 0       0 if(defined $self->{$key})
1807             {
1808 0         0 $self->{$formatted_key,$driver} = undef;
1809 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1810             }
1811              
1812 0 0       0 if(defined $self->{$formatted_key,$driver})
1813             {
1814 0         0 $self->{$key} = $db->parse_set($self->{$formatted_key,$driver}, { value_type => $value_type });
1815 0         0 $self->{$formatted_key,$driver} = undef;
1816              
1817 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1818             }
1819              
1820 0         0 return undef;
1821             }
1822 1         8 }
1823             }
1824             elsif($interface eq 'get')
1825             {
1826 1         5 my $default = $args->{'default'};
1827              
1828 1 50       2 if(defined $default)
1829             {
1830             $methods{$name} = sub
1831             {
1832 0     0   0 my $self = shift;
1833              
1834 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1835 0   0     0 my $driver = $db->driver || 'unknown';
1836              
1837 0 0 0     0 if(!defined $self->{$key} && (!$self->{STATE_SAVING()} || !defined $self->{$formatted_key,$driver}))
      0        
1838             {
1839 0 0 0     0 unless(!defined $default || ($undef_overrides_default &&
      0        
      0        
1840             ($self->{$mod_columns_key}{$column_name} || ($self->{STATE_IN_DB()} &&
1841             !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
1842             {
1843 0         0 my $set = $db->parse_set($default, { value_type => $value_type });
1844              
1845 0 0       0 if($choices)
1846             {
1847 0         0 foreach my $val (@$set)
1848             {
1849             Carp::croak "Invalid default value for set $key - '$val'"
1850 0 0       0 unless(exists $choices{$val});
1851             }
1852             }
1853              
1854 0         0 $self->{$key} = $set;
1855              
1856 0 0 0     0 if(!defined $default || defined $self->{$key})
1857             {
1858 0         0 $self->{$formatted_key,$driver} = undef;
1859 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1860             }
1861             else
1862             {
1863 0         0 Carp::croak $self->error($db->error);
1864             }
1865             }
1866             }
1867              
1868 0 0       0 if($self->{STATE_SAVING()})
1869             {
1870             $self->{$formatted_key,$driver} = $db->format_set($self->{$key})
1871 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1872              
1873 0         0 return $self->{$formatted_key,$driver};
1874             }
1875              
1876 0 0       0 return unless(defined wantarray);
1877              
1878 0 0       0 if(defined $self->{$key})
1879             {
1880 0         0 $self->{$formatted_key,$driver} = undef;
1881 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1882             }
1883              
1884 0 0       0 if(defined $self->{$formatted_key,$driver})
1885             {
1886 0         0 $self->{$key} = $db->parse_set($self->{$formatted_key,$driver}, { value_type => $value_type });
1887 0         0 $self->{$formatted_key,$driver} = undef;
1888              
1889 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1890             }
1891              
1892 0         0 return undef;
1893             }
1894 0         0 }
1895             else
1896             {
1897             $methods{$name} = sub
1898             {
1899 0     0   0 my $self = shift;
1900              
1901 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1902 0   0     0 my $driver = $db->driver || 'unknown';
1903              
1904 0 0       0 if($self->{STATE_SAVING()})
1905             {
1906 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1907              
1908             $self->{$formatted_key,$driver} = $db->format_set($self->{$key})
1909 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1910              
1911 0         0 return $self->{$formatted_key,$driver};
1912             }
1913              
1914 0 0       0 return unless(defined wantarray);
1915              
1916 0 0       0 if(defined $self->{$key})
1917             {
1918 0         0 $self->{$formatted_key,$driver} = undef;
1919 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1920             }
1921              
1922 0 0       0 if(defined $self->{$formatted_key,$driver})
1923             {
1924 0         0 $self->{$key} = $db->parse_set($self->{$formatted_key,$driver}, { value_type => $value_type });
1925 0         0 $self->{$formatted_key,$driver} = undef;
1926              
1927 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1928             }
1929              
1930 0         0 return undef;
1931             }
1932 1         15 }
1933             }
1934             elsif($interface eq 'set')
1935             {
1936             $methods{$name} = sub
1937             {
1938 0     0   0 my $self = shift;
1939              
1940 0 0       0 my $db = $self->db or die "Missing Rose::DB object attribute";
1941 0   0     0 my $driver = $db->driver || 'unknown';
1942              
1943 0 0       0 Carp::croak "Missing argument in call to $name" unless(@_);
1944              
1945 0 0       0 if($self->{STATE_LOADING()})
1946             {
1947 0         0 $self->{$key} = undef;
1948 0         0 $self->{$formatted_key,$driver} = $_[0];
1949             }
1950             else
1951             {
1952 0         0 my $set = $db->parse_set(@_, { value_type => $value_type });
1953              
1954 0 0       0 if($choices)
1955             {
1956 0         0 foreach my $val (@$set)
1957             {
1958             Carp::croak "Invalid value for set $key - '$val'"
1959 0 0       0 unless(exists $choices{$val});
1960             }
1961             }
1962              
1963 0         0 $self->{$key} = $set;
1964              
1965 0 0 0     0 if(!defined $_[0] || defined $self->{$key})
1966             {
1967 0         0 $self->{$formatted_key,$driver} = undef;
1968 0         0 $self->{$mod_columns_key}{$column_name} = 1;
1969             }
1970             else
1971             {
1972 0         0 Carp::croak $self->error($db->error);
1973             }
1974             }
1975              
1976 0 0       0 if($self->{STATE_SAVING()})
1977             {
1978 0 0 0     0 return undef unless(defined($self->{$formatted_key,$driver}) || defined($self->{$key}));
1979              
1980             $self->{$formatted_key,$driver} = $db->format_set($self->{$key})
1981 0 0 0     0 unless(defined $self->{$formatted_key,$driver} || !defined $self->{$key});
1982              
1983 0         0 return $self->{$formatted_key,$driver};
1984             }
1985              
1986 0 0       0 if(defined $self->{$key})
1987             {
1988 0         0 $self->{$formatted_key,$driver} = undef;
1989 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
1990             }
1991              
1992 0 0       0 if(defined $self->{$formatted_key,$driver})
1993             {
1994 0         0 $self->{$key} = $db->parse_set($self->{$formatted_key,$driver}, { value_type => $value_type });
1995 0         0 $self->{$formatted_key,$driver} = undef;
1996              
1997 0 0       0 return defined $self->{$key} ? wantarray ? @{$self->{$key}} : $self->{$key} : undef;
  0 0       0  
1998             }
1999              
2000 0         0 return undef;
2001             }
2002 1         8 }
2003 0         0 else { Carp::croak "Unknown interface: $interface" }
2004              
2005 3         9 return \%methods;
2006             }
2007              
2008             sub object_by_key
2009             {
2010 120     120 1 8777 my($class, $name, $args, $options) = @_;
2011              
2012             # Delegate to plural with coercion to single as indicated by args
2013 120 50 33     1285 if($args->{'manager_class'} || $args->{'manager_method'} ||
      33        
      33        
      33        
2014             $args->{'manager_args'} || $args->{'query_args'} ||
2015             $args->{'join_args'})
2016             {
2017 0         0 $args->{'single'} = 1;
2018 0         0 return $class->objects_by_key($name, $args, $options);
2019             }
2020              
2021 120         241 my %methods;
2022              
2023 120   33     321 my $key = $args->{'hash_key'} || $name;
2024 120   50     286 my $interface = $args->{'interface'} || 'get_set';
2025 120 50       294 my $target_class = $options->{'target_class'} or die "Missing target class";
2026             #my $query_args = $args->{'query_args'} || [];
2027              
2028 120   66     442 weaken(my $fk = $args->{'foreign_key'} || $args->{'relationship'});
2029 120 50       792 my $fk_class = $args->{'class'} or die "Missing foreign object class";
2030 120         460 weaken(my $fk_meta = $fk_class->meta);
2031 120         357 weaken(my $meta = $target_class->meta);
2032 120         192 my $fk_pk;
2033              
2034             my $required =
2035             exists $args->{'required'} ? $args->{'required'} :
2036 120 50       434 exists $args->{'referential_integrity'} ? $args->{'referential_integrity'} : 1;
    100          
2037              
2038 120 100 66     356 my $ref_integrity =
2039             ($fk && $fk->isa('Rose::DB::Object::Metadata::ForeignKey')) ? $fk->referential_integrity : 0;
2040              
2041 120 50 66     1487 if(exists $args->{'required'} && exists $args->{'referential_integrity'} &&
      33        
2042             (!$args->{'required'} != !$$args->{'referential_integrity'}))
2043             {
2044 0         0 Carp::croak "The required and referential_integrity parameters conflict. ",
2045             "Please pass one or the other, not both.";
2046             }
2047              
2048 120 50       316 my $fk_columns = $args->{'key_columns'} or die "Missing key columns hash";
2049 120         213 my $share_db = $args->{'share_db'};
2050              
2051             # Delegate to plural with coercion to single as indicated by column map
2052 120         200 my(%unique, $key_ok);
2053              
2054 120         386 foreach my $uk_cols (scalar($fk_meta->primary_key_column_names),
2055             $fk_meta->unique_keys_column_names)
2056             {
2057 120         464 $unique{join($;, sort @$uk_cols)} = 1;
2058             }
2059              
2060 120         418 my @f_columns = sort values %$fk_columns;
2061              
2062 120         345 for my $i (0 .. $#f_columns)
2063             {
2064 120 50       467 if($unique{join($;, @f_columns[0 .. $i])})
2065             {
2066 120         227 $key_ok = 1;
2067 120         207 last;
2068             }
2069             }
2070              
2071 120 50       295 unless($key_ok)
2072             {
2073 0         0 $args->{'single'} = 1;
2074 0   0     0 $args->{'relationship'} ||= $fk;
2075 0         0 return $class->objects_by_key($name, $args, $options);
2076             }
2077              
2078 120 50       488 if($interface eq 'get_set')
    50          
    100          
    50          
    50          
2079             {
2080             $methods{$name} = sub
2081             {
2082 0     0   0 my($self) = shift;
2083              
2084 0 0       0 if(@_)
2085             {
2086             # If loading, just assign
2087 0 0       0 if($self->{STATE_LOADING()})
2088             {
2089 0         0 return $self->{$key} = $_[0];
2090             }
2091              
2092 0 0       0 unless(defined $_[0]) # undef argument
2093             {
2094 0 0 0     0 if($ref_integrity || $required)
2095             {
2096 0         0 local $fk->{'disable_column_triggers'} = 1;
2097              
2098             # Set the foreign key columns
2099 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2100             {
2101 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2102 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2103 0         0 $self->$local_method(undef);
2104             }
2105             }
2106              
2107 0         0 return $self->{$key} = undef;
2108             }
2109              
2110 0         0 my $object = __args_to_object($self, $key, $fk_class, \$fk_pk, \@_);
2111              
2112 0         0 local $fk->{'disable_column_triggers'} = 1;
2113              
2114 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2115             {
2116 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2117 0         0 my $foreign_method = $fk_meta->column_accessor_method_name($foreign_column);
2118              
2119 0         0 $self->$local_method($object->$foreign_method);
2120             }
2121              
2122 0         0 return $self->{$key} = $object;
2123             }
2124              
2125 0 0       0 return $self->{$key} if(defined $self->{$key});
2126              
2127 0         0 my %key;
2128              
2129 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2130             {
2131 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2132 0         0 my $foreign_method = $fk_meta->column_mutator_method_name($foreign_column);
2133              
2134 0         0 $key{$foreign_method} = $self->$local_method();
2135              
2136             # XXX: Comment this out to allow null keys
2137 0 0       0 unless(defined $key{$foreign_method})
2138             {
2139 0         0 keys(%$fk_columns); # reset iterator
2140 0         0 $self->error("Could not load $name object - the " .
2141             "$local_method attribute is undefined");
2142 0         0 return undef;
2143             }
2144             }
2145              
2146 0         0 my $obj;
2147              
2148 0 0       0 if($share_db)
2149             {
2150 0         0 $obj = $fk_class->new(%key, db => $self->db);
2151             }
2152             else
2153             {
2154 0         0 $obj = $fk_class->new(%key);
2155             }
2156              
2157 0         0 my $ret;
2158              
2159 0 0       0 if($required)
2160             {
2161 0         0 my $error;
2162              
2163             TRY:
2164             {
2165 0         0 local $@;
  0         0  
2166 0         0 eval { $ret = $obj->load };
  0         0  
2167 0         0 $error = $@;
2168             }
2169              
2170 0 0 0     0 if($error || !$ret)
2171             {
2172 0   0     0 my $msg = $obj->error || $error;
2173              
2174             $self->error(ref $msg ? $msg :
2175             ("Could not load $fk_class object with key " .
2176 0 0       0 join(', ', map { "$_ = '$key{$_}'" } sort keys %key) .
  0         0  
2177             " - $msg"));
2178 0         0 $self->meta->handle_error($self);
2179 0         0 return $ret;
2180             }
2181             }
2182             else
2183             {
2184 0 0       0 return undef unless($obj->load(speculative => 1));
2185             }
2186              
2187 0         0 return $self->{$key} = $obj;
2188 0         0 };
2189             }
2190             elsif($interface eq 'get_set_now')
2191             {
2192             $methods{$name} = sub
2193             {
2194 0     0   0 my($self) = shift;
2195              
2196 0 0       0 if(@_)
2197             {
2198             # If loading, just assign
2199 0 0       0 if($self->{STATE_LOADING()})
2200             {
2201 0         0 return $self->{$key} = $_[0];
2202             }
2203              
2204             # Can't add until the object is saved
2205 0 0       0 unless($self->{STATE_IN_DB()})
2206             {
2207 0         0 Carp::croak "Can't $name() until this object is loaded or saved";
2208             }
2209              
2210 0 0       0 unless(defined $_[0]) # undef argument
2211             {
2212 0 0 0     0 if($ref_integrity || $required)
2213             {
2214 0         0 local $fk->{'disable_column_triggers'} = 1;
2215              
2216             # Set the foreign key columns
2217 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2218             {
2219 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2220 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2221 0         0 $self->$local_method(undef);
2222             }
2223             }
2224              
2225 0         0 return $self->{$key} = undef;
2226             }
2227              
2228 0         0 my $object = __args_to_object($self, $key, $fk_class, \$fk_pk, \@_);
2229              
2230 0         0 my($db, $started_new_tx, $error);
2231              
2232             TRY:
2233             {
2234 0         0 local $@;
  0         0  
2235              
2236             eval
2237 0         0 {
2238 0         0 $db = $self->db;
2239 0         0 $object->db($db);
2240              
2241 0         0 my $ret = $db->begin_work;
2242              
2243 0 0       0 unless(defined $ret)
2244             {
2245 0         0 die 'Could not begin transaction during call to $name() - ',
2246             $db->error;
2247             }
2248              
2249 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
2250              
2251             # If the object is not marked as already existing in the database,
2252             # see if it represents an existing row. If it does, merge the
2253             # existing row's column values into the object, allowing any
2254             # modified columns in the object to take precedence. Returns true
2255             # if the object represents an existing row.
2256 0 0       0 if(__check_and_merge($object))
2257             {
2258 0 0       0 $object->save(changes_only => 1) or die $object->error;
2259             }
2260             else
2261             {
2262 0 0       0 $object->save or die $object->error;
2263             }
2264              
2265 0         0 local $fk->{'disable_column_triggers'} = 1;
2266              
2267 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2268             {
2269 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2270 0         0 my $foreign_method = $fk_meta->column_accessor_method_name($foreign_column);
2271              
2272 0         0 $self->$local_method($object->$foreign_method);
2273             }
2274              
2275 0 0       0 $self->save(changes_only => 1) or die $self->error;
2276              
2277 0         0 $self->{$key} = $object;
2278              
2279             # Not sharing? Aw.
2280 0 0       0 $object->db(undef) unless($share_db);
2281              
2282 0 0       0 if($started_new_tx)
2283             {
2284 0 0       0 $db->commit or die $db->error;
2285             }
2286             };
2287              
2288 0         0 $error = $@;
2289             }
2290              
2291 0 0       0 if($error)
2292             {
2293 0 0       0 $self->error(ref $error ? $error : "Could not add $name object - $error");
2294 0 0 0     0 $db->rollback if($db && $started_new_tx);
2295 0         0 $meta->handle_error($self);
2296 0         0 return undef;
2297             }
2298              
2299 0         0 return $self->{$key};
2300             }
2301              
2302 0 0       0 return $self->{$key} if(defined $self->{$key});
2303              
2304 0         0 my %key;
2305              
2306 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2307             {
2308 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2309 0         0 my $foreign_method = $fk_meta->column_mutator_method_name($foreign_column);
2310              
2311 0         0 $key{$foreign_method} = $self->$local_method();
2312              
2313             # XXX: Comment this out to allow null keys
2314 0 0       0 unless(defined $key{$foreign_method})
2315             {
2316 0         0 keys(%$fk_columns); # reset iterator
2317 0         0 $self->error("Could not load $name object - the " .
2318             "$local_method attribute is undefined");
2319 0         0 return undef;
2320             }
2321             }
2322              
2323 0         0 my $obj;
2324              
2325 0 0       0 if($share_db)
2326             {
2327 0         0 $obj = $fk_class->new(%key, db => $self->db);
2328             }
2329             else
2330             {
2331 0         0 $obj = $fk_class->new(%key);
2332             }
2333              
2334 0         0 my $ret;
2335              
2336 0 0       0 if($required)
2337             {
2338 0         0 my $error;
2339              
2340             TRY:
2341             {
2342 0         0 local $@;
  0         0  
2343 0         0 eval { $ret = $obj->load };
  0         0  
2344 0         0 $error = $@;
2345             }
2346              
2347 0 0 0     0 if($error || !$ret)
2348             {
2349 0   0     0 my $msg = $obj->error || $error;
2350              
2351             $self->error(ref $msg ? $msg :
2352             ("Could not load $fk_class with key " .
2353 0 0       0 join(', ', map { "$_ = '$key{$_}'" } sort keys %key) .
  0         0  
2354             " - $msg"));
2355 0         0 $self->meta->handle_error($self);
2356 0         0 return $ret;
2357             }
2358             }
2359             else
2360             {
2361 0 0       0 return undef unless($obj->load(speculative => 1));
2362             }
2363              
2364 0         0 return $self->{$key} = $obj;
2365 0         0 };
2366             }
2367             elsif($interface eq 'get_set_on_save')
2368             {
2369 60 50       159 unless($fk)
2370             {
2371 0         0 Carp::confess "Cannot make 'get_set_on_save' method $name without foreign key argument";
2372             }
2373              
2374 60         284 my $fk_name = $fk->name;
2375 60 100       159 my $is_fk = $fk->type eq 'foreign key' ? 1 : 0;
2376              
2377             $methods{$name} = sub
2378             {
2379 0     0   0 my($self) = shift;
2380              
2381 0 0       0 if(@_)
2382             {
2383             # If loading, just assign
2384 0 0       0 if($self->{STATE_LOADING()})
2385             {
2386 0         0 return $self->{$key} = $_[0];
2387             }
2388              
2389 0 0       0 unless(defined $_[0]) # undef argument
2390             {
2391 0 0 0     0 if($ref_integrity || $required)
2392             {
2393 0         0 local $fk->{'disable_column_triggers'} = 1;
2394              
2395             # Set the foreign key columns
2396 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2397             {
2398 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2399 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2400 0         0 $self->$local_method(undef);
2401             }
2402             }
2403              
2404 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'};
2405 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'};
2406 0         0 return $self->{$key} = undef;
2407             }
2408              
2409 0         0 my $object = __args_to_object($self, $key, $fk_class, \$fk_pk, \@_);
2410              
2411 0         0 my $linked_up = 0;
2412              
2413 0 0 0     0 if($is_fk && (!$fk->requires_preexisting_parent_object || $self->{STATE_IN_DB()}))
      0        
2414             {
2415 0         0 local $fk->{'disable_column_triggers'} = 1;
2416              
2417             # Set the foreign key columns
2418 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2419             {
2420 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2421 0         0 my $foreign_method = $fk_meta->column_accessor_method_name($foreign_column);
2422              
2423 0         0 $self->$local_method($object->$foreign_method);
2424             }
2425              
2426 0         0 $linked_up = 1;
2427             }
2428              
2429             # Set the attribute
2430 0         0 $self->{$key} = $object;
2431              
2432             # Make the code that will run on save()
2433             my $save_code = sub
2434             {
2435 0         0 my($self, $args) = @_;
2436              
2437             # Bail if there's nothing to do
2438 0 0       0 my $object = $self->{$key} or return;
2439              
2440 0         0 my $db;
2441              
2442 0 0       0 unless($linked_up)
2443             {
2444 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2445             {
2446 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2447 0         0 my $foreign_method = $fk_meta->column_accessor_method_name($foreign_column);
2448              
2449 0 0       0 $object->$foreign_method($self->$local_method)
2450             unless(defined $object->$foreign_method);
2451             }
2452             }
2453              
2454 0         0 my $error;
2455              
2456             TRY:
2457             {
2458 0         0 local $@;
  0         0  
2459              
2460             eval
2461 0         0 {
2462 0         0 $db = $self->db;
2463 0         0 $object->db($db);
2464              
2465             # If the object is not marked as already existing in the database,
2466             # see if it represents an existing row. If it does, merge the
2467             # existing row's column values into the object, allowing any
2468             # modified columns in the object to take precedence. Returns true
2469             # if the object represents an existing row.
2470 0 0       0 if(__check_and_merge($object))
2471             {
2472 0 0       0 $object->save(%$args, changes_only => 1) or die $object->error;
2473             }
2474             else
2475             {
2476 0 0       0 $object->save(%$args) or die $object->error;
2477             }
2478              
2479 0         0 local $fk->{'disable_column_triggers'} = 1;
2480              
2481             # Set the foreign key columns
2482 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2483             {
2484 0         0 my $local_method = $meta->column_mutator_method_name($local_column);
2485 0         0 my $foreign_method = $fk_meta->column_accessor_method_name($foreign_column);
2486              
2487 0         0 $self->$local_method($object->$foreign_method);
2488             }
2489              
2490             # Not sharing? Aw.
2491 0 0       0 $object->db(undef) unless($share_db);
2492              
2493 0         0 return $self->{$key} = $object;
2494             };
2495              
2496 0         0 $error = $@;
2497             }
2498              
2499 0 0       0 if($error)
2500             {
2501 0 0       0 $self->error(ref $error ? $error : "Could not add $name object - $error");
2502 0         0 $meta->handle_error($self);
2503 0         0 return undef;
2504             }
2505              
2506 0         0 return $self->{$key};
2507 0         0 };
2508              
2509 0 0       0 if($linked_up)
2510             {
2511 0         0 $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'} = $save_code;
2512             }
2513             else
2514             {
2515 0         0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'} = $save_code;
2516             }
2517              
2518 0         0 return $self->{$key};
2519             }
2520              
2521 0 0       0 return $self->{$key} if(defined $self->{$key});
2522              
2523 0         0 my %key;
2524              
2525 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2526             {
2527 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2528 0         0 my $foreign_method = $fk_meta->column_mutator_method_name($foreign_column);
2529              
2530 0         0 $key{$foreign_method} = $self->$local_method();
2531              
2532             # XXX: Comment this out to allow null keys
2533 0 0       0 unless(defined $key{$foreign_method})
2534             {
2535 0         0 keys(%$fk_columns); # reset iterator
2536 0         0 $self->error("Could not load $name object - the " .
2537             "$local_method attribute is undefined");
2538 0         0 return undef;
2539             }
2540             }
2541              
2542 0         0 my $obj;
2543              
2544 0 0       0 if($share_db)
2545             {
2546 0         0 $obj = $fk_class->new(%key, db => $self->db);
2547             }
2548             else
2549             {
2550 0         0 $obj = $fk_class->new(%key);
2551             }
2552              
2553 0         0 my $ret;
2554              
2555 0 0       0 if($required)
2556             {
2557 0         0 my $error;
2558              
2559             TRY:
2560             {
2561 0         0 local $@;
  0         0  
2562 0         0 eval { $ret = $obj->load };
  0         0  
2563 0         0 $error = $@;
2564             }
2565              
2566 0 0 0     0 if($error || !$ret)
2567             {
2568 0   0     0 my $msg = $obj->error || $error;
2569             $self->error(ref $msg ? $msg : ("Could not load $fk_class with key " .
2570 0 0       0 join(', ', map { "$_ = '$key{$_}'" } sort keys %key) .
  0         0  
2571             " - $msg"));
2572 0         0 $self->meta->handle_error($self);
2573 0         0 return $ret;
2574             }
2575             }
2576             else
2577             {
2578 0 0       0 return undef unless($obj->load(speculative => 1));
2579             }
2580              
2581 0         0 return $self->{$key} = $obj;
2582 60         872 };
2583             }
2584             elsif($interface eq 'delete_now')
2585             {
2586 0 0       0 unless($fk)
2587             {
2588 0         0 Carp::croak "Cannot make 'delete' method $name without foreign key argument";
2589             }
2590              
2591 0         0 my $fk_name = $fk->name;
2592 0 0       0 my $is_fk = $fk->type eq 'foreign key' ? 1 : 0;
2593              
2594             $methods{$name} = sub
2595             {
2596 0     0   0 my($self) = shift;
2597              
2598 0   0     0 my $object = $self->{$key} || $fk_class->new;
2599              
2600 0         0 my %key;
2601              
2602 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2603             {
2604 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2605 0         0 my $foreign_method = $fk_meta->column_mutator_method_name($foreign_column);
2606              
2607 0         0 $key{$foreign_method} = $self->$local_method();
2608              
2609             # XXX: Comment this out to allow null keys
2610 0 0       0 unless(defined $key{$foreign_method})
2611             {
2612 0         0 keys(%$fk_columns); # reset iterator
2613              
2614             # If this failed because we haven't saved it yet
2615 0 0 0     0 if(delete $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'} ||
2616             delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'})
2617             {
2618 0 0 0     0 if($ref_integrity || $required)
2619             {
2620 0         0 local $fk->{'disable_column_triggers'} = 1;
2621              
2622             # Clear foreign key columns
2623 0         0 foreach my $local_column (keys %$fk_columns)
2624             {
2625 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2626 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2627 0         0 $self->$local_method(undef);
2628             }
2629             }
2630              
2631 0         0 $self->{$key} = undef;
2632 0         0 return 1;
2633             }
2634              
2635 0         0 $self->error("Could not delete $name object - the " .
2636             "$local_method attribute is undefined");
2637 0         0 return undef;
2638             }
2639             }
2640              
2641 0         0 $object->init(%key);
2642              
2643 0         0 my($db, $started_new_tx, $deleted, %save_fk, $to_save_pre, $to_save_post, $error);
2644              
2645             TRY:
2646             {
2647 0         0 local $@;
  0         0  
2648              
2649             eval
2650 0         0 {
2651 0         0 $db = $self->db;
2652 0         0 $object->db($db);
2653              
2654 0         0 my $ret = $db->begin_work;
2655              
2656 0 0       0 unless(defined $ret)
2657             {
2658 0         0 die 'Could not begin transaction during call to $name() - ',
2659             $db->error;
2660             }
2661              
2662 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
2663              
2664 0 0 0     0 if($ref_integrity || $required)
2665             {
2666 0         0 local $fk->{'disable_column_triggers'} = 1;
2667              
2668             # Clear columns that reference the foreign key
2669 0         0 foreach my $local_column (keys %$fk_columns)
2670             {
2671 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2672 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2673 0         0 $save_fk{$local_method} = $self->$local_method();
2674 0         0 $self->$local_method(undef);
2675             }
2676             }
2677              
2678             # Forget about any value we were going to set on save
2679 0         0 $to_save_pre = delete $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'};
2680 0         0 $to_save_post = delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'};
2681              
2682 0 0       0 $self->save or die $self->error;
2683              
2684             # Propogate cascade arg, if any
2685 0 0       0 $deleted = $object->delete(@_) or die $object->error;
2686              
2687 0 0       0 if($started_new_tx)
2688             {
2689 0 0       0 $db->commit or die $db->error;
2690             }
2691              
2692 0         0 $self->{$key} = undef;
2693              
2694             # Not sharing? Aw.
2695 0 0       0 $object->db(undef) unless($share_db);
2696             };
2697              
2698 0         0 $error = $@;
2699             }
2700              
2701 0 0       0 if($error)
2702             {
2703 0 0       0 $self->error(ref $error ? $error : "Could not delete $name object - $error");
2704 0 0 0     0 $db->rollback if($db && $started_new_tx);
2705              
2706             # Restore foreign key column values
2707 0         0 while(my($method, $value) = each(%save_fk))
2708             {
2709 0         0 $self->$method($value);
2710             }
2711              
2712             # Restore any value we were going to set on save
2713 0 0       0 $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'} = $to_save_pre
2714             if($to_save_pre);
2715              
2716 0 0       0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'} = $to_save_post
2717             if($to_save_post);
2718              
2719 0         0 $meta->handle_error($self);
2720 0         0 return undef;
2721             }
2722              
2723 0         0 return $deleted;
2724 0         0 };
2725             }
2726             elsif($interface eq 'delete_on_save')
2727             {
2728 60 50       167 unless($fk)
2729             {
2730 0         0 Carp::croak "Cannot make 'delete_on_save' method $name without foreign key argument";
2731             }
2732              
2733 60         313 my $fk_name = $fk->name;
2734 60 100       159 my $is_fk = $fk->type eq 'foreign key' ? 1 : 0;
2735              
2736             $methods{$name} = sub
2737             {
2738 0     0   0 my($self) = shift;
2739              
2740 0   0     0 my $object = $self->{$key} || $fk_class->new;
2741              
2742 0         0 my %key;
2743              
2744 0         0 while(my($local_column, $foreign_column) = each(%$fk_columns))
2745             {
2746 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2747 0         0 my $foreign_method = $fk_meta->column_mutator_method_name($foreign_column);
2748              
2749 0         0 $key{$foreign_method} = $self->$local_method();
2750              
2751             # XXX: Comment this out to allow null keys
2752 0 0       0 unless(defined $key{$foreign_method})
2753             {
2754 0         0 keys(%$fk_columns); # reset iterator
2755              
2756             # If this failed because we haven't saved it yet
2757 0 0 0     0 if(delete $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'} ||
2758             delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'})
2759             {
2760 0 0 0     0 if($ref_integrity || $required)
2761             {
2762 0         0 local $fk->{'disable_column_triggers'} = 1;
2763              
2764             # Clear foreign key columns
2765 0         0 foreach my $local_column (keys %$fk_columns)
2766             {
2767 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2768 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2769 0         0 $self->$local_method(undef);
2770             }
2771             }
2772              
2773 0         0 $self->{$key} = undef;
2774 0         0 return 0;
2775             }
2776              
2777 0         0 $self->error("Could not delete $name object - the " .
2778             "$local_method attribute is undefined");
2779 0         0 return undef;
2780             }
2781             }
2782              
2783 0         0 $object->init(%key);
2784              
2785 0         0 my %save_fk;
2786              
2787 0 0 0     0 if($ref_integrity || $required)
2788             {
2789 0         0 local $fk->{'disable_column_triggers'} = 1;
2790              
2791             # Clear columns that reference the foreign key, saving old values
2792 0         0 foreach my $local_column (keys %$fk_columns)
2793             {
2794 0 0       0 next if($meta->column($local_column)->is_primary_key_member);
2795 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2796 0         0 $save_fk{$local_method} = $self->$local_method();
2797 0         0 $self->$local_method(undef);
2798             }
2799             }
2800              
2801             # Forget about any value we were going to set on save
2802 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'pre'}{'fk'}{$fk_name}{'set'};
2803 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$fk_name}{'set'};
2804              
2805             # Clear the foreign object attribute
2806 0         0 $self->{$key} = undef;
2807              
2808             # Make the code to run on save
2809             my $delete_code = sub
2810             {
2811 0         0 my($self, $args) = @_;
2812              
2813             my @delete_args =
2814 0         0 map { ($_ => $args->{$_}) } grep { exists $args->{$_} } qw(prepare_cached);
  0         0  
  0         0  
2815              
2816 0         0 my($db, $error);
2817              
2818             TRY:
2819             {
2820 0         0 local $@;
  0         0  
2821              
2822             eval
2823 0         0 {
2824 0         0 $db = $self->db;
2825 0         0 $object->db($db);
2826 0 0       0 $object->delete(@delete_args) or die $object->error;
2827             };
2828              
2829 0         0 $error = $@;
2830             }
2831              
2832 0 0       0 if($error)
2833             {
2834 0 0       0 $self->error(ref $error ? $error : "Could not delete $name object - $error");
2835              
2836             # Restore old foreign key column values if prudent
2837 0         0 while(my($method, $value) = each(%save_fk))
2838             {
2839 0 0       0 $self->$method($value) unless(defined $self->$method);
2840             }
2841              
2842 0         0 $meta->handle_error($self);
2843 0         0 return undef;
2844             }
2845              
2846             # Not sharing? Aw.
2847 0 0       0 $object->db(undef) unless($share_db);
2848              
2849 0         0 return 1;
2850 0         0 };
2851              
2852             # Add the on save code to the list
2853 0         0 push(@{$self->{ON_SAVE_ATTR_NAME()}{'post'}{'fk'}{$fk_name}{'delete'}},
  0         0  
2854             { code => $delete_code, object => $object, is_fk => $is_fk });
2855              
2856 0         0 return 1;
2857 60         703 };
2858             }
2859 0         0 else { Carp::croak "Unknown interface: $interface" }
2860              
2861 120         657 return \%methods;
2862             }
2863              
2864             sub objects_by_key
2865             {
2866 12     12 1 809 my($class, $name, $args, $options) = @_;
2867              
2868 12         24 my %methods;
2869              
2870 12   33     32 my $key = $args->{'hash_key'} || $name;
2871 12   50     34 my $interface = $args->{'interface'} || 'get_set';
2872 12 50       28 my $target_class = $options->{'target_class'} or die "Missing target class";
2873              
2874 12         21 my $relationship = $args->{'relationship'};
2875              
2876 12 50       31 my $ft_class = $args->{'class'} or die "Missing foreign object class";
2877 12         42 weaken(my $meta = $target_class->meta);
2878 12         21 my $ft_pk;
2879              
2880 12 0 33     30 unless(exists $args->{'key_columns'} || exists $args->{'query_args'} ||
      0        
2881             exists $args->{'join_args'})
2882             {
2883             # The key_columns attr is aliased to column_map when used
2884             # through the OneToMany relationship.
2885 0         0 die "Missing both column_map hash and query_args";
2886             }
2887              
2888 12   50     34 my $ft_columns = $args->{'key_columns'} || {};
2889 12         25 my $ft_manager = $args->{'manager_class'};
2890 12   50     42 my $ft_method = $args->{'manager_method'} || 'get_objects';
2891 12   50     36 my $share_db = $args->{'share_db'} || 1;
2892 12   50     44 my $mgr_args = $args->{'manager_args'} || {};
2893 12   50     39 my $query_args = $args->{'query_args'} || [];
2894 12   50     49 my $single = $args->{'single'} || 0;
2895              
2896 12 50       25 push(@$query_args, @{$args->{'join_args'} || []});
  12         49  
2897              
2898 12   50     45 my $ft_count_method = $args->{'manager_count_method'} || 'get_objects_count';
2899              
2900 12 50       29 if($mgr_args->{'query'})
2901             {
2902 0         0 Carp::croak "Cannot use the key 'query' in the manager_args parameter ",
2903             "hash. Use the separate query_args parameter instead";
2904             }
2905              
2906             #if(@$query_args % 2 != 0)
2907             #{
2908             # Carp::croak "Odd number of arguments passed in query_args parameter";
2909             #}
2910              
2911 12 50       25 unless($ft_manager)
2912             {
2913 12         24 $ft_manager = 'Rose::DB::Object::Manager';
2914 12         30 $mgr_args->{'object_class'} = $ft_class;
2915             }
2916              
2917             my $required =
2918             exists $args->{'required'} ? $args->{'required'} :
2919 12 50       43 exists $args->{'referential_integrity'} ? $args->{'referential_integrity'} : 1;
    50          
2920              
2921 12 0 33     28 if(exists $args->{'required'} && exists $args->{'referential_integrity'} &&
      0        
2922             (!$args->{'required'} != !$$args->{'referential_integrity'}))
2923             {
2924 0         0 Carp::croak "The required and referential_integrity parameters conflict. ",
2925             "Please pass one or the other, not both.";
2926             }
2927              
2928 12 50       50 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
2929             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
2930              
2931 12 50 66     89 if($interface eq 'count')
    100 33        
    50          
    50          
    100          
    50          
    50          
    50          
    50          
2932             {
2933 0         0 my $cache_key = PRIVATE_PREFIX . '_' . $name;
2934              
2935             $methods{$name} = sub
2936             {
2937 0     0   0 my($self) = shift;
2938              
2939 0         0 my %args;
2940              
2941 0 0       0 if(my $ref = ref $_[0])
2942             {
2943 0 0       0 if($ref eq 'HASH')
    0          
2944             {
2945 0         0 %args = (query => [ %{shift(@_)} ], @_);
  0         0  
2946             }
2947             elsif(ref $_[0] eq 'ARRAY')
2948             {
2949 0         0 %args = (query => shift, @_);
2950             }
2951             }
2952 0         0 else { %args = @_ }
2953              
2954 0 0       0 if(delete $args{'from_cache'})
2955             {
2956 0 0       0 if(keys %args)
2957             {
2958 0         0 Carp::croak "Additional parameters not allowed in call to ",
2959             "$name() with from_cache parameter";
2960             }
2961              
2962 0 0       0 if(defined $self->{$cache_key})
2963             {
2964 0 0       0 return wantarray ? @{$self->{$cache_key}} : $self->{$cache_key};
  0         0  
2965             }
2966             }
2967              
2968 0         0 my $count;
2969              
2970             # Get query key
2971             my %key;
2972              
2973 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
2974             {
2975 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
2976              
2977 0         0 $key{$foreign_column} = $self->$local_method();
2978              
2979             # Comment this out to allow null keys
2980 0 0       0 unless(defined $key{$foreign_column})
2981             {
2982 0         0 keys(%$ft_columns); # reset iterator
2983 0         0 $self->error("Could not fetch objects via $name() - the " .
2984             "$local_method attribute is undefined");
2985 0         0 return;
2986             }
2987             }
2988              
2989 0         0 my $cache = delete $args{'cache'};
2990              
2991             # Merge query args
2992 0 0       0 my @query = (%key, @$query_args, @{delete $args{'query'} || []});
  0         0  
2993              
2994             # Merge the rest of the arguments
2995 0         0 foreach my $param (keys %args)
2996             {
2997 0 0       0 if(exists $mgr_args->{$param})
2998             {
2999 0         0 my $ref = ref $args{$param};
3000              
3001 0 0       0 if($ref eq 'ARRAY')
    0          
3002             {
3003 0         0 unshift(@{$args{$param}}, ref $mgr_args->{$param} ?
3004 0 0       0 @{$mgr_args->{$param}} : $mgr_args->{$param});
  0         0  
3005             }
3006             elsif($ref eq 'HASH')
3007             {
3008 0         0 while(my($k, $v) = each(%{$mgr_args->{$param}}))
  0         0  
3009             {
3010 0 0       0 $args{$param}{$k} = $v unless(exists $args{$param}{$k});
3011             }
3012             }
3013             }
3014             }
3015              
3016 0         0 while(my($k, $v) = each(%$mgr_args))
3017             {
3018 0 0       0 $args{$k} = $v unless(exists $args{$k});
3019             }
3020              
3021 0         0 $args{'multi_many_ok'} = 1;
3022              
3023 0         0 my $error;
3024              
3025             TRY:
3026             {
3027 0         0 local $@;
  0         0  
3028              
3029             # Make query for object count
3030             eval
3031 0         0 {
3032             #local $Rose::DB::Object::Manager::Debug = 1;
3033 0 0       0 if($share_db)
3034             {
3035 0         0 $count =
3036             $ft_manager->$ft_count_method(query => \@query, db => $self->db, %args);
3037             }
3038             else
3039             {
3040 0         0 $count =
3041             $ft_manager->$ft_count_method(query => \@query,
3042             db => $self->db,
3043             share_db => 0, %args);
3044             }
3045             };
3046              
3047 0         0 $error = $@;
3048             }
3049              
3050 0 0 0     0 if($error || !defined $count)
3051             {
3052 0   0     0 my $msg = $error || $ft_manager->error;
3053 0 0       0 $self->error(ref $msg ? $msg : ("Could not count $ft_class objects - $msg"));
3054 0         0 $self->meta->handle_error($self);
3055 0 0       0 return wantarray ? () : $count;
3056             }
3057              
3058 0 0       0 $self->{$cache_key} = $count if($cache);
3059              
3060 0         0 return $count;
3061 0         0 };
3062             }
3063             elsif($interface eq 'find' || $interface eq 'iterator')
3064             {
3065 4         32 my $cache_key = PRIVATE_PREFIX . ":$interface:$name";
3066              
3067 4 50       12 my $is_iterator = $interface eq 'iterator' ? 1 : 0;
3068              
3069 4 50       8 if($is_iterator)
3070             {
3071 0   0     0 $ft_method = $args->{'manager_iterator_method'} || 'get_objects_iterator';
3072             }
3073             else
3074             {
3075 4   50     35 $ft_method = $args->{'manager_find_method'} || 'get_objects';
3076             }
3077              
3078             $methods{$name} = sub
3079             {
3080 0     0   0 my($self) = shift;
3081              
3082 0         0 my %args;
3083              
3084 0 0       0 if(my $ref = ref $_[0])
3085             {
3086 0 0       0 if($ref eq 'HASH')
    0          
3087             {
3088 0         0 %args = (query => [ %{shift(@_)} ], @_);
  0         0  
3089             }
3090             elsif(ref $_[0] eq 'ARRAY')
3091             {
3092 0         0 %args = (query => shift, @_);
3093             }
3094             }
3095 0         0 else { %args = @_ }
3096              
3097 0 0       0 if(delete $args{'from_cache'})
3098             {
3099 0 0       0 if(keys %args)
3100             {
3101 0         0 Carp::croak "Additional parameters not allowed in call to ",
3102             "$name() with from_cache parameter";
3103             }
3104              
3105 0 0       0 if(defined $self->{$cache_key})
3106             {
3107 0 0       0 return wantarray ? @{$self->{$cache_key}} : $self->{$cache_key};
  0         0  
3108             }
3109             }
3110              
3111 0         0 my $objs;
3112              
3113             # Get query key
3114             my %key;
3115              
3116 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3117             {
3118 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3119              
3120 0         0 $key{$foreign_column} = $self->$local_method();
3121              
3122             # Comment this out to allow null keys
3123 0 0       0 unless(defined $key{$foreign_column})
3124             {
3125 0         0 keys(%$ft_columns); # reset iterator
3126 0         0 $self->error("Could not fetch objects via $name() - the " .
3127             "$local_method attribute is undefined");
3128 0         0 return;
3129             }
3130             }
3131              
3132 0         0 my $cache = delete $args{'cache'};
3133              
3134             # Merge query args
3135 0 0       0 my @query = (%key, @$query_args, @{delete $args{'query'} || []});
  0         0  
3136              
3137             # Merge the rest of the arguments
3138 0         0 foreach my $param (keys %args)
3139             {
3140 0 0       0 if(exists $mgr_args->{$param})
3141             {
3142 0         0 my $ref = ref $args{$param};
3143              
3144 0 0       0 if($ref eq 'ARRAY')
    0          
3145             {
3146 0         0 unshift(@{$args{$param}}, ref $mgr_args->{$param} ?
3147 0 0       0 @{$mgr_args->{$param}} : $mgr_args->{$param});
  0         0  
3148             }
3149             elsif($ref eq 'HASH')
3150             {
3151 0         0 while(my($k, $v) = each(%{$mgr_args->{$param}}))
  0         0  
3152             {
3153 0 0       0 $args{$param}{$k} = $v unless(exists $args{$param}{$k});
3154             }
3155             }
3156             }
3157             }
3158              
3159 0         0 while(my($k, $v) = each(%$mgr_args))
3160             {
3161 0 0       0 $args{$k} = $v unless(exists $args{$k});
3162             }
3163              
3164 0         0 my $error;
3165              
3166             TRY:
3167             {
3168 0         0 local $@;
  0         0  
3169              
3170             # Make query for object list
3171             eval
3172 0         0 {
3173             #local $Rose::DB::Object::Manager::Debug = 1;
3174 0 0       0 if($share_db)
3175             {
3176 0 0       0 $objs =
3177             $ft_manager->$ft_method(query => \@query, db => $self->db, %args)
3178             or die $ft_manager->error;
3179             }
3180             else
3181             {
3182 0 0       0 $objs =
3183             $ft_manager->$ft_method(query => \@query,
3184             db => $self->db,
3185             share_db => 0, %args)
3186             or die $ft_manager->error;
3187             }
3188             };
3189              
3190 0         0 $error = $@;
3191             }
3192              
3193 0 0 0     0 if($error || !$objs)
3194             {
3195 0   0     0 my $msg = $error || $ft_manager->error;
3196 0 0       0 $self->error(ref $msg ? $msg : ("Could not " . ($is_iterator ? 'get iterator for' : 'find') .
    0          
3197             " $ft_class objects - $msg"));
3198 0         0 $self->meta->handle_error($self);
3199 0 0       0 return wantarray ? () : $objs;
3200             }
3201              
3202 0 0       0 return $objs if($is_iterator);
3203              
3204 0 0       0 $self->{$cache_key} = $objs if($cache);
3205              
3206 0 0       0 return wantarray ? @$objs: $objs;
3207 4         54 };
3208             }
3209             elsif($interface eq 'get_set' || $interface eq 'get_set_load')
3210             {
3211             $methods{$name} = sub
3212             {
3213 0     0   0 my($self) = shift;
3214              
3215 0 0       0 if(@_)
3216             {
3217 0 0 0     0 return $self->{$key} = undef if(@_ == 1 && !defined $_[0]);
3218 0         0 $self->{$key} = __args_to_objects($self, $key, $ft_class, \$ft_pk, \@_);
3219              
3220 0 0       0 if(!$single)
3221             {
3222 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3223             }
3224             else
3225             {
3226 0         0 return $self->{$key}[0];
3227             }
3228             }
3229              
3230 0 0       0 if(defined $self->{$key})
3231             {
3232 0 0       0 if(!$single)
3233             {
3234 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3235             }
3236             else
3237             {
3238 0         0 return $self->{$key}[0];
3239             }
3240             }
3241              
3242 0         0 my %key;
3243              
3244 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3245             {
3246 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3247              
3248 0         0 $key{$foreign_column} = $self->$local_method();
3249              
3250             # Comment this out to allow null keys
3251 0 0       0 unless(defined $key{$foreign_column})
3252             {
3253 0         0 keys(%$ft_columns); # reset iterator
3254 0         0 $self->error("Could not fetch objects via $name() - the " .
3255             "$local_method attribute is undefined");
3256 0         0 return;
3257             }
3258             }
3259              
3260 0         0 my($objs, $error);
3261              
3262             TRY:
3263             {
3264 0         0 local $@;
  0         0  
3265              
3266             eval
3267 0         0 {
3268 0 0       0 if($share_db)
3269             {
3270 0 0       0 $objs =
3271             $ft_manager->$ft_method(query => [ %key, @$query_args ],
3272             %$mgr_args,
3273             db => $self->db)
3274             or die $ft_manager->error;
3275             }
3276             else
3277             {
3278 0 0       0 $objs =
3279             $ft_manager->$ft_method(query => [ %key, @$query_args ],
3280             db => $self->db,
3281             share_db => 0, %$mgr_args)
3282             or die $ft_manager->error;
3283             }
3284             };
3285              
3286 0         0 $error = $@;
3287             }
3288              
3289 0 0 0     0 if($error || !$objs)
3290             {
3291 0   0     0 my $msg = $error || $ft_manager->error;
3292             $self->error(ref $msg ? $msg : ("Could not load $ft_class objects with key " .
3293 0 0       0 join(', ', map { "$_ = '$key{$_}'" } sort keys %key) .
  0         0  
3294             " - $msg"));
3295 0         0 $self->meta->handle_error($self);
3296 0 0       0 return wantarray ? () : $objs;
3297             }
3298              
3299 0         0 $self->{$key} = $objs;
3300              
3301 0 0       0 if(!$single)
3302             {
3303 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3304             }
3305             else
3306             {
3307 0 0 0     0 if($required && !@$objs)
3308             {
3309 0         0 my %query = (%key, @$query_args);
3310             $self->error("No related $ft_class object found with query " .
3311 0         0 join(', ', map { "$_ = '$query{$_}'" } sort keys %query));
  0         0  
3312 0         0 $self->meta->handle_error($self);
3313 0         0 return 0;
3314             }
3315              
3316 0         0 return $self->{$key}[0];
3317             }
3318 0         0 };
3319              
3320 0 0       0 if($interface eq 'get_set_load')
3321             {
3322 0   0     0 my $method_name = $args->{'load_method'} || 'load_' . $name;
3323              
3324             $methods{$method_name} = sub
3325             {
3326 0 0   0   0 return (defined shift->$name(@_)) ? 1 : 0;
3327 0         0 };
3328             }
3329             }
3330             elsif($interface eq 'get_set_now')
3331             {
3332 0   0     0 my $ft_delete_method = $args->{'manager_delete_method'} || 'delete_objects';
3333              
3334 0 0       0 unless($relationship)
3335             {
3336 0         0 Carp::confess "Cannot make 'get_set_now' method $name without relationship argument";
3337             }
3338              
3339 0         0 my $rel_name = $relationship->name;
3340              
3341             $methods{$name} = sub
3342             {
3343 0     0   0 my($self) = shift;
3344              
3345 0 0       0 if(@_)
3346             {
3347             # If loading, just assign
3348 0 0       0 if($self->{STATE_LOADING()})
3349             {
3350 0 0 0     0 return $self->{$key} = undef if(@_ == 1 && !defined $_[0]);
3351 0 0 0     0 $self->{$key} = (@_ == 1 && ref $_[0] eq 'ARRAY') ? $_[0] : [ @_ ];
3352              
3353 0 0       0 if(!$single)
3354             {
3355 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3356             }
3357             else
3358             {
3359 0         0 return $self->{$key}[0];
3360             }
3361             }
3362              
3363             # Can't set until the object is saved
3364 0 0       0 unless($self->{STATE_IN_DB()})
3365             {
3366 0         0 Carp::croak "Can't set $name() until this object is loaded or saved";
3367             }
3368              
3369             # Set to undef resets the attr
3370 0 0 0     0 if(@_ == 1 && !defined $_[0])
3371             {
3372             # Delete any pending set or add actions
3373 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
3374 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
3375              
3376 0         0 $self->{$key} = undef;
3377 0 0       0 $single ? return undef : return;
3378             }
3379              
3380             # Set up join conditions and column map
3381 0         0 my(%key, %map);
3382              
3383 0 0       0 my $ft_meta = $ft_class->meta
3384             or Carp::croak "Missing metadata for foreign object class $ft_class";
3385              
3386 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3387             {
3388 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3389 0         0 my $foreign_accessor = $ft_meta->column_accessor_method_name($foreign_column);
3390 0         0 my $foreign_mutator = $ft_meta->column_mutator_method_name($foreign_column);
3391              
3392 0         0 $key{$foreign_column} = $map{$foreign_mutator} = $self->$local_method();
3393              
3394             # Comment this out to allow null keys
3395 0 0       0 unless(defined $key{$foreign_column})
3396             {
3397 0         0 keys(%$ft_columns); # reset iterator
3398 0         0 $self->error("Could not set objects via $name() - the " .
3399             "$local_method attribute is undefined");
3400 0 0       0 $single ? return undef : return;
3401             }
3402             }
3403              
3404 0         0 my($db, $started_new_tx, $error);
3405              
3406             TRY:
3407             {
3408 0         0 local $@;
  0         0  
3409              
3410             eval
3411 0         0 {
3412 0         0 $db = $self->db;
3413              
3414 0         0 my $ret = $db->begin_work;
3415              
3416 0 0       0 unless(defined $ret)
3417             {
3418 0         0 die 'Could not begin transaction during call to $name() - ',
3419             $db->error;
3420             }
3421              
3422 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
3423              
3424             # Get the list of new objects
3425 0         0 my $objects = __args_to_objects($self, $key, $ft_class, \$ft_pk, \@_);
3426              
3427             # Prep objects for saving.
3428 0         0 foreach my $object (@$objects)
3429             {
3430             # Map object to parent
3431 0         0 $object->init(%map, db => $db);
3432              
3433             # If the object is not marked as already existing in the database,
3434             # see if it represents an existing row. If it does, merge the
3435             # existing row's column values into the object, allowing any
3436             # modified columns in the object to take precedence.
3437 0         0 __check_and_merge($object);
3438             }
3439              
3440             # Delete any existing objects
3441 0         0 my $deleted =
3442             $ft_manager->$ft_delete_method(object_class => $ft_class,
3443             where => [ %key, @$query_args ],
3444             db => $db);
3445 0 0       0 die $ft_manager->error unless(defined $deleted);
3446              
3447             # Save all the new objects
3448 0         0 foreach my $object (@$objects)
3449             {
3450 0 0       0 $object->{STATE_IN_DB()} = 0 if($deleted);
3451              
3452             # If the object is not marked as already existing in the database,
3453             # see if it represents an existing row. If it does, merge the
3454             # existing row's column values into the object, allowing any
3455             # modified columns in the object to take precedence. Returns true
3456             # if the object represents an existing row.
3457 0 0       0 if(__check_and_merge($object))
3458             {
3459 0 0       0 $object->save(changes_only => 1) or die $object->error;
3460             }
3461             else
3462             {
3463 0 0       0 $object->save or die $object->error;
3464             }
3465              
3466             # Not sharing? Aw.
3467 0 0       0 $object->db(undef) unless($share_db);
3468             }
3469              
3470             # Assign to attribute or blank the attribute, causing the objects
3471             # to be fetched from the db next time, depending on whether or not
3472             # there's a custom sort order
3473 0 0       0 $self->{$key} = defined $mgr_args->{'sort_by'} ? undef : $objects;
3474              
3475 0 0       0 if($started_new_tx)
3476             {
3477 0 0       0 $db->commit or die $db->error;
3478             }
3479              
3480             # Delete any pending set or add actions
3481 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
3482 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
3483             };
3484              
3485 0         0 $error = $@;
3486             }
3487              
3488 0 0       0 if($error)
3489             {
3490 0 0       0 $self->error(ref $error ? $error : "Could not set $name objects - $error");
3491 0 0 0     0 $db->rollback if($db && $started_new_tx);
3492 0         0 $meta->handle_error($self);
3493 0         0 return undef;
3494             }
3495              
3496 0 0       0 return 1 unless(defined $self->{$key});
3497              
3498 0 0       0 if(!$single)
3499             {
3500 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3501             }
3502             else
3503             {
3504 0         0 return $self->{$key}[0];
3505             }
3506             }
3507              
3508             # Return existing list of objects, if it exists
3509 0 0       0 if(defined $self->{$key})
3510             {
3511 0 0       0 if(!$single)
3512             {
3513 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3514             }
3515             else
3516             {
3517 0         0 return $self->{$key}[0];
3518             }
3519             }
3520              
3521 0         0 my $objs;
3522              
3523             # Get query key
3524             my %key;
3525              
3526 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3527             {
3528 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3529              
3530 0         0 $key{$foreign_column} = $self->$local_method();
3531              
3532             # Comment this out to allow null keys
3533 0 0       0 unless(defined $key{$foreign_column})
3534             {
3535 0         0 keys(%$ft_columns); # reset iterator
3536 0         0 $self->error("Could not fetch objects via $name() - the " .
3537             "$local_method attribute is undefined");
3538 0 0       0 $single ? return undef : return;
3539             }
3540             }
3541              
3542 0         0 my $error;
3543              
3544             TRY:
3545             {
3546 0         0 local $@;
  0         0  
3547              
3548             # Make query for object list
3549             eval
3550 0         0 {
3551 0 0       0 if($share_db)
3552             {
3553 0 0       0 $objs =
3554             $ft_manager->$ft_method(query => [ %key, @$query_args ],
3555             %$mgr_args, db => $self->db)
3556             or die $ft_manager->error;
3557             }
3558             else
3559             {
3560 0 0       0 $objs =
3561             $ft_manager->$ft_method(query => [ %key, @$query_args ],
3562             db => $self->db,
3563             share_db => 0, %$mgr_args)
3564             or die $ft_manager->error;
3565             }
3566             };
3567              
3568 0         0 $error = $@;
3569             }
3570              
3571 0 0 0     0 if($error || !$objs)
3572             {
3573 0   0     0 my $msg = $error || $ft_manager->error;
3574             $self->error(ref $msg ? $msg : ("Could not load $ft_class objects with key " .
3575 0 0       0 join(', ', map { "$_ = '$key{$_}'" } sort keys %key) .
  0         0  
3576             " - $msg"));
3577 0         0 $self->meta->handle_error($self);
3578 0 0       0 return wantarray ? () : $objs;
3579             }
3580              
3581 0         0 $self->{$key} = $objs;
3582              
3583 0 0       0 if(!$single)
3584             {
3585 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3586             }
3587             else
3588             {
3589 0 0 0     0 if($required && !@$objs)
3590             {
3591 0         0 my %query = (%key, @$query_args);
3592             $self->error("Not related $ft_class object found with query " .
3593 0         0 join(', ', map { "$_ = '$query{$_}'" } sort keys %query));
  0         0  
3594 0         0 $self->meta->handle_error($self);
3595 0         0 return 0;
3596             }
3597              
3598 0         0 return $self->{$key}[0];
3599             }
3600 0         0 };
3601             }
3602             elsif($interface eq 'get_set_on_save')
3603             {
3604 4   50     18 my $ft_delete_method = $args->{'manager_delete_method'} || 'delete_objects';
3605              
3606 4 50       10 unless($relationship)
3607             {
3608 0         0 Carp::confess "Cannot make 'get_set_on_save' method $name without relationship argument";
3609             }
3610              
3611 4         11 my $rel_name = $relationship->name;
3612              
3613             $methods{$name} = sub
3614             {
3615 0     0   0 my($self) = shift;
3616              
3617 0 0       0 if(@_)
3618             {
3619             # If loading, just assign
3620 0 0       0 if($self->{STATE_LOADING()})
3621             {
3622 0 0 0     0 return $self->{$key} = undef if(@_ == 1 && !defined $_[0]);
3623 0 0 0     0 $self->{$key} = (@_ == 1 && ref $_[0] eq 'ARRAY') ? $_[0] : [ @_ ];
3624              
3625 0 0       0 if(!$single)
3626             {
3627 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3628             }
3629             else
3630             {
3631 0         0 return $self->{$key}[0];
3632             }
3633             }
3634              
3635             # Set to undef resets the attr
3636 0 0 0     0 if(@_ == 1 && !defined $_[0])
3637             {
3638             # Delete any pending set or add actions
3639 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
3640 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
3641              
3642 0         0 $self->{$key} = undef;
3643 0 0       0 $single ? return undef : return;
3644             }
3645              
3646 0         0 my $objects = __args_to_objects($self, $key, $ft_class, \$ft_pk, \@_);
3647              
3648 0         0 my $db = $self->db;
3649              
3650             # Set up column map
3651 0         0 my %map;
3652              
3653 0 0       0 my $ft_meta = $ft_class->meta
3654             or Carp::croak "Missing metadata for foreign object class $ft_class";
3655              
3656 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3657             {
3658 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3659 0         0 my $foreign_method = $ft_meta->column_mutator_method_name($foreign_column);
3660              
3661 0         0 $map{$foreign_method} = $self->$local_method();
3662             }
3663              
3664             # Map all the objects to the parent
3665 0         0 foreach my $object (@$objects)
3666             {
3667 0 0       0 $object->init(%map, ($share_db ? (db => $db) : ()));
3668             }
3669              
3670             # Set the attribute
3671 0         0 $self->{$key} = $objects;
3672              
3673             my $save_code = sub
3674             {
3675 0         0 my($self, $args) = @_;
3676              
3677             # Set up join conditions and column map
3678 0         0 my(%key, %map);
3679              
3680 0 0       0 my $ft_meta = $ft_class->meta
3681             or Carp::croak "Missing metadata for foreign object class $ft_class";
3682              
3683 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3684             {
3685 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3686 0         0 my $foreign_accessor = $ft_meta->column_accessor_method_name($foreign_column);
3687 0         0 my $foreign_mutator = $ft_meta->column_mutator_method_name($foreign_column);
3688              
3689 0         0 $key{$foreign_column} = $map{$foreign_mutator} = $self->$local_method();
3690              
3691             # Comment this out to allow null keys
3692 0 0       0 unless(defined $key{$foreign_column})
3693             {
3694 0         0 keys(%$ft_columns); # reset iterator
3695 0         0 $self->error("Could not set objects via $name() - the " .
3696             "$local_method attribute is undefined");
3697 0         0 return;
3698             }
3699             }
3700              
3701 0         0 my $db = $self->db;
3702              
3703             # Prep objects for saving. Use the current list, even if it's
3704             # different than it was when the "set on save" was called.
3705 0 0       0 foreach my $object (@{$self->{$key} || []})
  0         0  
3706             {
3707             # Map object to parent
3708 0         0 $object->init(%map, db => $db);
3709              
3710             # If the object is not marked as already existing in the database,
3711             # see if it represents an existing row. If it does, merge the
3712             # existing row's column values into the object, allowing any
3713             # modified columns in the object to take precedence.
3714 0         0 __check_and_merge($object);
3715             }
3716              
3717             # Delete any existing objects
3718 0         0 my $deleted =
3719             $ft_manager->$ft_delete_method(object_class => $ft_class,
3720             where => [ %key, @$query_args ],
3721             db => $db);
3722 0 0       0 die $ft_manager->error unless(defined $deleted);
3723              
3724             # Save all the objects. Use the current list, even if it's
3725             # different than it was when the "set on save" was called.
3726 0 0       0 foreach my $object (@{$self->{$key} || []})
  0         0  
3727             {
3728 0 0       0 $object->{STATE_IN_DB()} = 0 if($deleted);
3729              
3730             # If the object is not marked as already existing in the database,
3731             # see if it represents an existing row. If it does, merge the
3732             # existing row's column values into the object, allowing any
3733             # modified columns in the object to take precedence. Returns true
3734             # if the object represents an existing row.
3735 0 0       0 if(__check_and_merge($object))
3736             {
3737 0 0       0 $object->save(changes_only => 1) or die $object->error;
3738             }
3739             else
3740             {
3741 0 0       0 $object->save or die $object->error;
3742             }
3743              
3744             # Not sharing? Aw.
3745 0 0       0 $object->db(undef) unless($share_db);
3746             }
3747              
3748             # Forget about any adds if we just set the list
3749 0 0       0 if(defined $self->{$key})
3750             {
3751             # Set to undef instead of deleting because this code ref
3752             # will be called while iterating over this very hash.
3753 0         0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'} = undef;
3754             }
3755              
3756             # Blank the attribute, causing the objects to be fetched from
3757             # the db next time, if there's a custom sort order or if
3758             # the list is defined but empty
3759             $self->{$key} = undef if(defined $mgr_args->{'sort_by'} ||
3760 0 0 0     0 (defined $self->{$key} && !@{$self->{$key}}));
  0   0     0  
3761              
3762 0         0 return 1;
3763 0         0 };
3764              
3765 0         0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'} = $save_code;
3766              
3767             # Forget about any adds
3768 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
3769              
3770 0 0       0 return 1 unless(defined $self->{$key});
3771              
3772 0 0       0 if(!$single)
3773             {
3774 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3775             }
3776             else
3777             {
3778 0         0 return $self->{$key}[0];
3779             }
3780             }
3781              
3782             # Return existing list of objects, if it exists
3783 0 0       0 if(defined $self->{$key})
3784             {
3785 0 0       0 if(!$single)
3786             {
3787 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3788             }
3789             else
3790             {
3791 0         0 return $self->{$key}[0];
3792             }
3793             }
3794              
3795 0         0 my $objs;
3796              
3797             # Get query key
3798             my %key;
3799              
3800 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3801             {
3802 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3803              
3804 0         0 $key{$foreign_column} = $self->$local_method();
3805              
3806             # Comment this out to allow null keys
3807 0 0       0 unless(defined $key{$foreign_column})
3808             {
3809 0         0 keys(%$ft_columns); # reset iterator
3810 0         0 $self->error("Could not fetch objects via $name() - the " .
3811             "$local_method attribute is undefined");
3812 0 0       0 $single ? return undef : return;
3813             }
3814             }
3815              
3816 0         0 my $error;
3817              
3818             TRY:
3819             {
3820 0         0 local $@;
  0         0  
3821              
3822             # Make query for object list
3823             eval
3824 0         0 {
3825 0 0       0 if($share_db)
3826             {
3827 0 0       0 $objs =
3828             $ft_manager->$ft_method(query => [ %key, @$query_args ],
3829             %$mgr_args, db => $self->db)
3830             or die $ft_manager->error;
3831             }
3832             else
3833             {
3834 0 0       0 $objs =
3835             $ft_manager->$ft_method(query => [ %key, @$query_args ],
3836             db => $self->db,
3837             share_db => 0,
3838             %$mgr_args)
3839             or die $ft_manager->error;
3840             }
3841             };
3842              
3843 0         0 $error = $@;
3844             }
3845              
3846 0 0 0     0 if($error || !$objs)
3847             {
3848 0   0     0 my $msg = $error || $ft_manager->error;
3849             $self->error(ref $msg ? $msg : ("Could not load $ft_class objects with key " .
3850 0 0       0 join(', ', map { "$_ = '$key{$_}'" } sort keys %key) .
  0         0  
3851             " - $msg"));
3852 0         0 $self->meta->handle_error($self);
3853 0 0       0 return wantarray ? () : $objs;
3854             }
3855              
3856 0         0 $self->{$key} = $objs;
3857              
3858 0 0       0 if(!$single)
3859             {
3860 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
3861             }
3862             else
3863             {
3864 0 0 0     0 if($required && !@$objs)
3865             {
3866 0         0 my %query = (%key, @$query_args);
3867             $self->error("Not related $ft_class object found with query " .
3868 0         0 join(', ', map { "$_ = '$query{$_}'" } sort keys %query));
  0         0  
3869 0         0 $self->meta->handle_error($self);
3870 0         0 return 0;
3871             }
3872              
3873 0         0 return $self->{$key}[0];
3874             }
3875 4         99 };
3876             }
3877             elsif($interface eq 'delete_now')
3878             {
3879 0   0     0 my $ft_delete_method = $args->{'manager_delete_method'} || 'delete_objects';
3880              
3881 0 0       0 unless($relationship)
3882             {
3883 0         0 Carp::confess "Cannot make 'delete_now' method $name without relationship argument";
3884             }
3885              
3886 0         0 my $rel_name = $relationship->name;
3887              
3888             $methods{$name} = sub
3889             {
3890 0     0   0 my($self) = shift;
3891              
3892             # Set up join conditions and column map
3893 0         0 my(%key, %map);
3894              
3895 0 0       0 my $ft_meta = $ft_class->meta
3896             or Carp::croak "Missing metadata for foreign object class $ft_class";
3897              
3898 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
3899             {
3900 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
3901 0         0 my $foreign_accessor = $ft_meta->column_accessor_method_name($foreign_column);
3902 0         0 my $foreign_mutator = $ft_meta->column_mutator_method_name($foreign_column);
3903              
3904 0         0 $key{$foreign_column} = $map{$foreign_mutator} = $self->$local_method();
3905              
3906             # Comment this out to allow null keys
3907 0 0       0 unless(defined $key{$foreign_column})
3908             {
3909 0         0 keys(%$ft_columns); # reset iterator
3910 0         0 $self->error("Could not delete objects via $name() - the " .
3911             "$local_method attribute is undefined");
3912 0 0       0 $single ? return undef : return;
3913             }
3914             }
3915              
3916 0         0 my($db, $started_new_tx, $error);
3917              
3918             TRY:
3919             {
3920 0         0 local $@;
  0         0  
3921              
3922             eval
3923 0         0 {
3924 0         0 $db = $self->db;
3925              
3926 0         0 my $ret = $db->begin_work;
3927              
3928 0 0       0 unless(defined $ret)
3929             {
3930 0         0 die 'Could not begin transaction during call to $name() - ',
3931             $db->error;
3932             }
3933              
3934 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
3935              
3936             # Delete existing objects
3937 0         0 my $deleted =
3938             $ft_manager->$ft_delete_method(object_class => $ft_class,
3939             where => [ %key, @$query_args ],
3940             db => $db);
3941 0 0       0 die $ft_manager->error unless(defined $deleted);
3942              
3943             # Delete any pending set or add actions
3944 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
3945 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
3946              
3947 0 0       0 if($started_new_tx)
3948             {
3949 0 0       0 $db->commit or die $db->error;
3950             }
3951             };
3952              
3953 0         0 $error = $@;
3954             }
3955              
3956 0 0       0 if($error)
3957             {
3958 0 0       0 $self->error(ref $error ? $error : "Could not delete $name objects - $error");
3959 0 0 0     0 $db->rollback if($db && $started_new_tx);
3960 0         0 $meta->handle_error($self);
3961 0         0 return undef;
3962             }
3963              
3964 0         0 return 1;
3965 0         0 };
3966             }
3967             elsif($interface eq 'delete_on_save')
3968             {
3969 0   0     0 my $ft_delete_method = $args->{'manager_delete_method'} || 'delete_objects';
3970              
3971 0 0       0 unless($relationship)
3972             {
3973 0         0 Carp::confess "Cannot make 'delete_on_save' method $name without relationship argument";
3974             }
3975              
3976 0         0 my $rel_name = $relationship->name;
3977              
3978             $methods{$name} = sub
3979             {
3980 0     0   0 my($self) = shift;
3981              
3982             # Delete any pending set or add actions
3983 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
3984 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
3985              
3986 0         0 $self->{$key} = undef;
3987              
3988             #weaken(my $self = $self);
3989              
3990             my $delete_code = sub
3991             {
3992 0         0 my($self, $args) = @_;
3993              
3994             my @delete_args =
3995 0         0 map { ($_ => $args->{$_}) } grep { exists $args->{$_} } qw(prepare_cached);
  0         0  
  0         0  
3996              
3997             # Set up join conditions and column map
3998 0         0 my(%key, %map);
3999              
4000 0 0       0 my $ft_meta = $ft_class->meta
4001             or Carp::croak "Missing metadata for foreign object class $ft_class";
4002              
4003 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
4004             {
4005 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
4006 0         0 my $foreign_accessor = $ft_meta->column_accessor_method_name($foreign_column);
4007 0         0 my $foreign_mutator = $ft_meta->column_mutator_method_name($foreign_column);
4008              
4009 0         0 $key{$foreign_column} = $map{$foreign_mutator} = $self->$local_method();
4010              
4011             # Comment this out to allow null keys
4012 0 0       0 unless(defined $key{$foreign_column})
4013             {
4014 0         0 keys(%$ft_columns); # reset iterator
4015 0         0 $self->error("Could not set objects via $name() - the " .
4016             "$local_method attribute is undefined");
4017 0         0 return;
4018             }
4019             }
4020              
4021 0         0 my $db = $self->db;
4022              
4023             # Delete existing objects
4024 0         0 my $deleted =
4025             $ft_manager->$ft_delete_method(object_class => $ft_class,
4026             where => [ %key, @$query_args ],
4027             db => $db, @delete_args);
4028 0 0       0 die $ft_manager->error unless(defined $deleted);
4029              
4030 0         0 $self->{$key} = undef;
4031              
4032 0         0 return 1;
4033 0         0 };
4034              
4035 0         0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'delete'} = $delete_code;
4036              
4037             # Forget about any adds
4038 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
4039              
4040 0         0 return 1;
4041 0         0 };
4042             }
4043             elsif($interface eq 'add_now')
4044             {
4045 0 0       0 unless($relationship)
4046             {
4047 0         0 Carp::confess "Cannot make 'add_now' method $name without relationship argument";
4048             }
4049              
4050 0         0 my $rel_name = $relationship->name;
4051              
4052             $methods{$name} = sub
4053             {
4054 0     0   0 my($self) = shift;
4055              
4056 0 0       0 unless(@_)
4057             {
4058 0         0 $self->error("No $name to add");
4059 0 0       0 return wantarray ? () : 0;
4060             }
4061              
4062             # Can't add until the object is saved
4063 0 0       0 unless($self->{STATE_IN_DB()})
4064             {
4065 0         0 Carp::croak "Can't add $name until this object is loaded or saved";
4066             }
4067              
4068 0 0       0 if($self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'})
4069             {
4070 0         0 Carp::croak "Cannot add objects via the 'add_now' method $name() ",
4071             "because the list of objects is already going to be ".
4072             "set to something else on save. Use the 'add_on_save' ",
4073             "method type instead.";
4074             }
4075              
4076             # Set up column map
4077 0         0 my %map;
4078              
4079 0 0       0 my $ft_meta = $ft_class->meta
4080             or Carp::croak "Missing metadata for foreign object class $ft_class";
4081              
4082 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
4083             {
4084 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
4085 0         0 my $foreign_method = $ft_meta->column_mutator_method_name($foreign_column);
4086              
4087 0         0 $map{$foreign_method} = $self->$local_method();
4088              
4089             # Comment this out to allow null keys
4090 0 0       0 unless(defined $map{$foreign_method})
4091             {
4092 0         0 keys(%$ft_columns); # reset iterator
4093 0         0 $self->error("Could add set objects via $name() - the " .
4094             "$local_method attribute is undefined");
4095 0         0 return;
4096             }
4097             }
4098              
4099 0         0 my $objects = __args_to_objects($self, $key, $ft_class, \$ft_pk, \@_);
4100              
4101 0         0 my($db, $started_new_tx, $error);
4102              
4103             TRY:
4104             {
4105 0         0 local $@;
  0         0  
4106              
4107             eval
4108 0         0 {
4109 0         0 $db = $self->db;
4110              
4111 0         0 my $ret = $db->begin_work;
4112              
4113 0 0       0 unless(defined $ret)
4114             {
4115 0         0 die 'Could not begin transaction during call to $name() - ',
4116             $db->error;
4117             }
4118              
4119 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
4120              
4121             # Add all the new objects
4122 0         0 foreach my $object (@$objects)
4123             {
4124             # Map object to parent
4125 0         0 $object->init(%map, db => $db);
4126              
4127             # If the object is not marked as already existing in the database,
4128             # see if it represents an existing row. If it does, merge the
4129             # existing row's column values into the object, allowing any
4130             # modified columns in the object to take precedence. Returns true
4131             # if the object represents an existing row.
4132 0 0       0 if(__check_and_merge($object))
4133             {
4134 0 0       0 $object->save(changes_only => 1) or die $object->error;
4135             }
4136             else
4137             {
4138 0 0       0 $object->save or die $object->error;
4139             }
4140             }
4141              
4142             # Clear the existing list, forcing it to be reloaded next time
4143             # it's asked for
4144 0         0 $self->{$key} = undef;
4145              
4146 0 0       0 if($started_new_tx)
4147             {
4148 0 0       0 $db->commit or die $db->error;
4149             }
4150             };
4151              
4152 0         0 $error = $@;
4153             }
4154              
4155 0 0       0 if($error)
4156             {
4157 0 0       0 $self->error(ref $error ? $error : "Could not add $name - $error");
4158 0 0 0     0 $db->rollback if($db && $started_new_tx);
4159 0         0 $meta->handle_error($self);
4160 0         0 return;
4161             }
4162              
4163 0         0 return @$objects;
4164 0         0 };
4165             }
4166             elsif($interface eq 'add_on_save')
4167             {
4168 4 50       13 unless($relationship)
4169             {
4170 0         0 Carp::confess "Cannot make 'add_on_save' method $name without relationship argument";
4171             }
4172              
4173 4         12 my $rel_name = $relationship->name;
4174              
4175             $methods{$name} = sub
4176             {
4177 0     0   0 my($self) = shift;
4178              
4179 0 0       0 unless(@_)
4180             {
4181 0         0 $self->error("No $name to add");
4182 0 0       0 return wantarray ? () : 0;
4183             }
4184              
4185             # Add all the new objects
4186 0         0 my $objects = __args_to_objects($self, $key, $ft_class, \$ft_pk, \@_);
4187              
4188             # Add the objects to the list, if it's defined
4189 0 0       0 if(defined $self->{$key})
4190             {
4191 0         0 my $db = $self->db;
4192              
4193             # Set up column map
4194 0         0 my %map;
4195              
4196 0 0       0 my $ft_meta = $ft_class->meta
4197             or Carp::croak "Missing metadata for foreign object class $ft_class";
4198              
4199 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
4200             {
4201 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
4202 0         0 my $foreign_method = $ft_meta->column_mutator_method_name($foreign_column);
4203              
4204 0         0 $map{$foreign_method} = $self->$local_method();
4205             }
4206              
4207             # Map all the objects to the parent
4208 0         0 foreach my $object (@$objects)
4209             {
4210 0 0       0 $object->init(%map, ($share_db ? (db => $db) : ()));
4211             }
4212              
4213             # Add the objects
4214 0         0 push(@{$self->{$key}}, @$objects);
  0         0  
4215             }
4216              
4217             my $add_code = sub
4218             {
4219 0         0 my($self, $args) = @_;
4220              
4221             # Set up column map
4222 0         0 my %map;
4223              
4224 0 0       0 my $ft_meta = $ft_class->meta
4225             or Carp::croak "Missing metadata for foreign object class $ft_class";
4226              
4227 0         0 while(my($local_column, $foreign_column) = each(%$ft_columns))
4228             {
4229 0         0 my $local_method = $meta->column_accessor_method_name($local_column);
4230 0         0 my $foreign_method = $ft_meta->column_mutator_method_name($foreign_column);
4231              
4232 0         0 $map{$foreign_method} = $self->$local_method();
4233              
4234             # Comment this out to allow null keys
4235 0 0       0 unless(defined $map{$foreign_method})
4236             {
4237 0         0 keys(%$ft_columns); # reset iterator
4238 0         0 die $self->error("Could not add objects via $name() - the " .
4239             "$local_method attribute is undefined");
4240             }
4241             }
4242              
4243 0         0 my $db = $self->db;
4244              
4245             # Add all the objects.
4246 0         0 foreach my $object (@{$self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'}{'objects'}})
  0         0  
4247             {
4248             # Map object to parent
4249 0         0 $object->init(%map, db => $db);
4250              
4251             # If the object is not marked as already existing in the database,
4252             # see if it represents an existing row. If it does, merge the
4253             # existing row's column values into the object, allowing any
4254             # modified columns in the object to take precedence. Returns true
4255             # if the object represents an existing row.
4256 0 0       0 if(__check_and_merge($object))
4257             {
4258 0 0       0 $object->save(%$args, changes_only => 1) or die $object->error;
4259             }
4260             else
4261             {
4262 0 0       0 $object->save(%$args) or die $object->error;
4263             }
4264             }
4265              
4266             # Blank the attribute, causing the objects to be fetched from
4267             # the db next time, if there's a custom sort order or if
4268             # the list is defined but empty
4269             $self->{$key} = undef if(defined $mgr_args->{'sort_by'} ||
4270 0 0 0     0 (defined $self->{$key} && !@{$self->{$key}}));
  0   0     0  
4271              
4272 0         0 return 1;
4273 0         0 };
4274              
4275 0   0     0 my $stash = $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'} ||= {};
4276              
4277 0         0 push(@{$stash->{'objects'}}, @$objects);
  0         0  
4278 0         0 $stash->{'code'} = $add_code;
4279              
4280 0         0 return @$objects;
4281 4         39 };
4282             }
4283 0         0 else { Carp::croak "Unknown interface: $interface" }
4284              
4285 12         79 return \%methods;
4286             }
4287              
4288             # XXX: These are duplicated from ManyToMany.pm because I don't want to use()
4289             # XXX: that module from here if I don't have to. Lazy or foolish? Hm.
4290             # XXX: Anyway, make sure they stay in sync!
4291 61     61   818 use constant MAP_RECORD_METHOD => 'map_record';
  61         191  
  61         6366  
4292 61     61   2223 use constant DEFAULT_REL_KEY => PRIVATE_PREFIX . '_default_rel_key';
  61         228  
  61         527493  
4293              
4294             our %Made_Map_Record_Method;
4295              
4296             sub objects_by_map
4297             {
4298 46     46 1 3322 my($class, $name, $args, $options) = @_;
4299              
4300 46         82 my %methods;
4301              
4302 46   33     125 my $key = $args->{'hash_key'} || $name;
4303 46   50     116 my $interface = $args->{'interface'} || 'get_set';
4304 46 50       138 my $target_class = $options->{'target_class'} or die "Missing target class";
4305              
4306 46 50       137 my $relationship = $args->{'relationship'} or die "Missing relationship";
4307 46         117 my $rel_name = $relationship->name;
4308 46 50       121 my $map_class = $args->{'map_class'} or die "Missing map class";
4309 46   50     177 weaken(my $map_meta = $map_class->meta or die "Missing meta for $map_class");
4310 46         96 my $map_from = $args->{'map_from'};
4311 46         78 my $map_to = $args->{'map_to'};
4312 46         89 my $map_manager = $args->{'manager_class'};
4313 46   50     161 my $map_method = $args->{'manager_method'} || 'get_objects';
4314 46   100     149 my $mgr_args = $args->{'manager_args'} || {};
4315 46   50     168 my $query_args = $args->{'query_args'} || [];
4316              
4317 46 50       88 push(@$query_args, @{$args->{'join_args'} || []});
  46         170  
4318              
4319 46   50     167 my $count_method = $args->{'manager_count_method'} || 'get_objects_count';
4320              
4321 46 50       150 if($mgr_args->{'query'})
4322             {
4323 0         0 Carp::croak "Cannot use the key 'query' in the manager_args parameter ",
4324             "hash. Use the separate query_args parameter instead";
4325             }
4326              
4327 46         88 my($map_to_class, $map_to_meta, $map_to_method);
4328              
4329 46   50     151 my $map_delete_method = $args->{'map_delete_method'} || 'delete_objects';
4330              
4331             #if(@$query_args % 2 != 0)
4332             #{
4333             # Carp::croak "Odd number of arguments passed in query_args parameter";
4334             #}
4335              
4336 46 50       126 unless($map_manager)
4337             {
4338 46         83 $map_manager = 'Rose::DB::Object::Manager';
4339 46         118 $mgr_args->{'object_class'} = $map_class;
4340             }
4341              
4342 46         140 my $meta = $target_class->meta;
4343 46   50     125 my $share_db = $args->{'share_db'} || 1;
4344              
4345             # "map" is the map table, "self" is the $target_class, and "remote"
4346             # is the foreign object class
4347 46         160 my(%map_column_to_self_method,
4348             %map_column_to_self_column,
4349             %map_method_to_remote_method);
4350              
4351             # Also grab the foreign object class that the mapper points to,
4352             # the relationship name that points back to us, and the class
4353             # name of the objects we really want to fetch.
4354 46         0 my($require_objects, $local_rel, $foreign_class, %seen_fk);
4355              
4356 46         150 foreach my $item ($map_meta->foreign_keys, $map_meta->relationships)
4357             {
4358             # Track which foreign keys we've seen
4359 184 100       1391 if($item->isa('Rose::DB::Object::Metadata::ForeignKey'))
    50          
4360             {
4361 92         275 $seen_fk{$item->id}++;
4362             }
4363             elsif($item->isa('Rose::DB::Object::Metadata::Relationship'))
4364             {
4365             # Skip a relationship if we've already seen the equivalent foreign key
4366 92 50       253 next if($seen_fk{$item->id});
4367             }
4368              
4369 92 100 66     1261 if($item->can('class') && $item->class eq $target_class)
4370             {
4371             # Skip if there was an explicit local relationship name and
4372             # this is not that name.
4373 46 50 66     173 unless($map_from && $item->name ne $map_from)
4374             {
4375 46 50       105 if(%map_column_to_self_method)
4376             {
4377 0         0 Carp::croak "Map class $map_class has more than one foreign key ",
4378             "and/or 'many to one' relationship that points to the ",
4379             "class $target_class. Please specify one by name ",
4380             "with a 'local' parameter in the 'map' hash";
4381             }
4382              
4383 46         120 $map_from = $local_rel = $item->name;
4384              
4385 46 50       228 my $map_columns =
4386             $item->can('column_map') ? $item->column_map : $item->key_columns;
4387              
4388             # "local" and "foreign" here are relative to the *mapper* class
4389 46         389 while(my($local_column, $foreign_column) = each(%$map_columns))
4390             {
4391 46 50       152 my $foreign_method = $meta->column_accessor_method_name($foreign_column)
4392             or Carp::croak "Missing accessor method for column '$foreign_column'",
4393             " in class ", $meta->class;
4394 46         179 $map_column_to_self_method{$local_column} = $foreign_method;
4395 46         221 $map_column_to_self_column{$local_column} = $foreign_column;
4396             }
4397              
4398 46         113 next;
4399             }
4400             }
4401              
4402 46 50 33     174 if($item->isa('Rose::DB::Object::Metadata::ForeignKey') ||
4403             $item->type eq 'many to one')
4404             {
4405             # Skip if there was an explicit foreign relationship name and
4406             # this is not that name.
4407 46 50 66     201 next if($map_to && $item->name ne $map_to);
4408              
4409 46         117 $map_to = $item->name;
4410              
4411 46 50       121 if($require_objects)
4412             {
4413 0         0 Carp::croak "Map class $map_class has more than one foreign key ",
4414             "and/or 'many to one' relationship that points to a ",
4415             "class other than $target_class. Please specify one ",
4416             "by name with a 'foreign' parameter in the 'map' hash";
4417             }
4418              
4419 46         94 $map_to_class = $item->class;
4420 46         156 $map_to_meta = $map_to_class->meta;
4421              
4422 46 50       188 my $map_columns =
4423             $item->can('column_map') ? $item->column_map : $item->key_columns;
4424              
4425             # "local" and "foreign" here are relative to the *mapper* class
4426 46         342 while(my($local_column, $foreign_column) = each(%$map_columns))
4427             {
4428 46 50       130 my $local_method = $map_meta->column_accessor_method_name($local_column)
4429             or Carp::croak "Missing accessor method for column '$local_column'",
4430             " in class ", $map_meta->class;
4431              
4432 46 50       129 my $foreign_method = $map_to_meta->column_accessor_method_name($foreign_column)
4433             or Carp::croak "Missing accessor method for column '$foreign_column'",
4434             " in class ", $map_to_meta->class;
4435              
4436             # local foreign
4437             # Map:color_id => Color:id
4438 46         238 $map_method_to_remote_method{$local_method} = $foreign_method;
4439             }
4440              
4441 46         130 $require_objects = [ $item->name ];
4442 46         136 $foreign_class = $item->class;
4443 46   33     150 $map_to_method = $item->method_name('get_set') ||
4444             $item->method_name('get_set_now') ||
4445             $item->method_name('get_set_on_save') ||
4446             Carp::confess "No 'get_*' method found for ",
4447             $item->name;
4448             }
4449             }
4450              
4451 46 50       631 unless(%map_column_to_self_method)
4452             {
4453 0         0 Carp::croak "Could not find a foreign key or 'many to one' relationship ",
4454             "in $map_class that points to $target_class";
4455             }
4456              
4457 46 50       113 unless(%map_column_to_self_column)
4458             {
4459 0   0     0 Carp::croak "Could not find a foreign key or 'many to one' relationship ",
4460             "in $map_class that points to ", ($map_to_class || $map_to);
4461             }
4462              
4463 46 50       111 unless($require_objects)
4464             {
4465             # Make a second attempt to find a suitable foreign relationship in the
4466             # map class, this time looking for links back to $target_class so long as
4467             # it's a different relationship than the one used in the local link.
4468 0         0 foreach my $item ($map_meta->foreign_keys, $map_meta->relationships)
4469             {
4470             # Skip a relationship if we've already seen the equivalent foreign key
4471 0 0       0 if($item->isa('Rose::DB::Object::Metadata::Relationship'))
4472             {
4473 0 0       0 next if($seen_fk{$item->id});
4474             }
4475              
4476 0 0 0     0 if(($item->isa('Rose::DB::Object::Metadata::ForeignKey') ||
      0        
      0        
4477             $item->type eq 'many to one') &&
4478             $item->class eq $target_class && $item->name ne $local_rel)
4479             {
4480 0 0       0 if($require_objects)
4481             {
4482 0         0 Carp::croak "Map class $map_class has more than two foreign keys ",
4483             "and/or 'many to one' relationships that points to a ",
4484             "$target_class. Please specify which ones to use ",
4485             "by including 'local' and 'foreign' parameters in the ",
4486             "'map' hash";
4487             }
4488              
4489 0         0 $require_objects = [ $item->name ];
4490 0         0 $foreign_class = $item->class;
4491 0   0     0 $map_to_method = $item->method_name('get_set') ||
4492             $item->method_name('get_set_now') ||
4493             $item->method_name('get_set_on_save') ||
4494             Carp::confess "No 'get_*' method found for ",
4495             $item->name;
4496             }
4497             }
4498             }
4499              
4500 46 50       97 unless($require_objects)
4501             {
4502 0         0 Carp::croak "Could not find a foreign key or 'many to one' relationship ",
4503             "in $map_class that points to a class other than $target_class"
4504             }
4505              
4506             # Populate relationship with the info we've extracted
4507 46         183 $relationship->column_map(\%map_column_to_self_column);
4508 46         671 $relationship->map_from($map_from);
4509 46         108 $relationship->map_to($map_to);
4510 46         140 $relationship->foreign_class($foreign_class);
4511              
4512             # Relationship names
4513 46   33     111 $map_to ||= $require_objects->[0];
4514 46   33     93 $map_from ||= $local_rel;
4515              
4516             # This var will old the name of the primary key column in the foreign
4517             # class, provided that there is only one column in that key.
4518 46         74 my $ft_pk;
4519              
4520             # Pre-process sort_by args to map unqualified column names to the
4521             # leaf-node table rather than the map table.
4522 46 50       146 if(my $sort_by = $mgr_args->{'sort_by'})
4523             {
4524 0         0 my $table = $foreign_class->meta->table;
4525              
4526 0 0       0 foreach my $sort (ref $sort_by ? @$sort_by : $sort_by)
4527             {
4528 0         0 $sort =~ s/^(['"`]?)\w+\1(?:\s+(?:ASC|DESC))?$/$table.$sort/;
4529             }
4530              
4531 0         0 $mgr_args->{'sort_by'} = $sort_by;
4532             }
4533              
4534 46         98 my $map_record_method = $relationship->map_record_method;
4535              
4536 46 100       135 unless($map_record_method)
4537             {
4538 36 50       104 if($map_record_method = $mgr_args->{'with_map_records'})
4539             {
4540 0 0 0     0 if($map_record_method && $map_record_method eq '1')
4541             {
4542 0         0 $map_record_method = MAP_RECORD_METHOD;
4543             }
4544             }
4545             }
4546              
4547 46 100       112 if($map_record_method)
4548             {
4549 10 100 66     85 if($map_to_class->can($map_record_method) &&
4550             (my $info = $Made_Map_Record_Method{"${map_to_class}::$map_record_method"}))
4551             {
4552 9 100 66     44 unless($info->{'rel_class'} eq $target_class &&
4553             $info->{'rel_name'} eq $relationship->name)
4554             {
4555 1         325 Carp::croak "Already made a map record method named $map_record_method in ",
4556             "class $map_to_class on behalf of the relationship ",
4557             "'$info->{'rel_name'}' in class $info->{'rel_class'}. ",
4558             "Please choose another name for the map record method for ",
4559             "the relationship named '", $relationship->name, "' in $target_class.";
4560             }
4561             }
4562              
4563 9         54 require Rose::DB::Object::Metadata::Relationship::ManyToMany;
4564              
4565 9 100       37 unless($map_to_class->can($map_record_method))
4566             {
4567 1         8 Rose::DB::Object::Metadata::Relationship::ManyToMany::make_map_record_method(
4568             $map_to_class, $map_record_method, $map_class);
4569              
4570 1         13 $Made_Map_Record_Method{"${map_to_class}::$map_record_method"} =
4571             {
4572             rel_class => $target_class,
4573             rel_name => $relationship->name,
4574             };
4575             }
4576             }
4577              
4578 45 50       154 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
4579             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
4580              
4581 45 100 66     347 if($interface eq 'find' || $interface eq 'iterator')
    50 33        
    50          
    50          
    100          
    50          
    50          
4582             {
4583 15         88 my $cache_key = PRIVATE_PREFIX . ":$interface:$name";
4584              
4585 15 50       43 my $is_iterator = $interface eq 'iterator' ? 1 : 0;
4586              
4587 15 50 33     51 if($is_iterator && $map_method eq 'get_objects')
4588             {
4589 0         0 $map_method = 'get_objects_iterator';
4590             }
4591              
4592             $methods{$name} = sub
4593             {
4594 0     0   0 my($self) = shift;
4595              
4596 0         0 my %args;
4597              
4598 0 0       0 if(my $ref = ref $_[0])
4599             {
4600 0 0       0 if($ref eq 'HASH')
    0          
4601             {
4602 0         0 %args = (query => [ %{shift(@_)} ], @_);
  0         0  
4603             }
4604             elsif(ref $_[0] eq 'ARRAY')
4605             {
4606 0         0 %args = (query => shift, @_);
4607             }
4608             }
4609 0         0 else { %args = @_ }
4610              
4611 0 0       0 if(delete $args{'from_cache'})
4612             {
4613 0 0       0 if(keys %args)
4614             {
4615 0         0 Carp::croak "Additional parameters not allowed in call to ",
4616             "$name() with from_cache parameter";
4617             }
4618              
4619 0 0       0 if(defined $self->{$cache_key})
4620             {
4621 0 0       0 return wantarray ? @{$self->{$cache_key}} : $self->{$cache_key};
  0         0  
4622             }
4623             }
4624              
4625 0         0 my %join_map_to_self;
4626              
4627 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
4628             {
4629 0         0 $join_map_to_self{$map_column} = $self->$self_method();
4630              
4631             # Comment this out to allow null keys
4632 0 0       0 unless(defined $join_map_to_self{$map_column})
4633             {
4634 0         0 keys(%map_column_to_self_method); # reset iterator
4635 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
4636             "$self_method attribute is undefined");
4637 0         0 return;
4638             }
4639             }
4640              
4641 0         0 my $objs;
4642              
4643 0         0 my $cache = delete $args{'cache'};
4644              
4645             # Merge query args
4646 0 0       0 my @query = (%join_map_to_self, @$query_args, @{delete $args{'query'} || []});
  0         0  
4647              
4648             # Merge the rest of the arguments
4649 0         0 foreach my $param (keys %args)
4650             {
4651 0 0       0 if(exists $mgr_args->{$param})
4652             {
4653 0         0 my $ref = ref $args{$param};
4654              
4655 0 0       0 if($ref eq 'ARRAY')
    0          
4656             {
4657 0         0 unshift(@{$args{$param}}, ref $mgr_args->{$param} ?
4658 0 0       0 @{$mgr_args->{$param}} : $mgr_args->{$param});
  0         0  
4659             }
4660             elsif($ref eq 'HASH')
4661             {
4662 0         0 while(my($k, $v) = each(%{$mgr_args->{$param}}))
  0         0  
4663             {
4664 0 0       0 $args{$param}{$k} = $v unless(exists $args{$param}{$k});
4665             }
4666             }
4667             }
4668             }
4669              
4670 0         0 while(my($k, $v) = each(%$mgr_args))
4671             {
4672 0 0       0 $args{$k} = $v unless(exists $args{$k});
4673             }
4674              
4675 0         0 my $error;
4676              
4677             TRY:
4678             {
4679 0         0 local $@;
  0         0  
4680              
4681             eval
4682 0         0 {
4683 0 0       0 if($share_db)
4684             {
4685 0         0 $objs =
4686             $map_manager->$map_method(query => \@query,
4687             require_objects => $require_objects,
4688             %args, db => $self->db);
4689             }
4690             else
4691             {
4692 0         0 $objs =
4693             $map_manager->$map_method(query => \@query,
4694             require_objects => $require_objects,
4695             db => $self->db, share_db => 0,
4696             %args);
4697             }
4698             };
4699              
4700 0         0 $error = $@;
4701             }
4702              
4703 0 0 0     0 if($error || !$objs)
4704             {
4705 0   0     0 my $msg = $error || $map_manager->error;
4706 0 0       0 $self->error(ref $msg ? $msg : "Could not find $foreign_class objects - $msg");
4707 0         0 $self->meta->handle_error($self);
4708 0 0       0 return wantarray ? () : $objs;
4709             }
4710              
4711 0 0       0 if($map_record_method)
    0          
4712             {
4713             $objs =
4714             [
4715             map
4716             {
4717 0         0 my $map_rec = $_;
  0         0  
4718 0         0 my $o = $map_rec->$map_to_method();
4719              
4720             # This should work too, if we want to keep the ref
4721             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
4722             #{
4723             # weaken($map_rec->{$map_to} = $o);
4724             #}
4725              
4726             # Ditch the map record's reference to the foreign object
4727 0         0 delete $map_rec->{$map_to};
4728 0         0 $o->$map_record_method($map_rec);
4729 0         0 $o;
4730             }
4731             @$objs
4732             ];
4733             }
4734             elsif($is_iterator)
4735             {
4736 0         0 my $next_code = $objs->_next_code;
4737              
4738             my $post_proc = sub
4739             {
4740 0         0 my($self, $map_object) = @_;
4741 0         0 return $map_object->$map_to();
4742 0         0 };
4743              
4744             $objs->_next_code
4745             (
4746             sub
4747             {
4748 0         0 my $self = shift;
4749 0         0 my $object = $next_code->($self, @_);
4750 0 0       0 return $object unless($object);
4751 0         0 return $post_proc->($self, $object);
4752             }
4753 0         0 );
4754              
4755 0         0 return $objs;
4756             }
4757             else
4758             {
4759             $objs =
4760             [
4761             map
4762             {
4763             # This should work too, if we want to keep the ref
4764             #my $map_rec = $_;
4765             #my $o = $map_rec->$map_to_method();
4766             #
4767             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
4768             #{
4769             # weaken($map_rec->{$map_to} = $o);
4770             #}
4771             #
4772             #$o;
4773              
4774             # Ditch the map record's reference to the foreign object
4775 0         0 my $o = $_->$map_to_method();
  0         0  
4776 0         0 $_->$map_to_method(undef);
4777 0         0 $o;
4778             }
4779             @$objs
4780             ];
4781             }
4782              
4783 0 0       0 $self->{$cache_key} = $objs if($cache);
4784              
4785 0 0       0 return wantarray ? @$objs: $objs;
4786 15         236 };
4787             }
4788             elsif($interface eq 'count')
4789             {
4790 0         0 my $cache_key = PRIVATE_PREFIX . '_' . $name;
4791              
4792             $methods{$name} = sub
4793             {
4794 0     0   0 my($self) = shift;
4795              
4796 0         0 my %args;
4797              
4798 0 0       0 if(my $ref = ref $_[0])
4799             {
4800 0 0       0 if($ref eq 'HASH')
    0          
4801             {
4802 0         0 %args = (query => [ %{shift(@_)} ], @_);
  0         0  
4803             }
4804             elsif(ref $_[0] eq 'ARRAY')
4805             {
4806 0         0 %args = (query => shift, @_);
4807             }
4808             }
4809 0         0 else { %args = @_ }
4810              
4811 0 0       0 if(delete $args{'from_cache'})
4812             {
4813 0 0       0 if(keys %args)
4814             {
4815 0         0 Carp::croak "Additional parameters not allowed in call to ",
4816             "$name() with from_cache parameter";
4817             }
4818              
4819 0 0       0 if(defined $self->{$cache_key})
4820             {
4821 0 0       0 return wantarray ? @{$self->{$cache_key}} : $self->{$cache_key};
  0         0  
4822             }
4823             }
4824              
4825 0         0 my %join_map_to_self;
4826              
4827 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
4828             {
4829 0         0 $join_map_to_self{$map_column} = $self->$self_method();
4830              
4831             # Comment this out to allow null keys
4832 0 0       0 unless(defined $join_map_to_self{$map_column})
4833             {
4834 0         0 keys(%map_column_to_self_method); # reset iterator
4835 0         0 $self->error("Could not count indirect objects via $name() - the " .
4836             "$self_method attribute is undefined");
4837 0         0 return;
4838             }
4839             }
4840              
4841 0         0 my $cache = delete $args{'cache'};
4842              
4843             # Merge query args
4844 0 0       0 my @query = (%join_map_to_self, @$query_args, @{delete $args{'query'} || []});
  0         0  
4845              
4846             # Merge the rest of the arguments
4847 0         0 foreach my $param (keys %args)
4848             {
4849 0 0       0 if(exists $mgr_args->{$param})
4850             {
4851 0         0 my $ref = ref $args{$param};
4852              
4853 0 0       0 if($ref eq 'ARRAY')
    0          
4854             {
4855 0         0 unshift(@{$args{$param}}, ref $mgr_args->{$param} ?
4856 0 0       0 @{$mgr_args->{$param}} : $mgr_args->{$param});
  0         0  
4857             }
4858             elsif($ref eq 'HASH')
4859             {
4860 0         0 while(my($k, $v) = each(%{$mgr_args->{$param}}))
  0         0  
4861             {
4862 0 0       0 $args{$param}{$k} = $v unless(exists $args{$param}{$k});
4863             }
4864             }
4865             }
4866             }
4867              
4868 0         0 while(my($k, $v) = each(%$mgr_args))
4869             {
4870 0 0       0 $args{$k} = $v unless(exists $args{$k});
4871             }
4872              
4873 0         0 $args{'multi_many_ok'} = 1;
4874              
4875 0         0 my($count, $error);
4876              
4877             TRY:
4878             {
4879 0         0 local $@;
  0         0  
4880              
4881             eval
4882 0         0 {
4883 0 0       0 if($share_db)
4884             {
4885 0         0 $count =
4886             $map_manager->$count_method(query => \@query,
4887             require_objects => $require_objects,
4888             %$mgr_args, db => $self->db);
4889             }
4890             else
4891             {
4892 0         0 $count =
4893             $map_manager->$count_method(query => \@query,
4894             require_objects => $require_objects,
4895             db => $self->db, share_db => 0,
4896             %$mgr_args);
4897             }
4898             };
4899              
4900 0         0 $error = $@;
4901             }
4902              
4903 0 0 0     0 if($error || !defined $count)
4904             {
4905 0   0     0 my $msg = $error || $map_manager->error;
4906 0 0       0 $self->error(ref $msg ? $msg : "Could not count $foreign_class objects - $msg");
4907 0         0 $self->meta->handle_error($self);
4908 0         0 return $count;
4909             }
4910              
4911 0 0       0 $self->{$cache_key} = $count if($cache);
4912              
4913 0         0 return $count;
4914 0         0 };
4915             }
4916             elsif($interface eq 'get_set' || $interface eq 'get_set_load')
4917             {
4918             $methods{$name} = sub
4919             {
4920 0     0   0 my($self) = shift;
4921              
4922 0 0       0 if(@_)
4923             {
4924 0 0 0     0 return $self->{$key} = undef if(@_ == 1 && !defined $_[0]);
4925 0         0 $self->{$key} = __args_to_objects($self, $key, $foreign_class, \$ft_pk, \@_);
4926 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
4927             }
4928              
4929 0 0       0 if(defined $self->{$key})
4930             {
4931 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
4932             }
4933              
4934 0         0 my %join_map_to_self;
4935              
4936 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
4937             {
4938 0         0 $join_map_to_self{$map_column} = $self->$self_method();
4939              
4940             # Comment this out to allow null keys
4941 0 0       0 unless(defined $join_map_to_self{$map_column})
4942             {
4943 0         0 keys(%map_column_to_self_method); # reset iterator
4944 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
4945             "$self_method attribute is undefined");
4946 0         0 return;
4947             }
4948             }
4949              
4950 0         0 my $objs;
4951              
4952 0 0       0 if($share_db)
4953             {
4954 0         0 $objs =
4955             $map_manager->$map_method(query => [ %join_map_to_self, @$query_args ],
4956             require_objects => $require_objects,
4957             %$mgr_args, db => $self->db);
4958             }
4959             else
4960             {
4961 0         0 $objs =
4962             $map_manager->$map_method(query => [ %join_map_to_self, @$query_args ],
4963             require_objects => $require_objects,
4964             db => $self->db, share_db => 0,
4965             %$mgr_args);
4966             }
4967              
4968 0 0       0 unless($objs)
4969             {
4970 0         0 my $error = $map_manager->error;
4971 0 0       0 $self->error(ref $error ? $error : ("Could not load $foreign_class " .
4972             "objects via map class $map_class - $error"));
4973 0 0       0 return wantarray ? () : $objs;
4974             }
4975              
4976 0 0       0 if($map_record_method)
4977             {
4978             $self->{$key} =
4979             [
4980             map
4981             {
4982 0         0 my $map_rec = $_;
  0         0  
4983 0         0 my $o = $map_rec->$map_to_method();
4984              
4985             # This should work too, if we want to keep the ref
4986             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
4987             #{
4988             # weaken($map_rec->{$map_to} = $o);
4989             #}
4990              
4991             # Ditch the map record's reference to the foreign object
4992 0         0 delete $map_rec->{$map_to};
4993 0         0 $o->$map_record_method($map_rec);
4994 0         0 $o;
4995             }
4996             @$objs
4997             ];
4998             }
4999             else
5000             {
5001             $self->{$key} =
5002             [
5003             map
5004             {
5005             # This should work too, if we want to keep the ref
5006             #my $map_rec = $_;
5007             #my $o = $map_rec->$map_to_method();
5008             #
5009             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
5010             #{
5011             # weaken($map_rec->{$map_to} = $o);
5012             #}
5013             #
5014             #$o;
5015              
5016             # Ditch the map record's reference to the foreign object
5017 0         0 my $o = $_->$map_to_method();
  0         0  
5018 0         0 $_->$map_to_method(undef);
5019 0         0 $o;
5020             }
5021             @$objs
5022             ];
5023             }
5024              
5025 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5026 0         0 };
5027              
5028 0 0       0 if($interface eq 'get_set_load')
5029             {
5030 0   0     0 my $method_name = $args->{'load_method'} || 'load_' . $name;
5031              
5032             $methods{$method_name} = sub
5033             {
5034 0 0   0   0 return (defined shift->$name(@_)) ? 1 : 0;
5035 0         0 };
5036             }
5037             }
5038             elsif($interface eq 'get_set_now')
5039             {
5040             $methods{$name} = sub
5041             {
5042 0     0   0 my($self) = shift;
5043              
5044 0 0       0 if(@_)
5045             {
5046             # If loading, just assign
5047 0 0       0 if($self->{STATE_LOADING()})
5048             {
5049 0 0 0     0 return $self->{$key} = undef if(@_ == 1 && !defined $_[0]);
5050 0 0 0     0 return $self->{$key} = (@_ == 1 && ref $_[0] eq 'ARRAY') ? $_[0] : [@_];
5051             }
5052              
5053             # Can't set until the object is saved
5054 0 0       0 unless($self->{STATE_IN_DB()})
5055             {
5056 0         0 Carp::croak "Can't set $name() until this object is loaded or saved";
5057             }
5058              
5059             # Set to undef resets the attr
5060 0 0 0     0 if(@_ == 1 && !defined $_[0])
5061             {
5062             # Delete any pending set or add actions
5063 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
5064 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
5065              
5066 0         0 $self->{$key} = undef;
5067 0         0 return;
5068             }
5069              
5070             # Set up join conditions and map record connections
5071 0         0 my(%join_map_to_self, # map column => self value
5072             %method_map_to_self); # map method => self value
5073              
5074 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
5075             {
5076 0         0 my $map_method = $map_meta->column_accessor_method_name($map_column);
5077              
5078 0         0 $method_map_to_self{$map_method} = $join_map_to_self{$map_column} =
5079             $self->$self_method();
5080              
5081             # Comment this out to allow null keys
5082 0 0       0 unless(defined $join_map_to_self{$map_column})
5083             {
5084 0         0 keys(%map_column_to_self_method); # reset iterator
5085 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
5086             "$self_method attribute is undefined");
5087 0         0 return;
5088             }
5089             }
5090              
5091 0         0 my($db, $started_new_tx, $error);
5092              
5093             TRY:
5094             {
5095 0         0 local $@;
  0         0  
5096              
5097             eval
5098 0         0 {
5099 0         0 $db = $self->db;
5100              
5101 0         0 my $ret = $db->begin_work;
5102              
5103 0 0       0 unless(defined $ret)
5104             {
5105 0         0 die 'Could not begin transaction during call to $name() - ',
5106             $db->error;
5107             }
5108              
5109 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
5110              
5111             # Delete any existing objects
5112 0         0 my $deleted =
5113             $map_manager->$map_delete_method(object_class => $map_class,
5114             where => [ %join_map_to_self ],
5115             db => $db);
5116 0 0       0 die $map_manager->error unless(defined $deleted);
5117              
5118             # Save all the new objects
5119 0         0 my $objects = __args_to_objects($self, $key, $foreign_class, \$ft_pk, \@_);
5120              
5121 0         0 foreach my $object (@$objects)
5122             {
5123             # It's essential to share the db so that the code
5124             # below can see the delete (above) which happened in
5125             # the current transaction
5126 0         0 $object->db($db);
5127              
5128 0 0       0 $object->{STATE_IN_DB()} = 0 if($deleted);
5129              
5130             # If the object is not marked as already existing in the database,
5131             # see if it represents an existing row. If it does, merge the
5132             # existing row's column values into the object, allowing any
5133             # modified columns in the object to take precedence. Returns true
5134             # if the object represents an existing row.
5135 0 0       0 if(__check_and_merge($object))
5136             {
5137 0 0       0 $object->save or die $object->error;
5138             }
5139             else
5140             {
5141 0 0       0 $object->save or die $object->error;
5142             }
5143              
5144             # Not sharing? Aw.
5145 0 0       0 $object->db(undef) unless($share_db);
5146              
5147 0         0 my $map_record;
5148              
5149             # Create or retrieve map record, connected to self
5150 0 0       0 if($map_record_method)
5151             {
5152 0         0 $map_record = $object->$map_record_method();
5153              
5154 0 0       0 if($map_record)
5155             {
5156 0 0       0 if($map_record->{STATE_IN_DB()})
5157             {
5158 0         0 foreach my $method ($map_record->meta->primary_key_column_mutator_names)
5159             {
5160 0         0 $map_record->$method(undef);
5161             }
5162              
5163 0         0 $map_record->{STATE_IN_DB()} = 0;
5164             }
5165             }
5166             else
5167             {
5168 0         0 $map_record = $map_class->new;
5169             }
5170              
5171 0         0 $map_record->init(%method_map_to_self, db => $db);
5172             }
5173             else
5174             {
5175 0         0 $map_record = $map_class->new(%method_map_to_self, db => $db);
5176             }
5177              
5178             # Connect map record to remote object
5179 0         0 while(my($map_method, $remote_method) = each(%map_method_to_remote_method))
5180             {
5181 0         0 $map_record->$map_method($object->$remote_method);
5182             }
5183              
5184 0         0 my $in_db = $map_record->{STATE_IN_DB()};
5185              
5186             # Try to load the map record if doesn't appear to exist already
5187 0 0       0 unless($in_db)
5188             {
5189 0         0 my $dbh = $map_record->dbh;
5190              
5191             # It's okay if this fails because the key(s) is/are undefined
5192 0         0 local $dbh->{'PrintError'} = 0;
5193 0         0 eval { $in_db = $map_record->load(speculative => 1) };
  0         0  
5194              
5195 0 0       0 if(my $error = $@)
5196             {
5197             # ...but re-throw all other errors
5198 0 0 0     0 unless(UNIVERSAL::isa($error, 'Rose::DB::Object::Exception') &&
5199             $error->code == EXCEPTION_CODE_NO_KEY)
5200             {
5201 0         0 die $error;
5202             }
5203             }
5204             }
5205              
5206             # Save the map record, if necessary
5207 0 0       0 unless($in_db)
5208             {
5209 0 0       0 $map_record->save or die $map_record->error;
5210             }
5211             }
5212              
5213             # Assign to attribute or blank the attribute, causing the objects
5214             # to be fetched from the db next time, depending on whether or not
5215             # there's a custom sort order
5216 0 0       0 $self->{$key} = defined $mgr_args->{'sort_by'} ? undef : $objects;
5217              
5218 0 0       0 if($started_new_tx)
5219             {
5220 0 0       0 $db->commit or die $db->error;
5221             }
5222              
5223             # Delete any pending set or add actions
5224 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
5225 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
5226             };
5227              
5228 0         0 $error = $@;
5229             }
5230              
5231 0 0       0 if($error)
5232             {
5233 0 0       0 $self->error(ref $error ? $error : "Could not set $name objects - $error");
5234 0 0 0     0 $db->rollback if($db && $started_new_tx);
5235 0         0 $meta->handle_error($self);
5236 0         0 return undef;
5237             }
5238              
5239 0 0       0 return 1 unless(defined $self->{$key});
5240 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5241             }
5242              
5243             # Return existing list of objects, if it exists
5244 0 0       0 if(defined $self->{$key})
5245             {
5246 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5247             }
5248              
5249 0         0 my %join_map_to_self;
5250              
5251 0         0 while(my($local_column, $foreign_method) = each(%map_column_to_self_method))
5252             {
5253 0         0 $join_map_to_self{$local_column} = $self->$foreign_method();
5254              
5255             # Comment this out to allow null keys
5256 0 0       0 unless(defined $join_map_to_self{$local_column})
5257             {
5258 0         0 keys(%map_column_to_self_method); # reset iterator
5259 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
5260             "$foreign_method attribute is undefined");
5261 0         0 return;
5262             }
5263             }
5264              
5265 0         0 my $objs;
5266              
5267 0 0       0 if($share_db)
5268             {
5269 0         0 $objs =
5270             $map_manager->$map_method(query => [ %join_map_to_self, @$query_args ],
5271             require_objects => $require_objects,
5272             %$mgr_args, db => $self->db);
5273             }
5274             else
5275             {
5276 0         0 $objs =
5277             $map_manager->$map_method(query => [ %join_map_to_self, @$query_args ],
5278             require_objects => $require_objects,
5279             db => $self->db, share_db => 0,
5280             %$mgr_args);
5281             }
5282              
5283 0 0       0 unless($objs)
5284             {
5285 0         0 my $error = $map_manager->error;
5286 0 0       0 $self->error(ref $error ? $error : ("Could not load $foreign_class " .
5287             "objects via map class $map_class - $error"));
5288 0 0       0 return wantarray ? () : $objs;
5289             }
5290              
5291 0 0       0 if($map_record_method)
5292             {
5293             $self->{$key} =
5294             [
5295             map
5296             {
5297 0         0 my $map_rec = $_;
  0         0  
5298 0         0 my $o = $map_rec->$map_to_method();
5299              
5300             # This should work too, if we want to keep the ref
5301             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
5302             #{
5303             # weaken($map_rec->{$map_to} = $o);
5304             #}
5305              
5306             # Ditch the map record's reference to the foreign object
5307 0         0 delete $map_rec->{$map_to};
5308 0         0 $o->$map_record_method($map_rec);
5309 0         0 $o;
5310             }
5311             @$objs
5312             ];
5313             }
5314             else
5315             {
5316             $self->{$key} =
5317             [
5318             map
5319             {
5320             # This works too, if we want to keep the ref
5321             #my $map_rec = $_;
5322             #my $o = $map_rec->$map_to_method();
5323             #
5324             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
5325             #{
5326             # weaken($map_rec->{$map_to} = $o);
5327             #}
5328             #
5329             #$o;
5330              
5331             # Ditch the map record's reference to the foreign object
5332 0         0 my $o = $_->$map_to_method();
  0         0  
5333 0         0 $_->$map_to_method(undef);
5334 0         0 $o;
5335             }
5336             @$objs
5337             ];
5338             }
5339              
5340 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5341 0         0 };
5342             }
5343             elsif($interface eq 'get_set_on_save')
5344             {
5345             $methods{$name} = sub
5346             {
5347 0     0   0 my($self) = shift;
5348              
5349 0 0       0 if(@_)
5350             {
5351             # If loading, just assign
5352 0 0       0 if($self->{STATE_LOADING()})
5353             {
5354 0 0 0     0 return $self->{$key} = undef if(@_ == 1 && !defined $_[0]);
5355 0 0 0     0 return $self->{$key} = (@_ == 1 && ref $_[0] eq 'ARRAY') ? $_[0] : [@_];
5356             }
5357              
5358             # Set to undef resets the attr
5359 0 0 0     0 if(@_ == 1 && !defined $_[0])
5360             {
5361             # Delete any pending set or add actions
5362 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
5363 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
5364              
5365 0         0 $self->{$key} = undef;
5366 0         0 return;
5367             }
5368              
5369             # Get all the new objects
5370 0         0 my $objects = __args_to_objects($self, $key, $foreign_class, \$ft_pk, \@_);
5371              
5372             # Set the attribute
5373 0         0 $self->{$key} = $objects;
5374              
5375             my $save_code = sub
5376             {
5377 0         0 my($self, $args) = @_;
5378              
5379             # Set up join conditions and map record connections
5380 0         0 my(%join_map_to_self, # map column => self value
5381             %method_map_to_self); # map method => self value
5382              
5383 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
5384             {
5385 0         0 my $map_method = $map_meta->column_accessor_method_name($map_column);
5386              
5387 0         0 $method_map_to_self{$map_method} = $join_map_to_self{$map_column} =
5388             $self->$self_method();
5389              
5390             # Comment this out to allow null keys
5391 0 0       0 unless(defined $join_map_to_self{$map_column})
5392             {
5393 0         0 keys(%map_column_to_self_method); # reset iterator
5394 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
5395             "$self_method attribute is undefined");
5396 0         0 return;
5397             }
5398             }
5399              
5400 0         0 my $db = $self->db;
5401              
5402             # Delete any existing objects
5403 0         0 my $deleted =
5404             $map_manager->$map_delete_method(object_class => $map_class,
5405             where => [ %join_map_to_self ],
5406             db => $db);
5407 0 0       0 die $map_manager->error unless(defined $deleted);
5408              
5409             # Save all the objects. Use the current list, even if it's
5410             # different than it was when the "set on save" was called.
5411 0 0       0 foreach my $object (@{$self->{$key} || []})
  0         0  
5412             {
5413             # It's essential to share the db so that the code
5414             # below can see the delete (above) which happened in
5415             # the current transaction
5416 0         0 $object->db($db);
5417              
5418             #$object->{STATE_IN_DB()} = 0 if($deleted);
5419              
5420             # If the object is not marked as already existing in the database,
5421             # see if it represents an existing row. If it does, merge the
5422             # existing row's column values into the object, allowing any
5423             # modified columns in the object to take precedence. Returns true
5424             # if the object represents an existing row.
5425 0 0       0 if(__check_and_merge($object))
5426             {
5427 0 0       0 $object->save(%$args, changes_only => 1) or die $object->error;
5428             }
5429             else
5430             {
5431 0 0       0 $object->save(%$args) or die $object->error;
5432             }
5433              
5434             # Not sharing? Aw.
5435 0 0       0 $object->db(undef) unless($share_db);
5436              
5437 0         0 my $map_record;
5438              
5439             # Create or retrieve map record, connected to self
5440 0 0       0 if($map_record_method)
5441             {
5442 0         0 $map_record = $object->$map_record_method();
5443              
5444 0 0       0 if($map_record)
5445             {
5446 0 0       0 if($map_record->{STATE_IN_DB()})
5447             {
5448 0         0 foreach my $method ($map_record->meta->primary_key_column_mutator_names)
5449             {
5450 0         0 $map_record->$method(undef);
5451             }
5452              
5453 0         0 $map_record->{STATE_IN_DB()} = 0;
5454             }
5455             }
5456             else
5457             {
5458 0         0 $map_record = $map_class->new;
5459             }
5460              
5461 0         0 $map_record->init(%method_map_to_self, db => $db);
5462             }
5463             else
5464             {
5465 0         0 $map_record = $map_class->new(%method_map_to_self, db => $db);
5466             }
5467              
5468             # Connect map record to remote object
5469 0         0 while(my($map_method, $remote_method) = each(%map_method_to_remote_method))
5470             {
5471 0         0 $map_record->$map_method($object->$remote_method);
5472             }
5473              
5474 0         0 my $in_db = $map_record->{STATE_IN_DB()};
5475              
5476             # Try to load the map record if doesn't appear to exist already
5477 0 0       0 unless($in_db)
5478             {
5479 0         0 my $dbh = $map_record->dbh;
5480              
5481 0         0 my $error;
5482              
5483             TRY:
5484             {
5485 0         0 local $@;
  0         0  
5486             # It's okay if this fails because the key(s) is/are undefined
5487 0         0 local $dbh->{'PrintError'} = 0;
5488 0         0 eval { $in_db = $map_record->load(speculative => 1) };
  0         0  
5489 0         0 $error = $@;
5490             }
5491              
5492 0 0       0 if($error)
5493             {
5494             # ...but re-throw all other errors
5495 0 0 0     0 unless(UNIVERSAL::isa($error, 'Rose::DB::Object::Exception') &&
5496             $error->code == EXCEPTION_CODE_NO_KEY)
5497             {
5498 0         0 die $error;
5499             }
5500             }
5501             }
5502              
5503             # Save the map record, if necessary
5504 0 0       0 unless($in_db)
5505             {
5506 0 0       0 $map_record->save(%$args) or die $map_record->error;
5507             }
5508             }
5509              
5510             # Forget about any adds if we just set the list
5511 0 0       0 if(defined $self->{$key})
5512             {
5513             # Set to undef instead of deleting because this code ref
5514             # will be called while iterating over this very hash.
5515 0         0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'} = undef;
5516             }
5517              
5518             # Blank the attribute, causing the objects to be fetched from
5519             # the db next time, if there's a custom sort order or if
5520             # the list is defined but empty
5521             $self->{$key} = undef if(defined $mgr_args->{'sort_by'} ||
5522 0 0 0     0 (defined $self->{$key} && !@{$self->{$key}}));
  0   0     0  
5523              
5524 0         0 return 1;
5525 0         0 };
5526              
5527 0         0 $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'} = $save_code;
5528              
5529 0 0       0 return 1 unless(defined $self->{$key});
5530 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5531             }
5532              
5533             # Return existing list of objects, if it exists
5534 0 0       0 if(defined $self->{$key})
5535             {
5536 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5537             }
5538              
5539 0         0 my %join_map_to_self;
5540              
5541 0         0 while(my($local_column, $foreign_method) = each(%map_column_to_self_method))
5542             {
5543 0         0 $join_map_to_self{$local_column} = $self->$foreign_method();
5544              
5545             # Comment this out to allow null keys
5546 0 0       0 unless(defined $join_map_to_self{$local_column})
5547             {
5548 0         0 keys(%map_column_to_self_method); # reset iterator
5549 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
5550             "$foreign_method attribute is undefined");
5551 0         0 return;
5552             }
5553             }
5554              
5555 0         0 my $objs;
5556              
5557 0 0       0 if($share_db)
5558             {
5559 0         0 $objs =
5560             $map_manager->$map_method(query => [ %join_map_to_self, @$query_args ],
5561             require_objects => $require_objects,
5562             %$mgr_args, db => $self->db);
5563             }
5564             else
5565             {
5566 0         0 $objs =
5567             $map_manager->$map_method(query => [ %join_map_to_self, @$query_args ],
5568             require_objects => $require_objects,
5569             db => $self->db, share_db => 0,
5570             %$mgr_args);
5571             }
5572              
5573 0 0       0 unless($objs)
5574             {
5575 0         0 my $error = $map_manager->error;
5576 0 0       0 $self->error(ref $error ? $error : ("Could not load $foreign_class " .
5577             "objects via map class $map_class - $error"));
5578 0 0       0 return wantarray ? () : $objs;
5579             }
5580              
5581 0 0       0 if($map_record_method)
5582             {
5583             $self->{$key} =
5584             [
5585             map
5586             {
5587 0         0 my $map_rec = $_;
  0         0  
5588 0         0 my $o = $map_rec->$map_to_method();
5589              
5590             # This should work too, if we want to keep the ref
5591             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
5592             #{
5593             # weaken($map_rec->{$map_to} = $o);
5594             #}
5595              
5596             # Ditch the map record's reference to the foreign object
5597 0         0 delete $map_rec->{$map_to};
5598 0         0 $o->$map_record_method($map_rec);
5599 0         0 $o;
5600             }
5601             @$objs
5602             ];
5603             }
5604             else
5605             {
5606             $self->{$key} =
5607             [
5608             map
5609             {
5610             # This works too, if we want to keep the ref
5611             #my $map_rec = $_;
5612             #my $o = $map_rec->$map_to_method();
5613             #
5614             #if(refaddr($map_rec->{$map_to}) == refaddr($o))
5615             #{
5616             # weaken($map_rec->{$map_to} = $o);
5617             #}
5618             #
5619             #$o;
5620              
5621             # Ditch the map record's reference to the foreign object
5622 0         0 my $o = $_->$map_to_method();
  0         0  
5623 0         0 $_->$map_to_method(undef);
5624 0         0 $o;
5625             }
5626             @$objs
5627             ];
5628             }
5629              
5630 0 0       0 return wantarray ? @{$self->{$key}} : $self->{$key};
  0         0  
5631 15         258 };
5632             }
5633             elsif($interface eq 'add_now')
5634             {
5635             $methods{$name} = sub
5636             {
5637 0     0   0 my($self) = shift;
5638              
5639 0 0       0 unless(@_)
5640             {
5641 0         0 $self->error("No $name to add");
5642 0 0       0 return wantarray ? () : 0;
5643             }
5644              
5645             # Can't set until the object is saved
5646 0 0       0 unless($self->{STATE_IN_DB()})
5647             {
5648 0         0 Carp::croak "Can't add $name until this object is loaded or saved";
5649             }
5650              
5651 0 0       0 if($self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'})
5652             {
5653 0         0 Carp::croak "Cannot add objects via the 'add_now' method $name() ",
5654             "because the list of objects is already going to be ".
5655             "set to something else on save. Use the 'add_on_save' ",
5656             "method type instead.";
5657             }
5658              
5659             # Set up join conditions and map record connections
5660 0         0 my(%join_map_to_self, # map column => self value
5661             %method_map_to_self); # map method => self value
5662              
5663 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
5664             {
5665 0         0 my $map_method = $map_meta->column_accessor_method_name($map_column);
5666              
5667 0         0 $method_map_to_self{$map_method} = $join_map_to_self{$map_column} =
5668             $self->$self_method();
5669              
5670             # Comment this out to allow null keys
5671 0 0       0 unless(defined $join_map_to_self{$map_column})
5672             {
5673 0         0 keys(%map_column_to_self_method); # reset iterator
5674 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
5675             "$self_method attribute is undefined");
5676 0         0 return;
5677             }
5678             }
5679              
5680 0         0 my $objects = __args_to_objects($self, $key, $foreign_class, \$ft_pk, \@_);
5681              
5682 0         0 my($db, $started_new_tx, $error);
5683              
5684             TRY:
5685             {
5686 0         0 local $@;
  0         0  
5687              
5688             eval
5689 0         0 {
5690 0         0 $db = $self->db;
5691              
5692 0         0 my $ret = $db->begin_work;
5693              
5694 0 0       0 unless(defined $ret)
5695             {
5696 0         0 die 'Could not begin transaction during call to $name() - ',
5697             $db->error;
5698             }
5699              
5700 0 0       0 $started_new_tx = ($ret == IN_TRANSACTION) ? 0 : 1;
5701              
5702             # Add all the new objects
5703 0         0 foreach my $object (@$objects)
5704             {
5705             # It's essential to share the db so that the code
5706             # below can see the delete (above) which happened in
5707             # the current transaction
5708 0         0 $object->db($db);
5709              
5710             # If the object is not marked as already existing in the database,
5711             # see if it represents an existing row. If it does, merge the
5712             # existing row's column values into the object, allowing any
5713             # modified columns in the object to take precedence. Returns true
5714             # if the object represents an existing row.
5715 0 0       0 if(__check_and_merge($object))
5716             {
5717 0 0       0 $object->save(changes_only => 1) or die $object->error;
5718             }
5719             else
5720             {
5721 0 0       0 $object->save or die $object->error;
5722             }
5723              
5724             # Not sharing? Aw.
5725 0 0       0 $object->db(undef) unless($share_db);
5726              
5727             # Create map record, connected to self
5728 0         0 my $map_record = $map_class->new(%method_map_to_self, db => $db);
5729              
5730             # Connect map record to remote object
5731 0         0 while(my($map_method, $remote_method) = each(%map_method_to_remote_method))
5732             {
5733 0         0 $map_record->$map_method($object->$remote_method);
5734             }
5735              
5736 0         0 my $in_db = $map_record->{STATE_IN_DB()};
5737              
5738             # Try to load the map record if doesn't appear to exist already
5739 0 0       0 unless($in_db)
5740             {
5741 0         0 my $dbh = $map_record->dbh;
5742              
5743             # It's okay if this fails because the key(s) is/are undefined
5744 0         0 local $dbh->{'PrintError'} = 0;
5745 0         0 eval { $in_db = $map_record->load(speculative => 1) };
  0         0  
5746              
5747 0 0       0 if(my $error = $@)
5748             {
5749             # ...but re-throw all other errors
5750 0 0 0     0 unless(UNIVERSAL::isa($error, 'Rose::DB::Object::Exception') &&
5751             $error->code == EXCEPTION_CODE_NO_KEY)
5752             {
5753 0         0 die $error;
5754             }
5755             }
5756             }
5757              
5758             # Save the map record, if necessary
5759 0 0       0 unless($in_db)
5760             {
5761 0 0       0 $map_record->save or die $map_record->error;
5762             }
5763             }
5764              
5765             # Clear the existing list, forcing it to be reloaded next time
5766             # it's asked for
5767 0         0 $self->{$key} = undef;
5768              
5769 0 0       0 if($started_new_tx)
5770             {
5771 0 0       0 $db->commit or die $db->error;
5772             }
5773              
5774             # Delete any pending set or add actions
5775 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'set'};
5776 0         0 delete $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'};
5777             };
5778              
5779 0         0 $error = $@;
5780             }
5781              
5782 0 0       0 if($error)
5783             {
5784 0 0       0 $self->error(ref $error ? $error : "Could not add $name objects - $error");
5785 0 0 0     0 $db->rollback if($db && $started_new_tx);
5786 0         0 $meta->handle_error($self);
5787 0         0 return;
5788             }
5789              
5790 0         0 return @$objects;
5791 0         0 };
5792             }
5793             elsif($interface eq 'add_on_save')
5794             {
5795             $methods{$name} = sub
5796             {
5797 0     0   0 my($self) = shift;
5798              
5799 0 0       0 unless(@_)
5800             {
5801 0         0 $self->error("No $name to add");
5802 0 0       0 return wantarray ? () : 0;
5803             }
5804              
5805             # Get all the new objects
5806 0         0 my $objects = __args_to_objects($self, $key, $foreign_class, \$ft_pk, \@_);
5807              
5808             # Add the objects to the list, if it's defined
5809 0 0       0 if(defined $self->{$key})
5810             {
5811 0         0 push(@{$self->{$key}}, @$objects);
  0         0  
5812             }
5813              
5814             my $add_code = sub
5815             {
5816 0         0 my($self, $args) = @_;
5817              
5818             # Set up join conditions and map record connections
5819 0         0 my(%join_map_to_self, # map column => self value
5820             %method_map_to_self); # map method => self value
5821              
5822 0         0 while(my($map_column, $self_method) = each(%map_column_to_self_method))
5823             {
5824 0         0 my $map_method = $map_meta->column_accessor_method_name($map_column);
5825              
5826 0         0 $method_map_to_self{$map_method} = $join_map_to_self{$map_column} =
5827             $self->$self_method();
5828              
5829             # Comment this out to allow null keys
5830 0 0       0 unless(defined $join_map_to_self{$map_column})
5831             {
5832 0         0 keys(%map_column_to_self_method); # reset iterator
5833 0         0 $self->error("Could not fetch indirect objects via $name() - the " .
5834             "$self_method attribute is undefined");
5835 0         0 return;
5836             }
5837             }
5838              
5839 0         0 my $db = $self->db;
5840              
5841             # Add all the objects.
5842 0         0 foreach my $object (@{$self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'}{'objects'}})
  0         0  
5843             {
5844             # It's essential to share the db so that the code
5845             # below can see the delete (above) which happened in
5846             # the current transaction
5847 0         0 $object->db($db);
5848              
5849             # If the object is not marked as already existing in the database,
5850             # see if it represents an existing row. If it does, merge the
5851             # existing row's column values into the object, allowing any
5852             # modified columns in the object to take precedence. Returns true
5853             # if the object represents an existing row.
5854 0 0       0 if(__check_and_merge($object))
5855             {
5856 0 0       0 $object->save(%$args, changes_only => 1) or die $object->error;
5857             }
5858             else
5859             {
5860 0 0       0 $object->save(%$args) or die $object->error;
5861             }
5862              
5863             # Not sharing? Aw.
5864 0 0       0 $object->db(undef) unless($share_db);
5865              
5866             # Create map record, connected to self
5867 0         0 my $map_record = $map_class->new(%method_map_to_self, db => $db);
5868              
5869             # Connect map record to remote object
5870 0         0 while(my($map_method, $remote_method) = each(%map_method_to_remote_method))
5871             {
5872 0         0 $map_record->$map_method($object->$remote_method);
5873             }
5874              
5875 0         0 my $in_db = $map_record->{STATE_IN_DB()};
5876              
5877             # Try to load the map record if doesn't appear to exist already
5878 0 0       0 unless($in_db)
5879             {
5880 0         0 my $dbh = $map_record->dbh;
5881              
5882              
5883 0         0 my $error;
5884              
5885             TRY:
5886             {
5887 0         0 local $@;
  0         0  
5888              
5889             # It's okay if this fails because the key(s) is/are undefined...
5890 0         0 local $dbh->{'PrintError'} = 0;
5891              
5892             eval
5893 0         0 {
5894 0 0       0 if($map_record->load(speculative => 1))
5895             {
5896             # (Re)connect map record to self
5897 0         0 $map_record->init(%method_map_to_self);
5898              
5899             # (Re)connect map record to remote object
5900 0         0 while(my($map_method, $remote_method) = each(%map_method_to_remote_method))
5901             {
5902 0         0 $map_record->$map_method($object->$remote_method);
5903             }
5904             }
5905             };
5906              
5907 0         0 $error = $@;
5908             }
5909              
5910 0 0       0 if($error)
5911             {
5912             # ...but re-throw all other errors
5913 0 0 0     0 unless(UNIVERSAL::isa($error, 'Rose::DB::Object::Exception') &&
5914             $error->code == EXCEPTION_CODE_NO_KEY)
5915             {
5916 0         0 die $error;
5917             }
5918             }
5919             }
5920              
5921             # Save changes to map record
5922 0 0       0 $map_record->save(changes_only => 1) or die $map_record->error;
5923             }
5924              
5925             # Blank the attribute, causing the objects to be fetched from
5926             # the db next time, if there's a custom sort order or if
5927             # the list is defined but empty
5928             $self->{$key} = undef if(defined $mgr_args->{'sort_by'} ||
5929 0 0 0     0 (defined $self->{$key} && !@{$self->{$key}}));
  0   0     0  
5930              
5931 0         0 return 1;
5932 0         0 };
5933              
5934 0   0     0 my $stash = $self->{ON_SAVE_ATTR_NAME()}{'post'}{'rel'}{$rel_name}{'add'} ||= {};
5935              
5936 0         0 push(@{$stash->{'objects'}}, @$objects);
  0         0  
5937 0         0 $stash->{'code'} = $add_code;
5938              
5939 0         0 return @$objects;
5940 15         166 };
5941             }
5942 0         0 else { Carp::croak "Unknown interface: $interface" }
5943              
5944 45         403 return \%methods;
5945             }
5946              
5947             sub __args_to_objects
5948             {
5949 0     0   0 my($self, $name, $object_class, $pk_name, $args) = @_;
5950              
5951 0 0 0     0 if(@$args == 1 && ref $args->[0] eq 'ARRAY')
5952             {
5953 0         0 $args = $args->[0];
5954             }
5955              
5956 0 0       0 unless(defined $$pk_name)
5957             {
5958 0         0 my @cols = $object_class->meta->primary_key_column_names;
5959              
5960 0 0       0 if(@cols == 1)
5961             {
5962 0         0 $$pk_name = $cols[0];
5963             }
5964             else
5965             {
5966 0         0 $$pk_name = 0;
5967             }
5968             }
5969              
5970 0         0 my @objects;
5971              
5972 0         0 foreach my $arg (@$args)
5973             {
5974             # Already an object
5975 0 0       0 if(UNIVERSAL::isa($arg, $object_class))
5976             {
5977 0         0 push(@objects, $arg);
5978             }
5979             else
5980             {
5981 0         0 my $ref = ref $arg;
5982              
5983 0 0 0     0 if($ref eq 'HASH')
    0          
5984             {
5985 0         0 push(@objects, $object_class->new(%$arg));
5986             }
5987             elsif(!$ref && $pk_name)
5988             {
5989 0         0 push(@objects, $object_class->new($$pk_name => $arg));
5990             }
5991             else
5992             {
5993 0         0 Carp::croak "Invalid $name argument: $arg";
5994             }
5995             }
5996             }
5997              
5998 0         0 return \@objects;
5999             }
6000              
6001             sub __args_to_object
6002             {
6003 0     0   0 my($self, $name, $object_class, $pk_name, $args) = @_;
6004              
6005 0 0       0 unless(defined $$pk_name)
6006             {
6007 0         0 my @cols = $object_class->meta->primary_key_column_names;
6008              
6009 0 0       0 if(@cols == 1)
6010             {
6011 0         0 $$pk_name = $cols[0];
6012             }
6013             else
6014             {
6015 0         0 $$pk_name = 0;
6016             }
6017             }
6018              
6019 0 0       0 if(@$args == 1)
    0          
6020             {
6021 0         0 my $arg = $args->[0];
6022              
6023             # Already an object
6024 0 0       0 if(UNIVERSAL::isa($arg, $object_class))
    0          
    0          
6025             {
6026 0         0 return $arg;
6027             }
6028             elsif(ref $arg eq 'HASH')
6029             {
6030 0         0 return $object_class->new(%$arg);
6031             }
6032             elsif($pk_name)
6033             {
6034 0         0 return $object_class->new($$pk_name => $arg);
6035             }
6036             else
6037             {
6038 0         0 Carp::croak "Invalid $name argument: $arg";
6039             }
6040             }
6041             elsif(@$args % 2 == 0)
6042             {
6043 0         0 return $object_class->new(@$args);
6044             }
6045              
6046 0         0 Carp::croak "Invalid $name argument: @$args";
6047             }
6048              
6049             # If an object is not marked as already existing in the database, see if it
6050             # represents an existing row. If it does, merge the existing row's column
6051             # values into the object, allowing any modified columns in the object to
6052             # take precedence. Returns true if the object represents an existing row.
6053             sub __check_and_merge
6054             {
6055 0     0   0 my($object) = shift;
6056              
6057             # Attempt to load the object if necessary
6058 0 0       0 unless($object->{STATE_IN_DB()})
6059             {
6060 0         0 my $db = $object->db;
6061              
6062             # Make a key-column-only clone of object to test whether
6063             # it represents and existing row, and if it does, to pull
6064             # in any missing column values.
6065              
6066 0         0 my $clone = ref($object)->new(db => $db);
6067              
6068 0         0 Rose::DB::Object::Helpers::init_with_column_value_pairs($clone,
6069             Rose::DB::Object::Helpers::key_column_value_pairs($object));
6070              
6071 0         0 my($ret, $error);
6072              
6073             # Ignore any errors due to missing primary keys
6074             TRY:
6075             {
6076 0         0 local $@;
  0         0  
6077              
6078             eval
6079 0         0 {
6080 0         0 local $db->dbh->{'PrintError'} = 0;
6081 0         0 $ret = $clone->load(speculative => 1);
6082             };
6083              
6084 0         0 $error = $@;
6085             }
6086              
6087 0 0       0 if($error)
6088             {
6089             # ...but re-throw all other errors
6090 0 0 0     0 unless(UNIVERSAL::isa($error, 'Rose::DB::Object::Exception') &&
6091             $error->code == EXCEPTION_CODE_NO_KEY)
6092             {
6093 0         0 die $error;
6094             }
6095             }
6096              
6097             # $object represents and existing row
6098 0 0       0 if($ret)
6099             {
6100 0         0 my $meta = $object->meta;
6101              
6102 0         0 my $pk_present = 0;
6103              
6104 0 0       0 if(%{$object->{MODIFIED_COLUMNS()} || {}})
  0 0       0  
6105             {
6106 0         0 my $pk_columns = $meta->primary_key_column_names;
6107              
6108             # If any primary key columns are set, presume it was used to load()
6109             # and mark all pk columns as not modified
6110 0         0 foreach my $name (@$pk_columns)
6111             {
6112 0 0       0 if($object->{MODIFIED_COLUMNS()}{$name})
6113             {
6114 0         0 $pk_present = 1;
6115 0         0 delete @{$object->{MODIFIED_COLUMNS()}}{@$pk_columns};
  0         0  
6116 0         0 last;
6117             }
6118             }
6119             }
6120              
6121             # Otherwise, mark all key columns as not modified
6122 0 0       0 unless($pk_present)
6123             {
6124 0         0 delete @{$object->{MODIFIED_COLUMNS()}}{$meta->key_column_names};
  0         0  
6125             }
6126              
6127             # Merge the column values from the db into the new $object.
6128 0         0 my %modified = map { $_ => 1 } Rose::DB::Object::Helpers::dirty_columns($object);
  0         0  
6129              
6130             # Simulate loading
6131 0         0 local $object->{STATE_LOADING()} = 1;
6132              
6133             # XXX: Performance cheat
6134 0         0 foreach my $column (@{ $object->meta->columns_ordered })
  0         0  
6135             {
6136             # Values from the db only overwrite unmodified columns.
6137 0 0       0 next if($modified{$column->{'name'}}); # XXX: Performance cheat
6138              
6139 0         0 my $mutator_method = $column->mutator_method_name;
6140 0         0 my $accessor_method = $column->accessor_method_name;
6141              
6142 0         0 $object->$mutator_method($clone->$accessor_method());
6143             }
6144              
6145 0         0 $object->{STATE_IN_DB()} = 1;
6146             }
6147              
6148 0         0 return $ret;
6149             }
6150              
6151 0         0 return 1;
6152             }
6153              
6154             1;
6155              
6156             __END__
6157              
6158             =head1 NAME
6159              
6160             Rose::DB::Object::MakeMethods::Generic - Create generic object methods for Rose::DB::Object-derived objects.
6161              
6162             =head1 SYNOPSIS
6163              
6164             package MyDBObject;
6165              
6166             our @ISA = qw(Rose::DB::Object);
6167              
6168             use Rose::DB::Object::MakeMethods::Generic
6169             (
6170             scalar =>
6171             [
6172             'type' =>
6173             {
6174             with_init => 1,
6175             check_in => [ qw(AA AAA C D) ],
6176             },
6177              
6178             'set_type' => { hash_key => 'type' },
6179             ],
6180              
6181             character =>
6182             [
6183             code => { length => 6 }
6184             ],
6185              
6186             varchar =>
6187             [
6188             name => { length => 10 }
6189             ],
6190              
6191             boolean =>
6192             [
6193             'is_red',
6194             'is_happy' => { default => 1 },
6195             ],
6196             );
6197              
6198             sub init_type { 'C' }
6199             ...
6200              
6201             $obj = MyDBObject->new(...);
6202              
6203             print $obj->type; # C
6204              
6205             $obj->name('Bob'); # set
6206             $obj->set_type('C'); # set
6207             $obj->type('AA'); # set
6208              
6209             $obj->set_type; # Fatal error: no argument passed to "set" method
6210              
6211             $obj->name('C' x 40); # truncate on set
6212             print $obj->name; # 'CCCCCCCCCC'
6213              
6214             $obj->code('ABC'); # pad on set
6215             print $obj->code; # 'ABC '
6216              
6217             eval { $obj->type('foo') }; # fatal error: invalid value
6218              
6219             print $obj->name, ' is ', $obj->type; # get
6220              
6221             $obj->is_red; # returns undef
6222             $obj->is_red('true'); # returns 1 (assuming "true" a
6223             # valid boolean literal according to
6224             # $obj->db->parse_boolean('true'))
6225             $obj->is_red(''); # returns 0
6226             $obj->is_red; # returns 0
6227              
6228             $obj->is_happy; # returns 1
6229              
6230             ...
6231              
6232             package Person;
6233              
6234             our @ISA = qw(Rose::DB::Object);
6235             ...
6236             use Rose::DB::Object::MakeMethods::Generic
6237             (
6238             scalar => 'name',
6239              
6240             set =>
6241             [
6242             'nicknames',
6243             'parts' => { default => [ qw(arms legs) ] },
6244             ],
6245              
6246             # See the Rose::DB::Object::Metadata::Relationship::ManyToMany
6247             # documentation for a more complete example
6248             objects_by_map =>
6249             [
6250             friends =>
6251             {
6252             map_class => 'FriendMap',
6253             manager_args => { sort_by => Friend->meta->table . '.name' },
6254             },
6255             ],
6256             );
6257             ...
6258              
6259             @parts = $person->parts; # ('arms', 'legs')
6260             $parts = $person->parts; # [ 'arms', 'legs' ]
6261              
6262             $person->nicknames('Jack', 'Gimpy'); # set with list
6263             $person->nicknames([ 'Slim', 'Gip' ]); # set with array ref
6264              
6265             print join(', ', map { $_->name } $person->friends);
6266             ...
6267              
6268             package Program;
6269              
6270             our @ISA = qw(Rose::DB::Object);
6271             ...
6272             use Rose::DB::Object::MakeMethods::Generic
6273             (
6274             objects_by_key =>
6275             [
6276             bugs =>
6277             {
6278             class => 'Bug',
6279             key_columns =>
6280             {
6281             # Map Program column names to Bug column names
6282             id => 'program_id',
6283             version => 'version',
6284             },
6285             manager_args =>
6286             {
6287             sort_by => Bug->meta->table . '.date_submitted DESC',
6288             },
6289             query_args => [ state => { ne => 'closed' } ],
6290             },
6291             ]
6292             );
6293             ...
6294              
6295             $prog = Program->new(id => 5, version => '3.0', ...);
6296              
6297             $bugs = $prog->bugs;
6298              
6299             # Calls (essentially):
6300             #
6301             # Rose::DB::Object::Manager->get_objects(
6302             # db => $prog->db, # share_db defaults to true
6303             # object_class => 'Bug',
6304             # query =>
6305             # {
6306             # program_id => 5, # value of $prog->id
6307             # version => '3.0', # value of $prog->version
6308             # state => { ne => 'closed' },
6309             # },
6310             # sort_by => 'date_submitted DESC');
6311              
6312             ...
6313              
6314             package Product;
6315              
6316             our @ISA = qw(Rose::DB::Object);
6317             ...
6318             use Rose::DB::Object::MakeMethods::Generic
6319             (
6320             object_by_key =>
6321             [
6322             category =>
6323             {
6324             class => 'Category',
6325             key_columns =>
6326             {
6327             # Map Product column names to Category column names
6328             category_id => 'id',
6329             },
6330             },
6331             ]
6332             );
6333             ...
6334              
6335             $product = Product->new(id => 5, category_id => 99);
6336              
6337             $category = $product->category;
6338              
6339             # $product->category call is roughly equivalent to:
6340             #
6341             # $cat = Category->new(id => $product->category_id,
6342             # db => $prog->db);
6343             #
6344             # $ret = $cat->load;
6345             # return $ret unless($ret);
6346             # return $cat;
6347              
6348             =head1 DESCRIPTION
6349              
6350             L<Rose::DB::Object::MakeMethods::Generic> is a method maker that inherits from L<Rose::Object::MakeMethods>. See the L<Rose::Object::MakeMethods> documentation to learn about the interface. The method types provided by this module are described below.
6351              
6352             All method types defined by this module are designed to work with objects that are subclasses of (or otherwise conform to the interface of) L<Rose::DB::Object>. In particular, the object is expected to have a L<db|Rose::DB::Object/db> method that returns a L<Rose::DB>-derived object. See the L<Rose::DB::Object> documentation for more details.
6353              
6354             =head1 METHODS TYPES
6355              
6356             =over 4
6357              
6358             =item B<array>
6359              
6360             Create get/set methods for "array" attributes. A "array" column in a database table contains an ordered list of values. Not all databases support an "array" column type. Check the L<Rose::DB|Rose::DB/"DATABASE SUPPORT"> documentation for your database type.
6361              
6362             =over 4
6363              
6364             =item Options
6365              
6366             =over 4
6367              
6368             =item B<default VALUE>
6369              
6370             Determines the default value of the attribute. The value should be a reference to an array.
6371              
6372             =item B<hash_key NAME>
6373              
6374             The key inside the hash-based object to use for the storage of this
6375             attribute. Defaults to the name of the method.
6376              
6377             =item B<interface NAME>
6378              
6379             Choose the interface. The default is C<get_set>.
6380              
6381             =back
6382              
6383             =item Interfaces
6384              
6385             =over 4
6386              
6387             =item B<get_set>
6388              
6389             Creates a get/set method for a "array" object attribute. A "array" column in a database table contains an ordered list of values.
6390              
6391             When setting the attribute, the value is passed through the L<parse_array|Rose::DB::Pg/parse_array> method of the object's L<db|Rose::DB::Object/db> attribute.
6392              
6393             When saving to the database, if the attribute value is defined, the method will pass the attribute value through the L<format_array|Rose::DB::Pg/format_array> method of the object's L<db|Rose::DB::Object/db> attribute before returning it.
6394              
6395             When not saving to the database, the method returns the array as a list in list context, or as a reference to the array in scalar context.
6396              
6397             =item B<get>
6398              
6399             Creates an accessor method for a "array" object attribute. A "array" column in a database table contains an ordered list of values.
6400              
6401             When saving to the database, if the attribute value is defined, the method will pass the attribute value through the L<format_array|Rose::DB::Pg/format_array> method of the object's L<db|Rose::DB::Object/db> attribute before returning it.
6402              
6403             When not saving to the database, the method returns the array as a list in list context, or as a reference to the array in scalar context.
6404              
6405             =item B<set>
6406              
6407             Creates a mutator method for a "array" object attribute. A "array" column in a database table contains an ordered list of values.
6408              
6409             When setting the attribute, the value is passed through the L<parse_array|Rose::DB::Pg/parse_array> method of the object's L<db|Rose::DB::Object/db> attribute.
6410              
6411             When saving to the database, if the attribute value is defined, the method will pass the attribute value through the L<format_array|Rose::DB::Pg/format_array> method of the object's L<db|Rose::DB::Object/db> attribute before returning it.
6412              
6413             When not saving to the database, the method returns the array as a list in list context, or as a reference to the array in scalar context.
6414              
6415             If called with no arguments, a fatal error will occur.
6416              
6417             =back
6418              
6419             =back
6420              
6421             Example:
6422              
6423             package Person;
6424              
6425             our @ISA = qw(Rose::DB::Object);
6426             ...
6427             use Rose::DB::Object::MakeMethods::Generic
6428             (
6429             array =>
6430             [
6431             'nicknames',
6432             set_nicks => { interface => 'set', hash_key => 'nicknames' },
6433             parts => { default => [ qw(arms legs) ] },
6434             ],
6435             );
6436             ...
6437              
6438             @parts = $person->parts; # ('arms', 'legs')
6439             $parts = $person->parts; # [ 'arms', 'legs' ]
6440              
6441             $person->nicknames('Jack', 'Gimpy'); # set with list
6442             $person->nicknames([ 'Slim', 'Gip' ]); # set with array ref
6443              
6444             $person->set_nicks('Jack', 'Gimpy'); # set with list
6445             $person->set_nicks([ 'Slim', 'Gip' ]); # set with array ref
6446              
6447             =item B<bitfield>
6448              
6449             Create get/set methods for bitfield attributes.
6450              
6451             =over 4
6452              
6453             =item Options
6454              
6455             =over 4
6456              
6457             =item B<default VALUE>
6458              
6459             Determines the default value of the attribute.
6460              
6461             =item B<hash_key NAME>
6462              
6463             The key inside the hash-based object to use for the storage of this
6464             attribute. Defaults to the name of the method.
6465              
6466             =item B<interface NAME>
6467              
6468             Choose the interface. The default is C<get_set>.
6469              
6470             =item B<intersects NAME>
6471              
6472             Set the name of the "intersects" method. (See C<with_intersects> below.) Defaults to the bitfield attribute method name with "_intersects" appended.
6473              
6474             =item B<bits INT>
6475              
6476             The number of bits in the bitfield. Defaults to 32.
6477              
6478             =item B<with_intersects BOOL>
6479              
6480             This option is only applicable with the C<get_set> interface.
6481              
6482             If true, create an "intersects" helper method in addition to the C<get_set> method. The intersection method name will be the attribute method name with "_intersects" appended, or the value of the C<intersects> option, if it is passed.
6483              
6484             The "intersects" method will return true if there is any intersection between its arguments and the value of the bitfield attribute (i.e., if L<Bit::Vector>'s L<Intersection|Bit::Vector/Intersection> method returns a value greater than zero), false (but defined) otherwise. Its argument is passed through the L<parse_bitfield|Rose::DB/parse_bitfield> method of the object's L<db|Rose::DB::Object/db> attribute before being tested for intersection. Returns undef if the bitfield is not defined.
6485              
6486             =back
6487              
6488             =item Interfaces
6489              
6490             =over 4
6491              
6492             =item B<get_set>
6493              
6494             Creates a get/set method for a bitfield attribute. When setting the attribute, the value is passed through the L<parse_bitfield|Rose::DB/parse_bitfield> method of the object's L<db|Rose::DB::Object/db> attribute before being assigned.
6495              
6496             When saving to the database, the method will pass the attribute value through the L<format_bitfield|Rose::DB/format_bitfield> method of the object's L<db|Rose::DB::Object/db> attribute before returning it. Otherwise, the value is returned as-is.
6497              
6498             =item B<get>
6499              
6500             Creates an accessor method for a bitfield attribute. When saving to the database, the method will pass the attribute value through the L<format_bitfield|Rose::DB/format_bitfield> method of the object's L<db|Rose::DB::Object/db> attribute before returning it. Otherwise, the value is returned as-is.
6501              
6502             =item B<set>
6503              
6504             Creates a mutator method for a bitfield attribute. When setting the attribute, the value is passed through the L<parse_bitfield|Rose::DB/parse_bitfield> method of the object's L<db|Rose::DB::Object/db> attribute before being assigned.
6505              
6506             When saving to the database, the method will pass the attribute value through the L<format_bitfield|Rose::DB/format_bitfield> method of the object's L<db|Rose::DB::Object/db> attribute before returning it. Otherwise, the value is returned as-is.
6507              
6508             If called with no arguments, a fatal error will occur.
6509              
6510             =back
6511              
6512             =back
6513              
6514             Example:
6515              
6516             package MyDBObject;
6517              
6518             our @ISA = qw(Rose::DB::Object);
6519              
6520             use Rose::DB::Object::MakeMethods::Generic
6521             (
6522             bitfield =>
6523             [
6524             'flags' => { size => 32, default => 2 },
6525             'bits' => { size => 16, with_intersects => 1 },
6526             ],
6527             );
6528              
6529             ...
6530              
6531             print $o->flags->to_Bin; # 00000000000000000000000000000010
6532              
6533             $o->bits('101');
6534              
6535             $o->bits_intersects('100'); # true
6536             $o->bits_intersects('010'); # false
6537              
6538             =item B<boolean>
6539              
6540             Create get/set methods for boolean attributes.
6541              
6542             =over 4
6543              
6544             =item Options
6545              
6546             =over 4
6547              
6548             =item B<default VALUE>
6549              
6550             Determines the default value of the attribute.
6551              
6552             =item B<hash_key NAME>
6553              
6554             The key inside the hash-based object to use for the storage of this
6555             attribute. Defaults to the name of the method.
6556              
6557             =item B<interface NAME>
6558              
6559             Choose the interface. The default is C<get_set>.
6560              
6561             =back
6562              
6563             =item Interfaces
6564              
6565             =over 4
6566              
6567             =item B<get_set>
6568              
6569             Creates a get/set method for a boolean attribute. When setting the attribute, if the value is "true" according to Perl's rules, it is compared to a list of "common" true and false values: 1, 0, 1.0 (with any number of zeros), 0.0 (with any number of zeros), t, true, f, false, yes, no. (All are case-insensitive.) If the value matches, then it is set to true (1) or false (0) accordingly.
6570              
6571             If the value does not match any of those, then it is passed through the L<parse_boolean|Rose::DB/parse_boolean> method of the object's L<db|Rose::DB::Object/db> attribute. If L<parse_boolean|Rose::DB/parse_boolean> returns true (1) or false (0), then the attribute is set accordingly. If L<parse_boolean|Rose::DB/parse_boolean> returns undef, a fatal error will occur. If the value is "false" according to Perl's rules, the attribute is set to zero (0).
6572              
6573             When saving to the database, the method will pass the attribute value through the L<format_boolean|Rose::DB/format_boolean> method of the object's L<db|Rose::DB::Object/db> attribute before returning it. Otherwise, the value is returned as-is.
6574              
6575             =item B<get>
6576              
6577             Creates an accessor method for a boolean attribute. When saving to the database, the method will pass the attribute value through the L<format_boolean|Rose::DB/format_boolean> method of the object's L<db|Rose::DB::Object/db> attribute before returning it. Otherwise, the value is returned as-is.
6578              
6579             =item B<set>
6580              
6581             Creates a mutator method for a boolean attribute. When setting the attribute, if the value is "true" according to Perl's rules, it is compared to a list of "common" true and false values: 1, 0, 1.0 (with any number of zeros), 0.0 (with any number of zeros), t, true, f, false, yes, no. (All are case-insensitive.) If the value matches, then it is set to true (1) or false (0) accordingly.
6582              
6583             If the value does not match any of those, then it is passed through the L<parse_boolean|Rose::DB/parse_boolean> method of the object's L<db|Rose::DB::Object/db> attribute. If L<parse_boolean|Rose::DB/parse_boolean> returns true (1) or false (0), then the attribute is set accordingly. If L<parse_boolean|Rose::DB/parse_boolean> returns undef, a fatal error will occur. If the value is "false" according to Perl's rules, the attribute is set to zero (0).
6584              
6585             If called with no arguments, a fatal error will occur.
6586              
6587             =back
6588              
6589             =back
6590              
6591             Example:
6592              
6593             package MyDBObject;
6594              
6595             our @ISA = qw(Rose::DB::Object);
6596              
6597             use Rose::DB::Object::MakeMethods::Generic
6598             (
6599             boolean =>
6600             [
6601             'is_red',
6602             'is_happy' => { default => 1 },
6603             'set_happy' => { interface => 'set', hash_key => 'is_happy' },
6604             ],
6605             );
6606              
6607             $obj->is_red; # returns undef
6608             $obj->is_red('true'); # returns 1 (assuming "true" a
6609             # valid boolean literal according to
6610             # $obj->db->parse_boolean('true'))
6611             $obj->is_red(''); # returns 0
6612             $obj->is_red; # returns 0
6613              
6614             $obj->is_happy; # returns 1
6615             $obj->set_happy(0); # returns 0
6616             $obj->is_happy; # returns 0
6617              
6618             =item B<character>
6619              
6620             Create get/set methods for fixed-length character string attributes.
6621              
6622             =over 4
6623              
6624             =item Options
6625              
6626             =over 4
6627              
6628             =item B<check_in ARRAYREF>
6629              
6630             A reference to an array of valid values. When setting the attribute, if the new value is not equal (string comparison) to one of the valid values, a fatal error will occur.
6631              
6632             =item B<default VALUE>
6633              
6634             Determines the default value of the attribute.
6635              
6636             =item B<hash_key NAME>
6637              
6638             The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method.
6639              
6640             =item B<init_method NAME>
6641              
6642             The name of the method to call when initializing the value of an undefined attribute. Defaults to the method name with the prefix C<init_> added. This option implies C<with_init>.
6643              
6644             =item B<interface NAME>
6645              
6646             Choose the interface. The default is C<get_set>.
6647              
6648             =item B<length INT>
6649              
6650             The number of characters in the string. Any strings shorter than this will be padded with spaces to meet the length requirement. If length is omitted, the string will be left unmodified.
6651              
6652             =item B<overflow BEHAVIOR>
6653              
6654             Determines the behavior when the value is greater than the number of characters specified by the C<length> option. Valid values for BEHAVIOR are:
6655              
6656             =over 4
6657              
6658             =item B<fatal>
6659              
6660             Throw an exception.
6661              
6662             =item B<truncate>
6663              
6664             Truncate the value to the correct length.
6665              
6666             =item B<warn>
6667              
6668             Print a warning message.
6669              
6670             =back
6671              
6672             =item B<with_init BOOL>
6673              
6674             Modifies the behavior of the C<get_set> and C<get> interfaces. If the attribute is undefined, the method specified by the C<init_method> option is called and the attribute is set to the return value of that
6675             method.
6676              
6677             =back
6678              
6679             =item Interfaces
6680              
6681             =over 4
6682              
6683             =item B<get_set>
6684              
6685             Creates a get/set method for a fixed-length character string attribute. When setting, any strings longer than C<length> will be truncated, and any strings shorter will be padded with spaces to meet the length requirement. If C<length> is omitted, the string will be left unmodified.
6686              
6687             =item B<get>
6688              
6689             Creates an accessor method for a fixed-length character string attribute.
6690              
6691             =item B<set>
6692              
6693             Creates a mutator method for a fixed-length character string attribute. Any strings longer than C<length> will be truncated, and any strings shorter will be padded with spaces to meet the length requirement. If C<length> is omitted, the string will be left unmodified.
6694              
6695             =back
6696              
6697             =back
6698              
6699             Example:
6700              
6701             package MyDBObject;
6702              
6703             our @ISA = qw(Rose::DB::Object);
6704              
6705             use Rose::DB::Object::MakeMethods::Generic
6706             (
6707             character =>
6708             [
6709             'name' => { length => 3 },
6710             ],
6711             );
6712              
6713             ...
6714              
6715             $o->name('John'); # truncates on set
6716             print $o->name; # 'Joh'
6717              
6718             $o->name('A'); # pads on set
6719             print $o->name; # 'A '
6720              
6721             =item B<enum>
6722              
6723             Create get/set methods for enum attributes.
6724              
6725             =over 4
6726              
6727             =item Options
6728              
6729             =over 4
6730              
6731             =item B<default VALUE>
6732              
6733             Determines the default value of the attribute.
6734              
6735             =item B<values ARRAYREF>
6736              
6737             A reference to an array of the enum values. This attribute is required. When setting the attribute, if the new value is not equal (string comparison) to one of the enum values, a fatal error will occur.
6738              
6739             =item B<hash_key NAME>
6740              
6741             The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method.
6742              
6743             =item B<init_method NAME>
6744              
6745             The name of the method to call when initializing the value of an undefined attribute. Defaults to the method name with the prefix C<init_> added. This option implies C<with_init>.
6746              
6747             =item B<interface NAME>
6748              
6749             Choose the interface. The C<get_set> interface is the default.
6750              
6751             =item B<with_init BOOL>
6752              
6753             Modifies the behavior of the C<get_set> and C<get> interfaces. If the attribute is undefined, the method specified by the C<init_method> option is called and the attribute is set to the return value of that
6754             method.
6755              
6756             =back
6757              
6758             =item Interfaces
6759              
6760             =over 4
6761              
6762             =item B<get_set>
6763              
6764             Creates a get/set method for an enum attribute. When called with an argument, the value of the attribute is set. If the value is invalid, a fatal error will occur. The current value of the attribute is returned.
6765              
6766             =item B<get>
6767              
6768             Creates an accessor method for an object attribute that returns the current value of the attribute.
6769              
6770             =item B<set>
6771              
6772             Creates a mutator method for an object attribute. When called with an argument, the value of the attribute is set. If the value is invalid, a fatal error will occur. If called with no arguments, a fatal error will occur.
6773              
6774             =back
6775              
6776             =back
6777              
6778             Example:
6779              
6780             package MyDBObject;
6781              
6782             our @ISA = qw(Rose::DB::Object);
6783              
6784             use Rose::DB::Object::MakeMethods::Generic
6785             (
6786             enum =>
6787             [
6788             type => { values => [ qw(main aux extra) ], default => 'aux' },
6789             stage => { values => [ qw(new std old) ], with_init => 1 },
6790             ],
6791             );
6792              
6793             sub init_stage { 'new' }
6794             ...
6795              
6796             $o = MyDBObject->new(...);
6797              
6798             print $o->type; # aux
6799             print $o->stage; # new
6800              
6801             $o->type('aux'); # set
6802             $o->stage('old'); # set
6803              
6804             eval { $o->type('foo') }; # fatal error: invalid value
6805              
6806             print $o->type, ' is at stage ', $o->stage; # get
6807              
6808             =item B<integer>
6809              
6810             Create get/set methods for integer attributes.
6811              
6812             =over 4
6813              
6814             =item Options
6815              
6816             =over 4
6817              
6818             =item B<default VALUE>
6819              
6820             Determines the default value of the attribute.
6821              
6822             =item B<hash_key NAME>
6823              
6824             The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method.
6825              
6826             =item B<init_method NAME>
6827              
6828             The name of the method to call when initializing the value of an undefined attribute. Defaults to the method name with the prefix C<init_> added. This option implies C<with_init>.
6829              
6830             =item B<interface NAME>
6831              
6832             Choose the interface. The C<get_set> interface is the default.
6833              
6834             =item B<with_init BOOL>
6835              
6836             Modifies the behavior of the C<get_set> and C<get> interfaces. If the attribute is undefined, the method specified by the C<init_method> option is called and the attribute is set to the return value of that method.
6837              
6838             =back
6839              
6840             =item Interfaces
6841              
6842             =over 4
6843              
6844             =item B<get_set>
6845              
6846             Creates a get/set method for an integer object attribute. When called with an argument, the value of the attribute is set. The current value of the attribute is returned.
6847              
6848             =item B<get>
6849              
6850             Creates an accessor method for an integer object attribute that returns the current value of the attribute.
6851              
6852             =item B<set>
6853              
6854             Creates a mutator method for an integer object attribute. When called with an argument, the value of the attribute is set. If called with no arguments, a fatal error will occur.
6855              
6856             =back
6857              
6858             =back
6859              
6860             Example:
6861              
6862             package MyDBObject;
6863              
6864             our @ISA = qw(Rose::DB::Object);
6865              
6866             use Rose::DB::Object::MakeMethods::Generic
6867             (
6868             integer =>
6869             [
6870             code => { default => 99 },
6871             type => { with_init => 1 }
6872             ],
6873             );
6874              
6875             sub init_type { 123 }
6876             ...
6877              
6878             $o = MyDBObject->new(...);
6879              
6880             print $o->code; # 99
6881             print $o->type; # 123
6882              
6883             $o->code(8675309); # set
6884             $o->type(42); # set
6885              
6886              
6887             =item B<objects_by_key>
6888              
6889             Create get/set methods for an array of L<Rose::DB::Object>-derived objects fetched based on a key formed from attributes of the current object.
6890              
6891             =over 4
6892              
6893             =item Options
6894              
6895             =over 4
6896              
6897             =item B<class CLASS>
6898              
6899             The name of the L<Rose::DB::Object>-derived class of the objects to be fetched. This option is required.
6900              
6901             =item B<hash_key NAME>
6902              
6903             The key inside the hash-based object to use for the storage of the fetched objects. Defaults to the name of the method.
6904              
6905             =item B<key_columns HASHREF>
6906              
6907             A reference to a hash that maps column names in the current object to those in the objects to be fetched. This option is required.
6908              
6909             =item B<manager_args HASHREF>
6910              
6911             A reference to a hash of arguments passed to the C<manager_class> when fetching objects. If C<manager_class> defaults to L<Rose::DB::Object::Manager>, the following argument is added to the C<manager_args> hash: C<object_class =E<gt> CLASS>, where CLASS is the value of the C<class> option (see above). If C<manager_args> includes a "sort_by" argument, be sure to prefix each column name with the appropriate table name. (See the L<synopsis|/SYNOPSIS> for examples.)
6912              
6913             =item B<manager_class CLASS>
6914              
6915             The name of the L<Rose::DB::Object::Manager>-derived class used to fetch the objects. The C<manager_method> class method is called on this class. Defaults to L<Rose::DB::Object::Manager>.
6916              
6917             =item B<manager_method NAME>
6918              
6919             The name of the class method to call on C<manager_class> in order to fetch the objects. Defaults to C<get_objects>.
6920              
6921             =item B<manager_count_method NAME>
6922              
6923             The name of the class method to call on C<manager_class> in order to count the objects. Defaults to C<get_objects_count>.
6924              
6925             =item B<interface NAME>
6926              
6927             Choose the interface. The C<get_set> interface is the default.
6928              
6929             =item B<relationship OBJECT>
6930              
6931             The L<Rose::DB::Object::Metadata::Relationship> object that describes the "key" through which the "objects_by_key" are fetched. This is required when using the "add_now", "add_on_save", and "get_set_on_save" interfaces.
6932              
6933             =item B<share_db BOOL>
6934              
6935             If true, the L<db|Rose::DB::Object/db> attribute of the current object is shared with all of the objects fetched. Defaults to true.
6936              
6937             =item B<query_args ARRAYREF>
6938              
6939             A reference to an array of arguments added to the value of the C<query> parameter passed to the call to C<manager_class>'s C<manager_method> class method.
6940              
6941             =back
6942              
6943             =item Interfaces
6944              
6945             =over 4
6946              
6947             =item B<count>
6948              
6949             Creates a method that will attempt to count L<Rose::DB::Object>-derived objects based on a key formed from attributes of the current object, plus any additional parameters passed to the method call. Note that this method counts the objects I<in the database at the time of the call>. This may be different than the number of objects attached to the current object or otherwise in memory.
6950              
6951             Since the objects counted are partially determined by the arguments passed to the method, the count is not retained. It is simply returned. Each call counts the specified objects again, even if the arguments are the same as the previous call.
6952              
6953             If the first argument is a reference to a hash or array, it is converted to a reference to an array (if necessary) and taken as the value of the C<query> parameter. All arguments are passed on to the C<manager_class>'s C<manager_count_method> method, augmented by the key formed from attributes of the current object. Query parameters are added to the existing contents of the C<query> parameter. Other parameters replace existing parameters if the existing values are simple scalars, or augment existing parameters if the existing values are references to hashes or arrays.
6954              
6955             The count may fail for several reasons. The count will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_count_method> method returns undef, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
6956              
6957             If the count succeeds, the number is returned. (If the count finds zero objects, the count will be 0. This is still considered success.)
6958              
6959             =item B<find>
6960              
6961             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects based on a key formed from attributes of the current object, plus any additional parameters passed to the method call. Since the objects fetched are partially determined by the arguments passed to the method, the list of objects is not retained. It is simply returned. Each call fetches the requested objects again, even if the arguments are the same as the previous call.
6962              
6963             If the first argument is a reference to a hash or array, it is converted to a reference to an array (if necessary) and taken as the value of the C<query> parameter. All arguments are passed on to the C<manager_class>'s C<manager_method> method, augmented by the key formed from attributes of the current object. Query parameters are added to the existing contents of the C<query> parameter. Other parameters replace existing parameters if the existing values are simple scalars, or augment existing parameters if the existing values are references to hashes or arrays.
6964              
6965             The fetch may fail for several reasons. The fetch will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_method> method returns false, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
6966              
6967             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
6968              
6969             =item B<iterator>
6970              
6971             Behaves just like B<find> but returns an L<iterator|Rose::DB::Object::Iterator> rather than an array or arrayref.
6972              
6973             =item B<get_set>
6974              
6975             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects based on a key formed from attributes of the current object.
6976              
6977             If passed a single argument of undef, the C<hash_key> used to store the objects is set to undef. Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
6978              
6979             =over 4
6980              
6981             =item * An object of type C<class>.
6982              
6983             =item * A reference to a hash containing method name/value pairs.
6984              
6985             =item * A single scalar primary key value.
6986              
6987             =back
6988              
6989             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
6990              
6991             The list of object is assigned to C<hash_key>. Note that these objects are B<not> added to the database. Use the C<get_set_now> or C<get_set_on_save> interface to do that.
6992              
6993             If called with no arguments and the hash key used to store the list of objects is defined, the list (in list context) or a reference to that array (in scalar context) of objects is returned. Otherwise, the objects are fetched.
6994              
6995             The fetch may fail for several reasons. The fetch will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_method> method returns false, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
6996              
6997             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
6998              
6999             =item B<get_set_now>
7000              
7001             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects based on a key formed from attributes of the current object, and will also save the objects to the database when called with arguments. The objects do not have to already exist in the database; they will be inserted if needed.
7002              
7003             If passed a single argument of undef, the list of objects is set to undef, causing it to be reloaded the next time the method is called with no arguments. (Pass a reference to an empty array to cause all of the existing objects to be deleted from the database.) Any pending C<set_on_save> or C<add_on_save> actions are discarded.
7004              
7005             Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7006              
7007             =over 4
7008              
7009             =item * An object of type C<class>.
7010              
7011             =item * A reference to a hash containing method name/value pairs.
7012              
7013             =item * A single scalar primary key value.
7014              
7015             =back
7016              
7017             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7018              
7019             The list of object is assigned to C<hash_key>, the old objects are deleted from the database, and the new ones are added to the database. Any pending C<set_on_save> or C<add_on_save> actions are discarded.
7020              
7021             When adding each object, if the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7022              
7023             The parent object must have been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d prior to setting the list of objects. If this method is called with arguments before the object has been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d, a fatal error will occur.
7024              
7025             If called with no arguments and the hash key used to store the list of objects is defined, the list (in list context) or a reference to that array (in scalar context) of objects is returned. Otherwise, the objects are fetched.
7026              
7027             The fetch may fail for several reasons. The fetch will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_method> method returns false, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
7028              
7029             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
7030              
7031             =item B<get_set_on_save>
7032              
7033             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects based on a key formed from attributes of the current object, and will also save the objects to the database when the "parent" object is L<save|Rose::DB::Object/save>d. The objects do not have to already exist in the database; they will be inserted if needed.
7034              
7035             If passed a single argument of undef, the list of objects is set to undef, causing it to be reloaded the next time the method is called with no arguments. (Pass a reference to an empty array to cause all of the existing objects to be deleted from the database when the parent is L<save|Rose::DB::Object/save>d.)
7036              
7037             Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7038              
7039             =over 4
7040              
7041             =item * An object of type C<class>.
7042              
7043             =item * A reference to a hash containing method name/value pairs.
7044              
7045             =item * A single scalar primary key value.
7046              
7047             =back
7048              
7049             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7050              
7051             The list of object is assigned to C<hash_key>. The old objects are scheduled to be deleted from the database and the new ones are scheduled to be added to the database when the parent is L<save|Rose::DB::Object/save>d. Any pending C<set_on_save> or C<add_on_save> actions are discarded.
7052              
7053             When adding each object when the parent is L<save|Rose::DB::Object/save>d, if the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7054              
7055             If called with no arguments and the hash key used to store the list of objects is defined, the list (in list context) or a reference to that array (in scalar context) of objects is returned. Otherwise, the objects are fetched.
7056              
7057             The fetch may fail for several reasons. The fetch will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_method> method returns false, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
7058              
7059             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
7060              
7061             =item B<add_now>
7062              
7063             Creates a method that will add to a list of L<Rose::DB::Object>-derived objects that are related to the current object by a key formed from attributes of the current object. The objects do not have to already exist in the database; they will be inserted if needed.
7064              
7065             This method returns the list of objects added when called in list context, and the number of objects added when called in scalar context. If one or more objects could not be added, undef (in scalar context) or an empty list (in list context) is returned and the parent object's L<error|Rose::DB::Object/error> attribute is set.
7066              
7067             If passed an empty list, the method does nothing and the parent object's L<error|Rose::DB::Object/error> attribute is set.
7068              
7069             If passed any arguments, the parent object must have been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d prior to adding to the list of objects. If this method is called with a non-empty list as an argument before the parent object has been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d, a fatal error will occur.
7070              
7071             The argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7072              
7073             =over 4
7074              
7075             =item * An object of type C<class>.
7076              
7077             =item * A reference to a hash containing method name/value pairs.
7078              
7079             =item * A single scalar primary key value.
7080              
7081             =back
7082              
7083             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7084              
7085             These objects are linked to the parent object (by setting the appropriate key attributes) and then added to the database.
7086              
7087             When adding each object, if the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7088              
7089             The parent object's list of related objects is then set to undef, causing the related objects to be reloaded from the database the next time they're needed.
7090              
7091             =item B<add_on_save>
7092              
7093             Creates a method that will add to a list of L<Rose::DB::Object>-derived objects that are related to the current object by a key formed from attributes of the current object. The objects will be added to the database when the parent object is L<save|Rose::DB::Object/save>d. The objects do not have to already exist in the database; they will be inserted if needed.
7094              
7095             This method returns the list of objects to be added when called in list context, and the number of items to be added when called in scalar context.
7096              
7097             If passed an empty list, the method does nothing and the parent object's L<error|Rose::DB::Object/error> attribute is set.
7098              
7099             Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7100              
7101             =over 4
7102              
7103             =item * An object of type C<class>.
7104              
7105             =item * A reference to a hash containing method name/value pairs.
7106              
7107             =item * A single scalar primary key value.
7108              
7109             =back
7110              
7111             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7112              
7113             These objects are linked to the parent object (by setting the appropriate key attributes, whether or not they're defined in the parent object) and are scheduled to be added to the database when the parent object is L<save|Rose::DB::Object/save>d. They are also added to the parent object's current list of related objects, if the list is defined at the time of the call.
7114              
7115             When adding each object when the parent is L<save|Rose::DB::Object/save>d, if the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7116              
7117             =back
7118              
7119             =back
7120              
7121             Example setup:
7122              
7123             # CLASS DB TABLE
7124             # ------- --------
7125             # Program programs
7126             # Bug bugs
7127              
7128             package Program;
7129              
7130             our @ISA = qw(Rose::DB::Object);
7131             ...
7132             # You will almost never call the method-maker directly
7133             # like this. See the Rose::DB::Object::Metadata docs
7134             # for examples of more common usage.
7135             use Rose::DB::Object::MakeMethods::Generic
7136             (
7137             objects_by_key =>
7138             [
7139             find_bugs =>
7140             {
7141             interface => 'find',
7142             class => 'Bug',
7143             key_columns =>
7144             {
7145             # Map Program column names to Bug column names
7146             id => 'program_id',
7147             version => 'version',
7148             },
7149             manager_args => { sort_by => 'date_submitted DESC' },
7150             },
7151              
7152             bugs =>
7153             {
7154             interface => '...', # get_set, get_set_now, get_set_on_save
7155             class => 'Bug',
7156             key_columns =>
7157             {
7158             # Map Program column names to Bug column names
7159             id => 'program_id',
7160             version => 'version',
7161             },
7162             manager_args => { sort_by => 'date_submitted DESC' },
7163             query_args => { state => { ne => 'closed' } },
7164             },
7165              
7166             add_bugs =>
7167             {
7168             interface => '...', # add_now or add_on_save
7169             class => 'Bug',
7170             key_columns =>
7171             {
7172             # Map Program column names to Bug column names
7173             id => 'program_id',
7174             version => 'version',
7175             },
7176             manager_args => { sort_by => 'date_submitted DESC' },
7177             query_args => { state => { ne => 'closed' } },
7178             },
7179             ]
7180             );
7181             ...
7182              
7183             Example - find interface:
7184              
7185             # Read from the programs table
7186             $prog = Program->new(id => 5)->load;
7187              
7188             # Read from the bugs table
7189             $bugs = $prog->find_bugs;
7190              
7191             # Calls (essentially):
7192             #
7193             # Rose::DB::Object::Manager->get_objects(
7194             # db => $prog->db, # share_db defaults to true
7195             # object_class => 'Bug',
7196             # query =>
7197             # [
7198             # program_id => 5, # value of $prog->id
7199             # version => '3.0', # value of $prog->version
7200             # ],
7201             # sort_by => 'date_submitted DESC');
7202              
7203             # Augment query
7204             $bugs = $prog->find_bugs({ state => 'open' });
7205              
7206             # Calls (essentially):
7207             #
7208             # Rose::DB::Object::Manager->get_objects(
7209             # db => $prog->db, # share_db defaults to true
7210             # object_class => 'Bug',
7211             # query =>
7212             # [
7213             # program_id => 5, # value of $prog->id
7214             # version => '3.0', # value of $prog->version
7215             # state => 'open',
7216             # ],
7217             # sort_by => 'date_submitted DESC');
7218             ...
7219              
7220             # Augment query and replace sort_by value
7221             $bugs = $prog->find_bugs(query => [ state => 'defunct' ],
7222             sort_by => 'name');
7223              
7224             # Calls (essentially):
7225             #
7226             # Rose::DB::Object::Manager->get_objects(
7227             # db => $prog->db, # share_db defaults to true
7228             # object_class => 'Bug',
7229             # query =>
7230             # [
7231             # program_id => 5, # value of $prog->id
7232             # version => '3.0', # value of $prog->version
7233             # state => 'defunct',
7234             # ],
7235             # sort_by => 'name');
7236             ...
7237              
7238             Example - get_set interface:
7239              
7240             # Read from the programs table
7241             $prog = Program->new(id => 5)->load;
7242              
7243             # Read from the bugs table
7244             $bugs = $prog->bugs;
7245              
7246             # Calls (essentially):
7247             #
7248             # Rose::DB::Object::Manager->get_objects(
7249             # db => $prog->db, # share_db defaults to true
7250             # object_class => 'Bug',
7251             # query =>
7252             # [
7253             # program_id => 5, # value of $prog->id
7254             # version => '3.0', # value of $prog->version
7255             # state => { ne => 'closed' },
7256             # ],
7257             # sort_by => 'date_submitted DESC');
7258             ...
7259             $prog->version($new_version); # Does not hit the db
7260             $prog->bugs(@new_bugs); # Does not hit the db
7261              
7262             # @new_bugs can contain any mix of these types:
7263             #
7264             # @new_bugs =
7265             # (
7266             # 123, # primary key value
7267             # { id => 456 }, # method name/value pairs
7268             # Bug->new(id => 789), # object
7269             # );
7270              
7271             # Write to the programs table only. The bugs table is not
7272             # updated. See the get_set_now and get_set_on_save method
7273             # types for ways to write to the bugs table.
7274             $prog->save;
7275              
7276             Example - get_set_now interface:
7277              
7278             # Read from the programs table
7279             $prog = Program->new(id => 5)->load;
7280              
7281             # Read from the bugs table
7282             $bugs = $prog->bugs;
7283              
7284             $prog->name($new_name); # Does not hit the db
7285              
7286             # Writes to the bugs table, deleting existing bugs and
7287             # replacing them with @new_bugs (which must be an array
7288             # of Bug objects, either existing or new)
7289             $prog->bugs(@new_bugs);
7290              
7291             # @new_bugs can contain any mix of these types:
7292             #
7293             # @new_bugs =
7294             # (
7295             # 123, # primary key value
7296             # { id => 456 }, # method name/value pairs
7297             # Bug->new(id => 789), # object
7298             # );
7299              
7300             # Write to the programs table
7301             $prog->save;
7302              
7303             Example - get_set_on_save interface:
7304              
7305             # Read from the programs table
7306             $prog = Program->new(id => 5)->load;
7307              
7308             # Read from the bugs table
7309             $bugs = $prog->bugs;
7310              
7311             $prog->name($new_name); # Does not hit the db
7312             $prog->bugs(@new_bugs); # Does not hit the db
7313              
7314             # @new_bugs can contain any mix of these types:
7315             #
7316             # @new_bugs =
7317             # (
7318             # 123, # primary key value
7319             # { id => 456 }, # method name/value pairs
7320             # Bug->new(id => 789), # object
7321             # );
7322              
7323             # Write to the programs table and the bugs table, deleting any
7324             # existing bugs and replacing them with @new_bugs (which must be
7325             # an array of Bug objects, either existing or new)
7326             $prog->save;
7327              
7328             Example - add_now interface:
7329              
7330             # Read from the programs table
7331             $prog = Program->new(id => 5)->load;
7332              
7333             # Read from the bugs table
7334             $bugs = $prog->bugs;
7335              
7336             $prog->name($new_name); # Does not hit the db
7337              
7338             # Writes to the bugs table, adding @new_bugs to the current
7339             # list of bugs for this program
7340             $prog->add_bugs(@new_bugs);
7341              
7342             # @new_bugs can contain any mix of these types:
7343             #
7344             # @new_bugs =
7345             # (
7346             # 123, # primary key value
7347             # { id => 456 }, # method name/value pairs
7348             # Bug->new(id => 789), # object
7349             # );
7350              
7351             # Read from the bugs table, getting the full list of bugs,
7352             # including the ones that were added above.
7353             $bugs = $prog->bugs;
7354              
7355             # Write to the programs table only
7356             $prog->save;
7357              
7358             Example - add_on_save interface:
7359              
7360             # Read from the programs table
7361             $prog = Program->new(id => 5)->load;
7362              
7363             # Read from the bugs table
7364             $bugs = $prog->bugs;
7365              
7366             $prog->name($new_name); # Does not hit the db
7367             $prog->add_bugs(@new_bugs); # Does not hit the db
7368             $prog->add_bugs(@more_bugs); # Does not hit the db
7369              
7370             # @new_bugs and @more_bugs can contain any mix of these types:
7371             #
7372             # @new_bugs =
7373             # (
7374             # 123, # primary key value
7375             # { id => 456 }, # method name/value pairs
7376             # Bug->new(id => 789), # object
7377             # );
7378              
7379             # Write to the programs table and the bugs table, adding
7380             # @new_bugs to the current list of bugs for this program
7381             $prog->save;
7382              
7383             =item B<objects_by_map>
7384              
7385             Create methods that fetch L<Rose::DB::Object>-derived objects via an intermediate L<Rose::DB::Object>-derived class that maps between two other L<Rose::DB::Object>-derived classes. See the L<Rose::DB::Object::Metadata::Relationship::ManyToMany> documentation for a more complete example of this type of method in action.
7386              
7387             =over 4
7388              
7389             =item Options
7390              
7391             =over 4
7392              
7393             =item B<hash_key NAME>
7394              
7395             The key inside the hash-based object to use for the storage of the fetched objects. Defaults to the name of the method.
7396              
7397             =item B<interface NAME>
7398              
7399             Choose the interface. The C<get_set> interface is the default.
7400              
7401             =item B<manager_args HASHREF>
7402              
7403             A reference to a hash of arguments passed to the C<manager_class> when fetching objects. If C<manager_args> includes a "sort_by" argument, be sure to prefix each column name with the appropriate table name. (See the L<synopsis|/SYNOPSIS> for examples.)
7404              
7405             =item B<manager_class CLASS>
7406              
7407             The name of the L<Rose::DB::Object::Manager>-derived class that the C<map_class> will use to fetch records. Defaults to L<Rose::DB::Object::Manager>.
7408              
7409             =item B<manager_method NAME>
7410              
7411             The name of the class method to call on C<manager_class> in order to fetch the objects. Defaults to C<get_objects>.
7412              
7413             =item B<manager_count_method NAME>
7414              
7415             The name of the class method to call on C<manager_class> in order to count the objects. Defaults to C<get_objects_count>.
7416              
7417             =item B<map_class CLASS>
7418              
7419             The name of the L<Rose::DB::Object>-derived class that maps between the other two L<Rose::DB::Object>-derived classes. This class must have a foreign key and/or "many to one" relationship for each of the two tables that it maps between.
7420              
7421             =item B<map_from NAME>
7422              
7423             The name of the "many to one" relationship or foreign key in C<map_class> that points to the object of the class that this relationship exists in. Setting this value is only necessary if the C<map_class> has more than one foreign key or "many to one" relationship that points to one of the classes that it maps between.
7424              
7425             =item B<map_to NAME>
7426              
7427             The name of the "many to one" relationship or foreign key in C<map_class> that points to the "foreign" object to be fetched. Setting this value is only necessary if the C<map_class> has more than one foreign key or "many to one" relationship that points to one of the classes that it maps between.
7428              
7429             =item B<relationship OBJECT>
7430              
7431             The L<Rose::DB::Object::Metadata::Relationship> object that describes the "key" through which the "objects_by_key" are fetched. This option is required.
7432              
7433             =item B<share_db BOOL>
7434              
7435             If true, the L<db|Rose::DB::Object/db> attribute of the current object is shared with all of the objects fetched. Defaults to true.
7436              
7437             =item B<query_args ARRAYREF>
7438              
7439             A reference to an array of arguments added to the value of the C<query> parameter passed to the call to C<manager_class>'s C<manager_method> class method.
7440              
7441             =back
7442              
7443             =item Interfaces
7444              
7445             =over 4
7446              
7447             =item B<count>
7448              
7449             Creates a method that will attempt to count L<Rose::DB::Object>-derived objects that are related to the current object through the C<map_class>, plus any additional parameters passed to the method call. Note that this method counts the objects I<in the database at the time of the call>. This may be different than the number of objects attached to the current object or otherwise in memory.
7450              
7451             Since the objects counted are partially determined by the arguments passed to the method, the count is not retained. It is simply returned. Each call counts the specified objects again, even if the arguments are the same as the previous call.
7452              
7453             If the first argument is a reference to a hash or array, it is converted to a reference to an array (if necessary) and taken as the value of the C<query> parameter. All arguments are passed on to the C<manager_class>'s C<manager_count_method> method, augmented by the mapping to the current object. Query parameters are added to the existing contents of the C<query> parameter. Other parameters replace existing parameters if the existing values are simple scalars, or augment existing parameters if the existing values are references to hashes or arrays.
7454              
7455             The count may fail for several reasons. The count will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_count_method> method returns undef, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
7456              
7457             If the count succeeds, the number is returned. (If the count finds zero objects, the count will be 0. This is still considered success.)
7458              
7459             =item B<find>
7460              
7461             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived that are related to the current object through the C<map_class>, plus any additional parameters passed to the method call. Since the objects fetched are partially determined by the arguments passed to the method, the list of objects is not retained. It is simply returned. Each call fetches the requested objects again, even if the arguments are the same as the previous call.
7462              
7463             If the first argument is a reference to a hash or array, it is converted to a reference to an array (if necessary) and taken as the value of the C<query> parameter. All arguments are passed on to the C<manager_class>'s C<manager_method> method, augmented by the mapping to the current object. Query parameters are added to the existing contents of the C<query> parameter. Other parameters replace existing parameters if the existing values are simple scalars, or augment existing parameters if the existing values are references to hashes or arrays.
7464              
7465             The fetch may fail for several reasons. The fetch will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef (in scalar context) or an empty list (in list context) will be returned. If the call to C<manager_class>'s C<manager_method> method returns false, the behavior is determined by the L<metadata object|Rose::DB::Object/meta>'s L<error_mode|Rose::DB::Object::Metadata/error_mode>. If the mode is C<return>, that false value (in scalar context) or an empty list (in list context) is returned.
7466              
7467             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
7468              
7469             =item B<iterator>
7470              
7471             Behaves just like B<find> but returns an L<iterator|Rose::DB::Object::Iterator> rather than an array or arrayref.
7472              
7473             =item B<get_set>
7474              
7475             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects that are related to the current object through the C<map_class>.
7476              
7477             If passed a single argument of undef, the C<hash_key> used to store the objects is set to undef. Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7478              
7479             =over 4
7480              
7481             =item * An object of type C<class>.
7482              
7483             =item * A reference to a hash containing method name/value pairs.
7484              
7485             =item * A single scalar primary key value.
7486              
7487             =back
7488              
7489             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7490              
7491             The list of object is assigned to C<hash_key>. Note that these objects are B<not> added to the database. Use the C<get_set_now> or C<get_set_on_save> interface to do that.
7492              
7493             If called with no arguments and the hash key used to store the list of objects is defined, the list (in list context) or a reference to that array (in scalar context) of objects is returned. Otherwise, the objects are fetched.
7494              
7495             When fetching objects from the database, if the call to C<manager_class>'s C<manager_method> method returns false, that false value (in scalar context) or an empty list (in list context) is returned.
7496              
7497             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
7498              
7499             =item B<get_set_now>
7500              
7501             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects that are related to the current object through the C<map_class>, and will also save objects to the database and map them to the parent object when called with arguments. The objects do not have to already exist in the database; they will be inserted if needed.
7502              
7503             If passed a single argument of undef, the list of objects is set to undef, causing it to be reloaded the next time the method is called with no arguments. (Pass a reference to an empty array to cause all of the existing objects to be "unmapped"--that is, to have their entries in the mapping table deleted from the database.) Any pending C<set_on_save> or C<add_on_save> actions are discarded.
7504              
7505             Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7506              
7507             =over 4
7508              
7509             =item * An object of type C<class>.
7510              
7511             =item * A reference to a hash containing method name/value pairs.
7512              
7513             =item * A single scalar primary key value.
7514              
7515             =back
7516              
7517             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7518              
7519             The list of object is assigned to C<hash_key>, the old entries are deleted from the mapping table in the database, and the new objects are added to the database, along with their corresponding mapping entries. Any pending C<set_on_save> or C<add_on_save> actions are discarded.
7520              
7521             When adding each object, if the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7522              
7523             The parent object must have been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d prior to setting the list of objects. If this method is called with arguments before the object has been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d, a fatal error will occur.
7524              
7525             If called with no arguments and the hash key used to store the list of objects is defined, the list (in list context) or a reference to that array (in scalar context) of objects is returned. Otherwise, the objects are fetched.
7526              
7527             When fetching, if the call to C<manager_class>'s C<manager_method> method returns false, that false value (in scalar context) or an empty list (in list context) is returned.
7528              
7529             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
7530              
7531             =item B<get_set_on_save>
7532              
7533             Creates a method that will attempt to fetch L<Rose::DB::Object>-derived objects that are related to the current object through the C<map_class>, and will also save objects to the database and map them to the parent object when the "parent" object is L<save|Rose::DB::Object/save>d. The objects do not have to already exist in the database; they will be inserted if needed.
7534              
7535             If passed a single argument of undef, the list of objects is set to undef, causing it to be reloaded the next time the method is called with no arguments. (Pass a reference to an empty array to cause all of the existing objects to be "unmapped"--that is, to have their entries in the mapping table deleted from the database.) Any pending C<set_on_save> or C<add_on_save> actions are discarded.
7536              
7537             Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7538              
7539             =over 4
7540              
7541             =item * An object of type C<class>.
7542              
7543             =item * A reference to a hash containing method name/value pairs.
7544              
7545             =item * A single scalar primary key value.
7546              
7547             =back
7548              
7549             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7550              
7551             The list of object is assigned to C<hash_key>. The mapping table records that mapped the old objects to the parent object are scheduled to be deleted from the database and new ones are scheduled to be added to the database when the parent is L<save|Rose::DB::Object/save>d. Any previously pending C<set_on_save> or C<add_on_save> actions are discarded.
7552              
7553             When adding each object when the parent is L<save|Rose::DB::Object/save>d, if the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7554              
7555             If called with no arguments and the hash key used to store the list of objects is defined, the list (in list context) or a reference to that array (in scalar context) of objects is returned. Otherwise, the objects are fetched.
7556              
7557             When fetching, if the call to C<manager_class>'s C<manager_method> method returns false, that false value (in scalar context) or an empty list (in list context) is returned.
7558              
7559             If the fetch succeeds, a list (in list context) or a reference to the array of objects (in scalar context) is returned. (If the fetch finds zero objects, the list or array reference will simply be empty. This is still considered success.)
7560              
7561             =item B<add_now>
7562              
7563             Creates a method that will add to a list of L<Rose::DB::Object>-derived objects that are related to the current object through the C<map_class>, and will also save objects to the database and map them to the parent object. The objects do not have to already exist in the database; they will be inserted if needed.
7564              
7565             This method returns the list of objects added when called in list context, and the number of objects added when called in scalar context. If one or more objects could not be added, undef (in scalar context) or an empty list (in list context) is returned and the parent object's L<error|Rose::DB::Object/error> attribute is set.
7566              
7567             If passed an empty list, the method does nothing and the parent object's L<error|Rose::DB::Object/error> attribute is set.
7568              
7569             If passed any arguments, the parent object must have been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d prior to adding to the list of objects. If this method is called with a non-empty list as an argument before the parent object has been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d, a fatal error will occur.
7570              
7571             The argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7572              
7573             =over 4
7574              
7575             =item * An object of type C<class>.
7576              
7577             =item * A reference to a hash containing method name/value pairs.
7578              
7579             =item * A single scalar primary key value.
7580              
7581             =back
7582              
7583             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7584              
7585             The parent object's list of related objects is then set to undef, causing the related objects to be reloaded from the database the next time they're needed.
7586              
7587             =item B<add_on_save>
7588              
7589             Creates a method that will add to a list of L<Rose::DB::Object>-derived objects that are related to the current object through the C<map_class>, and will also save objects to the database and map them to the parent object when the "parent" object is L<save|Rose::DB::Object/save>d. The objects and map records will be added to the database when the parent object is L<save|Rose::DB::Object/save>d. The objects do not have to already exist in the database; they will be inserted if needed.
7590              
7591             This method returns the list of objects to be added when called in list context, and the number of items to be added when called in scalar context.
7592              
7593             If passed an empty list, the method does nothing and the parent object's L<error|Rose::DB::Object/error> attribute is set.
7594              
7595             Otherwise, the argument(s) must be a list or reference to an array containing items in one or more of the following formats:
7596              
7597             =over 4
7598              
7599             =item * An object of type C<class>.
7600              
7601             =item * A reference to a hash containing method name/value pairs.
7602              
7603             =item * A single scalar primary key value.
7604              
7605             =back
7606              
7607             The latter two formats will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7608              
7609             These objects are scheduled to be added to the database and mapped to the parent object when the parent object is L<save|Rose::DB::Object/save>d. They are also added to the parent object's current list of related objects, if the list is defined at the time of the call.
7610              
7611             =back
7612              
7613             =back
7614              
7615             For a complete example of this method type in action, see the L<Rose::DB::Object::Metadata::Relationship::ManyToMany> documentation.
7616              
7617             =item B<object_by_key>
7618              
7619             Create a get/set methods for a single L<Rose::DB::Object>-derived object loaded based on a primary key formed from attributes of the current object.
7620              
7621             =over 4
7622              
7623             =item Options
7624              
7625             =over 4
7626              
7627             =item B<class CLASS>
7628              
7629             The name of the L<Rose::DB::Object>-derived class of the object to be loaded. This option is required.
7630              
7631             =item B<foreign_key OBJECT>
7632              
7633             The L<Rose::DB::Object::Metadata::ForeignKey> object that describes the "key" through which the "object_by_key" is fetched. This (or the C<relationship> parameter) is required when using the "delete_now", "delete_on_save", and "get_set_on_save" interfaces.
7634              
7635             =item B<hash_key NAME>
7636              
7637             The key inside the hash-based object to use for the storage of the object. Defaults to the name of the method.
7638              
7639             =item B<if_not_found CONSEQUENCE>
7640              
7641             This setting determines what happens when the key_columns have defined values, but the foreign object they point to is not found. Valid values for CONSEQUENCE are C<fatal>, which will throw an exception if the foreign object is not found, and C<ok> which will merely cause the relevant method(s) to return undef. The default is C<fatal>.
7642              
7643             =item B<key_columns HASHREF>
7644              
7645             A reference to a hash that maps column names in the current object to those of the primary key in the object to be loaded. This option is required.
7646              
7647             =item B<interface NAME>
7648              
7649             Choose the interface. The default is C<get_set>.
7650              
7651             =item B<relationship OBJECT>
7652              
7653             The L<Rose::DB::Object::Metadata::Relationship>-derived object that describes the relationship through which the object is fetched. This (or the C<foreign_key> parameter) is required when using the "delete_now", "delete_on_save", and "get_set_on_save" interfaces.
7654              
7655             =item B<referential_integrity BOOL>
7656              
7657             If true, then a fatal error will occur when a method in one of the "get*" interfaces is called and no related object is found. The default is determined by the L<referential_integrity|Rose::DB::Object::Metadata::ForeignKey/referential_integrity> attribute of the C<foreign_key> object, or true if no C<foreign_key> parameter is passed.
7658              
7659             This parameter conflicts with the C<required> parameter. Only one of the two should be passed.
7660              
7661             =item B<required BOOL>
7662              
7663             If true, then a fatal error will occur when a method in one of the "get*" interfaces is called and no related object is found. The default is determined by the L<required|Rose::DB::Object::Metadata::Relationship::OneToOne/required> attribute of the C<relationship> object, or true if no C<relationship> parameter is passed.
7664              
7665             This parameter conflicts with the C<referential_integrity> parameter. Only one of the two should be passed.
7666              
7667             =item B<share_db BOOL>
7668              
7669             If true, the L<db|Rose::DB::Object/db> attribute of the current object is shared with the object loaded. Defaults to true.
7670              
7671             =back
7672              
7673             =item Interfaces
7674              
7675             =over 4
7676              
7677             =item B<delete_now>
7678              
7679             Deletes a L<Rose::DB::Object>-derived object from the database based on a primary key formed from attributes of the current object. If C<referential_integrity> or C<required> is true, then the "parent" object will have all of its attributes that refer to the "foreign" object (except any columns that are also part of the primary key) set to null , and it will be saved into the database. This needs to be done first because a database that enforces referential integrity will not allow a row to be deleted if it is still referenced by a foreign key in another table.
7680              
7681             Any previously pending C<get_set_on_save> action is discarded.
7682              
7683             The entire process takes place within a transaction if the database supports it. If not currently in a transaction, a new one is started and then committed on success and rolled back on failure.
7684              
7685             Returns true if the foreign object was deleted successfully or did not exist in the database, false if any of the keys that refer to the foreign object were undef, and triggers the normal L<Rose::DB::Object> L<error handling|Rose::DB::Object::Metadata/error_mode> in the case of any other kind of failure.
7686              
7687             =item B<delete_on_save>
7688              
7689             Deletes a L<Rose::DB::Object>-derived object from the database when the "parent" object is L<save|Rose::DB::Object/save>d, based on a primary key formed from attributes of the current object. If C<referential_integrity> or C<required> is true, then the "parent" object will have all of its attributes that refer to the "foreign" object (except any columns that are also part of the primary key) set to null immediately, but the actual delete will not be done until the parent is saved.
7690              
7691             Any previously pending C<get_set_on_save> action is discarded.
7692              
7693             The entire process takes place within a transaction if the database supports it. If not currently in a transaction, a new one is started and then committed on success and rolled back on failure.
7694              
7695             Returns true if the foreign object was deleted successfully or did not exist in the database, false if any of the keys that refer to the foreign object were undef, and triggers the normal L<Rose::DB::Object> L<error handling|Rose::DB::Object::Metadata/error_mode> in the case of any other kind of failure.
7696              
7697             =item B<get_set>
7698              
7699             Creates a method that will attempt to create and load a L<Rose::DB::Object>-derived object based on a primary key formed from attributes of the current object.
7700              
7701             If passed a single argument of undef, the C<hash_key> used to store the object is set to undef. If C<referential_integrity> or C<required> is true, then the columns that participate in the key are set to undef. (If any key column is part of the primary key, however, it is not set to undef.) Otherwise, the argument must be one of the following:
7702              
7703             =over 4
7704              
7705             =item * An object of type C<class>
7706              
7707             =item * A list of method name/value pairs.
7708              
7709             =item * A reference to a hash containing method name/value pairs.
7710              
7711             =item * A single scalar primary key value.
7712              
7713             =back
7714              
7715             The latter three argument types will be used to construct an object of type C<class>. A single primary key value is only valid if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7716              
7717             The object is assigned to C<hash_key> after having its C<key_columns> set to their corresponding values in the current object.
7718              
7719             If called with no arguments and the C<hash_key> used to store the object is defined, the object is returned. Otherwise, the object is created and loaded.
7720              
7721             The load may fail for several reasons. The load will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef will be returned.
7722              
7723             If the call to the newly created object's L<load|Rose::DB::Object/load> method returns false, then the normal L<Rose::DB::Object> L<error handling|Rose::DB::Object::Metadata/error_mode> is triggered. The false value returned by the call to the L<load|Rose::DB::Object/load> method is returned (assuming no exception was raised).
7724              
7725             If the load succeeds, the object is returned.
7726              
7727             =item B<get_set_now>
7728              
7729             Creates a method that will attempt to create and load a L<Rose::DB::Object>-derived object based on a primary key formed from attributes of the current object, and will also save the object to the database when called with an appropriate object as an argument.
7730              
7731             If passed a single argument of undef, the C<hash_key> used to store the object is set to undef. If C<referential_integrity> or C<required> is true, then the columns that participate in the key are set to undef. (If any key column is part of the primary key, however, it is not set to undef.) Otherwise, the argument must be one of the following:
7732              
7733             =over 4
7734              
7735             =item * An object of type C<class>
7736              
7737             =item * A list of method name/value pairs.
7738              
7739             =item * A reference to a hash containing method name/value pairs.
7740              
7741             =item * A single scalar primary key value.
7742              
7743             =back
7744              
7745             The latter three argument types will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7746              
7747             The object is assigned to C<hash_key> after having its C<key_columns> set to their corresponding values in the current object. The object is then immediately L<save|Rose::DB::Object/save>d to the database.
7748              
7749             If the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7750              
7751             The parent object must have been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d prior to setting the list of objects. If this method is called with arguments before the object has been L<load|Rose::DB::Object/load>ed or L<save|Rose::DB::Object/save>d, a fatal error will occur.
7752              
7753             If called with no arguments and the C<hash_key> used to store the object is defined, the object is returned. Otherwise, the object is created and loaded.
7754              
7755             The load may fail for several reasons. The load will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef will be returned.
7756              
7757             If the call to the newly created object's L<load|Rose::DB::Object/load> method returns false, then the normal L<Rose::DB::Object> L<error handling|Rose::DB::Object::Metadata/error_mode> is triggered. The false value returned by the call to the L<load|Rose::DB::Object/load> method is returned (assuming no exception was raised).
7758              
7759             If the load succeeds, the object is returned.
7760              
7761             =item B<get_set_on_save>
7762              
7763             Creates a method that will attempt to create and load a L<Rose::DB::Object>-derived object based on a primary key formed from attributes of the current object, and save the object when the "parent" object is L<save|Rose::DB::Object/save>d.
7764              
7765             If passed a single argument of undef, the C<hash_key> used to store the object is set to undef. If C<referential_integrity> or C<required> is true, then the columns that participate in the key are set to undef. (If any key column is part of the primary key, however, it is not set to undef.) Otherwise, the argument must be one of the following:
7766              
7767             =over 4
7768              
7769             =item * An object of type C<class>
7770              
7771             =item * A list of method name/value pairs.
7772              
7773             =item * A reference to a hash containing method name/value pairs.
7774              
7775             =item * A single scalar primary key value.
7776              
7777             =back
7778              
7779             The latter three argument types will be used to construct an object of type C<class>. A single primary key value is only a valid argument format if the C<class> in question has a single-column primary key. A hash reference argument must contain sufficient information for the object to be uniquely identified.
7780              
7781             The object is assigned to C<hash_key> after having its C<key_columns> set to their corresponding values in the current object. The object will be saved into the database when the "parent" object is L<save|Rose::DB::Object/save>d. Any previously pending C<get_set_on_save> action is discarded.
7782              
7783             If the object does not already exists in the database, it will be inserted. If the object was previously L<load|Rose::DB::Object/load>ed from or L<save|Rose::DB::Object/save>d to the database, it will be updated. Otherwise, it will be L<load|Rose::DB::Object/load>ed.
7784              
7785             If called with no arguments and the C<hash_key> used to store the object is defined, the object is returned. Otherwise, the object is created and loaded from the database.
7786              
7787             The load may fail for several reasons. The load will not even be attempted if any of the key attributes in the current object are undefined. Instead, undef will be returned.
7788              
7789             If the call to the newly created object's L<load|Rose::DB::Object/load> method returns false, then the normal L<Rose::DB::Object> L<error handling|Rose::DB::Object::Metadata/error_mode> is triggered. The false value returned by the call to the L<load|Rose::DB::Object/load> method is returned (assuming no exception was raised).
7790              
7791             If the load succeeds, the object is returned.
7792              
7793             =back
7794              
7795             =back
7796              
7797             Example setup:
7798              
7799             # CLASS DB TABLE
7800             # ------- --------
7801             # Product products
7802             # Category categories
7803              
7804             package Product;
7805              
7806             our @ISA = qw(Rose::DB::Object);
7807             ...
7808              
7809             # You will almost never call the method-maker directly
7810             # like this. See the Rose::DB::Object::Metadata docs
7811             # for examples of more common usage.
7812             use Rose::DB::Object::MakeMethods::Generic
7813             (
7814             object_by_key =>
7815             [
7816             category =>
7817             {
7818             interface => 'get_set',
7819             class => 'Category',
7820             key_columns =>
7821             {
7822             # Map Product column names to Category column names
7823             category_id => 'id',
7824             },
7825             },
7826             ]
7827             );
7828             ...
7829              
7830             Example - get_set interface:
7831              
7832             $product = Product->new(id => 5, category_id => 99);
7833              
7834             # Read from the categories table
7835             $category = $product->category;
7836              
7837             # $product->category call is roughly equivalent to:
7838             #
7839             # $cat = Category->new(id => $product->category_id
7840             # db => $prog->db);
7841             #
7842             # $ret = $cat->load;
7843             # return $ret unless($ret);
7844             # return $cat;
7845              
7846             # Does not write to the db
7847             $product->category(Category->new(...));
7848              
7849             $product->save; # writes to products table only
7850              
7851             Example - get_set_now interface:
7852              
7853             # Read from the products table
7854             $product = Product->new(id => 5)->load;
7855              
7856             # Read from the categories table
7857             $category = $product->category;
7858              
7859             # Write to the categories table:
7860             # (all possible argument formats show)
7861              
7862             # Object argument
7863             $product->category(Category->new(...));
7864              
7865             # Primary key value
7866             $product->category(123);
7867              
7868             # Method name/value pairs in a hashref
7869             $product->category(id => 123);
7870              
7871             # Method name/value pairs in a hashref
7872             $product->category({ id => 123 });
7873              
7874             # Write to the products table
7875             $product->save;
7876              
7877             Example - get_set_on_save interface:
7878              
7879             # Read from the products table
7880             $product = Product->new(id => 5)->load;
7881              
7882             # Read from the categories table
7883             $category = $product->category;
7884              
7885             # These do not write to the db:
7886              
7887             # Object argument
7888             $product->category(Category->new(...));
7889              
7890             # Primary key value
7891             $product->category(123);
7892              
7893             # Method name/value pairs in a hashref
7894             $product->category(id => 123);
7895              
7896             # Method name/value pairs in a hashref
7897             $product->category({ id => 123 });
7898              
7899             # Write to both the products and categories tables
7900             $product->save;
7901              
7902             Example - delete_now interface:
7903              
7904             # Read from the products table
7905             $product = Product->new(id => 5)->load;
7906              
7907             # Write to both the categories and products tables
7908             $product->delete_category();
7909              
7910             Example - delete_on_save interface:
7911              
7912             # Read from the products table
7913             $product = Product->new(id => 5)->load;
7914              
7915             # Does not write to the db
7916             $product->delete_category();
7917              
7918             # Write to both the products and categories tables
7919             $product->save;
7920              
7921             =item B<scalar>
7922              
7923             Create get/set methods for scalar attributes.
7924              
7925             =over 4
7926              
7927             =item Options
7928              
7929             =over 4
7930              
7931             =item B<default VALUE>
7932              
7933             Determines the default value of the attribute.
7934              
7935             =item B<check_in ARRAYREF>
7936              
7937             A reference to an array of valid values. When setting the attribute, if the new value is not equal (string comparison) to one of the valid values, a fatal error will occur.
7938              
7939             =item B<hash_key NAME>
7940              
7941             The key inside the hash-based object to use for the storage of this
7942             attribute. Defaults to the name of the method.
7943              
7944             =item B<init_method NAME>
7945              
7946             The name of the method to call when initializing the value of an undefined attribute. Defaults to the method name with the prefix C<init_> added. This option implies C<with_init>.
7947              
7948             =item B<interface NAME>
7949              
7950             Choose the interface. The C<get_set> interface is the default.
7951              
7952             =item B<length INT>
7953              
7954             The maximum number of characters in the string.
7955              
7956             =item B<overflow BEHAVIOR>
7957              
7958             Determines the behavior when the value is greater than the number of characters specified by the C<length> option. Valid values for BEHAVIOR are:
7959              
7960             =over 4
7961              
7962             =item B<fatal>
7963              
7964             Throw an exception.
7965              
7966             =item B<truncate>
7967              
7968             Truncate the value to the correct length.
7969              
7970             =item B<warn>
7971              
7972             Print a warning message.
7973              
7974             =back
7975              
7976             =item B<with_init BOOL>
7977              
7978             Modifies the behavior of the C<get_set> and C<get> interfaces. If the attribute is undefined, the method specified by the C<init_method> option is called and the attribute is set to the return value of that
7979             method.
7980              
7981             =back
7982              
7983             =item Interfaces
7984              
7985             =over 4
7986              
7987             =item B<get_set>
7988              
7989             Creates a get/set method for an object attribute. When called with an argument, the value of the attribute is set. The current value of the attribute is returned.
7990              
7991             =item B<get>
7992              
7993             Creates an accessor method for an object attribute that returns the current value of the attribute.
7994              
7995             =item B<set>
7996              
7997             Creates a mutator method for an object attribute. When called with an argument, the value of the attribute is set. If called with no arguments, a fatal error will occur.
7998              
7999             =back
8000              
8001             =back
8002              
8003             Example:
8004              
8005             package MyDBObject;
8006              
8007             our @ISA = qw(Rose::DB::Object);
8008              
8009             use Rose::DB::Object::MakeMethods::Generic
8010             (
8011             scalar =>
8012             [
8013             name => { default => 'Joe' },
8014             type =>
8015             {
8016             with_init => 1,
8017             check_in => [ qw(AA AAA C D) ],
8018             }
8019             set_type =>
8020             {
8021             check_in => [ qw(AA AAA C D) ],
8022             }
8023             ],
8024             );
8025              
8026             sub init_type { 'C' }
8027             ...
8028              
8029             $o = MyDBObject->new(...);
8030              
8031             print $o->name; # Joe
8032             print $o->type; # C
8033              
8034             $o->name('Bob'); # set
8035             $o->type('AA'); # set
8036              
8037             eval { $o->type('foo') }; # fatal error: invalid value
8038              
8039             print $o->name, ' is ', $o->type; # get
8040              
8041             =item B<set>
8042              
8043             Create get/set methods for "set" attributes. A "set" column in a database table contains an unordered group of values. Not all databases support a "set" column type. Check the L<Rose::DB|Rose::DB/"DATABASE SUPPORT"> documentation for your database type.
8044              
8045             =over 4
8046              
8047             =item Options
8048              
8049             =over 4
8050              
8051             =item B<default ARRAYREF>
8052              
8053             Determines the default value of the attribute. The value should be a reference to an array.
8054              
8055             =item B<hash_key NAME>
8056              
8057             The key inside the hash-based object to use for the storage of this
8058             attribute. Defaults to the name of the method.
8059              
8060             =item B<interface NAME>
8061              
8062             Choose the interface. The default is C<get_set>.
8063              
8064             =item B<values ARRAYREF>
8065              
8066             A reference to an array of valid values for the set. If present, attempting to use an invalid value will cause a fatal error.
8067              
8068             =back
8069              
8070             =item Interfaces
8071              
8072             =over 4
8073              
8074             =item B<get_set>
8075              
8076             Creates a get/set method for a "set" object attribute. A "set" column in a database table contains an unordered group of values. On the Perl side of the fence, an ordered list (an array) is used to store the values, but keep in mind that the order is not significant, nor is it guaranteed to be preserved.
8077              
8078             When setting the attribute, the value is passed through the L<parse_set|Rose::DB::Informix/parse_set> method of the object's L<db|Rose::DB::Object/db> attribute.
8079              
8080             When saving to the database, if the attribute value is defined, the method will pass the attribute value through the L<format_set|Rose::DB::Informix/format_set> method of the object's L<db|Rose::DB::Object/db> attribute before returning it.
8081              
8082             When not saving to the database, the method returns the set as a list in list context, or as a reference to the array in scalar context.
8083              
8084             =item B<get>
8085              
8086             Creates an accessor method for a "set" object attribute. A "set" column in a database table contains an unordered group of values. On the Perl side of the fence, an ordered list (an array) is used to store the values, but keep in mind that the order is not significant, nor is it guaranteed to be preserved.
8087              
8088             When saving to the database, if the attribute value is defined, the method will pass the attribute value through the L<format_set|Rose::DB::Informix/format_set> method of the object's L<db|Rose::DB::Object/db> attribute before returning it.
8089              
8090             When not saving to the database, the method returns the set as a list in list context, or as a reference to the array in scalar context.
8091              
8092             =item B<set>
8093              
8094             Creates a mutator method for a "set" object attribute. A "set" column in a database table contains an unordered group of values. On the Perl side of the fence, an ordered list (an array) is used to store the values, but keep in mind that the order is not significant, nor is it guaranteed to be preserved.
8095              
8096             When setting the attribute, the value is passed through the L<parse_set|Rose::DB::Informix/parse_set> method of the object's L<db|Rose::DB::Object/db> attribute.
8097              
8098             When saving to the database, if the attribute value is defined, the method will pass the attribute value through the L<format_set|Rose::DB::Informix/format_set> method of the object's L<db|Rose::DB::Object/db> attribute before returning it.
8099              
8100             When not saving to the database, the method returns the set as a list in list context, or as a reference to the array in scalar context.
8101              
8102             =back
8103              
8104             =back
8105              
8106             Example:
8107              
8108             package Person;
8109              
8110             our @ISA = qw(Rose::DB::Object);
8111             ...
8112             use Rose::DB::Object::MakeMethods::Generic
8113             (
8114             set =>
8115             [
8116             'nicknames',
8117             'set_nicks' => { interface => 'set', hash_key => 'nicknames' },
8118              
8119             'parts' => { default => [ qw(arms legs) ] },
8120             ],
8121             );
8122             ...
8123              
8124             @parts = $person->parts; # ('arms', 'legs')
8125             $parts = $person->parts; # [ 'arms', 'legs' ]
8126              
8127             $person->nicknames('Jack', 'Gimpy'); # set with list
8128             $person->nicknames([ 'Slim', 'Gip' ]); # set with array ref
8129              
8130             $person->set_nicks('Jack', 'Gimpy'); # set with list
8131             $person->set_nicks([ 'Slim', 'Gip' ]); # set with array ref
8132              
8133             =item B<varchar>
8134              
8135             Create get/set methods for variable-length character string attributes.
8136              
8137             =over 4
8138              
8139             =item Options
8140              
8141             =over 4
8142              
8143             =item B<default VALUE>
8144              
8145             Determines the default value of the attribute.
8146              
8147             =item B<hash_key NAME>
8148              
8149             The key inside the hash-based object to use for the storage of this attribute. Defaults to the name of the method.
8150              
8151             =item B<init_method NAME>
8152              
8153             The name of the method to call when initializing the value of an undefined attribute. Defaults to the method name with the prefix C<init_> added. This option implies C<with_init>.
8154              
8155             =item B<interface NAME>
8156              
8157             Choose the interface. The C<get_set> interface is the default.
8158              
8159             =item B<length INT>
8160              
8161             The maximum number of characters in the string.
8162              
8163             =item B<overflow BEHAVIOR>
8164              
8165             Determines the behavior when the value is greater than the number of characters specified by the C<length> option. Valid values for BEHAVIOR are:
8166              
8167             =over 4
8168              
8169             =item B<fatal>
8170              
8171             Throw an exception.
8172              
8173             =item B<truncate>
8174              
8175             Truncate the value to the correct length.
8176              
8177             =item B<warn>
8178              
8179             Print a warning message.
8180              
8181             =back
8182              
8183             =item B<with_init BOOL>
8184              
8185             Modifies the behavior of the C<get_set> and C<get> interfaces. If the attribute is undefined, the method specified by the C<init_method> option is called and the attribute is set to the return value of that
8186             method.
8187              
8188             =back
8189              
8190             =item Interfaces
8191              
8192             =over 4
8193              
8194             =item B<get_set>
8195              
8196             Creates a get/set accessor method for a fixed-length character string attribute. When setting, any strings longer than C<length> will be truncated. If C<length> is omitted, the string will be left unmodified.
8197              
8198             =back
8199              
8200             =back
8201              
8202             Example:
8203              
8204             package MyDBObject;
8205              
8206             our @ISA = qw(Rose::DB::Object);
8207              
8208             use Rose::DB::Object::MakeMethods::Generic
8209             (
8210             varchar =>
8211             [
8212             'name' => { length => 3 },
8213             ],
8214             );
8215              
8216             ...
8217              
8218             $o->name('John'); # truncates on set
8219             print $o->name; # 'Joh'
8220              
8221             =back
8222              
8223             =head1 AUTHOR
8224              
8225             John C. Siracusa (siracusa@gmail.com)
8226              
8227             =head1 LICENSE
8228              
8229             Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is
8230             free software; you can redistribute it and/or modify it under the same terms
8231             as Perl itself.