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; |
31 | |
32 | die 'No DBIx::Schema' unless ($dbixschema); |
33 | if (!ref $dbixschema) { |
34 | eval "use $dbixschema;"; |
35 | die "Can't load $dbixschema ($@)" if($@); |
36 | } |
37 | |
38 | my $schema = $tr->schema; |
39 | my $table_no = 0; |
40 | |
41 | # print Dumper($dbixschema->registered_classes); |
42 | |
43 | foreach my $tableclass ($dbixschema->registered_classes) |
44 | { |
45 | eval "use $tableclass"; |
46 | print("Can't load $tableclass"), next if($@); |
47 | my $source = $tableclass->result_source_instance; |
48 | |
49 | my $table = $schema->add_table( |
50 | name => $source->name, |
51 | type => 'TABLE', |
52 | ) || die $schema->error; |
53 | my $colcount = 0; |
54 | foreach my $col ($source->columns) |
55 | { |
56 | # assuming column_info in dbix is the same as DBI (?) |
57 | # data_type is a number, column_type is text? |
58 | my %colinfo = ( |
59 | name => $col, |
60 | default_value => '', |
61 | size => 0, |
62 | is_auto_increment => 0, |
63 | is_foreign_key => 0, |
64 | is_nullable => 0, |
65 | %{$source->column_info($col)} |
66 | ); |
67 | my $f = $table->add_field(%colinfo) || die $table->error; |
68 | } |
69 | $table->primary_key($source->primary_columns); |
70 | |
71 | |
72 | my @rels = $source->relationships(); |
73 | foreach my $rel (@rels) |
74 | { |
75 | my $rel_info = $source->relationship_info($rel); |
76 | print "Accessor: $rel_info->{attrs}{accessor}\n"; |
77 | next if(!exists $rel_info->{attrs}{accessor} || |
1d996af5 |
78 | $rel_info->{attrs}{accessor} eq 'multi'); |
79 | # Going by the accessor type isn't such a good idea (yes, I know |
80 | # I suggested it). I think the best way to tell if something's a |
81 | # foreign key constraint is to assume if it doesn't include our |
82 | # primaries then it is (dumb but it'll do). Ignore any rel cond |
83 | # that isn't a straight hash, but get both sets of keys in full |
84 | # so you don't barf on multi-primaries. Oh, and a dog-simple |
85 | # deploy method to chuck the results of this exercise at a db |
86 | # for testing is |
87 | # $schema->storage->dbh->do($_) for split(";\n", $sql); |
88 | # -- mst (03:42 local time, please excuse any mistakes) |
89 | my $rel_table = $rel_info->{class}->table(); |
b02b20b5 |
90 | my $cond = (keys (%{$rel_info->{cond}}))[0]; |
91 | my ($refkey) = $cond =~ /^\w+\.(\w+)$/; |
92 | if($rel_table && $refkey) |
1d996af5 |
93 | { |
b02b20b5 |
94 | $table->add_constraint( |
95 | type => 'foreign_key', |
96 | name => "fk_${rel}_id", |
97 | fields => $rel, |
98 | reference_fields => $refkey, |
99 | reference_table => $rel_table, |
100 | ); |
101 | } |
102 | } |
103 | } |
104 | |
105 | } |
106 | |
107 | 1; |