From: Mark Addison Date: Wed, 6 Aug 2003 17:14:09 +0000 (+0000) Subject: Moved Producer::XML to Producer::SqlfXML. X-Git-Tag: v0.04~358 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FSQL-Translator.git;a=commitdiff_plain;h=c957e92dd6b604eed3167580716f418b9dec42f8 Moved Producer::XML to Producer::SqlfXML. Added Parser::XML to parse the XML from Producer::SqlfXML. --- diff --git a/MANIFEST b/MANIFEST index 50b32db..5963dfd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -16,6 +16,7 @@ lib/SQL/Translator/Parser/MySQL.pm lib/SQL/Translator/Parser/Oracle.pm lib/SQL/Translator/Parser/PostgreSQL.pm lib/SQL/Translator/Parser/xSV.pm +lib/SQL/Translator/Parser/SqlfXML.pm lib/SQL/Translator/Producer.pm lib/SQL/Translator/Producer/ClassDBI.pm lib/SQL/Translator/Producer/Diagram.pm @@ -27,7 +28,7 @@ lib/SQL/Translator/Producer/POD.pm lib/SQL/Translator/Producer/PostgreSQL.pm lib/SQL/Translator/Producer/SQLite.pm lib/SQL/Translator/Producer/Sybase.pm -lib/SQL/Translator/Producer/XML.pm +lib/SQL/Translator/Producer/SqlfXML.pm lib/SQL/Translator/Schema.pm lib/SQL/Translator/Schema/Constants.pm lib/SQL/Translator/Schema/Constraint.pm diff --git a/lib/SQL/Translator/Parser/SqlfXML.pm b/lib/SQL/Translator/Parser/SqlfXML.pm new file mode 100644 index 0000000..6919b3a --- /dev/null +++ b/lib/SQL/Translator/Parser/SqlfXML.pm @@ -0,0 +1,170 @@ +package SQL::Translator::Parser::SqlfXML; + +# ------------------------------------------------------------------- +# $Id: SqlfXML.pm,v 1.1 2003-08-06 17:14:08 grommit Exp $ +# ------------------------------------------------------------------- +# Copyright (C) 2003 Mark Addison , +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License as +# published by the Free Software Foundation; version 2. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +# 02111-1307 USA +# ------------------------------------------------------------------- + +=head1 NAME + +SQL::Translator::Parser::SqlfXML - parser for the XML produced by +SQL::Translator::Producer::SqlfXML. + +=head1 SYNOPSIS + + use SQL::Translator; + use SQL::Translator::Parser::SqlfXML; + + my $translator = SQL::Translator->new( + show_warnings => 1, + add_drop_table => 1, + ); + print = $obj->translate( + from => "SqlfXML", + to =>"MySQL", + filename => "fooschema.xml", + ); + +=head1 DESCRIPTION + +A SQL Translator parser to parse the XML files produced by its SqftXML producer. +The XML must be in the namespace http://sqlfairy.sourceforge.net/sqlfairy.xml. + +To see and example of the XML translate one of your schema :) e.g. + + $ sql_translator.pl --from MySQL --to SqftXML foo_schema.sql + +=cut + +use strict; +use warnings; + +use vars qw[ $DEBUG $VERSION @EXPORT_OK ]; +$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; +$DEBUG = 0 unless defined $DEBUG; + +use Data::Dumper; +use Exporter; +use base qw(Exporter); +@EXPORT_OK = qw(parse); + +use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo! +use XML::XPath; +use XML::XPath::XMLParser; + +sub debug { + warn @_,"\n" if $DEBUG; +} + +sub parse { + my ( $translator, $data ) = @_; + my $schema = $translator->schema; + local $DEBUG = $translator->debug; + #local $TRACE = $translator->trace ? 1 : undef; + # Nothing with trace option yet! + + my $xp = XML::XPath->new(xml => $data); + $xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml"); + + # Work our way through the tables + # + my @nodes = $xp->findnodes('/sqlf:schema/sqlf:table'); + for my $tblnode ( + sort { "".$xp->findvalue('sqlf:order',$a) + <=> "".$xp->findvalue('sqlf:order',$b) } @nodes + ) { + debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode); + my $table = $schema->add_table( + get_tagfields($xp, $tblnode, "sqlf:" => qw/name order/) + ) or die $schema->error; + + # Fields + # + my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode); + foreach ( + sort { "".$xp->findvalue('sqlf:order',$a) + <=> "".$xp->findvalue('sqlf:order',$b) } @nodes + ) { + my %fdata = get_tagfields($xp, $_, "sqlf:", + qw/name data_type size default_value is_nullable is_auto_increment + is_primary_key is_foreign_key comments/); + my $field = $table->add_field(%fdata) or die $schema->error; + $table->primary_key($field->name) if $fdata{'is_primary_key'}; + # TODO We should be able to make the table obj spot this when we + # use add_field. + # TODO Deal with $field->extra + } + + # Constraints + # + @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode); + foreach (@nodes) { + my %data = get_tagfields($xp, $_, "sqlf:", + qw/name type table fields reference_fields reference_table + match_type on_delete_do on_update_do/); + $table->add_constraint(%data) or die $schema->error; + } + + # Indexes + # + @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode); + foreach (@nodes) { + my %data = get_tagfields($xp, $_, "sqlf:", + qw/name type fields options/); + $table->add_index(%data) or die $schema->error; + } + + } # tables loop + + return 1; +} + +# get_tagfields XPNODE, NAMESPACE => qw/TAGNAMES/; +# get_tagfields $node, "sqlf:" => qw/name type fields reference/; +sub get_tagfields { + my ($xp, $node, @names) = @_; + my (%data, $ns); + foreach (@names) { + if ( m/:$/ ) { $ns = $_; next; } # Set def namespace + $data{$_} = "".$xp->findvalue( (s/(^.*?:)// ? $1 : $ns).$_, $node ); + } + return wantarray ? %data : \%data; +} + +1; + +__END__ + +=pod + +=head1 TODO + + * Support sqf:options. + * Test forign keys are parsed ok. + * Control over defaulting and parsing of empty vs non-existant tags. + +=head1 AUTHOR + +Mark D. Addison Emark.addison@itn.co.ukE, + +=head1 SEE ALSO + +perl(1), SQL::Translator, SQL::Translator::Producer::SqlfXML, +SQL::Translator::Schema. + +=cut diff --git a/lib/SQL/Translator/Producer/XML.pm b/lib/SQL/Translator/Producer/SqlfXML.pm similarity index 90% rename from lib/SQL/Translator/Producer/XML.pm rename to lib/SQL/Translator/Producer/SqlfXML.pm index 2315b20..f6333f2 100644 --- a/lib/SQL/Translator/Producer/XML.pm +++ b/lib/SQL/Translator/Producer/SqlfXML.pm @@ -1,7 +1,7 @@ -package SQL::Translator::Producer::XML; +package SQL::Translator::Producer::SqlfXML; # ------------------------------------------------------------------- -# $Id: XML.pm,v 1.11 2003-07-31 20:48:23 dlc Exp $ +# $Id: SqlfXML.pm,v 1.1 2003-08-06 17:14:09 grommit Exp $ # ------------------------------------------------------------------- # Copyright (C) 2003 Ken Y. Clark , # darren chamberlain , @@ -24,7 +24,7 @@ package SQL::Translator::Producer::XML; use strict; use vars qw[ $VERSION ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; use IO::Scalar; use SQL::Translator::Utils qw(header_comment); @@ -145,11 +145,21 @@ sub produce { =head1 NAME -SQL::Translator::Producer::XML - XML output +SQL::Translator::Producer::SqlfXML - XML output =head1 SYNOPSIS - use SQL::Translator::Producer::XML; + use SQL::Translator; + + my $translator = SQL::Translator->new( + show_warnings => 1, + add_drop_table => 1, + ); + print = $obj->translate( + from => "MySQL", + to => "SqlfXML", + filename => "fooschema.sql", + ); =head1 DESCRIPTION @@ -161,4 +171,5 @@ Ken Y. Clark Ekclark@cpan.orgE, darren chamberlain Edarren@cpan.orgE =head1 SEE ALSO -L +perl(1), SQL::Translator, SQL::Translator::Parser::SqlfXML, +SQL::Translator::Schema, XML::Writer. diff --git a/t/16xml-parser.t b/t/16xml-parser.t new file mode 100644 index 0000000..f5209b2 --- /dev/null +++ b/t/16xml-parser.t @@ -0,0 +1,141 @@ +#!/usr/bin/perl -w +# vim:filetype=perl + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +# +# basic.t +# ------- +# Tests that; +# + +use Test::More qw/no_plan/; +use Test::Exception; + +use strict; +use Data::Dumper; +our %opt; +BEGIN { map { $opt{$_}=1 if s/^-// } @ARGV; } +use constant DEBUG => (exists $opt{d} ? 1 : 0); +local $SIG{__WARN__} = sub { diag "[warn] ", @_; }; + +use FindBin qw/$Bin/; + +# Usefull test subs for the schema objs +#============================================================================= + +our %ATTRIBUTES; +$ATTRIBUTES{field} = [qw/ +name +order +data_type +default_value +size +is_primary_key +is_unique +is_nullable +is_foreign_key +is_auto_increment +/]; + +sub test_field { + my ($fld,$test) = @_; + die "test_field needs a least a name!" unless $test->{name}; + my $name = $test->{name}; + is $fld->name, $name, "$name - Name right"; + + foreach my $attr ( @{$ATTRIBUTES{field}} ) { + if ( defined(my $ans = $test->{$attr}) ) { + if ( $attr =~ m/^is_/ ) { + ok $fld->$attr, " $name - $attr true"; + } + else { + is $fld->$attr, $ans, " $name - $attr = '$ans'"; + } + } + else { + ok !$fld->$attr, "$name - $attr not set"; + } + } +} + +# TODO test_constraint, test_index + +# Testing 1,2,3,4... +#============================================================================= + +use SQL::Translator; +use SQL::Translator::Schema::Constants; + +# Parse the test XML schema +our $obj; +$obj = SQL::Translator->new( + debug => DEBUG, + show_warnings => 1, + add_drop_table => 1, +); +my $testschema = "$Bin/data/xml/schema-basic.xml"; +die "Can't find test schema $testschema" unless -e $testschema; +my $sql = $obj->translate( + from => "SqlfXML", + to =>"MySQL", + filename => $testschema, +); +print $sql; +#print "Debug:", Dumper($obj) if DEBUG; + +# Test the schema objs generted from the XML +# +my $scma = $obj->schema; +my @tblnames = map {$_->name} $scma->get_tables; +is_deeply( \@tblnames, [qw/Basic/], "tables"); + +# Basic +my $tbl = $scma->get_table("Basic"); +is $tbl->order, 1, "Basic->order"; +is_deeply( [map {$_->name} $tbl->get_fields], [qw/id title description email/] + , "Table Basic's fields"); +test_field($tbl->get_field("id"),{ + name => "id", + order => 1, + data_type => "int", + size => 10, + is_primary_key => 1, + is_auto_increment => 1, +}); +test_field($tbl->get_field("title"),{ + name => "title", + order => 2, + data_type => "varchar", + default_value => "hello", + size => 100, +}); +test_field($tbl->get_field("description"),{ + name => "description", + order => 3, + data_type => "text", + is_nullable => 1, +}); +test_field($tbl->get_field("email"),{ + name => "email", + order => 4, + data_type => "varchar", + size => 255, + is_unique => 1, +}); + +my @indices = $tbl->get_indices; +is scalar(@indices), 1, "Table basic has 1 index"; + +my @constraints = $tbl->get_constraints; +is scalar(@constraints), 2, "Table basic has 2 constraints"; +my $con = shift @constraints; +is $con->table, $tbl, "Constaints table right"; +is $con->name, "", "Constaints table right"; +is $con->type, PRIMARY_KEY, "Constaint is primary key"; +is_deeply [$con->fields], ["id"], "Constaint fields"; +$con = shift @constraints; +is $con->table, $tbl, "Constaints table right"; +is $con->type, UNIQUE, "Constaint UNIQUE"; +is_deeply [$con->fields], ["email"], "Constaint fields"; diff --git a/t/data/xml/schema-basic.xml b/t/data/xml/schema-basic.xml new file mode 100644 index 0000000..cd7bf3c --- /dev/null +++ b/t/data/xml/schema-basic.xml @@ -0,0 +1,61 @@ + + + + + + + Basic + 1 + + + id + 1 + 1 + int + 10 + 1 + + + title + varchar + 100 + hello + 2 + + + description + text + 1 + 3 + + + email + varchar + 255 + 4 + + + + + + title + titleindex + NORMAL + + + + + + 1 + email + emailuniqueindex + UNIQUE + + + + +