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

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