Commit | Line | Data |
b02b20b5 |
1 | package SQL::Translator::Parser::DBIx::Class; |
2 | |
3 | # AUTHOR: Jess Robinson |
4 | |
1d996af5 |
5 | # Some mistakes the fault of Matt S Trout |
6 | |
b02b20b5 |
7 | use strict; |
8 | use warnings; |
9 | use vars qw($DEBUG $VERSION @EXPORT_OK); |
10 | $DEBUG = 0 unless defined $DEBUG; |
11 | $VERSION = sprintf "%d.%02d", q$Revision 1.0$ =~ /(\d+)\.(\d+)/; |
12 | |
13 | use Exporter; |
14 | use Data::Dumper; |
15 | use SQL::Translator::Utils qw(debug normalize_name); |
16 | |
17 | use base qw(Exporter); |
18 | |
19 | @EXPORT_OK = qw(parse); |
20 | |
21 | # ------------------------------------------------------------------- |
22 | # parse($tr, $data) |
23 | # |
24 | # Note that $data, in the case of this parser, is unuseful. |
25 | # We're working with DBIx::Class Schemas, not data streams. |
26 | # ------------------------------------------------------------------- |
27 | sub parse { |
28 | my ($tr, $data) = @_; |
29 | my $args = $tr->parser_args; |
30 | my $dbixschema = $args->{'DBIx::Schema'} || $data; |
bddbe61c |
31 | $dbixschema ||= $args->{'package'}; |
b02b20b5 |
32 | |
33 | die 'No DBIx::Schema' unless ($dbixschema); |
34 | if (!ref $dbixschema) { |
35 | eval "use $dbixschema;"; |
36 | die "Can't load $dbixschema ($@)" if($@); |
37 | } |
38 | |
39 | my $schema = $tr->schema; |
40 | my $table_no = 0; |
41 | |
42 | # print Dumper($dbixschema->registered_classes); |
43 | |
0009fa49 |
44 | #foreach my $tableclass ($dbixschema->registered_classes) |
45 | foreach my $moniker ($dbixschema->sources) |
b02b20b5 |
46 | { |
0009fa49 |
47 | #eval "use $tableclass"; |
48 | #print("Can't load $tableclass"), next if($@); |
49 | my $source = $dbixschema->source($moniker); |
b02b20b5 |
50 | |
51 | my $table = $schema->add_table( |
52 | name => $source->name, |
53 | type => 'TABLE', |
54 | ) || die $schema->error; |
55 | my $colcount = 0; |
56 | foreach my $col ($source->columns) |
57 | { |
58 | # assuming column_info in dbix is the same as DBI (?) |
59 | # data_type is a number, column_type is text? |
60 | my %colinfo = ( |
61 | name => $col, |
b02b20b5 |
62 | size => 0, |
63 | is_auto_increment => 0, |
64 | is_foreign_key => 0, |
65 | is_nullable => 0, |
66 | %{$source->column_info($col)} |
67 | ); |
0009fa49 |
68 | if ($colinfo{is_nullable}) { |
69 | $colinfo{default} = '' unless exists $colinfo{default}; |
70 | } |
b02b20b5 |
71 | my $f = $table->add_field(%colinfo) || die $table->error; |
72 | } |
73 | $table->primary_key($source->primary_columns); |
74 | |
b02b20b5 |
75 | my @rels = $source->relationships(); |
76 | foreach my $rel (@rels) |
77 | { |
78 | my $rel_info = $source->relationship_info($rel); |
b02b20b5 |
79 | next if(!exists $rel_info->{attrs}{accessor} || |
1d996af5 |
80 | $rel_info->{attrs}{accessor} eq 'multi'); |
81 | # Going by the accessor type isn't such a good idea (yes, I know |
82 | # I suggested it). I think the best way to tell if something's a |
83 | # foreign key constraint is to assume if it doesn't include our |
84 | # primaries then it is (dumb but it'll do). Ignore any rel cond |
85 | # that isn't a straight hash, but get both sets of keys in full |
86 | # so you don't barf on multi-primaries. Oh, and a dog-simple |
87 | # deploy method to chuck the results of this exercise at a db |
88 | # for testing is |
89 | # $schema->storage->dbh->do($_) for split(";\n", $sql); |
90 | # -- mst (03:42 local time, please excuse any mistakes) |
d22bc4e3 |
91 | my $rel_table = $source->related_source($rel)->name; |
b02b20b5 |
92 | my $cond = (keys (%{$rel_info->{cond}}))[0]; |
93 | my ($refkey) = $cond =~ /^\w+\.(\w+)$/; |
2478970c |
94 | my ($key) = $rel_info->{cond}->{$cond} =~ /^\w+\.(\w+)$/; |
b02b20b5 |
95 | if($rel_table && $refkey) |
1d996af5 |
96 | { |
b02b20b5 |
97 | $table->add_constraint( |
98 | type => 'foreign_key', |
2478970c |
99 | name => "fk_${key}", |
100 | fields => $key, |
b02b20b5 |
101 | reference_fields => $refkey, |
102 | reference_table => $rel_table, |
2478970c |
103 | ); |
b02b20b5 |
104 | } |
105 | } |
106 | } |
107 | |
108 | } |
109 | |
110 | 1; |