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

   1 package SQL::Translator::Parser::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLFairy.pm,v 1.1 2003-08-22 18:01:50 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =head1 NAME
  24
  25 SQL::Translator::Parser::XML::SQLFairy - parser for SQL::Translator's XML
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator;
  30   use SQL::Translator::Parser::XML::SQLFairy;
  31
  32   my $translator     = SQL::Translator->new(
  33       from           => 'XML-SQLFairy',
  34       to             => 'MySQL',
  35       filename       => 'schema.xml',
  36       show_warnings  => 1,
  37       add_drop_table => 1,
  38   );
  39
  40   print $obj->translate;
  41
  42 =head1 DESCRIPTION
  43
  44 This parser handles the flavor of XML used natively by the SQLFairy
  45 project (SQL::Translator).  The XML must be in the namespace
  46 "http://sqlfairy.sourceforge.net/sqlfairy.xml."
  47
  48 To see an example of the XML translate one of your schema :) e.g.
  49
  50   $ sql_translator.pl -f MySQL -t XML-SQLFairy schema.sql
  51
  52 =head2 attrib_values
  53
  54 The parser will happily parse XML produced with the attrib_values arg set. If
  55 it sees a value set as an attribute and a tag, the tag value will override
  56 that of the attribute.
  57
  58 e.g. For the xml below the table would get the name 'bar'.
  59
  60   <sqlf:table name="foo">
  61     <sqlf:name>foo</name>
  62   </sqlf:table>
  63
  64 =head2 default_value
  65
  66 Leave the tag out all together to use the default in Schema::Field. Use empty
  67 tags or EMPTY_STRING for a zero lenth string. NULL for an explicit null
  68 (currently sets default_value to undef in the Schema::Field obj).
  69
  70  <sqlf:default_value></sqlf:default_value>             <!-- Empty string -->
  71  <sqlf:default_value>EMPTY_STRING</sqlf:default_value> <!-- Empty string -->
  72  <sqlf:default_value>NULL</sqlf:default_value>         <!-- NULL -->
  73
  74  <sqlf:default_value/> <!-- Empty string BUT DON'T USE! See BUGS -->
  75
  76 =head2 ARGS
  77
  78 Doesn't take any extra parser args at the moment.
  79
  80 =cut
  81
  82 # -------------------------------------------------------------------
  83
  84 use strict;
  85
  86 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
  87 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
  88 $DEBUG   = 0 unless defined $DEBUG;
  89
  90 use Data::Dumper;
  91 use Exporter;
  92 use base qw(Exporter);
  93 @EXPORT_OK = qw(parse);
  94
  95 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
  96 use XML::XPath;
  97 use XML::XPath::XMLParser;
  98
  99 sub debug {
 100     warn @_,"\n" if $DEBUG;
 101 }
 102
 103 sub parse {
 104     my ( $translator, $data ) = @_;
 105     my $schema   = $translator->schema;
 106     local $DEBUG = $translator->debug;
 107     #local $TRACE  = $translator->trace ? 1 : undef;
 108     # Nothing with trace option yet!
 109
 110     my $xp = XML::XPath->new(xml => $data);
 111     $xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
 112
 113     # Work our way through the tables
 114     #
 115     my @nodes = $xp->findnodes('/sqlf:schema/sqlf:table');
 116     for my $tblnode (
 117         sort { "".$xp->findvalue('sqlf:order',$a)
 118                <=> "".$xp->findvalue('sqlf:order',$b) } @nodes
 119     ) {
 120         debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
 121         my $table = $schema->add_table(
 122             get_tagfields($xp, $tblnode, "sqlf:" => qw/name order/)
 123         ) or die $schema->error;
 124
 125         # Fields
 126         #
 127         my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
 128         foreach (
 129             sort { ("".$xp->findvalue('sqlf:order',$a) || 0)
 130                    <=> ("".$xp->findvalue('sqlf:order',$b) || 0) } @nodes
 131         ) {
 132             my %fdata = get_tagfields($xp, $_, "sqlf:",
 133             qw/name data_type size default_value is_nullable is_auto_increment
 134                is_primary_key is_foreign_key comments/);
 135             if (exists $fdata{default_value} and defined $fdata{default_value}){
 136                 if ( $fdata{default_value} =~ /^\s*NULL\s*$/ ) {
 137                     $fdata{default_value}= undef;
 138                 }
 139                 elsif ( $fdata{default_value} =~ /^\s*EMPTY_STRING\s*$/ ) {
 140                     $fdata{default_value} = "";
 141                 }
 142             }
 143             my $field = $table->add_field(%fdata) or die $schema->error;
 144             $table->primary_key($field->name) if $fdata{'is_primary_key'};
 145                 # TODO We should be able to make the table obj spot this when we
 146                 # use add_field.
 147             # TODO Deal with $field->extra
 148         }
 149
 150         # Constraints
 151         #
 152         @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
 153         foreach (@nodes) {
 154             my %data = get_tagfields($xp, $_, "sqlf:",
 155             qw/name type table fields reference_fields reference_table
 156                match_type on_delete_do on_update_do/);
 157             $table->add_constraint(%data) or die $schema->error;
 158         }
 159
 160         # Indexes
 161         #
 162         @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
 163         foreach (@nodes) {
 164             my %data = get_tagfields($xp, $_, "sqlf:",
 165             qw/name type fields options/);
 166             $table->add_index(%data) or die $schema->error;
 167         }
 168
 169     } # tables loop
 170
 171     return 1;
 172 }
 173
 174 # get_tagfields XPNODE, NAMESPACE => qw/TAGNAMES/;
 175 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
 176 #
 177 # Returns hash of data. If a tag isn't in the file it is not in this
 178 # hash.
 179 # TODO Add handling of and explicit NULL value.
 180 sub get_tagfields {
 181     my ($xp, $node, @names) = @_;
 182     my (%data, $ns);
 183     foreach (@names) {
 184         if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
 185         my $thisns = (s/(^.*?:)// ? $1 : $ns);
 186         foreach my $path ( "\@$thisns$_","$thisns$_") {
 187             $data{$_} = $xp->findvalue($path,$node) if $xp->exists($path,$node);
 188             debug "Got $_=".(defined $data{$_} ? $data{$_} : "UNDEF");
 189         }
 190     }
 191     return wantarray ? %data : \%data;
 192 }
 193
 194 1;
 195
 196 # -------------------------------------------------------------------
 197
 198 =pod
 199
 200 =head1 BUGS
 201
 202 B<Empty Tags> e.g. <sqlf:default_value/> Will be parsed as "" and
 203 hence also false.  This is a bit counter intuative for some tags as
 204 seeing <sqlf:is_nullable /> you might think that it was set when it
 205 fact it wouldn't be.  So for now it is safest not to use them until
 206 their handling by the parser is defined.
 207
 208 =head1 TODO
 209
 210 =over 4
 211
 212 =item * Support sqf:options.
 213
 214 =item * Test forign keys are parsed ok.
 215
 216 =item * Sort out sane handling of empty tags <foo/> vs tags with no content
 217    <foo></foo> vs it no tag being there.
 218
 219 =item * Control over defaulting of non-existant tags.
 220
 221 =back
 222
 223 =head1 AUTHOR
 224
 225 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 226
 227 =head1 SEE ALSO
 228
 229 perl(1), SQL::Translator, SQL::Translator::Producer::XML::SQLFairy,
 230 SQL::Translator::Schema.
 231
 232 =cut