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

   1 package SQL::Translator::Parser::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # Copyright (C) 2002-2009 The SQLFairy Authors,
   5 # Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
   6 # Copyright (C) 2009 Jonathan Yu <frequency@cpan.org>
   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.60';
 104 $DEBUG   = 0 unless defined $DEBUG;
 105
 106 use Data::Dumper;
 107 use Carp::Clan qw/^SQL::Translator/;
 108 use Exporter;
 109 use base qw(Exporter);
 110 @EXPORT_OK = qw(parse);
 111
 112 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
 113 use SQL::Translator::Utils 'debug';
 114 use XML::LibXML;
 115 use XML::LibXML::XPathContext;
 116
 117 sub parse {
 118     my ( $translator, $data ) = @_;
 119     my $schema                = $translator->schema;
 120     local $DEBUG              = $translator->debug;
 121     my $doc                   = XML::LibXML->new->parse_string($data);
 122     my $xp                    = XML::LibXML::XPathContext->new($doc);
 123
 124     $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
 125
 126     #
 127     # Work our way through the tables
 128     #
 129     my @nodes = $xp->findnodes(
 130         '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
 131     );
 132     for my $tblnode (
 133         sort {
 134             ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
 135             <=>
 136             ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
 137         } @nodes
 138     ) {
 139         debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
 140
 141         my $table = $schema->add_table(
 142             get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
 143         ) or die $schema->error;
 144
 145         #
 146         # Fields
 147         #
 148         my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
 149         foreach (
 150             sort {
 151                 ("".$xp->findvalue('sqlf:order',$a) || 0)
 152                 <=>
 153                 ("".$xp->findvalue('sqlf:order',$b) || 0)
 154             } @nodes
 155         ) {
 156             my %fdata = get_tagfields($xp, $_, "sqlf:",
 157                 qw/name data_type size default_value is_nullable extra
 158                 is_auto_increment is_primary_key is_foreign_key comments/
 159             );
 160
 161             if (
 162                 exists $fdata{'default_value'} and
 163                 defined $fdata{'default_value'}
 164             ) {
 165                 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
 166                     $fdata{'default_value'}= undef;
 167                 }
 168                 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
 169                     $fdata{'default_value'} = "";
 170                 }
 171             }
 172
 173             my $field = $table->add_field( %fdata ) or die $table->error;
 174
 175             $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
 176
 177             #
 178             # TODO:
 179             # - We should be able to make the table obj spot this when
 180             #   we use add_field.
 181             #
 182         }
 183
 184         #
 185         # Constraints
 186         #
 187         @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
 188         foreach (@nodes) {
 189             my %data = get_tagfields($xp, $_, "sqlf:",
 190                 qw/name type table fields reference_fields reference_table
 191                 match_type on_delete on_update extra/
 192             );
 193             $table->add_constraint( %data ) or die $table->error;
 194         }
 195
 196         #
 197         # Indexes
 198         #
 199         @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
 200         foreach (@nodes) {
 201             my %data = get_tagfields($xp, $_, "sqlf:",
 202                 qw/name type fields options extra/);
 203             $table->add_index( %data ) or die $table->error;
 204         }
 205
 206
 207         #
 208         # Comments
 209         #
 210         @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
 211         foreach (@nodes) {
 212             my $data = $_->string_value;
 213             $table->comments( $data );
 214         }
 215
 216     } # tables loop
 217
 218     #
 219     # Views
 220     #
 221     @nodes = $xp->findnodes(
 222         '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
 223     );
 224     foreach (@nodes) {
 225         my %data = get_tagfields($xp, $_, "sqlf:",
 226             qw/name sql fields order extra/
 227         );
 228         $schema->add_view( %data ) or die $schema->error;
 229     }
 230
 231     #
 232     # Triggers
 233     #
 234     @nodes = $xp->findnodes(
 235         '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
 236     );
 237     foreach (@nodes) {
 238         my %data = get_tagfields($xp, $_, "sqlf:", qw/
 239             name perform_action_when database_event database_events fields
 240             on_table action order extra
 241         /);
 242
 243         # back compat
 244         if (my $evt = $data{database_event} and $translator->{show_warnings}) {
 245           carp 'The database_event tag is deprecated - please use ' .
 246             'database_events (which can take one or more comma separated ' .
 247             'event names)';
 248           $data{database_events} = join (', ',
 249             $data{database_events} || (),
 250             $evt,
 251           );
 252         }
 253
 254         # split into arrayref
 255         if (my $evts = $data{database_events}) {
 256           $data{database_events} = [split (/\s*,\s*/, $evts) ];
 257         }
 258
 259         $schema->add_trigger( %data ) or die $schema->error;
 260     }
 261
 262     #
 263     # Procedures
 264     #
 265     @nodes = $xp->findnodes(
 266        '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
 267     );
 268     foreach (@nodes) {
 269         my %data = get_tagfields($xp, $_, "sqlf:",
 270         qw/name sql parameters owner comments order extra/
 271         );
 272         $schema->add_procedure( %data ) or die $schema->error;
 273     }
 274
 275     return 1;
 276 }
 277
 278 # -------------------------------------------------------------------
 279 sub get_tagfields {
 280 #
 281 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
 282 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
 283 #
 284 # Returns hash of data.
 285 # TODO - Add handling of an explicit NULL value.
 286 #
 287
 288     my ($xp, $node, @names) = @_;
 289     my (%data, $ns);
 290     foreach (@names) {
 291         if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
 292         my $thisns = (s/(^.*?:)// ? $1 : $ns);
 293
 294         my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
 295
 296         my $attrib_path = "\@$_";
 297         my $tag_path    = "$thisns$_";
 298         if ( my $found = $xp->find($attrib_path,$node) ) {
 299             $data{$_} = "".$found->to_literal;
 300             warn "Use of '$_' as an attribute is depricated."
 301                 ." Use a child tag instead."
 302                 ." To convert your file to the new version see the Docs.\n"
 303                 unless $is_attrib;
 304             debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
 305         }
 306         elsif ( $found = $xp->find($tag_path,$node) ) {
 307             if ($_ eq "extra") {
 308                 my %extra;
 309                 foreach ( $found->pop->getAttributes ) {
 310                     $extra{$_->getName} = $_->getData;
 311                 }
 312                 $data{$_} = \%extra;
 313             }
 314             else {
 315                 $data{$_} = "".$found->to_literal;
 316             }
 317             warn "Use of '$_' as a child tag is depricated."
 318                 ." Use an attribute instead."
 319                 ." To convert your file to the new version see the Docs.\n"
 320                 if $is_attrib;
 321             debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
 322         }
 323     }
 324
 325     return wantarray ? %data : \%data;
 326 }
 327
 328 1;
 329
 330 # -------------------------------------------------------------------
 331
 332 =pod
 333
 334 =head1 BUGS
 335
 336 Ignores the order attribute for Constraints, Views, Indices, Views, Triggers
 337 and Procedures, using the tag order instead. (This is the order output by the
 338 SQLFairy XML producer).
 339
 340 =head1 SEE ALSO
 341
 342 L<perl>, L<SQL::Translator>, L<SQL::Translator::Producer::XML::SQLFairy>,
 343 L<SQL::Translator::Schema>.
 344
 345 =head1 TODO
 346
 347 =over 4
 348
 349 =item *
 350
 351 Support options attribute.
 352
 353 =item *
 354
 355 Test foreign keys are parsed ok.
 356
 357 =item *
 358
 359 Control over defaulting.
 360
 361 =back
 362
 363 =head1 AUTHOR
 364
 365 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
 366 Jonathan Yu E<lt>frequency@cpan.orgE<gt>
 367
 368 =cut