File Coverage

blib/lib/DBIx/DataModel/Meta/Source.pm
Criterion Covered Total %
statement 75 75 100.0
branch 15 18 83.3
condition 2 2 100.0
subroutine 18 18 100.0
pod 0 5 0.0
total 110 118 93.2


line stmt bran cond sub pod time code
1             package DBIx::DataModel::Meta::Source;
2 18     18   8516 use strict;
  18         44  
  18         528  
3 18     18   94 use warnings;
  18         37  
  18         477  
4 18     18   96 use parent "DBIx::DataModel::Meta";
  18         41  
  18         182  
5 18     18   1527 use DBIx::DataModel;
  18         206  
  18         143  
6 18         1212 use DBIx::DataModel::Meta::Utils qw/define_class define_readonly_accessors
7 18     18   120 define_abstract_methods/;
  18         39  
8              
9 18     18   118 use Params::Validate qw/validate_with SCALAR ARRAYREF HASHREF OBJECT/;
  18         57  
  18         1223  
10 18     18   123 use Scalar::Util qw/weaken/;
  18         38  
  18         1049  
11 18     18   149 use List::MoreUtils qw/any/;
  18         38  
  18         214  
12 18     18   12535 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  18         43  
  18         116  
13              
14 18     18   1688 use namespace::clean;
  18         50  
  18         135  
15              
16             #----------------------------------------------------------------------
17             # COMPILE-TIME METHODS
18             #----------------------------------------------------------------------
19              
20             my %common_arg_spec = (
21             schema => {isa => "DBIx::DataModel::Meta::Schema"},
22             class => {type => SCALAR},
23             default_columns => {type => SCALAR, default => "*"},
24             parents => {type => OBJECT|ARRAYREF, default => [] },
25             primary_key => {type => SCALAR|ARRAYREF, default => [] },
26             aliased_tables => {type => HASHREF, default => {} }, # for joins
27              
28             # other slot filled later : 'name'
29             );
30              
31              
32             define_readonly_accessors(__PACKAGE__, keys %common_arg_spec, 'name');
33             define_abstract_methods (__PACKAGE__, qw/db_from where/);
34              
35             sub _new_meta_source { # called by new() in Meta::Table and Meta::Join
36 79     79   166 my $class = shift;
37 79         157 my $more_arg_spec = shift;
38 79         133 my $isa_slot = shift;
39              
40             # validation spec is built from a common part and a specific part
41 79         588 my %spec = (%common_arg_spec, %$more_arg_spec);
42              
43             # validate the parameters
44 79         3246 my $self = validate_with(
45             params => \@_,
46             spec => \%spec,
47             allow_extra => 0,
48             );
49              
50             # force into arrayref if accepts ARRAYREF but given as scalar
51 79   100     657 for my $attr (grep {($spec{$_}{type} || 0) & ARRAYREF} keys %spec) {
  853         1993  
52 237 100       544 next if not $self->{$attr};
53 189 50       538 $self->{$attr} = [$self->{$attr}] if not ref $self->{$attr};
54             }
55              
56             # the name is the short class name (before prepending the schema)
57 79         285 $self->{name} = $self->{class};
58              
59             # prepend schema name in class name, unless it already contains "::"
60             $self->{class} =~ s/^/$self->{schema}{class}::/
61 79 100       658 unless $self->{class} =~ /::/;
62              
63             # avoid circular references
64 79         391 weaken $self->{schema};
65              
66             # instanciate the metaclass
67 79         175 bless $self, $class;
68              
69             # build the list of parent classes
70 79         152 my @isa = map {$_->{class}} @{$self->{parents}};
  82         233  
  79         340  
71 79 50       222 if ($isa_slot) {
72 79         226 my $parent_class = $self->{schema}{$isa_slot}[0];
73             unshift @isa, $parent_class
74 79 100   80   560 unless any {$_->isa($parent_class)} @isa;
  80         591  
75             }
76              
77             # create the Perl class
78             define_class(
79             name => $self->{class},
80 79         648 isa => \@isa,
81             metadm => $self,
82             );
83              
84 79         434 return $self;
85             }
86              
87              
88             #----------------------------------------------------------------------
89             # RUN-TIME METHODS
90             #----------------------------------------------------------------------
91              
92              
93              
94             sub ancestors { # walk through parent metaobjects, similar to C3 inheritance
95 295     295 0 494 my $self = shift;
96 295         440 my %seen;
97 295         779 my @pool = $self->parents;
98 295         524 my @result;
99 295         801 while (@pool) {
100 45         83 my $parent = shift @pool;
101 45 50       112 if (!$seen{$parent}){
102 45         107 $seen{$parent} = 1;
103 45         76 push @result, $parent;
104 45         94 push @pool, $parent->parents;
105             }
106             }
107 295         850 return @result;
108             }
109              
110              
111              
112              
113 36     36 0 123 sub path {shift->_consolidate_hash('path', @_)}
114 23     23 0 64 sub auto_insert_column {shift->_consolidate_hash('auto_insert_columns', @_)}
115 53     53 0 135 sub auto_update_column {shift->_consolidate_hash('auto_update_columns', @_)}
116 55     55 0 175 sub no_update_column {shift->_consolidate_hash('no_update_columns', @_)}
117              
118             sub _consolidate_hash {
119 291     291   658 my ($self, $field, $optional_hash_key) = @_;
120 291         437 my %hash;
121              
122 291         673 my @meta_sources = ($self, $self->ancestors, $self->{schema});
123              
124 291         613 foreach my $meta_source (reverse @meta_sources) {
125 615 100       914 while (my ($name, $val) = each %{$meta_source->{$field} || {}}) {
  1138         4559  
126 523 100       1367 $val ? $hash{$name} = $val : delete $hash{$name};
127             }
128             }
129 291 100       1460 return $optional_hash_key ? $hash{$optional_hash_key} : %hash;
130             }
131              
132              
133              
134             1;
135              
136