lib/SQL/Translator/Parser/XML/SQLFairy.pm

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