Remove duplicate entry in DBI drivers hash
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / XML / SQLFairy.pm
CommitLineData
0a1ec87a 1package SQL::Translator::Parser::XML::SQLFairy;
2
0a1ec87a 3=head1 NAME
4
8571d198 5SQL::Translator::Parser::XML::SQLFairy - parser for SQL::Translator's XML.
0a1ec87a 6
7=head1 SYNOPSIS
8
9 use SQL::Translator;
0a1ec87a 10
85633bfb 11 my $translator = SQL::Translator->new( show_warnings => 1 );
0a1ec87a 12
85633bfb 13 my $out = $obj->translate(
14 from => 'XML-SQLFairy',
15 to => 'MySQL',
16 filename => 'schema.xml',
17 ) or die $translator->error;
18
19 print $out;
0a1ec87a 20
21=head1 DESCRIPTION
22
23This parser handles the flavor of XML used natively by the SQLFairy
97d0d778 24project (L<SQL::Translator>). The XML must be in the XML namespace
25C<http://sqlfairy.sourceforge.net/sqlfairy.xml>.
8571d198 26See L<SQL::Translator::Producer::XML::SQLFairy> for details of this format.
0a1ec87a 27
8571d198 28You do not need to specify every attribute of the Schema objects as any missing
29from the XML will be set to their default values. e.g. A field could be written
30using only;
0a1ec87a 31
8571d198 32 <sqlf:field name="email" data_type="varchar" size="255" />
0a1ec87a 33
8571d198 34Instead of the full;
0a1ec87a 35
8571d198 36 <sqlf:field name="email" data_type="varchar" size="255" is_nullable="1"
37 is_auto_increment="0" is_primary_key="0" is_foreign_key="0" order="4">
38 <sqlf:comments></sqlf:comments>
39 </sqlf:field>
0a1ec87a 40
8571d198 41If you do not explicitly set the order of items using order attributes on the
42tags then the order the tags appear in the XML will be used.
0a1ec87a 43
44=head2 default_value
45
ac7adbab 46Leave the attribute out all together to use the default in
47L<SQL::Translator::Schema::Field>. Use empty quotes or 'EMPTY_STRING'
48for a zero length string. 'NULL' for an explicit null (currently sets
49default_value to undef in the field object).
0a1ec87a 50
91f28468 51 <sqlf:field default_value="" /> <!-- Empty string -->
52 <sqlf:field default_value="EMPTY_STRING" /> <!-- Empty string -->
53 <sqlf:field default_value="NULL" /> <!-- NULL -->
0a1ec87a 54
0a1ec87a 55=head2 ARGS
56
57Doesn't take any extra parser args at the moment.
58
4a268a6c 59=head1 LEGACY FORMAT
60
a0e61cf6 61The previous version of the SQLFairy XML allowed the attributes of the
4a268a6c 62schema objects to be written as either xml attributes or as data elements, in
63any combination. While this allows for lots of flexibility in writing the XML
64the result is a great many possible XML formats, not so good for DTD writing,
65XPathing etc! So we have moved to a fixed version described in
66L<SQL::Translator::Producer::XML::SQLFairy>.
67
a0e61cf6 68This version of the parser will still parse the old formats and emit warnings
91f28468 69when it sees them being used but they should be considered B<heavily
70depreciated>.
4a268a6c 71
91f28468 72To convert your old format files simply pass them through the translator :)
4a268a6c 73
91f28468 74 $ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
4a268a6c 75
0a1ec87a 76=cut
77
0a1ec87a 78use strict;
f27f9229 79use warnings;
0a1ec87a 80
0c04c5a2 81our ( $DEBUG, @EXPORT_OK );
82our $VERSION = '1.59';
0a1ec87a 83$DEBUG = 0 unless defined $DEBUG;
84
85use Data::Dumper;
9768b204 86use Carp::Clan qw/^SQL::Translator/;
0a1ec87a 87use Exporter;
88use base qw(Exporter);
89@EXPORT_OK = qw(parse);
90
91use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo!
a5e624ac 92use SQL::Translator::Utils 'debug';
90097ddd 93use XML::LibXML;
1c56cdb0 94use XML::LibXML::XPathContext;
0a1ec87a 95
0a1ec87a 96sub parse {
97 my ( $translator, $data ) = @_;
a5e624ac 98 my $schema = $translator->schema;
99 local $DEBUG = $translator->debug;
1c56cdb0 100 my $doc = XML::LibXML->new->parse_string($data);
101 my $xp = XML::LibXML::XPathContext->new($doc);
0a1ec87a 102
1c56cdb0 103 $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
0a1ec87a 104
a5e624ac 105 #
0a1ec87a 106 # Work our way through the tables
107 #
87c5565e 108 my @nodes = $xp->findnodes(
109 '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
110 );
0a1ec87a 111 for my $tblnode (
8571d198 112 sort {
53a533ef 113 ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
8571d198 114 <=>
53a533ef 115 ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
a5e624ac 116 } @nodes
0a1ec87a 117 ) {
118 debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
a5e624ac 119
0a1ec87a 120 my $table = $schema->add_table(
b1789409 121 get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
0a1ec87a 122 ) or die $schema->error;
123
a5e624ac 124 #
0a1ec87a 125 # Fields
126 #
127 my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
128 foreach (
8571d198 129 sort {
a5e624ac 130 ("".$xp->findvalue('sqlf:order',$a) || 0)
8571d198 131 <=>
132 ("".$xp->findvalue('sqlf:order',$b) || 0)
a5e624ac 133 } @nodes
0a1ec87a 134 ) {
135 my %fdata = get_tagfields($xp, $_, "sqlf:",
94ed484b 136 qw/name data_type size default_value is_nullable extra
a5e624ac 137 is_auto_increment is_primary_key is_foreign_key comments/
138 );
139
140 if (
8571d198 141 exists $fdata{'default_value'} and
a5e624ac 142 defined $fdata{'default_value'}
143 ) {
144 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
145 $fdata{'default_value'}= undef;
0a1ec87a 146 }
a5e624ac 147 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
148 $fdata{'default_value'} = "";
0a1ec87a 149 }
150 }
a5e624ac 151
19922fbc 152 my $field = $table->add_field( %fdata ) or die $table->error;
a5e624ac 153
154 $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
155
156 #
157 # TODO:
8571d198 158 # - We should be able to make the table obj spot this when
a5e624ac 159 # we use add_field.
a5e624ac 160 #
0a1ec87a 161 }
162
a5e624ac 163 #
0a1ec87a 164 # Constraints
165 #
166 @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
167 foreach (@nodes) {
168 my %data = get_tagfields($xp, $_, "sqlf:",
a5e624ac 169 qw/name type table fields reference_fields reference_table
100684f3 170 match_type on_delete on_update extra/
a5e624ac 171 );
19922fbc 172 $table->add_constraint( %data ) or die $table->error;
0a1ec87a 173 }
174
a5e624ac 175 #
0a1ec87a 176 # Indexes
177 #
178 @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
179 foreach (@nodes) {
180 my %data = get_tagfields($xp, $_, "sqlf:",
b1789409 181 qw/name type fields options extra/);
19922fbc 182 $table->add_index( %data ) or die $table->error;
0a1ec87a 183 }
184
ea93df61 185
7c71eaab 186 #
187 # Comments
188 #
189 @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
190 foreach (@nodes) {
191 my $data = $_->string_value;
192 $table->comments( $data );
193 }
194
0a1ec87a 195 } # tables loop
196
19922fbc 197 #
198 # Views
199 #
87c5565e 200 @nodes = $xp->findnodes(
201 '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
202 );
19922fbc 203 foreach (@nodes) {
204 my %data = get_tagfields($xp, $_, "sqlf:",
b1789409 205 qw/name sql fields order extra/
19922fbc 206 );
207 $schema->add_view( %data ) or die $schema->error;
208 }
8571d198 209
19922fbc 210 #
211 # Triggers
212 #
87c5565e 213 @nodes = $xp->findnodes(
214 '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
215 );
19922fbc 216 foreach (@nodes) {
b1789409 217 my %data = get_tagfields($xp, $_, "sqlf:", qw/
1c56cdb0 218 name perform_action_when database_event database_events fields
219 on_table action order extra
b1789409 220 /);
af858b8a 221
222 # back compat
9768b204 223 if (my $evt = $data{database_event} and $translator->{show_warnings}) {
1c56cdb0 224 carp 'The database_event tag is deprecated - please use ' .
225 'database_events (which can take one or more comma separated ' .
226 'event names)';
af858b8a 227 $data{database_events} = join (', ',
228 $data{database_events} || (),
229 $evt,
230 );
231 }
232
233 # split into arrayref
234 if (my $evts = $data{database_events}) {
235 $data{database_events} = [split (/\s*,\s*/, $evts) ];
236 }
237
19922fbc 238 $schema->add_trigger( %data ) or die $schema->error;
239 }
8571d198 240
19922fbc 241 #
242 # Procedures
243 #
87c5565e 244 @nodes = $xp->findnodes(
245 '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
246 );
19922fbc 247 foreach (@nodes) {
248 my %data = get_tagfields($xp, $_, "sqlf:",
b1789409 249 qw/name sql parameters owner comments order extra/
19922fbc 250 );
251 $schema->add_procedure( %data ) or die $schema->error;
252 }
8571d198 253
0a1ec87a 254 return 1;
255}
256
a5e624ac 257sub get_tagfields {
258#
8571d198 259# get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
0a1ec87a 260# get_tagfields $node, "sqlf:" => qw/name type fields reference/;
261#
8571d198 262# Returns hash of data.
263# TODO - Add handling of an explicit NULL value.
a5e624ac 264#
265
0a1ec87a 266 my ($xp, $node, @names) = @_;
267 my (%data, $ns);
268 foreach (@names) {
269 if ( m/:$/ ) { $ns = $_; next; } # Set def namespace
270 my $thisns = (s/(^.*?:)// ? $1 : $ns);
a5e624ac 271
94ed484b 272 my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
a5e624ac 273
1c56cdb0 274 my $attrib_path = "\@$_";
8571d198 275 my $tag_path = "$thisns$_";
1c56cdb0 276 if ( my $found = $xp->find($attrib_path,$node) ) {
277 $data{$_} = "".$found->to_literal;
8571d198 278 warn "Use of '$_' as an attribute is depricated."
279 ." Use a child tag instead."
280 ." To convert your file to the new version see the Docs.\n"
281 unless $is_attrib;
282 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
283 }
1c56cdb0 284 elsif ( $found = $xp->find($tag_path,$node) ) {
94ed484b 285 if ($_ eq "extra") {
286 my %extra;
1c56cdb0 287 foreach ( $found->pop->getAttributes ) {
94ed484b 288 $extra{$_->getName} = $_->getData;
289 }
290 $data{$_} = \%extra;
291 }
292 else {
1c56cdb0 293 $data{$_} = "".$found->to_literal;
94ed484b 294 }
8571d198 295 warn "Use of '$_' as a child tag is depricated."
296 ." Use an attribute instead."
297 ." To convert your file to the new version see the Docs.\n"
298 if $is_attrib;
a5e624ac 299 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
0a1ec87a 300 }
301 }
a5e624ac 302
0a1ec87a 303 return wantarray ? %data : \%data;
304}
305
3061;
307
0a1ec87a 308=pod
309
310=head1 BUGS
311
1c56cdb0 312Ignores the order attribute for Constraints, Views, Indices, Views, Triggers
313and Procedures, using the tag order instead. (This is the order output by the
314SQLFairy XML producer).
0a1ec87a 315
91f28468 316=head1 SEE ALSO
317
318L<perl>, L<SQL::Translator>, L<SQL::Translator::Producer::XML::SQLFairy>,
319L<SQL::Translator::Schema>.
320
0a1ec87a 321=head1 TODO
322
323=over 4
324
8571d198 325=item *
a5e624ac 326
94ed484b 327Support options attribute.
a5e624ac 328
8571d198 329=item *
0a1ec87a 330
8571d198 331Test foreign keys are parsed ok.
0a1ec87a 332
8571d198 333=item *
0a1ec87a 334
91f28468 335Control over defaulting.
0a1ec87a 336
337=back
338
339=head1 AUTHOR
340
1c56cdb0 341Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
342Jonathan Yu E<lt>frequency@cpan.orgE<gt>
0a1ec87a 343
0a1ec87a 344=cut