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