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