1 package SQL::Translator::Parser::XML::SQLFairy;
3 # -------------------------------------------------------------------
4 # Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
5 # Copyright (C) 2009 Jonathan Yu <frequency@cpan.org>
7 # This program is free software; you can redistribute it and/or
8 # modify it under the terms of the GNU General Public License as
9 # published by the Free Software Foundation; version 2.
11 # This program is distributed in the hope that it will be useful, but
12 # WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 # General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program; if not, write to the Free Software
18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
20 # -------------------------------------------------------------------
24 SQL::Translator::Parser::XML::SQLFairy - parser for SQL::Translator's XML.
30 my $translator = SQL::Translator->new( show_warnings => 1 );
32 my $out = $obj->translate(
33 from => 'XML-SQLFairy',
35 filename => 'schema.xml',
36 ) or die $translator->error;
42 This parser handles the flavor of XML used natively by the SQLFairy
43 project (L<SQL::Translator>). The XML must be in the namespace
44 "http://sqlfairy.sourceforge.net/sqlfairy.xml."
45 See L<SQL::Translator::Producer::XML::SQLFairy> for details of this format.
47 You do not need to specify every attribute of the Schema objects as any missing
48 from the XML will be set to their default values. e.g. A field could be written
51 <sqlf:field name="email" data_type="varchar" size="255" />
55 <sqlf:field name="email" data_type="varchar" size="255" is_nullable="1"
56 is_auto_increment="0" is_primary_key="0" is_foreign_key="0" order="4">
57 <sqlf:comments></sqlf:comments>
60 If you do not explicitly set the order of items using order attributes on the
61 tags then the order the tags appear in the XML will be used.
65 Leave the attribute out all together to use the default in L<Schema::Field>.
66 Use empty quotes or 'EMPTY_STRING' for a zero lenth string. 'NULL' for an
67 explicit null (currently sets default_value to undef in the
70 <sqlf:field default_value="" /> <!-- Empty string -->
71 <sqlf:field default_value="EMPTY_STRING" /> <!-- Empty string -->
72 <sqlf:field default_value="NULL" /> <!-- NULL -->
76 Doesn't take any extra parser args at the moment.
80 The previous version of the SQLFairy XML allowed the attributes of the the
81 schema objects to be written as either xml attributes or as data elements, in
82 any combination. While this allows for lots of flexibility in writing the XML
83 the result is a great many possible XML formats, not so good for DTD writing,
84 XPathing etc! So we have moved to a fixed version described in
85 L<SQL::Translator::Producer::XML::SQLFairy>.
87 This version of the parser will still parse the old formats and emmit warnings
88 when it sees them being used but they should be considered B<heavily
91 To convert your old format files simply pass them through the translator :)
93 $ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
97 # -------------------------------------------------------------------
101 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
103 $DEBUG = 0 unless defined $DEBUG;
106 use Carp::Clan qw/^SQL::Translator/;
108 use base qw(Exporter);
109 @EXPORT_OK = qw(parse);
111 use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo!
112 use SQL::Translator::Utils 'debug';
113 use XML::LibXML 1.69;
114 use XML::LibXML::XPathContext;
117 my ( $translator, $data ) = @_;
118 my $schema = $translator->schema;
119 local $DEBUG = $translator->debug;
120 my $doc = XML::LibXML->new->parse_string($data);
121 my $xp = XML::LibXML::XPathContext->new($doc);
123 $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
126 # Work our way through the tables
128 my @nodes = $xp->findnodes(
129 '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
133 ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
135 ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
138 debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
140 my $table = $schema->add_table(
141 get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
142 ) or die $schema->error;
147 my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
150 ("".$xp->findvalue('sqlf:order',$a) || 0)
152 ("".$xp->findvalue('sqlf:order',$b) || 0)
155 my %fdata = get_tagfields($xp, $_, "sqlf:",
156 qw/name data_type size default_value is_nullable extra
157 is_auto_increment is_primary_key is_foreign_key comments/
161 exists $fdata{'default_value'} and
162 defined $fdata{'default_value'}
164 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
165 $fdata{'default_value'}= undef;
167 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
168 $fdata{'default_value'} = "";
172 my $field = $table->add_field( %fdata ) or die $table->error;
174 $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
178 # - We should be able to make the table obj spot this when
186 @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
188 my %data = get_tagfields($xp, $_, "sqlf:",
189 qw/name type table fields reference_fields reference_table
190 match_type on_delete on_update extra/
192 $table->add_constraint( %data ) or die $table->error;
198 @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
200 my %data = get_tagfields($xp, $_, "sqlf:",
201 qw/name type fields options extra/);
202 $table->add_index( %data ) or die $table->error;
209 @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
211 my $data = $_->string_value;
212 $table->comments( $data );
220 @nodes = $xp->findnodes(
221 '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
224 my %data = get_tagfields($xp, $_, "sqlf:",
225 qw/name sql fields order extra/
227 $schema->add_view( %data ) or die $schema->error;
233 @nodes = $xp->findnodes(
234 '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
237 my %data = get_tagfields($xp, $_, "sqlf:", qw/
238 name perform_action_when database_event database_events fields
239 on_table action order extra
243 if (my $evt = $data{database_event} and $translator->{show_warnings}) {
244 carp 'The database_event tag is deprecated - please use ' .
245 'database_events (which can take one or more comma separated ' .
247 $data{database_events} = join (', ',
248 $data{database_events} || (),
253 # split into arrayref
254 if (my $evts = $data{database_events}) {
255 $data{database_events} = [split (/\s*,\s*/, $evts) ];
258 $schema->add_trigger( %data ) or die $schema->error;
264 @nodes = $xp->findnodes(
265 '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
268 my %data = get_tagfields($xp, $_, "sqlf:",
269 qw/name sql parameters owner comments order extra/
271 $schema->add_procedure( %data ) or die $schema->error;
277 # -------------------------------------------------------------------
280 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
281 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
283 # Returns hash of data.
284 # TODO - Add handling of an explicit NULL value.
287 my ($xp, $node, @names) = @_;
290 if ( m/:$/ ) { $ns = $_; next; } # Set def namespace
291 my $thisns = (s/(^.*?:)// ? $1 : $ns);
293 my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
295 my $attrib_path = "\@$_";
296 my $tag_path = "$thisns$_";
297 if ( my $found = $xp->find($attrib_path,$node) ) {
298 $data{$_} = "".$found->to_literal;
299 warn "Use of '$_' as an attribute is depricated."
300 ." Use a child tag instead."
301 ." To convert your file to the new version see the Docs.\n"
303 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
305 elsif ( $found = $xp->find($tag_path,$node) ) {
308 foreach ( $found->pop->getAttributes ) {
309 $extra{$_->getName} = $_->getData;
314 $data{$_} = "".$found->to_literal;
316 warn "Use of '$_' as a child tag is depricated."
317 ." Use an attribute instead."
318 ." To convert your file to the new version see the Docs.\n"
320 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
324 return wantarray ? %data : \%data;
329 # -------------------------------------------------------------------
335 Ignores the order attribute for Constraints, Views, Indices, Views, Triggers
336 and Procedures, using the tag order instead. (This is the order output by the
337 SQLFairy XML producer).
341 L<perl>, L<SQL::Translator>, L<SQL::Translator::Producer::XML::SQLFairy>,
342 L<SQL::Translator::Schema>.
350 Support options attribute.
354 Test foreign keys are parsed ok.
358 Control over defaulting.
364 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
365 Jonathan Yu E<lt>frequency@cpan.orgE<gt>