File Coverage

blib/lib/DBIx/DataModel/Meta/Source/Table.pm
Criterion Covered Total %
statement 74 85 87.0
branch 18 26 69.2
condition 3 6 50.0
subroutine 19 22 86.3
pod 0 8 0.0
total 114 147 77.5


line stmt bran cond sub pod time code
1             package DBIx::DataModel::Meta::Source::Table;
2 16     16   9996 use strict;
  16         40  
  16         808  
3 16     16   114 use warnings;
  16         48  
  16         563  
4 16     16   98 use parent "DBIx::DataModel::Meta::Source";
  16         41  
  16         118  
5 16     16   1148 use DBIx::DataModel;
  16         35  
  16         135  
6 16     16   116 use DBIx::DataModel::Meta::Utils qw/define_method does/;
  16         44  
  16         995  
7 16     16   121 use Params::Validate qw/HASHREF ARRAYREF SCALAR/;
  16         55  
  16         1009  
8 16     16   117 use List::MoreUtils qw/any/;
  16         50  
  16         158  
9 16     16   11799 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  16         39  
  16         143  
10              
11 16     16   1531 use namespace::clean;
  16         50  
  16         111  
12              
13              
14              
15             sub new {
16 50     50 0 102 my $class = shift;
17              
18             # the real work occurs in parent class
19 50         617 my $self = $class->_new_meta_source(
20              
21             # more spec for Params::Validate
22             { column_types => {type => HASHREF, default => {}},
23             column_handlers => {type => HASHREF, default => {}},
24             db_name => {type => SCALAR},
25             where => {type => HASHREF|ARRAYREF, optional => 1},
26              
27             auto_insert_columns => {type => HASHREF, default => {}},
28             auto_update_columns => {type => HASHREF, default => {}},
29             no_update_columns => {type => HASHREF, default => {}},
30              
31             },
32              
33             # method to call in schema for building @ISA
34             'table_parent',
35              
36             # original args
37             @_
38             );
39              
40 50         237 my $types = delete $self->{column_types};
41 50         233 while (my ($type_name, $columns_aref) = each %$types) {
42 0         0 $self->define_column_type($type_name, @$columns_aref);
43             }
44              
45 50         158 return $self;
46             }
47              
48              
49             sub db_from {
50 385     385 0 993 my $self = shift;
51 385         1078 return $self->{db_name};
52             }
53              
54              
55             sub where {
56 0     0 0 0 my $self = shift;
57              
58 0         0 return $self->{where};
59             }
60              
61             sub components {
62 38     38 0 80 my $self = shift;
63              
64 38 100       66 return @{$self->{components} || []};
  38         222  
65             }
66              
67              
68              
69             sub define_navigation_method {
70 62     62 0 186 my ($self, $method_name, @path) = @_;
71 62 50       218 @path or croak "define_navigation_method: not enough arguments";
72              
73             # last arg may be a hashref of parameters to be passed to select()
74 62         112 my $pre_args;
75 62 100       181 $pre_args = pop @path if ref $path[-1];
76              
77             # build the method body
78             my $method_body = sub {
79 24     24   64318 my ($self, @args) = @_;
80              
81             # if called without args, and just one role, and that role
82             # was previously expanded, then return the cached version
83 24 100 100     197 if (@path == 1 && !@args) {
84 8         29 my $cached = $self->{$path[0]};
85 8 100       35 return $cached if $cached;
86             }
87              
88             # otherwise, build a query
89 22 100       68 unshift @args, %$pre_args if $pre_args;
90 22         130 my $statement = $self->join(@path); # Source::join, not Schema::join
91              
92             # return either the resulting rows, or the query statement
93 20 100       70 return $self->_is_called_as_class_method
94             ? $statement->refine(@args) # when class method
95             : $statement->select(@args); # when instance method
96 62         379 };
97              
98             # install the method
99             define_method(
100             class => $self->{class},
101 62         266 name => $method_name,
102             body => $method_body,
103             );
104             }
105              
106              
107             sub define_column_type {
108 9     9 0 39 my ($self, $type_name, @columns) = @_;
109              
110 9 50       34 my $type = $self->{schema}->type($type_name)
111             or croak "unknown column type : $type_name";
112              
113 9         23 foreach my $column (@columns) {
114 14         24 $self->define_column_handlers($column, %{$type->{handlers}})
  14         51  
115             }
116              
117 9         26 return $self;
118             }
119              
120              
121             sub define_column_handlers {
122 17     17 0 58 my ($self, $column_name, %handlers) = @_;
123              
124 17         82 while (my ($handler_name, $body) = each %handlers) {
125 37         61 my $handler = $body;
126 37         70 my $previous = $self->{column_handlers}{$column_name}{$handler_name};
127 37 100       72 if ($previous) {
128             # compose new coderef with previous coderef
129             $handler
130 0     0   0 = $handler_name eq 'from_DB' ? sub {$body->(@_); $previous->(@_)}
  0         0  
131 1 50   1   16 : sub {$previous->(@_); $body->(@_)};
  1         6  
  1         7  
132             }
133 37         117 $self->{column_handlers}{$column_name}{$handler_name} = $handler;
134             }
135              
136 17         44 return $self;
137             }
138              
139              
140             sub define_auto_expand {
141 3     3 0 10 my ($self, @component_names) = @_;
142              
143             # check that we only auto_expand on components
144 3         11 my @components = $self->components;
145 3         11 foreach my $component_name (@component_names) {
146 3     3   26 any {$component_name eq $_} @components
147 3 50       42 or croak "cannot auto_expand on $component_name: not a composition";
148             }
149              
150             # closure to iterate on the components
151             my $body = sub {
152 0     0   0 my ($self, $want_recurse) = @_;
153 0         0 foreach my $component_name (@component_names) {
154 0         0 my $r = $self->expand($component_name); # result can be an object ref
155             # or an array ref
156 0 0 0     0 if ($r and $want_recurse) {
157 0 0       0 $r = [$r] unless does($r, 'ARRAY');
158 0         0 $_->auto_expand($want_recurse) foreach @$r;
159             }
160             }
161 3         30 };
162              
163             # install the method
164             define_method(
165             class => $self->{class},
166 3         17 name => 'auto_expand',
167             body => $body,
168             check_override => 0,
169             );
170              
171 3         12 return $self;
172             }
173              
174              
175             1;
176