File Coverage

blib/lib/DBIx/DataModel/Source.pm
Criterion Covered Total %
statement 105 112 93.7
branch 22 30 73.3
condition 8 11 72.7
subroutine 22 24 91.6
pod 4 9 44.4
total 161 186 86.5


line stmt bran cond sub pod time code
1             #----------------------------------------------------------------------
2             package DBIx::DataModel::Source;
3             #----------------------------------------------------------------------
4              
5             # see POD doc at end of file
6              
7 18     18   8643 use warnings;
  18         41  
  18         650  
8 18     18   97 no warnings 'uninitialized';
  18         37  
  18         526  
9 18     18   95 use strict;
  18         45  
  18         382  
10 18     18   88 use mro 'c3';
  18         47  
  18         156  
11 18     18   735 use List::MoreUtils qw/firstval/;
  18         36  
  18         178  
12 18     18   13310 use Module::Load qw/load/;
  18         45  
  18         187  
13 18     18   1240 use Scalar::Util qw/refaddr/;
  18         62  
  18         1174  
14 18     18   10952 use Storable qw/freeze/;
  18         53923  
  18         1245  
15 18     18   144 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  18         37  
  18         210  
16 18     18   1777 use DBIx::DataModel::Meta::Utils qw/does/;
  18         41  
  18         827  
17              
18 18     18   119 use namespace::clean;
  18         48  
  18         166  
19              
20              
21              
22             #----------------------------------------------------------------------
23             # accessors
24             #----------------------------------------------------------------------
25              
26             sub schema {
27 1892     1892 1 2980 my $self = shift;
28             return (ref $self && $self->{__schema})
29 1892   66     9306 || $self->metadm->schema->class->singleton;
30             }
31              
32              
33             sub primary_key {
34 34     34 1 2410 my $self = shift;
35              
36             # get primary key columns
37 34         93 my @primary_key = $self->metadm->primary_key;
38              
39             # if called as instance method, get values in those columns
40 34 50       108 @primary_key = @{$self}{@primary_key} if !$self->_is_called_as_class_method;
  0         0  
41              
42             # choose what to return depending on context
43 34 50       90 if (wantarray) {
44 34         153 return @primary_key;
45             }
46             else {
47 0 0       0 @primary_key == 1
48             or croak "cannot return a multi-column primary key in a scalar context";
49 0         0 return $primary_key[0];
50             }
51             }
52              
53             #----------------------------------------------------------------------
54             # select and fetch
55             #----------------------------------------------------------------------
56              
57             # methods delegated to the Statement class
58             foreach my $method (qw/select bless_from_DB/) {
59 18     18   9673 no strict 'refs';
  18         43  
  18         3535  
60             *{$method} = sub {
61 141     141   125653 my $self = shift;
62              
63 141 50       550 $self->_is_called_as_class_method
64             or croak "$method() should be called as a class method";
65              
66 141         547 my $stmt_class = $self->metadm->schema->statement_class;
67 141         623 load $stmt_class;
68 141         10340 my $statement = $stmt_class->new($self);
69 141         584 return $statement->$method(@_);
70             };
71             }
72              
73              
74             sub fetch {
75 10     10 0 22543 my $self = shift;
76              
77 10 50       41 $self->_is_called_as_class_method
78             or croak "fetch() should be called as a class method";
79              
80 10         31 my %select_args;
81              
82             # if last argument is a hashref, it contains arguments to the select() call
83 18     18   133 no warnings 'uninitialized';
  18         40  
  18         16986  
84 10 100       46 if (does $_[-1], 'HASH') {
85 2         28 %select_args = %{pop @_};
  2         11  
86             }
87              
88 10         109 return $self->select(-fetch => \@_, %select_args);
89             }
90              
91              
92             sub fetch_cached {
93 4     4 0 3316 my $self = shift;
94 4         12 my $dbh_addr = refaddr $self->schema->dbh;
95 4         24 my $freeze_args = freeze \@_;
96 4   66     341 return $self->metadm->{fetch_cached}{$dbh_addr}{$freeze_args}
97             ||= $self->fetch(@_);
98             }
99              
100              
101              
102             #----------------------------------------------------------------------
103             # join
104             #----------------------------------------------------------------------
105              
106              
107             sub join {
108 35     35 1 60202 my ($self, $first_role, @other_roles) = @_;
109              
110             # direct references to utility objects
111 35         106 my $schema = $self->schema;
112 35         141 my $meta_schema = $schema->metadm;
113              
114             # find first join information
115 35 100       97 my $path = $self->metadm->path($first_role)
116             or croak "could not find role $first_role in " . $self->metadm->class;
117              
118             # build search criteria on %$self from first join information
119 33         93 my (%criteria, @left_cols);
120 33         113 my $prefix = $schema->placeholder_prefix;
121 33         66 while (my ($left_col, $right_col) = each %{$path->{on}}) {
  66         253  
122 33         113 $criteria{$right_col} = "$prefix$left_col";
123 33         101 push @left_cols, $left_col;
124             }
125              
126             # choose meta_source (just a table or build a join)
127             my $meta_source = @other_roles ? $meta_schema->define_join($path->{to}{name},
128             @other_roles)
129 33 100       144 : $path->{to};
130              
131             # build args for the statement
132 31         181 my $source = bless {__schema => $schema}, $meta_source->class;
133 31         106 my @stmt_args = ($source, -where => \%criteria);
134              
135             # keep a reference to @left_cols so that Source::join can bind them
136 31         92 push @stmt_args, -_left_cols => \@left_cols;
137              
138             # TODO: should add -select_as => 'firstrow' if all multiplicities are 1
139              
140             # build and return the new statement
141 31         112 my $statement = $meta_schema->statement_class->new(@stmt_args);
142              
143 31 100       119 if (!$self->_is_called_as_class_method) { # called as instance method
144             my $left_cols = $statement->{args}{-_left_cols}
145 23 50       76 or die "statement had no {left_cols} entry";
146              
147             # check that all foreign keys are present
148 23         57 my $missing = join ", ", grep {not exists $self->{$_}} @$left_cols;
  23         103  
149 23 100       73 not $missing
150             or croak "cannot follow role '$first_role': missing column '$missing'";
151              
152             # bind to foreign keys
153 21         43 $statement->bind(map {($_ => $self->{$_})} @$left_cols);
  21         94  
154             }
155              
156              
157 29         187 return $statement;
158             }
159              
160              
161             #----------------------------------------------------------------------
162             # column handlers and column expansion
163             #----------------------------------------------------------------------
164              
165              
166             sub expand {
167 0     0 1 0 my ($self, $path, @options) = @_;
168 0         0 $self->{$path} = $self->$path(@options);
169             }
170              
171       0 0   sub auto_expand {} # overridden in subclasses through define_auto_expand()
172              
173              
174             sub apply_column_handler {
175 63     63 0 174 my ($self, $handler_name, $objects) = @_;
176              
177 63   50     286 my $targets = $objects || [$self];
178 63         185 my %column_handlers = $self->metadm->_consolidate_hash('column_handlers');
179 63         165 my $results = {};
180              
181             # iterate over all registered columnHandlers
182             COLUMN:
183 63         254 while (my ($column_name, $handlers) = each %column_handlers) {
184              
185             # is $handler_name registered in this column ?
186 142 100       409 my $handler = $handlers->{$handler_name} or next COLUMN;
187              
188             # apply that handler to all targets that possess the $column_name
189 105         185 foreach my $obj (@$targets) {
190             my $result = exists $obj->{$column_name}
191 105 100       293 ? $handler->($obj->{$column_name}, $obj, $column_name, $handler_name)
192             : undef;
193 105 50       1052 if ($objects) { push(@{$results->{$column_name}}, $result); }
  0         0  
  0         0  
194 105         425 else { $results->{$column_name} = $result; }
195             }
196             }
197              
198 63         250 return $results;
199             }
200              
201              
202             #----------------------------------------------------------------------
203             # utilities
204             #----------------------------------------------------------------------
205              
206              
207             sub _is_called_as_class_method {
208 294     294   568 my $self = shift;
209              
210             # class method call in the usual Perl sense
211 294 100       1057 return 1 if ! ref $self;
212              
213             # fake class method call : an object with only one field '__schema'
214 143         654 my @k = keys %$self;
215 143   100     939 return @k == 1 && $k[0] eq '__schema';
216             }
217              
218              
219             sub TO_JSON {
220 3     3 0 6 my $self = shift;
221 3         12 my $clone = {%$self};
222 3         6 delete $clone->{__schema};
223 3         18 return $clone;
224             }
225              
226              
227             1; # End of DBIx::DataModel::Source
228              
229             __END__