1 package SQL::Translator::Parser::XML::SQLFairy;
3 # -------------------------------------------------------------------
4 # Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 # -------------------------------------------------------------------
23 SQL::Translator::Parser::XML::SQLFairy - parser for SQL::Translator's XML.
29 my $translator = SQL::Translator->new( show_warnings => 1 );
31 my $out = $obj->translate(
32 from => 'XML-SQLFairy',
34 filename => 'schema.xml',
35 ) or die $translator->error;
41 This parser handles the flavor of XML used natively by the SQLFairy
42 project (L<SQL::Translator>). The XML must be in the namespace
43 "http://sqlfairy.sourceforge.net/sqlfairy.xml."
44 See L<SQL::Translator::Producer::XML::SQLFairy> for details of this format.
46 You do not need to specify every attribute of the Schema objects as any missing
47 from the XML will be set to their default values. e.g. A field could be written
50 <sqlf:field name="email" data_type="varchar" size="255" />
54 <sqlf:field name="email" data_type="varchar" size="255" is_nullable="1"
55 is_auto_increment="0" is_primary_key="0" is_foreign_key="0" order="4">
56 <sqlf:comments></sqlf:comments>
59 If you do not explicitly set the order of items using order attributes on the
60 tags then the order the tags appear in the XML will be used.
64 Leave the attribute out all together to use the default in L<Schema::Field>.
65 Use empty quotes or 'EMPTY_STRING' for a zero lenth string. 'NULL' for an
66 explicit null (currently sets default_value to undef in the
69 <sqlf:field default_value="" /> <!-- Empty string -->
70 <sqlf:field default_value="EMPTY_STRING" /> <!-- Empty string -->
71 <sqlf:field default_value="NULL" /> <!-- NULL -->
75 Doesn't take any extra parser args at the moment.
79 The previous version of the SQLFairy XML allowed the attributes of the the
80 schema objects to be written as either xml attributes or as data elements, in
81 any combination. While this allows for lots of flexibility in writing the XML
82 the result is a great many possible XML formats, not so good for DTD writing,
83 XPathing etc! So we have moved to a fixed version described in
84 L<SQL::Translator::Producer::XML::SQLFairy>.
86 This version of the parser will still parse the old formats and emmit warnings
87 when it sees them being used but they should be considered B<heavily
90 To convert your old format files simply pass them through the translator :)
92 $ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
96 # -------------------------------------------------------------------
100 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
102 $DEBUG = 0 unless defined $DEBUG;
105 use Carp::Clan qw/^SQL::Translator/;
107 use base qw(Exporter);
108 @EXPORT_OK = qw(parse);
110 use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo!
111 use SQL::Translator::Utils 'debug';
113 use XML::XPath::XMLParser;
116 my ( $translator, $data ) = @_;
117 my $schema = $translator->schema;
118 local $DEBUG = $translator->debug;
119 my $xp = XML::XPath->new(xml => $data);
121 $xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
124 # Work our way through the tables
126 my @nodes = $xp->findnodes(
127 '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
131 ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
133 ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
136 debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
138 my $table = $schema->add_table(
139 get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
140 ) or die $schema->error;
145 my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
148 ("".$xp->findvalue('sqlf:order',$a) || 0)
150 ("".$xp->findvalue('sqlf:order',$b) || 0)
153 my %fdata = get_tagfields($xp, $_, "sqlf:",
154 qw/name data_type size default_value is_nullable extra
155 is_auto_increment is_primary_key is_foreign_key comments/
159 exists $fdata{'default_value'} and
160 defined $fdata{'default_value'}
162 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
163 $fdata{'default_value'}= undef;
165 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
166 $fdata{'default_value'} = "";
170 my $field = $table->add_field( %fdata ) or die $table->error;
172 $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
176 # - We should be able to make the table obj spot this when
184 @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
186 my %data = get_tagfields($xp, $_, "sqlf:",
187 qw/name type table fields reference_fields reference_table
188 match_type on_delete on_update extra/
190 $table->add_constraint( %data ) or die $table->error;
196 @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
198 my %data = get_tagfields($xp, $_, "sqlf:",
199 qw/name type fields options extra/);
200 $table->add_index( %data ) or die $table->error;
207 @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
209 my $data = $_->string_value;
210 $table->comments( $data );
218 @nodes = $xp->findnodes(
219 '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
222 my %data = get_tagfields($xp, $_, "sqlf:",
223 qw/name sql fields order extra/
225 $schema->add_view( %data ) or die $schema->error;
231 @nodes = $xp->findnodes(
232 '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
235 my %data = get_tagfields($xp, $_, "sqlf:", qw/
236 name perform_action_when database_event database_events fields on_table action order
241 if (my $evt = $data{database_event} and $translator->{show_warnings}) {
242 carp 'The database_event tag is deprecated - please use database_events (which can take one or more comma separated event names)';
243 $data{database_events} = join (', ',
244 $data{database_events} || (),
249 # split into arrayref
250 if (my $evts = $data{database_events}) {
251 $data{database_events} = [split (/\s*,\s*/, $evts) ];
254 $schema->add_trigger( %data ) or die $schema->error;
260 @nodes = $xp->findnodes(
261 '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
264 my %data = get_tagfields($xp, $_, "sqlf:",
265 qw/name sql parameters owner comments order extra/
267 $schema->add_procedure( %data ) or die $schema->error;
273 # -------------------------------------------------------------------
276 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
277 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
279 # Returns hash of data.
280 # TODO - Add handling of an explicit NULL value.
283 my ($xp, $node, @names) = @_;
286 if ( m/:$/ ) { $ns = $_; next; } # Set def namespace
287 my $thisns = (s/(^.*?:)// ? $1 : $ns);
289 my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
291 my $attrib_path = "\@$thisns$_";
292 my $tag_path = "$thisns$_";
293 if ( $xp->exists($attrib_path,$node) ) {
294 $data{$_} = "".$xp->findvalue($attrib_path,$node);
295 warn "Use of '$_' as an attribute is depricated."
296 ." Use a child tag instead."
297 ." To convert your file to the new version see the Docs.\n"
299 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
301 elsif ( $xp->exists($tag_path,$node) ) {
304 my $extra_nodes = $xp->find($tag_path,$node);
305 foreach ( $extra_nodes->pop->getAttributes ) {
306 $extra{$_->getName} = $_->getData;
311 $data{$_} = "".$xp->findvalue($tag_path,$node);
313 warn "Use of '$_' as a child tag is depricated."
314 ." Use an attribute instead."
315 ." To convert your file to the new version see the Docs.\n"
317 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
321 return wantarray ? %data : \%data;
326 # -------------------------------------------------------------------
332 Ignores the order attribute for Constraints, Views, Indices,
333 Views, Triggers and Procedures, using the tag order instead. (This is the order
334 output by the SQLFairy XML producer).
338 L<perl>, L<SQL::Translator>, L<SQL::Translator::Producer::XML::SQLFairy>,
339 L<SQL::Translator::Schema>.
347 Support options attribute.
351 Test foreign keys are parsed ok.
355 Control over defaulting.
361 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.