lib/SQL/Translator/Parser/SqlfXML.pm

   1 package SQL::Translator::Parser::SqlfXML;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SqlfXML.pm,v 1.5 2003-08-15 15:08:08 grommit 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::SqlfXML - parser for the XML produced by
  26 SQL::Translator::Producer::SqlfXML.
  27
  28 =head1 SYNOPSIS
  29
  30   use SQL::Translator;
  31   use SQL::Translator::Parser::SqlfXML;
  32
  33   my $translator = SQL::Translator->new(
  34       show_warnings  => 1,
  35       add_drop_table => 1,
  36   );
  37   print = $obj->translate(
  38       from     => "SqlfXML",
  39       to       =>"MySQL",
  40       filename => "fooschema.xml",
  41   );
  42
  43 =head1 DESCRIPTION
  44
  45 A SQL Translator parser to parse the XML files produced by its SqftXML producer.
  46 The XML must be in the namespace 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 --from=MySQL --to=SqftXML foo_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 use strict;
  83 use warnings;
  84
  85 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
  86 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
  87 $DEBUG   = 0 unless defined $DEBUG;
  88
  89 use Data::Dumper;
  90 use Exporter;
  91 use base qw(Exporter);
  92 @EXPORT_OK = qw(parse);
  93
  94 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
  95 use XML::XPath;
  96 use XML::XPath::XMLParser;
  97
  98 sub debug {
  99     warn @_,"\n" if $DEBUG;
 100 }
 101
 102 sub parse {
 103     my ( $translator, $data ) = @_;
 104     my $schema   = $translator->schema;
 105     local $DEBUG = $translator->debug;
 106     #local $TRACE  = $translator->trace ? 1 : undef;
 107     # Nothing with trace option yet!
 108
 109     my $xp = XML::XPath->new(xml => $data);
 110     $xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
 111
 112     # Work our way through the tables
 113     #
 114     my @nodes = $xp->findnodes('/sqlf:schema/sqlf:table');
 115     for my $tblnode (
 116         sort { "".$xp->findvalue('sqlf:order',$a)
 117                <=> "".$xp->findvalue('sqlf:order',$b) } @nodes
 118     ) {
 119         debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
 120         my $table = $schema->add_table(
 121             get_tagfields($xp, $tblnode, "sqlf:" => qw/name order/)
 122         ) or die $schema->error;
 123
 124         # Fields
 125         #
 126         my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
 127         foreach (
 128             sort { ("".$xp->findvalue('sqlf:order',$a) || 0)
 129                    <=> ("".$xp->findvalue('sqlf:order',$b) || 0) } @nodes
 130         ) {
 131             my %fdata = get_tagfields($xp, $_, "sqlf:",
 132             qw/name data_type size default_value is_nullable is_auto_increment
 133                is_primary_key is_foreign_key comments/);
 134             if (exists $fdata{default_value} and defined $fdata{default_value}){
 135                 if ( $fdata{default_value} =~ /^\s*NULL\s*$/ ) {
 136                     $fdata{default_value}= undef;
 137                 }
 138                 elsif ( $fdata{default_value} =~ /^\s*EMPTY_STRING\s*$/ ) {
 139                     $fdata{default_value} = "";
 140                 }
 141             }
 142             my $field = $table->add_field(%fdata) or die $schema->error;
 143             $table->primary_key($field->name) if $fdata{'is_primary_key'};
 144                 # TODO We should be able to make the table obj spot this when we
 145                 # use add_field.
 146             # TODO Deal with $field->extra
 147         }
 148
 149         # Constraints
 150         #
 151         @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
 152         foreach (@nodes) {
 153             my %data = get_tagfields($xp, $_, "sqlf:",
 154             qw/name type table fields reference_fields reference_table
 155                match_type on_delete_do on_update_do/);
 156             $table->add_constraint(%data) or die $schema->error;
 157         }
 158
 159         # Indexes
 160         #
 161         @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
 162         foreach (@nodes) {
 163             my %data = get_tagfields($xp, $_, "sqlf:",
 164             qw/name type fields options/);
 165             $table->add_index(%data) or die $schema->error;
 166         }
 167
 168     } # tables loop
 169
 170     return 1;
 171 }
 172
 173 # get_tagfields XPNODE, NAMESPACE => qw/TAGNAMES/;
 174 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
 175 #
 176 # Returns hash of data. If a tag isn't in the file it is not in this
 177 # hash.
 178 # TODO Add handling of and explicit NULL value.
 179 sub get_tagfields {
 180     my ($xp, $node, @names) = @_;
 181     my (%data, $ns);
 182     foreach (@names) {
 183         if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
 184         my $thisns = (s/(^.*?:)// ? $1 : $ns);
 185         foreach my $path ( "\@$thisns$_","$thisns$_") {
 186             $data{$_} = $xp->findvalue($path,$node) if $xp->exists($path,$node);
 187             debug "Got $_=".(defined $data{$_} ? $data{$_} : "UNDEF");
 188         }
 189     }
 190     return wantarray ? %data : \%data;
 191 }
 192
 193 1;
 194
 195 __END__
 196
 197 =pod
 198
 199 =head1 BUGS
 200
 201 B<Empty Tags> e.g. <sqlf:default_value/> Will be parsed as "" and hence also
 202 false. This is a bit counter intuative for some tags as seeing
 203 <sqlf:is_nullable /> you might think that it was set when it fact it wouldn't
 204 be. So for now it is safest not to use them until their handling by the parser
 205 is defined.
 206
 207 =head1 TODO
 208
 209  * Support sqf:options.
 210  * Test forign keys are parsed ok.
 211  * Sort out sane handling of empty tags <foo/> vs tags with no content
 212    <foo></foo> vs it no tag being there.
 213  * Control over defaulting of non-existant tags.
 214
 215 =head1 AUTHOR
 216
 217 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
 218
 219 =head1 SEE ALSO
 220
 221 perl(1), SQL::Translator, SQL::Translator::Producer::SqlfXML,
 222 SQL::Translator::Schema.
 223
 224 =cut