[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / SqlfXML.pm

package SQL::Translator::Parser::SqlfXML;

# -------------------------------------------------------------------
# $Id: SqlfXML.pm,v 1.4 2003-08-07 15:03:30 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

==head1 default_value

Leave the tag out all together to use the default in Schema::Field. Use empty
tags or EMPTY_STRING for a zero lenth string. NULL for an explicit null 
(currently sets default_value to undef Schema::Field).

 <sqlf:default_value></sqlf:default_value>               <!-- Empty string -->
 <sqlf:default_value>EMPTY_STRING</sqlf:default_value>   <!-- Empty string -->
 <sqlf:default_value>NULL</sqlf:default_value>           <!-- NULL -->
 
 <sqlf:default_value/>            <!-- Empty string BUT DON'T USE! See BUGS -->
 
=cut

use strict;
use warnings;

use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\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/);
            if (exists $fdata{default_value} and defined $fdata{default_value}){
                if ( $fdata{default_value} =~ /^\s*NULL\s*$/ ) {
                    $fdata{default_value}= undef;
                }
                elsif ( $fdata{default_value} =~ /^\s*EMPTY_STRING\s*$/ ) {
                    $fdata{default_value} = "";
                }
            }
            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/;
#
# Returns hash of data. If a tag isn't in the file it is not in this
# hash.
# TODO Add handling of and explicit NULL value.
sub get_tagfields {
    my ($xp, $node, @names) = @_;
    my (%data, $ns);
    foreach (@names) {
        if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
        my $path = (s/(^.*?:)// ? $1 : $ns).$_;
        $data{$_} = $xp->findvalue($path,$node) if $xp->exists($path,$node);
        debug "Got $_=".(defined $data{$_} ? $data{$_} : "UNDEF");
    }
    return wantarray ? %data : \%data;
}

1;

__END__

=pod

=head1 BUGS

B<Empty Tags> e.g. <sqlf:default_value/> Will be parsed as "" and hence also
false. This is a bit counter intuative for some tags as seeing 
<sqlf:is_nullable /> you might think that it was set when it fact it wouldn't 
be. So for now it is safest not to use them until their handling by the parser
is defined.

=head1 TODO

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