Clarify licensing, ensure footers are consistent throughout the project
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Relationship / BelongsTo.pm
1 package # hide from PAUSE
2     DBIx::Class::Relationship::BelongsTo;
3
4 # Documentation for these methods can be found in
5 # DBIx::Class::Relationship
6
7 use strict;
8 use warnings;
9 use Try::Tiny;
10 use namespace::clean;
11
12 our %_pod_inherit_config =
13   (
14    class_map => { 'DBIx::Class::Relationship::BelongsTo' => 'DBIx::Class::Relationship' }
15   );
16
17 sub belongs_to {
18   my ($class, $rel, $f_class, $cond, $attrs) = @_;
19
20   # assume a foreign key constraint unless defined otherwise
21   $attrs->{is_foreign_key_constraint} = 1
22     if not exists $attrs->{is_foreign_key_constraint};
23   $attrs->{undef_on_null_fk} = 1
24     if not exists $attrs->{undef_on_null_fk};
25
26   # no join condition or just a column name
27   if (!ref $cond) {
28
29     my ($f_key, $guess);
30     if (defined $cond and length $cond) {
31       $f_key = $cond;
32       $guess = "caller specified foreign key '$f_key'";
33     }
34     else {
35       $f_key = $rel;
36       $guess = "using given relationship name '$rel' as foreign key column name";
37     }
38
39     $class->throw_exception(
40       "No such column '$f_key' declared yet on ${class} ($guess)"
41     )  unless $class->has_column($f_key);
42
43     $class->ensure_class_loaded($f_class);
44     my $f_rsrc = try {
45       $f_class->result_source_instance;
46     }
47     catch {
48       $class->throw_exception(
49         "Foreign class '$f_class' does not seem to be a Result class "
50       . "(or it simply did not load entirely due to a circular relation chain)"
51       );
52     };
53
54     my $pri = $f_rsrc->_single_pri_col_or_die;
55
56     $cond = { "foreign.${pri}" => "self.${f_key}" };
57
58   }
59   # explicit join condition
60   else {
61     if (ref $cond eq 'HASH') { # ARRAY is also valid
62       my $cond_rel;
63       # FIXME This loop is ridiculously incomplete and dangerous
64       # staving off changes until implmentation of the swindon consensus
65       for (keys %$cond) {
66         if (m/\./) { # Explicit join condition
67           $cond_rel = $cond;
68           last;
69         }
70         $cond_rel->{"foreign.$_"} = "self.".$cond->{$_};
71       }
72       $cond = $cond_rel;
73     }
74   }
75
76   my $acc_type = (
77     ref $cond eq 'HASH'
78       and
79     keys %$cond == 1
80       and
81     (keys %$cond)[0] =~ /^foreign\./
82       and
83     $class->has_column($rel)
84   ) ? 'filter' : 'single';
85
86   my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH')
87     ? { map { $_ =~ /^self\.(.+)/ ? ( $1 => 1 ) : () } (values %$cond ) }
88     : undef
89   ;
90
91   $class->add_relationship($rel, $f_class,
92     $cond,
93     {
94       is_depends_on => 1,
95       accessor => $acc_type,
96       $fk_columns ? ( fk_columns => $fk_columns ) : (),
97       %{$attrs || {}}
98     }
99   );
100
101   return 1;
102 }
103
104 1;