lib/SQL/Translator/Parser/SqlfXML.pm

   1 package SQL::Translator::Parser::SqlfXML;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SqlfXML.pm,v 1.2 2003-08-06 22:08:16 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 and 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 ==head1 default_value
  53
  54 Leave the tag out all together to use the default in Schema::Field. Use empty
  55 tags or EMPTY_STRING for a zero lenth string. NULL for an explicit null
  56 (currently sets default_value to undef Schema::Field).
  57
  58  <sqlf:default_value></sqlf:default_value>               <!-- Empty string -->
  59  <sqlf:default_value>EMPTY_STRING</sqlf:default_value>   <!-- Empty string -->
  60  <sqlf:default_value>NULL</sqlf:default_value>           <!-- NULL -->
  61
  62 =cut
  63
  64 use strict;
  65 use warnings;
  66
  67 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
  68 $VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
  69 $DEBUG   = 0 unless defined $DEBUG;
  70
  71 use Data::Dumper;
  72 use Exporter;
  73 use base qw(Exporter);
  74 @EXPORT_OK = qw(parse);
  75
  76 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
  77 use XML::XPath;
  78 use XML::XPath::XMLParser;
  79
  80 sub debug {
  81     warn @_,"\n" if $DEBUG;
  82 }
  83
  84 sub parse {
  85     my ( $translator, $data ) = @_;
  86     my $schema   = $translator->schema;
  87     local $DEBUG = $translator->debug;
  88     #local $TRACE  = $translator->trace ? 1 : undef;
  89     # Nothing with trace option yet!
  90
  91     my $xp = XML::XPath->new(xml => $data);
  92     $xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
  93
  94     # Work our way through the tables
  95     #
  96     my @nodes = $xp->findnodes('/sqlf:schema/sqlf:table');
  97     for my $tblnode (
  98         sort { "".$xp->findvalue('sqlf:order',$a)
  99                <=> "".$xp->findvalue('sqlf:order',$b) } @nodes
 100     ) {
 101         debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
 102         my $table = $schema->add_table(
 103             get_tagfields($xp, $tblnode, "sqlf:" => qw/name order/)
 104         ) or die $schema->error;
 105
 106         # Fields
 107         #
 108         my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
 109         foreach (
 110             sort { "".$xp->findvalue('sqlf:order',$a)
 111                    <=> "".$xp->findvalue('sqlf:order',$b) } @nodes
 112         ) {
 113             my %fdata = get_tagfields($xp, $_, "sqlf:",
 114             qw/name data_type size default_value is_nullable is_auto_increment
 115                is_primary_key is_foreign_key comments/);
 116             if (exists $fdata{default_value} and defined $fdata{default_value}){
 117                 if ( $fdata{default_value} =~ /^\s*NULL\s*$/ ) {
 118                     $fdata{default_value}= undef;
 119                 }
 120                 elsif ( $fdata{default_value} =~ /^\s*EMPTY_STRING\s*$/ ) {
 121                     $fdata{default_value} = "";
 122                 }
 123             }
 124             my $field = $table->add_field(%fdata) or die $schema->error;
 125             $table->primary_key($field->name) if $fdata{'is_primary_key'};
 126                 # TODO We should be able to make the table obj spot this when we
 127                 # use add_field.
 128             # TODO Deal with $field->extra
 129         }
 130
 131         # Constraints
 132         #
 133         @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
 134         foreach (@nodes) {
 135             my %data = get_tagfields($xp, $_, "sqlf:",
 136             qw/name type table fields reference_fields reference_table
 137                match_type on_delete_do on_update_do/);
 138             $table->add_constraint(%data) or die $schema->error;
 139         }
 140
 141         # Indexes
 142         #
 143         @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
 144         foreach (@nodes) {
 145             my %data = get_tagfields($xp, $_, "sqlf:",
 146             qw/name type fields options/);
 147             $table->add_index(%data) or die $schema->error;
 148         }
 149
 150     } # tables loop
 151
 152     return 1;
 153 }
 154
 155 # get_tagfields XPNODE, NAMESPACE => qw/TAGNAMES/;
 156 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
 157 #
 158 # Returns hash of data. If a tag isn't in the file it is not in this
 159 # hash.
 160 # TODO Add handling of and explicit NULL value.
 161 sub get_tagfields {
 162     my ($xp, $node, @names) = @_;
 163     my (%data, $ns);
 164     foreach (@names) {
 165         if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
 166         my $path = (s/(^.*?:)// ? $1 : $ns).$_;
 167         $data{$_} = $xp->findvalue($path,$node) if $xp->exists($path,$node);
 168         debug "Got $_=".(defined $data{$_} ? $data{$_} : "UNDEF");
 169     }
 170     return wantarray ? %data : \%data;
 171 }
 172
 173 1;
 174
 175 __END__
 176
 177 =pod
 178
 179 =head1 TODO
 180
 181  * Support sqf:options.
 182  * Test forign keys are parsed ok.
 183  * Control over defaulting of non-existant tags.
 184
 185 =head1 AUTHOR
 186
 187 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
 188
 189 =head1 SEE ALSO
 190
 191 perl(1), SQL::Translator, SQL::Translator::Producer::SqlfXML,
 192 SQL::Translator::Schema.
 193
 194 =cut