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

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