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