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

package SQL::Translator::Parser::XML::SQLFairy;

# -------------------------------------------------------------------
# $Id: SQLFairy.pm,v 1.8 2004-07-09 00:50:06 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::XML::SQLFairy - parser for SQL::Translator's XML.

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::XML::SQLFairy;

  my $translator     = SQL::Translator->new(
      from           => 'XML-SQLFairy',
      to             => 'MySQL',
      filename       => 'schema.xml',
      show_warnings  => 1,
      add_drop_table => 1,
  );

  print $obj->translate;

=head1 DESCRIPTION

This parser handles the flavor of XML used natively by the SQLFairy
project (SQL::Translator).  The XML must be in the namespace
"http://sqlfairy.sourceforge.net/sqlfairy.xml."
See L<SQL::Translator::Producer::XML::SQLFairy> for details of this format.

You do not need to specify every attribute of the Schema objects as any missing
from the XML will be set to their default values. e.g. A field could be written
using only;

 <sqlf:field name="email" data_type="varchar" size="255" />

Instead of the full;

 <sqlf:field name="email" data_type="varchar" size="255" is_nullable="1"
   is_auto_increment="0" is_primary_key="0" is_foreign_key="0" order="4">
   <sqlf:comments></sqlf:comments>
 </sqlf:field>

If you do not explicitly set the order of items using order attributes on the
tags then the order the tags appear in the XML will be used.

=head2 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 in the
Schema::Field obj).

  <sqlf:default_value></sqlf:default_value>             <!-- Empty string -->
  <sqlf:default_value>EMPTY_STRING</sqlf:default_value> <!-- Empty string -->
  <sqlf:default_value/>                                 <!-- Empty string -->
  <sqlf:default_value>NULL</sqlf:default_value>         <!-- NULL -->

=head2 ARGS

Doesn't take any extra parser args at the moment.

=head1 LEGACY FORMAT

The previous version of the SQLFairy XML allowed the attributes of the the
schema objects to be written as either xml attributes or as data elements, in
any combination. While this allows for lots of flexibility in writing the XML
the result is a great many possible XML formats, not so good for DTD writing,
XPathing etc! So we have moved to a fixed version described in
L<SQL::Translator::Producer::XML::SQLFairy>.

This version of the parser will still parse the old formats and emmit warnings
when it sees them being used.
The old format is B<heavily depreciated> and B<will not> be supported in future
versions.

To convert your old format files simply pass them through the translator;

 sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml

=cut

# -------------------------------------------------------------------

use strict;

use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\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 SQL::Translator::Utils 'debug';
use XML::XPath;
use XML::XPath::XMLParser;

sub parse {
    my ( $translator, $data ) = @_;
    my $schema                = $translator->schema;
    local $DEBUG              = $translator->debug;
    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|@order',$a)
            <=>
            "".$xp->findvalue('sqlf:order|@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) || 0)
                <=>
                ("".$xp->findvalue('sqlf:order',$b) || 0)
            } @nodes
        ) {
            my %fdata = get_tagfields($xp, $_, "sqlf:",
                qw/name data_type size default_value is_nullable extra
                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 $table->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.
            #
        }

        #
        # 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 $table->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 $table->error;
        }

    } # tables loop

    #
    # Views
    #
    @nodes = $xp->findnodes('/sqlf:schema/sqlf:view');
    foreach (@nodes) {
        my %data = get_tagfields($xp, $_, "sqlf:",
            qw/name sql fields order/
        );
        $schema->add_view( %data ) or die $schema->error;
    }

    #
    # Triggers
    #
    @nodes = $xp->findnodes('/sqlf:schema/sqlf:trigger');
    foreach (@nodes) {
        my %data = get_tagfields($xp, $_, "sqlf:",
        qw/name perform_action_when database_event fields on_table action order/
        );
        $schema->add_trigger( %data ) or die $schema->error;
    }

    #
    # Procedures
    #
    @nodes = $xp->findnodes('/sqlf:schema/sqlf:procedure');
    foreach (@nodes) {
        my %data = get_tagfields($xp, $_, "sqlf:",
        qw/name sql parameters owner comments order/
        );
        $schema->add_procedure( %data ) or die $schema->error;
    }

    return 1;
}

# -------------------------------------------------------------------
sub get_tagfields {
#
# get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
# get_tagfields $node, "sqlf:" => qw/name type fields reference/;
#
# Returns hash of data.
# TODO - Add handling of an explicit NULL value.
#

    my ($xp, $node, @names) = @_;
    my (%data, $ns);
    foreach (@names) {
        if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
        my $thisns = (s/(^.*?:)// ? $1 : $ns);

        my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;

        my $attrib_path = "\@$thisns$_";
        my $tag_path    = "$thisns$_";
        if ( $xp->exists($attrib_path,$node) ) {
            $data{$_} = "".$xp->findvalue($attrib_path,$node);
            warn "Use of '$_' as an attribute is depricated."
                ." Use a child tag instead."
                ." To convert your file to the new version see the Docs.\n"
                unless $is_attrib;
            debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
        }
        elsif ( $xp->exists($tag_path,$node) ) {
            if ($_ eq "extra") {
                my %extra;
                my $extra_nodes = $xp->find($tag_path,$node);
                foreach ( $extra_nodes->pop->getAttributes ) {
                    $extra{$_->getName} = $_->getData;
                }
                $data{$_} = \%extra;
            }
            else {
                $data{$_} = "".$xp->findvalue($tag_path,$node);
            }
            warn "Use of '$_' as a child tag is depricated."
                ." Use an attribute instead."
                ." To convert your file to the new version see the Docs.\n"
                if $is_attrib;
            debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
        }
    }

    return wantarray ? %data : \%data;
}

1;

# -------------------------------------------------------------------

=pod

=head1 BUGS

Ignores the order attribute for Constraints, Views, Indices,
Views, Triggers and Procedures, using the tag order instead. (This is the order
output by the SQLFairy XML producer).

=head1 TODO

=over 4

=item *

Support options attribute.

=item *

Test foreign keys are parsed ok.

=item *

Control over defaulting of non-existant tags.

=back

=head1 AUTHOR

Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.

=head1 SEE ALSO

perl(1), SQL::Translator, SQL::Translator::Producer::XML::SQLFairy,
SQL::Translator::Schema.

=cut
Commit	Line	Data
0a1ec87a	1	package SQL::Translator::Parser::XML::SQLFairy;
	2
	3	# -------------------------------------------------------------------
94ed484b	4	# $Id: SQLFairy.pm,v 1.8 2004-07-09 00:50:06 grommit Exp $
0a1ec87a	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
8571d198	25	SQL::Translator::Parser::XML::SQLFairy - parser for SQL::Translator's XML.
0a1ec87a	26
	27	=head1 SYNOPSIS
	28
	29	use SQL::Translator;
	30	use SQL::Translator::Parser::XML::SQLFairy;
	31
	32	my $translator = SQL::Translator->new(
	33	from => 'XML-SQLFairy',
	34	to => 'MySQL',
	35	filename => 'schema.xml',
	36	show_warnings => 1,
	37	add_drop_table => 1,
	38	);
	39
	40	print $obj->translate;
	41
	42	=head1 DESCRIPTION
	43
	44	This parser handles the flavor of XML used natively by the SQLFairy
	45	project (SQL::Translator). The XML must be in the namespace
	46	"http://sqlfairy.sourceforge.net/sqlfairy.xml."
8571d198	47	See L<SQL::Translator::Producer::XML::SQLFairy> for details of this format.
0a1ec87a	48
8571d198	49	You do not need to specify every attribute of the Schema objects as any missing
	50	from the XML will be set to their default values. e.g. A field could be written
	51	using only;
0a1ec87a	52
8571d198	53	<sqlf:field name="email" data_type="varchar" size="255" />
0a1ec87a	54
8571d198	55	Instead of the full;
0a1ec87a	56
8571d198	57	<sqlf:field name="email" data_type="varchar" size="255" is_nullable="1"
	58	is_auto_increment="0" is_primary_key="0" is_foreign_key="0" order="4">
	59	<sqlf:comments></sqlf:comments>
	60	</sqlf:field>
0a1ec87a	61
8571d198	62	If you do not explicitly set the order of items using order attributes on the
8571d198	63	tags then the order the tags appear in the XML will be used.
0a1ec87a	64
	65	=head2 default_value
	66
a5e624ac	67	Leave the tag out all together to use the default in Schema::Field.
8571d198	68	Use empty tags or 'EMPTY_STRING' for a zero lenth string. 'NULL' for an
a5e624ac	69	explicit null (currently sets default_value to undef in the
a5e624ac	70	Schema::Field obj).
0a1ec87a	71
a5e624ac	72	<sqlf:default_value></sqlf:default_value> <!-- Empty string -->
a5e624ac	73	<sqlf:default_value>EMPTY_STRING</sqlf:default_value> <!-- Empty string -->
8571d198	74	<sqlf:default_value/> <!-- Empty string -->
a5e624ac	75	<sqlf:default_value>NULL</sqlf:default_value> <!-- NULL -->
0a1ec87a	76
0a1ec87a	77	=head2 ARGS
	78
	79	Doesn't take any extra parser args at the moment.
	80
4a268a6c	81	=head1 LEGACY FORMAT
	82
	83	The previous version of the SQLFairy XML allowed the attributes of the the
	84	schema objects to be written as either xml attributes or as data elements, in
	85	any combination. While this allows for lots of flexibility in writing the XML
	86	the result is a great many possible XML formats, not so good for DTD writing,
	87	XPathing etc! So we have moved to a fixed version described in
	88	L<SQL::Translator::Producer::XML::SQLFairy>.
	89
	90	This version of the parser will still parse the old formats and emmit warnings
	91	when it sees them being used.
	92	The old format is B<heavily depreciated> and B<will not> be supported in future
	93	versions.
	94
	95	To convert your old format files simply pass them through the translator;
	96
	97	sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
	98
0a1ec87a	99	=cut
	100
	101	# -------------------------------------------------------------------
	102
	103	use strict;
	104
	105	use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
94ed484b	106	$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/;
0a1ec87a	107	$DEBUG = 0 unless defined $DEBUG;
	108
	109	use Data::Dumper;
	110	use Exporter;
	111	use base qw(Exporter);
	112	@EXPORT_OK = qw(parse);
	113
	114	use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo!
a5e624ac	115	use SQL::Translator::Utils 'debug';
0a1ec87a	116	use XML::XPath;
	117	use XML::XPath::XMLParser;
	118
0a1ec87a	119	sub parse {
0a1ec87a	120	my ( $translator, $data ) = @_;
a5e624ac	121	my $schema = $translator->schema;
	122	local $DEBUG = $translator->debug;
	123	my $xp = XML::XPath->new(xml => $data);
0a1ec87a	124
0a1ec87a	125	$xp->set_namespace("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
0a1ec87a	126
a5e624ac	127	#
0a1ec87a	128	# Work our way through the tables
	129	#
	130	my @nodes = $xp->findnodes('/sqlf:schema/sqlf:table');
	131	for my $tblnode (
8571d198	132	sort {
59b2ec83	133	"".$xp->findvalue('sqlf:order\|@order',$a)
8571d198	134	<=>
8571d198	135	"".$xp->findvalue('sqlf:order\|@order',$b)
a5e624ac	136	} @nodes
0a1ec87a	137	) {
0a1ec87a	138	debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
a5e624ac	139
0a1ec87a	140	my $table = $schema->add_table(
	141	get_tagfields($xp, $tblnode, "sqlf:" => qw/name order/)
	142	) or die $schema->error;
	143
a5e624ac	144	#
0a1ec87a	145	# Fields
	146	#
	147	my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
	148	foreach (
8571d198	149	sort {
a5e624ac	150	("".$xp->findvalue('sqlf:order',$a) \|\| 0)
8571d198	151	<=>
8571d198	152	("".$xp->findvalue('sqlf:order',$b) \|\| 0)
a5e624ac	153	} @nodes
0a1ec87a	154	) {
0a1ec87a	155	my %fdata = get_tagfields($xp, $_, "sqlf:",
94ed484b	156	qw/name data_type size default_value is_nullable extra
a5e624ac	157	is_auto_increment is_primary_key is_foreign_key comments/
	158	);
	159
	160	if (
8571d198	161	exists $fdata{'default_value'} and
a5e624ac	162	defined $fdata{'default_value'}
	163	) {
	164	if ( $fdata{'default_value'} =~ /^\sNULL\s$/ ) {
	165	$fdata{'default_value'}= undef;
0a1ec87a	166	}
a5e624ac	167	elsif ( $fdata{'default_value'} =~ /^\sEMPTY_STRING\s$/ ) {
a5e624ac	168	$fdata{'default_value'} = "";
0a1ec87a	169	}
0a1ec87a	170	}
a5e624ac	171
19922fbc	172	my $field = $table->add_field( %fdata ) or die $table->error;
a5e624ac	173
	174	$table->primary_key( $field->name ) if $fdata{'is_primary_key'};
	175
	176	#
	177	# TODO:
8571d198	178	# - We should be able to make the table obj spot this when
a5e624ac	179	# we use add_field.
a5e624ac	180	#
0a1ec87a	181	}
0a1ec87a	182
a5e624ac	183	#
0a1ec87a	184	# Constraints
	185	#
	186	@nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
	187	foreach (@nodes) {
	188	my %data = get_tagfields($xp, $_, "sqlf:",
a5e624ac	189	qw/name type table fields reference_fields reference_table
	190	match_type on_delete_do on_update_do/
	191	);
19922fbc	192	$table->add_constraint( %data ) or die $table->error;
0a1ec87a	193	}
0a1ec87a	194
a5e624ac	195	#
0a1ec87a	196	# Indexes
	197	#
	198	@nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
	199	foreach (@nodes) {
	200	my %data = get_tagfields($xp, $_, "sqlf:",
a5e624ac	201	qw/name type fields options/);
19922fbc	202	$table->add_index( %data ) or die $table->error;
0a1ec87a	203	}
	204
	205	} # tables loop
	206
19922fbc	207	#
	208	# Views
	209	#
	210	@nodes = $xp->findnodes('/sqlf:schema/sqlf:view');
	211	foreach (@nodes) {
	212	my %data = get_tagfields($xp, $_, "sqlf:",
	213	qw/name sql fields order/
	214	);
	215	$schema->add_view( %data ) or die $schema->error;
	216	}
8571d198	217
19922fbc	218	#
	219	# Triggers
	220	#
	221	@nodes = $xp->findnodes('/sqlf:schema/sqlf:trigger');
	222	foreach (@nodes) {
	223	my %data = get_tagfields($xp, $_, "sqlf:",
	224	qw/name perform_action_when database_event fields on_table action order/
	225	);
	226	$schema->add_trigger( %data ) or die $schema->error;
	227	}
8571d198	228
19922fbc	229	#
	230	# Procedures
	231	#
	232	@nodes = $xp->findnodes('/sqlf:schema/sqlf:procedure');
	233	foreach (@nodes) {
	234	my %data = get_tagfields($xp, $_, "sqlf:",
	235	qw/name sql parameters owner comments order/
	236	);
	237	$schema->add_procedure( %data ) or die $schema->error;
	238	}
8571d198	239
0a1ec87a	240	return 1;
	241	}
	242
a5e624ac	243	# -------------------------------------------------------------------
	244	sub get_tagfields {
	245	#
8571d198	246	# get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
0a1ec87a	247	# get_tagfields $node, "sqlf:" => qw/name type fields reference/;
0a1ec87a	248	#
8571d198	249	# Returns hash of data.
8571d198	250	# TODO - Add handling of an explicit NULL value.
a5e624ac	251	#
a5e624ac	252
0a1ec87a	253	my ($xp, $node, @names) = @_;
	254	my (%data, $ns);
	255	foreach (@names) {
	256	if ( m/:$/ ) { $ns = $_; next; } # Set def namespace
	257	my $thisns = (s/(^.*?:)// ? $1 : $ns);
a5e624ac	258
94ed484b	259	my $is_attrib = m/^(sql\|comments\|action\|extra)$/ ? 0 : 1;
a5e624ac	260
8571d198	261	my $attrib_path = "\@$thisns$_";
	262	my $tag_path = "$thisns$_";
	263	if ( $xp->exists($attrib_path,$node) ) {
	264	$data{$_} = "".$xp->findvalue($attrib_path,$node);
	265	warn "Use of '$_' as an attribute is depricated."
	266	." Use a child tag instead."
	267	." To convert your file to the new version see the Docs.\n"
	268	unless $is_attrib;
	269	debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
	270	}
	271	elsif ( $xp->exists($tag_path,$node) ) {
94ed484b	272	if ($_ eq "extra") {
	273	my %extra;
	274	my $extra_nodes = $xp->find($tag_path,$node);
	275	foreach ( $extra_nodes->pop->getAttributes ) {
	276	$extra{$_->getName} = $_->getData;
	277	}
	278	$data{$_} = \%extra;
	279	}
	280	else {
	281	$data{$_} = "".$xp->findvalue($tag_path,$node);
	282	}
8571d198	283	warn "Use of '$_' as a child tag is depricated."
	284	." Use an attribute instead."
	285	." To convert your file to the new version see the Docs.\n"
	286	if $is_attrib;
a5e624ac	287	debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
0a1ec87a	288	}
0a1ec87a	289	}
a5e624ac	290
0a1ec87a	291	return wantarray ? %data : \%data;
	292	}
	293
	294	1;
	295
	296	# -------------------------------------------------------------------
	297
	298	=pod
	299
	300	=head1 BUGS
	301
8571d198	302	Ignores the order attribute for Constraints, Views, Indices,
	303	Views, Triggers and Procedures, using the tag order instead. (This is the order
	304	output by the SQLFairy XML producer).
0a1ec87a	305
	306	=head1 TODO
	307
	308	=over 4
	309
8571d198	310	=item *
a5e624ac	311
94ed484b	312	Support options attribute.
a5e624ac	313
8571d198	314	=item *
0a1ec87a	315
8571d198	316	Test foreign keys are parsed ok.
0a1ec87a	317
8571d198	318	=item *
0a1ec87a	319
a5e624ac	320	Control over defaulting of non-existant tags.
0a1ec87a	321
	322	=back
	323
	324	=head1 AUTHOR
	325
	326	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
	327
	328	=head1 SEE ALSO
	329
	330	perl(1), SQL::Translator, SQL::Translator::Producer::XML::SQLFairy,
	331	SQL::Translator::Schema.
	332
	333	=cut