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

   1 package SQL::Translator::Parser::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
   5 #
   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.
   9 #
  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.
  14 #
  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
  18 # 02111-1307  USA
  19 # -------------------------------------------------------------------
  20
  21 =head1 NAME
  22
  23 SQL::Translator::Parser::XML::SQLFairy - parser for SQL::Translator's XML.
  24
  25 =head1 SYNOPSIS
  26
  27   use SQL::Translator;
  28
  29   my $translator = SQL::Translator->new( show_warnings  => 1 );
  30
  31   my $out = $obj->translate(
  32       from     => 'XML-SQLFairy',
  33       to       => 'MySQL',
  34       filename => 'schema.xml',
  35   ) or die $translator->error;
  36
  37   print $out;
  38
  39 =head1 DESCRIPTION
  40
  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.
  45
  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
  48 using only;
  49
  50  <sqlf:field name="email" data_type="varchar" size="255" />
  51
  52 Instead of the full;
  53
  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>
  57  </sqlf:field>
  58
  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.
  61
  62 =head2 default_value
  63
  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
  67 Schema::Field obj).
  68
  69   <sqlf:field default_value="" />                <!-- Empty string -->
  70   <sqlf:field default_value="EMPTY_STRING" />    <!-- Empty string -->
  71   <sqlf:field default_value="NULL" />            <!-- NULL -->
  72
  73 =head2 ARGS
  74
  75 Doesn't take any extra parser args at the moment.
  76
  77 =head1 LEGACY FORMAT
  78
  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>.
  85
  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
  88 depreciated>.
  89
  90 To convert your old format files simply pass them through the translator :)
  91
  92  $ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
  93
  94 =cut
  95
  96 # -------------------------------------------------------------------
  97
  98 use strict;
  99
 100 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
 101 $VERSION = '1.99';
 102 $DEBUG   = 0 unless defined $DEBUG;
 103
 104 use Data::Dumper;
 105 use Exporter;
 106 use base qw(Exporter);
 107 @EXPORT_OK = qw(parse);
 108
 109 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
 110 use SQL::Translator::Utils 'debug';
 111 use XML::XPath;
 112 use XML::XPath::XMLParser;
 113
 114 sub parse {
 115     my ( $translator, $data ) = @_;
 116     my $schema                = $translator->schema;
 117     local $DEBUG              = $translator->debug;
 118     my $xp                    = XML::XPath->new(xml => $data);
 119
 120     $xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
 121
 122     #
 123     # Work our way through the tables
 124     #
 125     my @nodes = $xp->findnodes(
 126         '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
 127     );
 128     for my $tblnode (
 129         sort {
 130             ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
 131             <=>
 132             ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
 133         } @nodes
 134     ) {
 135         debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
 136
 137         my $table = $schema->add_table(
 138             get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
 139         ) or die $schema->error;
 140
 141         #
 142         # Fields
 143         #
 144         my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
 145         foreach (
 146             sort {
 147                 ("".$xp->findvalue('sqlf:order',$a) || 0)
 148                 <=>
 149                 ("".$xp->findvalue('sqlf:order',$b) || 0)
 150             } @nodes
 151         ) {
 152             my %fdata = get_tagfields($xp, $_, "sqlf:",
 153                 qw/name data_type size default_value is_nullable extra
 154                 is_auto_increment is_primary_key is_foreign_key comments/
 155             );
 156
 157             if (
 158                 exists $fdata{'default_value'} and
 159                 defined $fdata{'default_value'}
 160             ) {
 161                 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
 162                     $fdata{'default_value'}= undef;
 163                 }
 164                 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
 165                     $fdata{'default_value'} = "";
 166                 }
 167             }
 168
 169             my $field = $table->add_field( %fdata ) or die $table->error;
 170
 171             $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
 172
 173             #
 174             # TODO:
 175             # - We should be able to make the table obj spot this when
 176             #   we use add_field.
 177             #
 178         }
 179
 180         #
 181         # Constraints
 182         #
 183         @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
 184         foreach (@nodes) {
 185             my %data = get_tagfields($xp, $_, "sqlf:",
 186                 qw/name type table fields reference_fields reference_table
 187                 match_type on_delete on_update extra/
 188             );
 189             $table->add_constraint( %data ) or die $table->error;
 190         }
 191
 192         #
 193         # Indexes
 194         #
 195         @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
 196         foreach (@nodes) {
 197             my %data = get_tagfields($xp, $_, "sqlf:",
 198                 qw/name type fields options extra/);
 199             $table->add_index( %data ) or die $table->error;
 200         }
 201
 202
 203         #
 204         # Comments
 205         #
 206         @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
 207         foreach (@nodes) {
 208             my $data = $_->string_value;
 209             $table->comments( $data );
 210         }
 211
 212     } # tables loop
 213
 214     #
 215     # Views
 216     #
 217     @nodes = $xp->findnodes(
 218         '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
 219     );
 220     foreach (@nodes) {
 221         my %data = get_tagfields($xp, $_, "sqlf:",
 222             qw/name sql fields order extra/
 223         );
 224         $schema->add_view( %data ) or die $schema->error;
 225     }
 226
 227     #
 228     # Triggers
 229     #
 230     @nodes = $xp->findnodes(
 231         '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
 232     );
 233     foreach (@nodes) {
 234         my %data = get_tagfields($xp, $_, "sqlf:", qw/
 235             name perform_action_when database_event fields on_table action order
 236             extra
 237         /);
 238         $schema->add_trigger( %data ) or die $schema->error;
 239     }
 240
 241     #
 242     # Procedures
 243     #
 244     @nodes = $xp->findnodes(
 245        '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
 246     );
 247     foreach (@nodes) {
 248         my %data = get_tagfields($xp, $_, "sqlf:",
 249         qw/name sql parameters owner comments order extra/
 250         );
 251         $schema->add_procedure( %data ) or die $schema->error;
 252     }
 253
 254     return 1;
 255 }
 256
 257 # -------------------------------------------------------------------
 258 sub get_tagfields {
 259 #
 260 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
 261 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
 262 #
 263 # Returns hash of data.
 264 # TODO - Add handling of an explicit NULL value.
 265 #
 266
 267     my ($xp, $node, @names) = @_;
 268     my (%data, $ns);
 269     foreach (@names) {
 270         if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
 271         my $thisns = (s/(^.*?:)// ? $1 : $ns);
 272
 273         my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
 274
 275         my $attrib_path = "\@$thisns$_";
 276         my $tag_path    = "$thisns$_";
 277         if ( $xp->exists($attrib_path,$node) ) {
 278             $data{$_} = "".$xp->findvalue($attrib_path,$node);
 279             warn "Use of '$_' as an attribute is depricated."
 280                 ." Use a child tag instead."
 281                 ." To convert your file to the new version see the Docs.\n"
 282                 unless $is_attrib;
 283             debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
 284         }
 285         elsif ( $xp->exists($tag_path,$node) ) {
 286             if ($_ eq "extra") {
 287                 my %extra;
 288                 my $extra_nodes = $xp->find($tag_path,$node);
 289                 foreach ( $extra_nodes->pop->getAttributes ) {
 290                     $extra{$_->getName} = $_->getData;
 291                 }
 292                 $data{$_} = \%extra;
 293             }
 294             else {
 295                 $data{$_} = "".$xp->findvalue($tag_path,$node);
 296             }
 297             warn "Use of '$_' as a child tag is depricated."
 298                 ." Use an attribute instead."
 299                 ." To convert your file to the new version see the Docs.\n"
 300                 if $is_attrib;
 301             debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
 302         }
 303     }
 304
 305     return wantarray ? %data : \%data;
 306 }
 307
 308 1;
 309
 310 # -------------------------------------------------------------------
 311
 312 =pod
 313
 314 =head1 BUGS
 315
 316 Ignores the order attribute for Constraints, Views, Indices,
 317 Views, Triggers and Procedures, using the tag order instead. (This is the order
 318 output by the SQLFairy XML producer).
 319
 320 =head1 SEE ALSO
 321
 322 L<perl>, L<SQL::Translator>, L<SQL::Translator::Producer::XML::SQLFairy>,
 323 L<SQL::Translator::Schema>.
 324
 325 =head1 TODO
 326
 327 =over 4
 328
 329 =item *
 330
 331 Support options attribute.
 332
 333 =item *
 334
 335 Test foreign keys are parsed ok.
 336
 337 =item *
 338
 339 Control over defaulting.
 340
 341 =back
 342
 343 =head1 AUTHOR
 344
 345 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 346
 347 =cut