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