Commit | Line | Data |
b9d98887 |
1 | use MooseX::Declare; |
2 | role SQL::Translator::Parser::DDL::XML { |
1c5b81b5 |
3 | use MooseX::MultiMethods; |
4 | use MooseX::Types::Moose qw(Any); |
5 | use XML::LibXML; |
6 | use XML::LibXML::XPathContext; |
7 | use aliased 'SQL::Translator::Object::Column'; |
8 | use aliased 'SQL::Translator::Object::Constraint'; |
9 | use aliased 'SQL::Translator::Object::Index'; |
10 | use aliased 'SQL::Translator::Object::Procedure'; |
11 | use aliased 'SQL::Translator::Object::Table'; |
12 | use aliased 'SQL::Translator::Object::Trigger'; |
13 | use aliased 'SQL::Translator::Object::View'; |
14 | use SQL::Translator::Types qw(Schema); |
15 | |
16 | multi method parse(Schema $data) { $data } |
17 | multi method parse(Any $data) { |
098b1353 |
18 | my $translator = $self->translator; |
b9d98887 |
19 | my $schema = $translator->schema; |
1c5b81b5 |
20 | # local $DEBUG = $translator->debug; |
b9d98887 |
21 | my $doc = XML::LibXML->new->parse_string($data); |
22 | my $xp = XML::LibXML::XPathContext->new($doc); |
23 | |
24 | $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml"); |
25 | |
26 | # |
27 | # Work our way through the tables |
28 | # |
29 | my @nodes = $xp->findnodes( |
30 | '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table' |
31 | ); |
32 | for my $tblnode ( |
33 | sort { |
34 | ("".$xp->findvalue('sqlf:order|@order',$a) || 0) |
35 | <=> |
36 | ("".$xp->findvalue('sqlf:order|@order',$b) || 0) |
37 | } @nodes |
38 | ) { |
1c5b81b5 |
39 | # debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode); |
b9d98887 |
40 | |
1c5b81b5 |
41 | my $table = Table->new({ |
42 | get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/), schema => $schema |
43 | }); |
44 | $schema->add_table($table); |
b9d98887 |
45 | |
46 | # |
47 | # Fields |
48 | # |
49 | my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode); |
50 | foreach ( |
51 | sort { |
52 | ("".$xp->findvalue('sqlf:order',$a) || 0) |
53 | <=> |
54 | ("".$xp->findvalue('sqlf:order',$b) || 0) |
55 | } @nodes |
56 | ) { |
57 | my %fdata = get_tagfields($xp, $_, "sqlf:", |
58 | qw/name data_type size default_value is_nullable extra |
59 | is_auto_increment is_primary_key is_foreign_key comments/ |
60 | ); |
61 | |
62 | if ( |
63 | exists $fdata{'default_value'} and |
64 | defined $fdata{'default_value'} |
65 | ) { |
66 | if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) { |
67 | $fdata{'default_value'}= undef; |
68 | } |
69 | elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) { |
70 | $fdata{'default_value'} = ""; |
71 | } |
72 | } |
73 | |
1c5b81b5 |
74 | $fdata{table} = $table; |
75 | $fdata{sql_data_type} = $self->data_type_mapping->{$fdata{data_type}} || -99999; |
76 | my $field = Column->new(%fdata); |
77 | $table->add_column($field); |
b9d98887 |
78 | |
49eb21a3 |
79 | $field->is_primary_key(1) if $fdata{is_primary_key}; |
b9d98887 |
80 | |
81 | # |
82 | # TODO: |
83 | # - We should be able to make the table obj spot this when |
84 | # we use add_field. |
85 | # |
86 | } |
87 | |
88 | # |
89 | # Constraints |
90 | # |
91 | @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode); |
92 | foreach (@nodes) { |
93 | my %data = get_tagfields($xp, $_, "sqlf:", |
94 | qw/name type table fields reference_fields reference_table |
95 | match_type on_delete on_update extra/ |
96 | ); |
1c5b81b5 |
97 | |
98 | $data{table} = $table; |
99 | my $constraint = Constraint->new(%data); |
100 | $table->add_constraint($constraint); |
b9d98887 |
101 | } |
102 | |
103 | # |
104 | # Indexes |
105 | # |
106 | @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode); |
107 | foreach (@nodes) { |
108 | my %data = get_tagfields($xp, $_, "sqlf:", |
109 | qw/name type fields options extra/); |
1c5b81b5 |
110 | |
111 | $data{table} = $table; |
112 | my $index = Index->new(%data); |
113 | $table->add_index($index); |
b9d98887 |
114 | } |
115 | |
116 | |
117 | # |
118 | # Comments |
119 | # |
120 | @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode); |
121 | foreach (@nodes) { |
122 | my $data = $_->string_value; |
123 | $table->comments( $data ); |
124 | } |
125 | |
126 | } # tables loop |
127 | |
128 | # |
129 | # Views |
130 | # |
131 | @nodes = $xp->findnodes( |
132 | '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view' |
133 | ); |
134 | foreach (@nodes) { |
135 | my %data = get_tagfields($xp, $_, "sqlf:", |
1c5b81b5 |
136 | qw/name sql fields extra/ |
b9d98887 |
137 | ); |
1c5b81b5 |
138 | my $view = View->new(%data); |
139 | $schema->add_view($view); |
b9d98887 |
140 | } |
141 | |
142 | # |
143 | # Triggers |
144 | # |
145 | @nodes = $xp->findnodes( |
146 | '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger' |
147 | ); |
148 | foreach (@nodes) { |
149 | my %data = get_tagfields($xp, $_, "sqlf:", qw/ |
150 | name perform_action_when database_event database_events fields |
1c5b81b5 |
151 | on_table action extra |
b9d98887 |
152 | /); |
153 | |
154 | # back compat |
155 | if (my $evt = $data{database_event} and $translator->{show_warnings}) { |
1c5b81b5 |
156 | # carp 'The database_event tag is deprecated - please use ' . |
157 | # 'database_events (which can take one or more comma separated ' . |
158 | # 'event names)'; |
b9d98887 |
159 | $data{database_events} = join (', ', |
160 | $data{database_events} || (), |
161 | $evt, |
162 | ); |
163 | } |
164 | |
165 | # split into arrayref |
166 | if (my $evts = $data{database_events}) { |
167 | $data{database_events} = [split (/\s*,\s*/, $evts) ]; |
168 | } |
1c5b81b5 |
169 | my $trigger = Trigger->new(%data); |
170 | $schema->add_trigger($trigger); |
b9d98887 |
171 | } |
172 | |
173 | # |
174 | # Procedures |
175 | # |
176 | @nodes = $xp->findnodes( |
177 | '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure' |
178 | ); |
179 | foreach (@nodes) { |
180 | my %data = get_tagfields($xp, $_, "sqlf:", |
1c5b81b5 |
181 | qw/name sql parameters owner comments extra/ |
b9d98887 |
182 | ); |
1c5b81b5 |
183 | my $procedure = Procedure->new(%data); |
184 | $schema->add_procedure($procedure); |
b9d98887 |
185 | } |
186 | |
187 | return 1; |
188 | } |
189 | |
190 | # ------------------------------------------------------------------- |
191 | sub get_tagfields { |
192 | # |
193 | # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/; |
194 | # get_tagfields $node, "sqlf:" => qw/name type fields reference/; |
195 | # |
196 | # Returns hash of data. |
197 | # TODO - Add handling of an explicit NULL value. |
198 | # |
199 | |
200 | my ($xp, $node, @names) = @_; |
201 | my (%data, $ns); |
202 | foreach (@names) { |
203 | if ( m/:$/ ) { $ns = $_; next; } # Set def namespace |
204 | my $thisns = (s/(^.*?:)// ? $1 : $ns); |
205 | |
206 | my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1; |
207 | |
208 | my $attrib_path = "\@$_"; |
209 | my $tag_path = "$thisns$_"; |
210 | if ( my $found = $xp->find($attrib_path,$node) ) { |
211 | $data{$_} = "".$found->to_literal; |
212 | warn "Use of '$_' as an attribute is depricated." |
213 | ." Use a child tag instead." |
214 | ." To convert your file to the new version see the Docs.\n" |
215 | unless $is_attrib; |
1c5b81b5 |
216 | # debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' ); |
b9d98887 |
217 | } |
218 | elsif ( $found = $xp->find($tag_path,$node) ) { |
219 | if ($_ eq "extra") { |
220 | my %extra; |
221 | foreach ( $found->pop->getAttributes ) { |
222 | $extra{$_->getName} = $_->getData; |
223 | } |
224 | $data{$_} = \%extra; |
225 | } |
226 | else { |
227 | $data{$_} = "".$found->to_literal; |
228 | } |
229 | warn "Use of '$_' as a child tag is depricated." |
230 | ." Use an attribute instead." |
231 | ." To convert your file to the new version see the Docs.\n" |
232 | if $is_attrib; |
1c5b81b5 |
233 | # debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' ); |
b9d98887 |
234 | } |
235 | } |
236 | |
237 | return wantarray ? %data : \%data; |
238 | } |
239 | } |