File Coverage

blib/lib/ObjectDB/Meta.pm
Criterion Covered Total %
statement 189 256 73.8
branch 46 86 53.4
condition 17 31 54.8
subroutine 42 57 73.6
pod 5 39 12.8
total 299 469 63.7


line stmt bran cond sub pod time code
1             package ObjectDB::Meta;
2              
3 5     5   37 use strict;
  5         11  
  5         149  
4 5     5   27 use warnings;
  5         9  
  5         149  
5 5     5   26 use mro;
  5         9  
  5         36  
6              
7             our $VERSION = '3.28';
8              
9             require Storable;
10             require Carp;
11 5     5   256 use List::Util qw(first);
  5         10  
  5         621  
12              
13 5     5   2153 use ObjectDB::Meta::RelationshipFactory;
  5         10  
  5         12985  
14              
15             my %OBJECTS;
16              
17             sub find_or_register_meta {
18 42     42 0 65 my $class = shift;
19 42         124 my ($meta_class, @args) = @_;
20              
21 42   66     188 return $OBJECTS{$meta_class} ||= ObjectDB::Meta->new(class => $meta_class, @args);
22             }
23              
24             sub find_by_table {
25 0     0 0 0 my $class = shift;
26 0         0 my ($table) = @_;
27              
28 0         0 foreach my $meta_class (keys %OBJECTS) {
29 0         0 my $meta = $OBJECTS{$meta_class};
30              
31 0 0       0 if ($meta->table eq $table) {
32 0         0 return $meta;
33             }
34             }
35              
36 0         0 return;
37             }
38              
39             sub new {
40 28     28 0 51849 my $class = shift;
41 28         108 my (%params) = @_;
42              
43 28 100       161 Carp::croak('Class is required when building meta') unless $params{class};
44              
45 27 100       116 if (my $parent = $class->_is_inheriting($params{class})) {
46 2         13 return $parent;
47             }
48              
49 25 100       233 Carp::croak('Table is required when building meta') unless $params{table};
50              
51             my $self = {
52             class => $params{class},
53             table => $params{table}
54 24         64 };
55 24         47 bless $self, $class;
56              
57 24 50       52 if ($params{discover_schema}) {
58 0         0 $self->discover_schema;
59             }
60              
61 24 100       59 $self->set_columns($params{columns}) if $params{columns};
62 24 50       52 $self->set_primary_key($params{primary_key}) if $params{primary_key};
63 24 50       44 $self->set_unique_keys($params{unique_keys}) if $params{unique_keys};
64             $self->set_auto_increment($params{auto_increment})
65 24 50       48 if $params{auto_increment};
66              
67 24         74 $self->_build_relationships($params{relationships});
68              
69 24 100       108 if ($params{generate_columns_methods}) {
70 1         9 $self->generate_columns_methods;
71             }
72              
73 24 100       52 if ($params{generate_related_methods}) {
74 1         6 $self->generate_related_methods;
75             }
76              
77 24         82 return $self;
78             }
79              
80 2     2 0 19 sub class { $_[0]->{class} }
81 0     0 1 0 sub table { $_[0]->{table} }
82 1     1 1 5 sub relationships { $_[0]->{relationships} }
83 0     0 0 0 sub column { shift->get_column(@_); }
84 0     0 1 0 sub columns { $_[0]->get_columns; }
85 0     0 1 0 sub primary_key { $_[0]->get_primary_key; }
86 0     0 1 0 sub auto_increment { $_[0]->get_auto_increment; }
87              
88             sub is_primary_key {
89 0     0 0 0 my $self = shift;
90 0         0 my ($name) = @_;
91              
92 0     0   0 return !!first { $name eq $_ } $self->get_primary_key;
  0         0  
93             }
94              
95             sub is_unique_key {
96 0     0 0 0 my $self = shift;
97 0         0 my ($name) = @_;
98              
99 0         0 foreach my $key (@{ $self->{unique_keys} }) {
  0         0  
100 0 0   0   0 return 1 if first { $name eq $_ } @$key;
  0         0  
101             }
102              
103 0         0 return 0;
104             }
105              
106             sub is_nullable {
107 2     2 0 4 my $self = shift;
108 2         5 my ($name) = @_;
109              
110 2         5 my $column = $self->get_column($name);
111              
112 2         11 return $column->{is_null};
113             }
114              
115             sub get_class {
116 5     5 0 15 my $self = shift;
117              
118 5         23 return $self->{class};
119             }
120              
121             sub get_table {
122 2     2 0 10 my $self = shift;
123              
124 2         9 return $self->{table};
125             }
126              
127             sub set_table {
128 0     0 0 0 my $self = shift;
129 0         0 my ($value) = @_;
130              
131 0         0 $self->{table} = $value;
132              
133 0         0 return $self;
134             }
135              
136             sub is_column {
137 104     104 0 134 my $self = shift;
138 104         165 my ($name) = @_;
139              
140 104 50       169 Carp::croak('Name is required') unless $name;
141              
142 104     158   261 return !!first { $name eq $_->{name} } @{ $self->{columns} };
  158         732  
  104         293  
143             }
144              
145             sub get_column {
146 10     10 0 13 my $self = shift;
147 10         15 my ($name) = @_;
148              
149 10 50       17 Carp::croak("Unknown column '$name'") unless $self->is_column($name);
150              
151 10     25   38 return first { $_->{name} eq $name } @{ $self->{columns} };
  25         52  
  10         22  
152             }
153              
154             sub get_columns {
155 5     5 0 15 my $self = shift;
156              
157 5         7 return map { $_->{name} } @{ $self->{columns} };
  13         46  
  5         10  
158             }
159              
160             sub get_regular_columns {
161 1     1 0 6 my $self = shift;
162              
163 1         2 my @columns;
164              
165 1         3 foreach my $column ($self->get_columns) {
166 3 100   3   13 next if first { $column eq $_ } $self->get_primary_key;
  3         10  
167              
168 2         5 push @columns, $column;
169             }
170              
171 1         5 return @columns;
172             }
173              
174             sub set_columns {
175 20     20 0 97 my $self = shift;
176              
177 20         39 $self->{columns} = [];
178              
179 20         53 $self->add_columns(@_);
180              
181 20         42 return $self;
182             }
183              
184             sub add_columns {
185 20     20 0 27 my $self = shift;
186 20 100 66     89 my (@columns) = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
  4         11  
187              
188 20         30 my $count = 0;
189 20         66 while (my ($name, $options) = @columns[ $count, $count + 1 ]) {
190 76 100       134 last unless $name;
191              
192 56 100       100 if (ref $options eq 'HASH') {
193 2         5 $self->add_column($name, $options);
194             }
195             else {
196 54         113 $self->add_column($name);
197              
198 54         66 $count++;
199 54         184 next;
200             }
201              
202 2         5 $count += 2;
203             }
204              
205 20         37 return $self;
206             }
207              
208             sub add_column {
209 59     59 0 138 my $self = shift;
210 59         94 my ($name, $attributes) = @_;
211              
212 59 50       105 Carp::croak('Name is required') unless $name;
213 59 100       103 Carp::croak("Column '$name' already exists") if $self->is_column($name);
214              
215 58   100     277 $attributes ||= {};
216              
217 58         73 push @{ $self->{columns} }, { name => $name, %$attributes };
  58         151  
218              
219 58         122 return $self;
220             }
221              
222             sub remove_column {
223 0     0 0 0 my $self = shift;
224 0         0 my ($name) = @_;
225              
226 0 0 0     0 return unless $name && $self->is_column($name);
227              
228 0         0 $self->{columns} = [ grep { $_->{name} ne $name } @{ $self->{columns} } ];
  0         0  
  0         0  
229              
230 0         0 return $self;
231             }
232              
233             sub get_primary_key {
234 4     4 0 11 my $self = shift;
235              
236 4 50       5 return @{ $self->{primary_key} || [] };
  4         18  
237             }
238              
239             sub set_primary_key {
240 6     6 0 137 my $self = shift;
241 6 50 33     31 my (@columns) = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
  0         0  
242              
243 6         11 foreach my $column (@columns) {
244 6 100       11 Carp::croak("Unknown column '$column' set as primary key")
245             unless $self->is_column($column);
246             }
247              
248 4         14 $self->{primary_key} = [@columns];
249              
250 4         9 return $self;
251             }
252              
253             sub get_unique_keys {
254 3     3 0 19 my $self = shift;
255              
256 3         3 return @{ $self->{unique_keys} };
  3         22  
257             }
258              
259             sub set_unique_keys {
260 3     3 0 25 my $self = shift;
261 3 50 66     19 my (@columns) = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
  0         0  
262              
263 3         8 $self->{unique_keys} = [];
264              
265 3         9 $self->add_unique_keys(@columns);
266              
267 3         6 return $self;
268             }
269              
270             sub add_unique_keys {
271 3     3 0 19 my $self = shift;
272 3 50 66     14 my (@columns) = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
  0         0  
273              
274 3         7 foreach my $column (@columns) {
275 5         10 $self->add_unique_key($column);
276             }
277              
278 3         5 return $self;
279             }
280              
281             sub add_unique_key {
282 5     5 0 9 my $self = shift;
283 5 100 66     22 my (@columns) = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
  2         5  
284              
285 5         8 foreach my $column (@columns) {
286 6 50       12 Carp::croak("Unknown column '$column' set as unique key")
287             unless $self->is_column($column);
288             }
289              
290 5         9 push @{ $self->{unique_keys} }, [@columns];
  5         13  
291              
292 5         11 return $self;
293             }
294              
295             sub get_auto_increment {
296 1     1 0 5 my $self = shift;
297              
298 1         4 return $self->{auto_increment};
299             }
300              
301             sub set_auto_increment {
302 2     2 0 64 my $self = shift;
303 2         4 my ($column) = @_;
304              
305 2 100       6 Carp::croak("Unknown column '$column' set as auto increment")
306             unless $self->is_column($column);
307              
308 1         4 $self->{auto_increment} = $column;
309              
310 1         2 return $self;
311             }
312              
313             sub is_relationship {
314 8     8 0 24 my $self = shift;
315 8         50 my ($name) = @_;
316              
317 8         67 return exists $self->{relationships}->{$name};
318             }
319              
320             sub get_relationship {
321 1     1 0 14 my $self = shift;
322 1         3 my ($name) = @_;
323              
324             Carp::croak("Unknown relationship '$name'")
325 1 50       5 unless exists $self->{relationships}->{$name};
326              
327 1         4 return $self->{relationships}->{$name};
328             }
329              
330             sub add_relationship {
331 4     4 0 15 my $self = shift;
332 4         8 my ($name, $options) = @_;
333              
334 4 50 33     18 Carp::croak('Name and options are required') unless $name && $options;
335              
336             $self->{relationships}->{$name} = ObjectDB::Meta::RelationshipFactory->new->build(
337 4         27 $options->{type}, %{$options},
  4         13  
338             orig_class => $self->get_class,
339             name => $name
340             );
341             }
342              
343             sub add_relationships {
344 2     2 0 13 my $self = shift;
345              
346 2         3 my $count = 0;
347 2         9 while (my ($name, $options) = @_[ $count, $count + 1 ]) {
348 4 100 66     19 last unless $name && $options;
349              
350 2         6 $self->add_relationship($name, $options);
351              
352 2         9 $count += 2;
353             }
354             }
355              
356             sub discover_schema {
357 0     0 0 0 my $self = shift;
358              
359 0 0       0 eval { require DBIx::Inspector; 1 } or do {
  0         0  
  0         0  
360 0         0 Carp::croak('DBIx::Inspector is required for auto discover');
361             };
362              
363 0         0 my $dbh = $self->class->init_db;
364              
365 0         0 my $inspector = DBIx::Inspector->new(dbh => $dbh);
366              
367 0         0 my $table = $inspector->table($self->table);
368 0 0       0 Carp::croak('auto discovery failed') unless $table;
369              
370 0         0 $self->{columns} = [];
371 0         0 foreach my $column ($table->columns) {
372 0         0 my $default_value = undef;
373              
374 0 0       0 if (defined $column->column_def) {
375 0 0       0 $default_value = $column->column_def =~ /^'(.*?)'/ ? $1 : $column->column_def;
376              
377 0 0       0 if ($column->type_name =~ m/^bool/i) {
378 0 0       0 if ($column->column_def =~ m/^\d/) {
379 0         0 $default_value = $column->column_def;
380             }
381             else {
382 0 0       0 $default_value = $column->column_def =~ m/^t/ ? 1 == 1 : 1 == 0;
383             }
384             }
385             }
386              
387 0         0 my $type = 'string';
388 0 0       0 if ( $column->type_name =~ m/^bool/i ) {
    0          
389 0         0 $type = 'bool';
390             }
391             elsif ( $column->type_name =~ m/^(?:int|num|float|real|decimal)/i ) {
392 0         0 $type = 'number';
393             }
394              
395 0 0       0 my $is_null = $column->is_nullable eq 'YES' ? 1 : 0;
396              
397 0         0 $self->add_column($column->name, { default => $default_value, is_null => $is_null, type => $type });
398             }
399              
400 0         0 $self->set_primary_key(map { $_->name } $table->primary_key);
  0         0  
401              
402 0         0 return $self;
403             }
404              
405             sub generate_columns_methods {
406 1     1 0 3 my $self = shift;
407              
408 5     5   47 no strict 'refs';
  5         16  
  5         199  
409 5     5   31 no warnings 'redefine';
  5         10  
  5         705  
410 1         4 foreach my $column ($self->get_columns) {
411 1         3 *{ $self->class . '::' . $column } =
412 1     0   5 sub { shift->column($column, @_) };
  0         0  
413             }
414              
415 1         3 return $self;
416             }
417              
418             sub generate_related_methods {
419 1     1 0 3 my $self = shift;
420              
421 5     5   35 no strict 'refs';
  5         18  
  5         179  
422 5     5   28 no warnings 'redefine';
  5         12  
  5         1593  
423 1         2 foreach my $rel_name (keys %{ $self->relationships }) {
  1         4  
424 1         5 *{ $self->class . '::' . $rel_name } =
425 1     0   5 sub { shift->related($rel_name, @_) };
  0         0  
426             }
427              
428 1         3 return $self;
429             }
430              
431             sub _build_relationships {
432 24     24   33 my $self = shift;
433 24         62 my ($relationships) = @_;
434              
435 24   50     121 $self->{relationships} ||= {};
436              
437 24         38 foreach my $rel (keys %{$relationships}) {
  24         75  
438             $self->{relationships}->{$rel} = ObjectDB::Meta::RelationshipFactory->new->build(
439 1         6 $relationships->{$rel}->{type}, %{ $relationships->{$rel} },
440             orig_class => $self->{class},
441 1         7 name => $rel
442             );
443             }
444             }
445              
446             sub _is_inheriting {
447 27     27   40 my $class = shift;
448 27         47 my ($for_class) = @_;
449              
450 27         110 my $parents = mro::get_linear_isa($for_class);
451 27         57 foreach my $parent (@$parents) {
452 34 100       95 if (my $parent_meta = $OBJECTS{$parent}) {
453 2         232 my $meta = Storable::dclone($parent_meta);
454              
455 2         8 $meta->{class} = $for_class;
456              
457 2         9 return $meta;
458             }
459             }
460              
461 25         73 return;
462             }
463              
464             1;
465             __END__