File Coverage

blib/lib/DBIx/Class/ResultDDL.pm
Criterion Covered Total %
statement 291 321 90.6
branch 100 154 64.9
condition 70 143 48.9
subroutine 84 103 81.5
pod 68 74 91.8
total 613 795 77.1


line stmt bran cond sub pod time code
1             package DBIx::Class::ResultDDL;
2             # capture the default values of $^H and $^W for this version of Perl
3 8     8   392439 BEGIN { $DBIx::Class::ResultDDL::_default_h= $^H; $DBIx::Class::ResultDDL::_default_w= $^W; }
  8         317  
4 8     8   5130 use Exporter::Extensible -exporter_setup => 1;
  8         61797  
  8         80  
5 8     8   3896 use B::Hooks::EndOfScope 'on_scope_end';
  8         57118  
  8         70  
6 8     8   768 use Carp;
  8         27  
  8         1018  
7              
8             # ABSTRACT: Sugar methods for declaring DBIx::Class::Result data definitions
9             our $VERSION = '2.03'; # VERSION
10              
11              
12             our $CALLER; # can be used localized to wrap caller context into an anonymous sub
13              
14             sub swp :Export(-) {
15 47     47 0 1020 my $self= shift;
16 47 50       256 require strict; strict->import if $^H == $DBIx::Class::ResultDDL::_default_h;
  47         190  
17 47 50       167 require warnings; warnings->import if $^W == $DBIx::Class::ResultDDL::_default_w;
  47         552  
18 47         161 $self->_inherit_dbic;
19 8     8   1105 }
  8         2398  
  8         58  
20             sub _inherit_dbic {
21 59     59   114 my $self= shift;
22 59         116 my $pkg= $self->{into};
23 59 100 66     1510 unless ($pkg->can('load_components') && $pkg->can('add_column')) {
24 35         2465 require DBIx::Class::Core;
25 8     8   5286 no strict 'refs';
  8         21  
  8         1048  
26 35         610168 push @{ $pkg . '::ISA' }, 'DBIx::Class::Core';
  35         1473  
27             }
28             }
29              
30              
31             our $DISABLE_AUTOCLEAN;
32             sub autoclean :Export(-) {
33 47 100   47 0 62364 return if $DISABLE_AUTOCLEAN;
34 41         109 my $self= shift;
35 41         160 my $sref= $self->exporter_config_scope;
36 41 50       404 $self->exporter_config_scope($sref= \my $x) unless $sref;
37 41     41   879 on_scope_end { $$sref->clean };
  41         39728  
38 8     8   59 }
  8         16  
  8         38  
39              
40              
41             sub V2 :Export(-) {
42 23     23 0 13746 shift->exporter_also_import('-swp',':V2','-autoclean');
43 8     8   1913 }
  8         25  
  8         42  
44             sub exporter_autoload_symbol {
45 8     8 1 15912 my ($self, $sym)= @_;
46 8 50       55 if ($sym =~ /^-V([0-9]+)$/) {
47 8         26 my $tag= ":V$1";
48 8     24   34 my $method= sub { shift->exporter_also_import('-swp',$tag,'-autoclean') };
  24         90983  
49 8         40 return $self->exporter_register_option("V$1", $method);
50             }
51 0         0 return shift->next::method(@_);
52             }
53              
54             # The functions and tag list for previous versions are not loaded by default.
55             # They are contained in a separate package ::V$N, which inherits many methods
56             # from this one but then overrides all the ones whose API were different in
57             # the past version.
58             # In order to make those versions exportable, they have to be loaded into
59             # the cache or symbol table of this package before they can be added to a tag
60             # to get exported. This also requires that they be given a different name
61             # The pattern used here is to prefix "v0_" and so on to the methods which
62             # are re-defined in the subclass.
63             sub exporter_autoload_tag {
64 8     8 1 575 my ($self, $name)= @_;
65 8   33     44 my $class= ref $self || $self;
66 8 50       76 if ($name =~ /^V([0-9]+)$/) {
67 8         34 my $v_pkg= "DBIx::Class::ResultDDL::$name";
68 8         28 my $v= $1;
69 8 50       634 eval "require $v_pkg"
70             or croak "Can't load package $v_pkg: $@";
71 8         89 my $ver_exports= $v_pkg->exporter_get_tag($name);
72             # For each tag member, see if it is the same as the method in this class.
73             # If not, bring it in as v${X}_${name} and then export { -as => $name }
74 8         1217 my @tag;
75 8         24 for (@$ver_exports) {
76 442 100       1817 if ($class->can($_) == $v_pkg->can($_)) {
77 360         739 push @tag, $_;
78             }
79             else {
80 82         199 my $install_as= "v${v}_$_";
81 82         335 $class->exporter_export($install_as => $v_pkg->can($_));
82 82         1780 push @tag, $install_as, { -as => $_ };
83             }
84             }
85 8         60 return \@tag;
86             }
87 0         0 return shift->next::method(@_);
88             }
89              
90              
91             our %_settings_for_package;
92             sub _settings_for_package {
93 61   100 61   373 return $_settings_for_package{shift()} ||= {};
94             }
95              
96             sub enable_inflate_datetime :Export(-inflate_datetime) {
97 10     10 0 269 my $self= shift;
98 10         42 $self->_inherit_dbic;
99 10         33 my $pkg= $self->{into};
100 10 100       194 $pkg->load_components('InflateColumn::DateTime')
101             unless $pkg->isa('DBIx::Class::InflateColumn::DateTime');
102 10         9259 _settings_for_package($pkg)->{inflate_datetime}= 1;
103 8     8   5545 }
  8         30  
  8         53  
104              
105             sub enable_inflate_json :Export(-inflate_json) {
106 2     2 0 78 my $self= shift;
107 2         11 $self->_inherit_dbic;
108 2         11 my $pkg= $self->{into};
109 2 50       46 $pkg->load_components('InflateColumn::Serializer')
110             unless $pkg->isa('DBIx::Class::InflateColumn::Serializer');
111 2         474 my $settings= _settings_for_package($pkg);
112 2         7 $settings->{inflate_json}= 1;
113 2         10 $settings->{json_defaults}{serializer_class}= 'JSON';
114 8     8   2701 }
  8         30  
  8         37  
115              
116              
117             sub enable_retrieve_defaults :Export(-retrieve_defaults) {
118 1     1 0 47 my $self= shift;
119 1         4 my $pkg= $self->{into};
120 1         4 _settings_for_package($pkg)->{retrieve_defaults}= 1;
121 8     8   2292 }
  8         62  
  8         59  
122              
123              
124             my @V2= qw(
125             table view
126             col
127             null default auto_inc fk
128             integer unsigned tinyint smallint bigint decimal numeric money
129             float float4 float8 double real
130             char varchar nchar nvarchar MAX binary varbinary bit varbit
131             blob tinyblob mediumblob longblob text tinytext mediumtext longtext ntext bytea
132             date datetime timestamp enum bool boolean
133             uuid json jsonb inflate_json array
134             primary_key idx create_index unique sqlt_add_index sqlt_add_constraint
135             rel_one rel_many has_one might_have has_many belongs_to many_to_many
136             ddl_cascade dbic_cascade
137             );
138              
139             our %EXPORT_TAGS;
140             $EXPORT_TAGS{V2}= \@V2;
141             export @V2;
142              
143              
144             sub table {
145 39     39 1 39932 my $name= shift;
146 39   33     1025 DBIx::Class::Core->can('table')->(scalar($CALLER||caller), $name);
147             }
148              
149              
150             sub col {
151 133     133 1 276 my $name= shift;
152 133 50       372 croak "Odd number of arguments for col(): (".join(',',@_).")"
153             if scalar(@_) & 1;
154 133   33     545 my $pkg= $CALLER || caller;
155 133         353 $pkg->add_column($name, expand_col_options($pkg, @_));
156 133         60929 1;
157             }
158              
159             sub expand_col_options;
160              
161             sub _maybe_array {
162 124     124   241 my @dims;
163 124   100     484 while (@_ && ref $_[0] eq 'ARRAY') {
164 5         13 my $array= shift @_;
165 5 50       24 push @dims, @$array? @$array : '';
166             }
167 124         1109 join '', map "[$_]", @dims
168             }
169             sub _maybe_size {
170 19 100 100 19   107 return shift if @_ && Scalar::Util::looks_like_number($_[0]);
171 8         16 return undef;
172             }
173             sub _maybe_size_or_max {
174 44 50 66 44   338 return shift if @_ && (Scalar::Util::looks_like_number($_[0]) || uc($_[0]) eq 'MAX');
      100        
175 12         36 return undef;
176             }
177             sub _maybe_timezone {
178             # This is a weak check, but assume the timezone will have at least one capital letter,
179             # and that DBIC column attribute names will not.
180 23 100 66 23   247 return shift if @_ && !ref $_[0] && $_[0] =~ /(^floating$|^local$|[A-Z])/;
      100        
181 15         36 return undef;
182             }
183              
184              
185 27     27 1 136 sub null { is_nullable => 1, @_ }
186 6     6 1 55 sub auto_inc { is_auto_increment => 1, 'extra.auto_increment_type' => 'monotonic', @_ }
187 6     6 1 43 sub fk { is_foreign_key => 1, @_ }
188 17 50   17 1 133 sub default { default_value => (@_ > 1? [ @_ ] : $_[0]) }
189              
190              
191             sub integer {
192 22 50 66 22 1 4647 my $size= shift if @_ && Scalar::Util::looks_like_number($_[0]);
193 22   50     86 data_type => 'integer'.&_maybe_array, size => $size || 11, @_
194             }
195 2     2 1 8 sub unsigned { 'extra.unsigned' => 1, @_ }
196 1     1 1 6 sub tinyint { data_type => 'tinyint', size => 4, @_ }
197 1     1 1 7 sub smallint { data_type => 'smallint', size => 6, @_ }
198 1     1 1 44 sub bigint { data_type => 'bigint', size => 22, @_ }
199 1     1 1 17 sub decimal { _numeric(decimal => @_) }
200 4     4 1 14 sub numeric { _numeric(numeric => @_) }
201             sub _numeric {
202 5     5   11 my $type= shift;
203 5         32 my $precision= &_maybe_size;
204 5         11 my $size;
205 5 100       14 if (defined $precision) {
206 4         9 my $scale= &_maybe_size;
207 4 100       16 $size= defined $scale? [ $precision, $scale ] : [ $precision ];
208             }
209 5 100       13 return data_type => $type.&_maybe_array, ($size? ( size => $size ) : ()), @_;
210             }
211 0     0 1 0 sub money { data_type => 'money'.&_maybe_array, @_ }
212 1     1 1 4 sub double { data_type => 'double precision'.&_maybe_array, @_ }
213 1     1 1 6 sub float8 { data_type => 'float8'.&_maybe_array, @_ }
214 0     0 1 0 sub real { data_type => 'real'.&_maybe_array, @_ }
215 1     1 1 4 sub float4 { data_type => 'float4'.&_maybe_array, @_ }
216             # the float used by SQL Server allows variable size spec as number of bits of mantissa
217 2 100   2 1 9 sub float { my $size= &_maybe_size; data_type => 'float'.&_maybe_array, (defined $size? (size => $size) : ()), @_ }
  2         21  
218              
219              
220 3   100 3 1 508 sub char { my $size= &_maybe_size; data_type => 'char'.&_maybe_array, size => $size || 1, @_ }
  3         10  
221 2   100 2 1 7 sub nchar { my $size= &_maybe_size; data_type => 'nchar'.&_maybe_array, size => $size || 1, @_ }
  2         6  
222 30     30 1 1265 sub varchar { my $size= &_maybe_size_or_max; data_type => 'varchar'.&_maybe_array, size => $size, @_ }
  30         88  
223 2     2 1 6 sub nvarchar { my $size= &_maybe_size_or_max; data_type => 'nvarchar'.&_maybe_array, size => $size, @_ }
  2         6  
224 0     0 1 0 sub binary { my $size= &_maybe_size_or_max; data_type => 'binary'.&_maybe_array, size => $size, @_ }
  0         0  
225 0     0 1 0 sub varbinary { my $size= &_maybe_size_or_max; data_type => 'varbinary'.&_maybe_array, size => $size, @_ }
  0         0  
226 1 50   1 1 3 sub bit { my $size= &_maybe_size; data_type => 'bit'.&_maybe_array, size => (defined $size? $size : 1), @_ }
  1         5  
227 2 100   2 1 6 sub varbit { my $size= &_maybe_size; data_type => 'varbit'.&_maybe_array, (defined $size? (size => $size) : ()), @_ }
  2         5  
228 1     1 1 5 sub MAX { 'MAX' }
229              
230             # postgres blob type
231 0     0 1 0 sub bytea { data_type => 'bytea'.&_maybe_array, @_ }
232              
233             # These aren't valid for Postgres, so no array notation needed
234 0 0   0 1 0 sub blob { my $size= &_maybe_size; data_type => 'blob', (defined $size? (size => $size) : ()), @_ }
  0         0  
235 0     0 1 0 sub tinyblob { data_type => 'tinyblob', size => 0xFF, @_ }
236 0     0 1 0 sub mediumblob { data_type => 'mediumblob',size => 0xFFFFFF, @_ }
237 0     0 1 0 sub longblob { data_type => 'longblob', size => 0xFFFFFFFF, @_ }
238              
239 12 50   12 1 1867 sub text { my $size= &_maybe_size_or_max; data_type => 'text'.&_maybe_array, (defined $size? (size => $size) : ()), @_ }
  12         37  
240 0   0 0 1 0 sub ntext { my $size= &_maybe_size_or_max; data_type => 'ntext', size => ($size || 0x3FFFFFFF), @_ }
  0         0  
241 0     0 1 0 sub tinytext { data_type => 'tinytext', size => 0xFF, @_ }
242 0     0 1 0 sub mediumtext { data_type => 'mediumtext',size => 0xFFFFFF, @_ }
243 0     0 1 0 sub longtext { data_type => 'longtext', size => 0xFFFFFFFF, @_ }
244              
245              
246 0     0 1 0 sub enum { data_type => 'enum', 'extra.list' => [ @_ ]}
247 0     0 1 0 sub boolean { data_type => 'boolean'.&_maybe_array, @_ }
248 0     0 1 0 sub bool { data_type => 'boolean'.&_maybe_array, @_ }
249              
250              
251 4     4 1 1033 sub date { data_type => 'date'.&_maybe_array, @_ }
252 20 100   20 1 68 sub datetime { my $tz= &_maybe_timezone; data_type => 'datetime'.&_maybe_array, ($tz? (timezone => $tz) : ()), @_ }
  20         50  
253 0 0   0 1 0 sub timestamp { my $tz= &_maybe_timezone; data_type => 'timestamp'.&_maybe_array,($tz? (timezone => $tz) : ()), @_ }
  0         0  
254              
255              
256             sub array {
257             # If one argument and the argument is a string, then it is a type name
258 4 50 66 4 1 518 if (@_ == 1 && $_[0] && !ref $_[0]) {
      33        
259 2         10 return data_type => $_[0] . '[]';
260             }
261             # Else, scan through argument list looking for data_type, and append [] to following item.
262 2         4 my $data_type_idx;
263 2         14 for (my $i= 0; $i < @_; $i++) {
264 6 100       18 $data_type_idx= $i+1 if $_[$i] eq 'data_type'
265             }
266 2 50 33     17 $data_type_idx && $_[$data_type_idx] && !ref $_[$data_type_idx]
      33        
267             or die 'array needs a type';
268 2         5 $_[$data_type_idx] .= '[]';
269 2         8 return @_;
270             }
271              
272              
273 2     2 1 7 sub uuid { data_type => 'uuid'.&_maybe_array, @_ }
274              
275              
276             # This is a generator that includes the json_args into the installed method.
277             sub json {
278 10   33 10 1 1051 my $pkg= ($CALLER||caller);
279 10         39 my $defaults= _settings_for_package($pkg)->{json_defaults};
280 10 100       40 return data_type => 'json'.&_maybe_array, ($defaults? %$defaults : ()), @_
281             }
282             sub jsonb {
283 1   33 1 1 8 my $pkg= ($CALLER||caller);
284 1         4 my $defaults= _settings_for_package($pkg)->{json_defaults};
285 1 50       13 return data_type => 'jsonb'.&_maybe_array, ($defaults? %$defaults : ()), @_
286             }
287              
288             sub inflate_json {
289 3   33 3 1 21 my $pkg= ($CALLER||caller);
290 3 100       73 $pkg->load_components('InflateColumn::Serializer')
291             unless $pkg->isa('DBIx::Class::InflateColumn::Serializer');
292 3         517 return serializer_class => 'JSON', @_;
293             }
294              
295              
296 21   33 21 1 695 sub primary_key { ($CALLER||caller)->set_primary_key(@_); }
297              
298              
299 3   33 3 1 85 sub unique { ($CALLER||caller)->add_unique_constraint(@_) }
300              
301              
302             sub rel_one {
303 1   33 1 1 9 _add_rel(scalar($CALLER||caller), 'rel_one', @_);
304             }
305             sub rel_many {
306 2   33 2 1 26 _add_rel(scalar($CALLER||caller), 'rel_many', @_);
307             }
308             sub might_have {
309 2   33 2 1 31 _add_rel(scalar($CALLER||caller), 'might_have', @_);
310             }
311             sub has_one {
312 0   0 0 1 0 _add_rel(scalar($CALLER||caller), 'has_one', @_);
313             }
314             sub has_many {
315 4   33 4 1 47 _add_rel(scalar($CALLER||caller), 'has_many', @_);
316             }
317             sub belongs_to {
318 3   33 3 1 29 _add_rel(scalar($CALLER||caller), 'belongs_to', @_);
319             }
320             sub many_to_many {
321 0   0 0 1 0 DBIx::Class::Core->can('many_to_many')->(scalar($CALLER||caller), @_);
322             }
323              
324             sub expand_relationship_params;
325              
326             sub _add_rel {
327 12     12   36 my ($pkg, $reltype, $relname, $rel_pkg, $dbic_colmap, $opts)= &expand_relationship_params;
328 12 100 100     86 if ($reltype eq 'rel_one' || $reltype eq 'rel_many') {
329             # Are we referring to the foreign row's primary key? DBIC load order might not have
330             # gotten there yet, so take a guess that if it isn't a part of our primary key, then it
331             # is a part of their primary key.
332 3         5 my $is_f_key;
333 3 50       15 if (ref $dbic_colmap eq 'HASH') {
334 3         86 my @pk= $pkg->primary_columns;
335 3 50       1251 $is_f_key= !grep { defined $dbic_colmap->{$_} || defined $dbic_colmap->{"self.$_"} } @pk;
  3         46  
336             }
337            
338             $pkg->add_relationship(
339             $relname,
340             $rel_pkg,
341             $dbic_colmap,
342             {
343             accessor => ($reltype eq 'rel_one'? 'single' : 'multi'),
344             join_type => 'LEFT',
345             ($is_f_key? (
346 3 100       25 fk_columns => { map { do {(my $x= $_) =~ s/^self\.//; $x } => 1 } values %$dbic_colmap },
  3 50       5  
  3         17  
  3         46  
347             is_depends_on => 1,
348             is_foreign_key_constraint => 1,
349             undef_on_null_fk => 1,
350             ) : (
351             is_depends_on => 0,
352             )),
353             cascade_copy => 0, cascade_delete => 0,
354             %$opts
355             }
356             );
357             } else {
358 9         56 require DBIx::Class::Core;
359 9         194 DBIx::Class::Core->can($reltype)->($pkg, $relname, $rel_pkg, $dbic_colmap, $opts);
360             }
361             }
362              
363              
364             sub ddl_cascade {
365 4     4 1 14 my $mode= shift;
366 4 50 33     26 $mode= 'CASCADE' if !defined $mode || $mode eq '1';
367 4 50       13 $mode= 'RESTRICT' if $mode eq '0';
368             return
369 4         24 on_update => $mode,
370             on_delete => $mode;
371             }
372              
373              
374             sub dbic_cascade {
375 4 50   4 1 19 my $mode= defined $_[0]? $_[0] : 1;
376             return
377 4         20 cascade_copy => $mode,
378             cascade_delete => $mode;
379             }
380              
381              
382             sub view {
383 2     2 1 3603 my ($name, $definition, %opts) = @_;
384 2   33     14 my $pkg= $CALLER || caller;
385 2         104 DBIx::Class::Core->can('table_class')->($pkg, 'DBIx::Class::ResultSource::View');
386 2         58 DBIx::Class::Core->can('table')->($pkg, $name);
387              
388 2         2913 my $rsi = $pkg->result_source_instance;
389 2         42 $rsi->view_definition($definition);
390              
391 2 50       187 $rsi->deploy_depends_on($opts{depends}) if $opts{depends};
392 2         10 $rsi->is_virtual($opts{virtual});
393            
394 2         200 return $rsi
395             }
396              
397              
398             our %_installed_sqlt_hook_functions;
399             sub _get_sqlt_hook_method_array {
400 5     5   10 my $pkg= shift;
401 5   66     21 $_installed_sqlt_hook_functions{$pkg} ||= do {
402             # $pkg->can("sqlt_deploy_hook") is insufficient, because it might be declared
403             # in a parent class, and that is not an error. It is only an error if it was
404             # already declared in this package.
405 8     8   25339 no strict 'refs';
  8         60  
  8         765  
406 2         6 my $stash= %{$pkg.'::'};
  2         9  
407             croak "${pkg}::sqlt_deploy_hook already exists; DBIx::Class::ResultDDL won't overwrite it."
408             ." (but you can use Moo(se) or Class::Method::Modifiers to apply your own wrapper to this generated method)"
409 2 0 33     36 if $stash->{sqlt_deploy_hook} && $stash->{sqlt_deploy_hook}{CODE};
410              
411             # Create the sub once, bound to this array. The array can then be extended without
412             # needing to re-declare the sub.
413 8     8   57 no warnings 'closure';
  8         42  
  8         3062  
414 2         6 my @methods;
415 2 50   1   307 eval 'sub '.$pkg.'::sqlt_deploy_hook {
  1         6862  
  1         22  
  1         53  
  4         131  
  4         19  
416             my $self= shift;
417             $self->maybe::next::method(@_);
418             for (@methods) {
419             my ($m, @args)= @$_;
420             $_[0]->$m(@args);
421             }
422             } 1' or die "failed to generate sqlt_deploy_hook: $@";
423 2         13 \@methods;
424             };
425             }
426             sub sqlt_add_index {
427 1   33 1 1 8 my $pkg= $CALLER || caller;
428 1         8 my $methods= _get_sqlt_hook_method_array($pkg);
429 1         19 push @$methods, [ add_index => @_ ];
430             }
431              
432             sub sqlt_add_constraint {
433 1   33 1 1 10 my $pkg= $CALLER || caller;
434 1         3 my $methods= _get_sqlt_hook_method_array($pkg);
435 1         17 push @$methods, [ add_constraint => @_ ];
436             }
437              
438             sub create_index {
439 3   33 3 1 17 my $pkg= $CALLER || caller;
440 3 50       14 my $name= ref $_[0]? undef : shift;
441 3         9 my $fields= shift;
442 3 0       14 ref $fields eq 'ARRAY'
    50          
443             or croak((defined $name? 'Second':'First').' argument must be arrayref of index fields');
444 3         16 my %options= @_;
445 3         8 my $type= delete $options{type}; # this is an attribute of Index, not a member of %options
446 3         9 my $methods= _get_sqlt_hook_method_array($pkg);
447 3 50       76 push @$methods, [
    100          
    100          
448             add_index =>
449             (defined $name? (name => $name) : ()),
450             fields => $fields,
451             (keys %options? (options => \%options) : ()),
452             (defined $type? (type => $type) : ())
453             ];
454             }
455              
456 8     8   9387 BEGIN { *idx= *create_index; }
457              
458              
459             sub expand_col_options {
460 153     153 1 264 my $pkg= shift;
461 153         419 my $opts= { is_nullable => 0 };
462             # Apply options to the hash in order, so that they get overwritten as expected
463 153         402 while (@_) {
464 338         717 my ($k, $v)= (shift, shift);
465 338 100       1344 $opts->{$k}= $v, next
466             unless index($k, '.') >= 0;
467             # We support "foo.bar => $v" syntax which we convert to "foo => { bar => $v }"
468             # because "foo => { bar => 1 }, foo => { baz => 2 }" would overwrite eachother.
469 9         55 my @path= split /\./, $k;
470 9         56 $k= pop @path;
471 9         20 my $dest= $opts;
472 9   100     94 $dest= ($dest->{$_} ||= {}) for @path;
473 9         83 $dest->{$k}= $v;
474             }
475             $opts->{retrieve_on_insert}= 1
476             if $opts->{default_value} and !defined $opts->{retrieve_on_insert}
477 153 100 66     655 and _settings_for_package($pkg)->{retrieve_defaults};
      100        
478 153         1309 return $opts;
479             }
480              
481              
482             sub expand_relationship_params {
483 16     16 1 57 my ($pkg, $reltype, $relname, $maybe_colmap)= splice(@_, 0, 4);
484 16 50 66     105 my ($rel_pkg, $dbic_colmap, %opts)= ref $maybe_colmap eq 'HASH'? _translate_colmap($maybe_colmap, $pkg)
    100          
    100          
485             : !ref $maybe_colmap && $maybe_colmap =~ /JOIN /? _translate_join_sql($maybe_colmap, $pkg)
486             : !ref $maybe_colmap? ( _interpret_pkg_name($maybe_colmap, $pkg), shift )
487             : croak "Unexpected arguments";
488 16         82 %opts= (%opts, @_);
489 16         112 return $pkg, $reltype, $relname, $rel_pkg, $dbic_colmap, \%opts;
490             }
491              
492             sub _interpret_pkg_name {
493 16     16   51 my ($rel_class, $current_pkg)= @_;
494             # Related class may be relative to same namespace as current
495 16 100       72 return $rel_class if index($rel_class, '::') >= 0;
496 14         82 my ($parent_namespace)= ($current_pkg =~ /(.*)::[^:]+$/);
497 14         58 return $parent_namespace.'::'.$rel_class;
498             }
499              
500             # DBIC is normally { foreign.col => self.col } but I don't think that's very intuitive,
501             # so allow an alternate notation of { self_col => CLASS.col } and automatically determine
502             # which the user is using.
503             sub _translate_colmap {
504 12     12   50 my ($colmap, $self_pkg)= @_;
505 12         34 my ($rel_class, $direction, %result, $inconsistent)= ('',0);
506             # First pass, find the values for $rel_class and $reverse
507 12         49 for (keys %$colmap) {
508 12         41 my ($key, $val)= ($_, $colmap->{$_});
509 12 100       54 if ($key =~ /([^.]+)\.(.*)/) {
510 1 50       5 if ($1 eq 'self') {
511 0   0     0 $direction ||= 1;
512 0 0       0 ++$inconsistent if $direction < 0;
513             }
514             else {
515 1   50     9 $direction ||= -1;
516 1 50       4 ++$inconsistent if $direction > 0;
517 1 50       7 if ($1 ne 'foreign') {
518 1   33     18 $rel_class ||= $1;
519 1 50       8 ++$inconsistent if $rel_class ne $1;
520             }
521             }
522             }
523 12 100       78 if ($val =~ /([^.]+)\.(.*)/) {
524 11 50       43 if ($1 eq 'self') {
525 0   0     0 $direction ||= -1;
526 0 0       0 ++$inconsistent if $direction > 0;
527             }
528             else {
529 11   50     64 $direction ||= 1;
530 11 50       104 ++$inconsistent if $direction < 0;
531 11 50       38 if ($1 ne 'foreign') {
532 11   33     85 $rel_class ||= $1;
533 11 50       47 ++$inconsistent if $rel_class ne $1;
534             }
535             }
536             }
537             }
538 12 50       61 croak "Inconsistent {self=>foreign} notation found in relation mapping"
539             if $inconsistent;
540 12 50 33     63 croak "Must reference foreign Result class name in one of the keys or values of relation mapping"
541             unless $rel_class && $direction;
542             # Related class may be relative to same namespace as current
543 12         41 $rel_class= _interpret_pkg_name($rel_class, $self_pkg);
544            
545             # Second pass, rename the keys & values to DBIC canonical notation
546 12         41 for (keys %$colmap) {
547 12         32 my ($key, $val)= ($_, $colmap->{$_});
548 12         39 $key =~ s/.*\.//;
549 12         49 $val =~ s/.*\.//;
550 12 100       96 $result{ $direction > 0? "foreign.$val" : "foreign.$key" }= $direction > 0? "self.$key" : "self.$val";
    100          
551             }
552 12         61 return $rel_class, \%result;
553             }
554              
555             sub _translate_join_sql {
556 2     2   14 my ($sql, $self_pkg)= @_;
557 2 50       31 my ($join_type, $rsrc, $alias, $on, $tpl)
558             = ($sql =~ /^\s*(LEFT\s*|INNER\s*)?JOIN\s+(\S+)\s+(\w+)\s+(ON\s+)?(.*)/si)
559             or Carp::croak("Can't pase SQL, make sure it starts with (LEFT)? JOIN \$class (\$alias)? ON ...\n$sql");
560 2         6 my $rel_class= _interpret_pkg_name($rsrc, $self_pkg);
561 2 100       22 my $replace= $alias =~ /^ON\s*$/i? $rsrc : $alias;
562 2         5 $tpl =~ s/(["\$\@\\])/\\$1/g;
563 2         51 $tpl =~ s/\b\Q$replace\E[.]/\$_[0]{foreign_alias}./g;
564 2         13 $tpl =~ s/\bself[.]/\$_[0]{self_alias}./g;
565 2 50       243 my $tpl_fn= eval 'sub { \"'.$tpl.'" }' or die "$@\n in generated expression \"$tpl\"";
566 2 50       19 return $rel_class, $tpl_fn, ($join_type? (join_type => $join_type) : () );
567             }
568              
569              
570             1;
571              
572             __END__