File Coverage

blib/lib/DBIx/DataModel/Schema/Generator.pm
Criterion Covered Total %
statement 125 200 62.5
branch 15 50 30.0
condition 14 47 29.7
subroutine 18 24 75.0
pod 9 9 100.0
total 181 330 54.8


line stmt bran cond sub pod time code
1             #----------------------------------------------------------------------
2             package DBIx::DataModel::Schema::Generator;
3             #----------------------------------------------------------------------
4              
5             # see POD doc at end of file
6             # version : see DBIx::DataModel
7              
8 2     2   1827 use strict;
  2         10  
  2         58  
9 2     2   9 use warnings;
  2         5  
  2         49  
10 2     2   9 no warnings 'uninitialized';
  2         4  
  2         62  
11 2     2   13 use Carp;
  2         4  
  2         174  
12 2     2   12 use List::Util qw/max/;
  2         6  
  2         270  
13 2     2   13 use Exporter qw/import/;
  2         4  
  2         101  
14 2     2   3506 use DBI;
  2         38255  
  2         117  
15 2     2   581 use Try::Tiny;
  2         2128  
  2         112  
16 2     2   492 use Module::Load ();
  2         1127  
  2         43  
17 2     2   520 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  2         4267  
  2         14  
18              
19              
20             our @EXPORT = qw/fromDBIxClass fromDBI/;
21              
22              
23 2     2   248 use constant CASCADE => 0; # see L
  2         5  
  2         6100  
24              
25             #----------------------------------------------------------------------
26             # front methods
27             #----------------------------------------------------------------------
28              
29             sub new {
30 2     2 1 20188 my ($class, @args) = @_;
31 2         10 my $self = bless {@args}, $class;
32 2   50     14 $self->{-schema} ||= "My::Schema";
33 2   50     17 $self->{tables} ||= [];
34 2   50     13 $self->{assoc} ||= [];
35 2         37 return $self;
36             }
37              
38              
39             sub fromDBI {
40             # may be called as ordinary sub or as method
41 0 0   0 1 0 my $self = ref $_[0] eq __PACKAGE__ ? shift : __PACKAGE__->new(@ARGV);
42              
43 0         0 $self->parse_DBI(@_);
44 0         0 print $self->perl_code;
45             }
46              
47              
48             sub fromDBIxClass {
49             # may be called as ordinary sub or as method
50 0 0   0 1 0 my $self = ref $_[0] eq __PACKAGE__ ? shift : __PACKAGE__->new(@ARGV);
51              
52 0         0 $self->parse_DBIx_Class(@_);
53 0         0 print $self->perl_code;
54             }
55              
56             # other name for this method
57             *fromDBIC = \&fromDBIxClass;
58              
59              
60              
61             # support for SQL::Translator::Producer
62             sub produce {
63 0     0 1 0 my $tr = shift;
64              
65 0 0       0 my $self = __PACKAGE__->new(%{$tr->{producer_args} || {}});
  0         0  
66 0         0 $self->parse_SQL_Translator($tr);
67 0         0 return $self->perl_code;
68             }
69              
70              
71             sub load {
72 0     0 1 0 my $self = shift;
73 0         0 eval $self->perl_code;
74             }
75              
76              
77             #----------------------------------------------------------------------
78             # build internal data from external sources
79             #----------------------------------------------------------------------
80              
81             sub parse_DBI {
82 2     2 1 14 my $self = shift;
83              
84             # dbh connection
85 2 50       7 my $arg1 = shift or croak "missing arg (dsn for DBI->connect(..))";
86 2 50 33     24 my $dbh = ref $arg1 && $arg1->isa('DBI::db') ? $arg1 : do {
87 0   0     0 my $user = shift || "";
88 0   0     0 my $passwd = shift || "";
89 0   0     0 my $options = shift || {RaiseError => 1};
90 0 0       0 DBI->connect($arg1, $user, $passwd, $options)
91             or croak "DBI->connect failed ($DBI::errstr)";
92             };
93              
94             # get list of tables
95 2         4 my %args;
96 2         6 $args{catalog} = shift;
97 2         5 $args{schema} = shift;
98 2   50     13 $args{type} = shift || "TABLE";
99 2         17 my $tables_sth = $dbh->table_info(@args{qw/catalog schema table type/});
100 2         872 my $tables = $tables_sth->fetchall_arrayref({});
101              
102             TABLE:
103 2         217 foreach my $table (@$tables) {
104              
105             # get primary key info
106 7         347 my @table_id = @{$table}{qw/TABLE_CAT TABLE_SCHEM TABLE_NAME/};
  7         33  
107 7   100     54 my $pkey = join(" ", $dbh->primary_key(@table_id)) || "unknown_pk";
108              
109             my $table_info = {
110             classname => _table2class($table->{TABLE_NAME}),
111             tablename => $table->{TABLE_NAME},
112             pkey => $pkey,
113             remarks => $table->{REMARKS},
114 7         10762 };
115              
116             # insert into list of tables
117 7         20 push @{$self->{tables}}, $table_info;
  7         24  
118              
119              
120             # get association info (in an eval because unimplemented by some drivers)
121 7     7   285 my $fkey_sth = try {$dbh->foreign_key_info(@table_id,
122             undef, undef, undef)}
123 7 50       51 or next TABLE;
124              
125 7         14020 while (my $fk_row = $fkey_sth->fetchrow_hashref) {
126              
127             # hack for unifying "ODBC" or "SQL/CLI" column names (see L)
128 5   33     175 $fk_row->{"UK_$_"} ||= $fk_row->{"PK$_"} for qw/TABLE_NAME COLUMN_NAME/;
129 5   33     42 $fk_row->{"FK_$_"} ||= $fk_row->{"FK$_"} for qw/TABLE_NAME COLUMN_NAME/;
130              
131 5         12 my $del_rule = $fk_row->{DELETE_RULE};
132              
133             my @assoc = (
134             { table => _table2class($fk_row->{UK_TABLE_NAME}),
135             col => $fk_row->{UK_COLUMN_NAME},
136             role => _table2role($fk_row->{UK_TABLE_NAME}),
137             mult_min => 1, #0/1 (TODO: depend on is_nullable on other side)
138             mult_max => 1,
139             },
140             { table => _table2class($fk_row->{FK_TABLE_NAME}),
141             col => $fk_row->{FK_COLUMN_NAME},
142 5   66     14 role => _table2role($fk_row->{FK_TABLE_NAME}, "s"),
143             mult_min => 0,
144             mult_max => '*',
145             is_cascade => defined $del_rule && $del_rule == CASCADE,
146             }
147             );
148              
149 5         19 push @{$self->{assoc}}, \@assoc;
  5         135  
150             }
151             }
152             }
153              
154              
155             sub parse_DBIx_Class {
156 0     0 1 0 my $self = shift;
157              
158 0 0       0 my $dbic_schema = shift or croak "missing arg (DBIC schema name)";
159              
160             # load the DBIx::Class schema
161 0 0       0 eval {Module::Load::load $dbic_schema; 1} or croak $@;
  0         0  
  0         0  
162              
163             # global hash to hold assoc. info (because we must collect info from
164             # both tables to get both directions of the association)
165 0         0 my %associations;
166              
167             # foreach DBIC table class ("moniker" : short class name)
168 0         0 foreach my $moniker ($dbic_schema->sources) {
169 0         0 my $source = $dbic_schema->source($moniker); # full DBIC class
170              
171             # table info
172 0         0 my $table_info = {
173             classname => $moniker,
174             tablename => $source->from,
175             pkey => join(" ", $source->primary_columns),
176             };
177              
178             # inflated columns
179 0         0 foreach my $col ($source->columns) {
180 0         0 my $column_info = $source->column_info($col);
181             my $inflate_info = $column_info->{_inflate_info}
182 0 0       0 or next;
183              
184             # don't care about inflators for related objects
185 0 0       0 next if $source->relationship_info($col);
186              
187 0         0 my $data_type = $column_info->{data_type};
188 0         0 push @{$self->{column_types}{$data_type}{$moniker}}, $col;
  0         0  
189             }
190              
191             # insert into list of tables
192 0         0 push @{$self->{tables}}, $table_info;
  0         0  
193              
194             # association info
195 0         0 foreach my $relname ($source->relationships) {
196 0         0 my $relinfo = $source->relationship_info($relname);
197              
198             # extract join keys from $relinfo->{cond} (which
199             # is of shape {"foreign.k1" => "self.k2"})
200 0         0 my ($fk, $pk) = map /\.(.*)/, %{$relinfo->{cond}};
  0         0  
201              
202             # moniker of the other side of the relationship
203 0         0 my $relmoniker = $source->related_source($relname)->source_name;
204              
205             # info structure
206             my %info = (
207             table => $relmoniker,
208             col => $fk,
209             role => $relname,
210              
211             # compute multiplicities
212             mult_min => $relinfo->{attrs}{join_type} eq 'LEFT' ? 0 : 1,
213 0 0       0 mult_max => $relinfo->{attrs}{accessor} eq 'multi' ? "*" : 1,
    0          
214             );
215              
216             # store assoc info into global hash; since both sides of the assoc must
217             # ultimately be joined, we compute a unique key from alphabetic ordering
218 0 0 0     0 my ($key, $index) = ($moniker cmp $relmoniker || $fk cmp $pk) < 0
219             ? ("$moniker/$relmoniker/$fk/$pk", 0)
220             : ("$relmoniker/$moniker/$pk/$fk", 1);
221 0         0 $associations{$key}[$index] = \%info;
222              
223             # info on other side of the association
224 0         0 my $other_index = 1 - $index;
225 0   0     0 my $other_assoc = $associations{$key}[1 - $index] ||= {};
226 0   0     0 $other_assoc->{table} ||= $moniker;
227 0   0     0 $other_assoc->{col} ||= $pk;
228 0 0       0 defined $other_assoc->{mult_min} or $other_assoc->{mult_min} = 1;
229 0 0       0 defined $other_assoc->{mult_max} or $other_assoc->{mult_max} = 1;
230             }
231             }
232              
233 0         0 $self->{assoc} = [values %associations];
234             }
235              
236              
237             sub parse_SQL_Translator {
238 0     0 1 0 my ($self, $tr) = @_;
239              
240 0         0 my $schema = $tr->schema;
241 0         0 foreach my $table ($schema->get_tables) {
242 0         0 my $tablename = $table->name;
243 0         0 my $classname = _table2class($tablename);
244 0         0 my $pk = $table->primary_key;
245 0 0       0 my @pkey = $pk ? ($pk->field_names) : qw/unknown_pk/;
246              
247 0         0 my $table_info = {
248             classname => $classname,
249             tablename => $tablename,
250             pkey => join(" ", @pkey),
251             remarks => join("\n", $table->comments),
252             };
253 0         0 push @{$self->{tables}}, $table_info;
  0         0  
254              
255             my @foreign_keys
256 0         0 = grep {$_->type eq 'FOREIGN KEY'} ($table->get_constraints);
  0         0  
257              
258 0         0 my $role = _table2role($tablename, "s");
259 0         0 foreach my $fk (@foreign_keys) {
260 0         0 my $ref_table = $fk->reference_table;
261 0         0 my @ref_fields = $fk->reference_fields;
262              
263             my @assoc = (
264             { table => _table2class($ref_table),
265             col => $table_info->{pkey},
266 0         0 role => _table2role($ref_table),
267             mult_min => 1, #0/1 (TODO: depend on is_nullable on other side)
268             mult_max => 1,
269             },
270             { table => $classname,
271             col => join(" ", $fk->fields),
272             role => $role,
273             mult_min => 0,
274             mult_max => '*',
275             }
276             );
277 0         0 push @{$self->{assoc}}, \@assoc;
  0         0  
278             }
279             }
280             }
281              
282              
283             #----------------------------------------------------------------------
284             # emit perl code
285             #----------------------------------------------------------------------
286              
287             sub perl_code {
288 2     2 1 159 my ($self) = @_;
289              
290             # check that we have some data
291 2 50       4 @{$self->{tables}}
  2         10  
292             or croak "can't generate schema: no data. "
293             . "Call parse_DBI() or parse_DBIx_Class() before";
294              
295             # make sure there is no duplicate role on the same table
296 2         5 my %seen_role;
297 2         4 foreach my $assoc (@{$self->{assoc}}) {
  2         7  
298 5         8 my $count;
299 5         23 $count = ++$seen_role{$assoc->[0]{table}}{$assoc->[1]{role}};
300 5 100       13 $assoc->[1]{role} .= "_$count" if $count > 1;
301 5         17 $count = ++$seen_role{$assoc->[1]{table}}{$assoc->[0]{role}};
302 5 100       13 $assoc->[0]{role} .= "_$count" if $count > 1;
303             }
304              
305             # compute max length of various fields (for prettier source alignment)
306 2         4 my %l;
307 2         6 foreach my $field (qw/classname tablename pkey/) {
308 6         9 $l{$field} = max map {length $_->{$field}} @{$self->{tables}};
  21         52  
  6         13  
309             }
310 2         5 foreach my $field (qw/col role mult/) {
311 6         9 $l{$field} = max map {length $_->{$field}} map {(@$_)} @{$self->{assoc}};
  30         56  
  15         25  
  6         14  
312             }
313 2         9 $l{mult} = max ($l{mult}, 4);
314              
315             # start emitting code
316 2         10 my $code = <<__END_OF_CODE__;
317             use strict;
318             use warnings;
319             use DBIx::DataModel;
320              
321             DBIx::DataModel # no semicolon (intentional)
322              
323             #---------------------------------------------------------------------#
324             # SCHEMA DECLARATION #
325             #---------------------------------------------------------------------#
326             ->Schema('$self->{-schema}')
327              
328             #---------------------------------------------------------------------#
329             # TABLE DECLARATIONS #
330             #---------------------------------------------------------------------#
331             __END_OF_CODE__
332              
333 2         10 my $colsizes = "%-$l{classname}s %-$l{tablename}s %-$l{pkey}s";
334 2         7 my $format = "->Table(qw/$colsizes/)\n";
335              
336 2         19 $code .= sprintf("# $colsizes\n", qw/Class Table PK/)
337             . sprintf("# $colsizes\n", qw/===== ===== ==/);
338              
339 2         5 foreach my $table (@{$self->{tables}}) {
  2         6  
340 7 50       18 if ($table->{remarks}) {
341 0         0 $table->{remarks} =~ s/^/# /gm;
342 0         0 $code .= "\n$table->{remarks}\n";
343             }
344 7         14 $code .= sprintf $format, @{$table}{qw/classname tablename pkey/};
  7         21  
345             }
346              
347              
348 2         11 $colsizes = "%-$l{classname}s %-$l{role}s %-$l{mult}s %-$l{col}s";
349 2         6 $format = " [qw/$colsizes/]";
350              
351 2         9 $code .= <<__END_OF_CODE__;
352              
353             #---------------------------------------------------------------------#
354             # ASSOCIATION DECLARATIONS #
355             #---------------------------------------------------------------------#
356             __END_OF_CODE__
357              
358 2         16 $code .= sprintf("# $colsizes\n", qw/Class Role Mult Join/)
359             . sprintf("# $colsizes", qw/===== ==== ==== ====/);
360              
361 2         6 foreach my $a (@{$self->{assoc}}) {
  2         5  
362              
363             # for prettier output, make sure that multiplicity "1" is first
364             @$a = reverse @$a if $a->[1]{mult_max} eq "1"
365 5 50 33     20 && $a->[0]{mult_max} eq "*";
366              
367             # complete association info
368 5         8 for my $i (0, 1) {
369 10   50     21 $a->[$i]{role} ||= "---";
370 10         28 my $mult = "$a->[$i]{mult_min}..$a->[$i]{mult_max}";
371 10   33     40 $a->[$i]{mult} = {"0..*" => "*", "1..1" => "1"}->{$mult} || $mult;
372             }
373              
374             # association or composition
375 5 100       14 my $relationship = $a->[1]{is_cascade} ? 'Composition' : 'Association';
376              
377             $code .= "\n->$relationship(\n"
378 5         17 . sprintf($format, @{$a->[0]}{qw/table role mult col/})
379             . ",\n"
380 5         10 . sprintf($format, @{$a->[1]}{qw/table role mult col/})
  5         22  
381             . ")\n";
382             }
383 2         5 $code .= "\n;\n";
384              
385             # column types
386 2         10 $code .= <<__END_OF_CODE__;
387              
388             #---------------------------------------------------------------------#
389             # COLUMN TYPES #
390             #---------------------------------------------------------------------#
391             # $self->{-schema}->ColumnType(ColType_Example =>
392             # fromDB => sub {...},
393             # toDB => sub {...});
394              
395             # $self->{-schema}::SomeTable->ColumnType(ColType_Example =>
396             # qw/column1 column2 .../);
397              
398             __END_OF_CODE__
399              
400 2 50       5 while (my ($type, $targets) = each %{$self->{column_types} || {}}) {
  2         22  
401 0         0 $code .= <<__END_OF_CODE__;
402             # $type
403             $self->{-schema}->ColumnType($type =>
404             fromDB => sub {}, # SKELETON .. PLEASE FILL IN
405             toDB => sub {});
406             __END_OF_CODE__
407              
408 0         0 while (my ($table, $cols) = each %$targets) {
409             $code .= sprintf("%s::%s->ColumnType($type => qw/%s/);\n",
410 0         0 $self->{-schema}, $table, join(" ", @$cols));
411             }
412 0         0 $code .= "\n";
413             }
414              
415             # end of module
416 2         7 $code .= "\n\n1;\n";
417              
418 2         13 return $code;
419             }
420              
421             #----------------------------------------------------------------------
422             # utility methods/functions
423             #----------------------------------------------------------------------
424              
425             # generate a Perl classname from a database table name
426             sub _table2class{
427 17     17   43 my ($tablename) = @_;
428              
429 17         218 my $classname = join '', map ucfirst, split /[\W_]+/, lc $tablename;
430             }
431              
432             # singular / plural inflection. Start with simple-minded defaults,
433             # and try to more sophisticated use Lingua::Inflect if module is installed
434             my $to_S = sub {(my $r = $_[0]) =~ s/s$//i; $r};
435             my $to_PL = sub {$_[0] . "s"};
436 2     2   1257 eval "use Lingua::EN::Inflect::Phrase qw/to_S to_PL/;"
  2         205445  
  2         178  
437             . "\$to_S = \\&to_S; \$to_PL = \\&to_PL;"
438             or warn "Lingua::EN::Inflect::Phrase is recommended; please install it to "
439             . "generate better names for associations";
440             ;
441              
442             # generate a rolename from a database table name
443             sub _table2role{
444 10     10   29 my ($tablename, $plural) = @_;
445              
446 10 100       23 my $inflect = $plural ? $to_PL : $to_S;
447             # my ($first, @other) = map {$inflect->($_)} split /[\W_]+/, lc $tablename;
448             # my $role = join '_', $first, @other;
449 10         39 my $role = $inflect->(lc $tablename);
450 10         194280 return $role;
451             }
452              
453              
454             1;
455              
456             __END__