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