Added Parser::XML to parse the XML from Producer::SqlfXML.
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
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
--- /dev/null
+package SQL::Translator::Parser::SqlfXML;
+
+# -------------------------------------------------------------------
+# $Id: SqlfXML.pm,v 1.1 2003-08-06 17:14:08 grommit Exp $
+# -------------------------------------------------------------------
+# Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
+#
+# 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 E<lt>mark.addison@itn.co.ukE<gt>,
+
+=head1 SEE ALSO
+
+perl(1), SQL::Translator, SQL::Translator::Producer::SqlfXML,
+SQL::Translator::Schema.
+
+=cut
-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 <kclark@cpan.org>,
# darren chamberlain <darren@cpan.org>,
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);
=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
=head1 SEE ALSO
-L<XML::Writer>
+perl(1), SQL::Translator, SQL::Translator::Parser::SqlfXML,
+SQL::Translator::Schema, XML::Writer.
--- /dev/null
+#!/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";
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!--
+Created by SQL::Translator::Producer::XML
+Created on Fri Aug 1 11:24:58 2003
+
+ -->
+
+<sqlf:schema xmlns:sqlf="http://sqlfairy.sourceforge.net/sqlfairy.xml">
+
+ <sqlf:table>
+ <sqlf:name>Basic</sqlf:name>
+ <sqlf:order>1</sqlf:order>
+ <sqlf:fields>
+ <sqlf:field>
+ <sqlf:name>id</sqlf:name>
+ <sqlf:is_primary_key>1</sqlf:is_primary_key>
+ <sqlf:is_auto_increment>1</sqlf:is_auto_increment>
+ <sqlf:data_type>int</sqlf:data_type>
+ <sqlf:size>10</sqlf:size>
+ <sqlf:order>1</sqlf:order>
+ </sqlf:field>
+ <sqlf:field>
+ <sqlf:name>title</sqlf:name>
+ <sqlf:data_type>varchar</sqlf:data_type>
+ <sqlf:size>100</sqlf:size>
+ <sqlf:default_value>hello</sqlf:default_value>
+ <sqlf:order>2</sqlf:order>
+ </sqlf:field>
+ <sqlf:field>
+ <sqlf:name>description</sqlf:name>
+ <sqlf:data_type>text</sqlf:data_type>
+ <sqlf:is_nullable>1</sqlf:is_nullable>
+ <sqlf:order>3</sqlf:order>
+ </sqlf:field>
+ <sqlf:field>
+ <sqlf:name>email</sqlf:name>
+ <sqlf:data_type>varchar</sqlf:data_type>
+ <sqlf:size>255</sqlf:size>
+ <sqlf:order>4</sqlf:order>
+ </sqlf:field>
+ </sqlf:fields>
+
+ <sqlf:indices>
+ <sqlf:index>
+ <sqlf:fields>title</sqlf:fields>
+ <sqlf:name>titleindex</sqlf:name>
+ <sqlf:type>NORMAL</sqlf:type>
+ </sqlf:index>
+ </sqlf:indices>
+
+ <sqlf:constraints>
+ <sqlf:constraint>
+ <sqlf:deferrable>1</sqlf:deferrable>
+ <sqlf:fields>email</sqlf:fields>
+ <sqlf:name>emailuniqueindex</sqlf:name>
+ <sqlf:type>UNIQUE</sqlf:type>
+ </sqlf:constraint>
+ </sqlf:constraints>
+ </sqlf:table>
+
+</sqlf:schema>
projects / dbsrgits/SQL-Translator.git / commitdiff