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

package SQL::Translator::Producer::XML::SQLFairy;

# -------------------------------------------------------------------
# $Id: SQLFairy.pm,v 1.11 2004-03-04 14:39:46 dlc Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.org>,
#                    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
# -------------------------------------------------------------------

=pod

=head1 NAME

SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format

=head1 SYNOPSIS

  use SQL::Translator;

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

  print $t->translate;

=head1 ARGS

Takes the following extra producer args.

=over 4

=item * emit_empty_tags

Default is false, set to true to emit <foo></foo> style tags for undef values
in the schema.

=item * attrib_values

Set true to use attributes for values of the schema objects instead of tags.

 <!-- attrib_values => 0 -->
 <table>
   <name>foo</name>
   <order>1</order>
 </table>

 <!-- attrib_values => 1 -->
 <table name="foo" order="1">
 </table>

=back

=head1 DESCRIPTION

Creates XML output of a schema.

=cut

use strict;
use vars qw[ $VERSION @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;

use Exporter;
use base qw(Exporter);
@EXPORT_OK = qw(produce);

use IO::Scalar;
use SQL::Translator::Utils qw(header_comment debug);
BEGIN {
    # Will someone fix XML::Writer already?
    local $^W = 0;
    require XML::Writer;
    import XML::Writer;
}

my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
my $Name      = 'sqlt';
my $PArgs     = {};

sub produce {
    my $translator  = shift;
    my $schema      = $translator->schema;
    $PArgs          = $translator->producer_args;
    my $io          = IO::Scalar->new;
    my $xml         = XML::Writer->new(
        OUTPUT      => $io,
        NAMESPACES  => 1,
        PREFIX_MAP  => { $Namespace => $Name },
        DATA_MODE   => 1,
        DATA_INDENT => 2,
    );

    $xml->xmlDecl('UTF-8');
    $xml->comment(header_comment('', ''));
    #$xml->startTag([ $Namespace => 'schema' ]);
    xml_obj($xml, $schema,
        tag => "schema", methods => [qw/name database/], end_tag => 0 );

    #
    # Table
    #
    for my $table ( $schema->get_tables ) {
        debug "Table:",$table->name;
        xml_obj($xml, $table,
             tag => "table", methods => [qw/name order/], end_tag => 0 );

        #
        # Fields
        #
        $xml->startTag( [ $Namespace => 'fields' ] );
        for my $field ( $table->get_fields ) {
            debug "    Field:",$field->name;
            xml_obj($xml, $field,
                tag     =>"field",
                end_tag => 1,
                methods =>[qw/name data_type size is_nullable default_value
                    is_auto_increment is_primary_key is_foreign_key comments order
                /],
            );
        }
        $xml->endTag( [ $Namespace => 'fields' ] );

        #
        # Indices
        #
        $xml->startTag( [ $Namespace => 'indices' ] );
        for my $index ( $table->get_indices ) {
            debug "Index:",$index->name;
            xml_obj($xml, $index,
                tag     => "index",
                end_tag => 1,
                methods =>[qw/ name type fields options/],
            );
        }
        $xml->endTag( [ $Namespace => 'indices' ] );

        #
        # Constraints
        #
        $xml->startTag( [ $Namespace => 'constraints' ] );
        for my $index ( $table->get_constraints ) {
            debug "Constraint:",$index->name;
            xml_obj($xml, $index,
                tag     => "constraint",
                end_tag => 1,
                methods =>[qw/
                    name type fields reference_table reference_fields
                    on_delete on_update match_type expression options deferrable
                    /],
            );
        }
        $xml->endTag( [ $Namespace => 'constraints' ] );

        $xml->endTag( [ $Namespace => 'table' ] );
    }

    #
    # Views
    #
    for my $foo ( $schema->get_views ) {
        xml_obj($xml, $foo, tag => "view",
        methods => [qw/name sql fields order/], end_tag => 1 );
    }

    #
    # Tiggers
    #
    for my $foo ( $schema->get_triggers ) {
        xml_obj($xml, $foo, tag => "trigger",
        methods => [qw/name database_event action on_table perform_action_when
        fields order/], end_tag => 1 );
    }

    #
    # Procedures
    #
    for my $foo ( $schema->get_procedures ) {
        xml_obj($xml, $foo, tag => "procedure",
        methods => [qw/name sql parameters owner comments order/], end_tag=>1 );
    }

    $xml->endTag([ $Namespace => 'schema' ]);
    $xml->end;

    return $io;
}

# -------------------------------------------------------------------
#
# TODO 
# - Doc this sub
# - Should the Namespace be passed in instead of global? Pass in the same
#   as Writer ie [ NS => TAGNAME ]
#
sub xml_obj {
    my ($xml, $obj, %args) = @_;
    my $tag                = $args{'tag'}              || '';
    my $end_tag            = $args{'end_tag'}          || '';
    my $attrib_values      = $PArgs->{'attrib_values'} || '';
    my @meths              = @{ $args{'methods'} };
    my $empty_tag          = 0;

    if ( $attrib_values and $end_tag ) {
        $empty_tag = 1;
        $end_tag   = 0;
    }

    if ( $attrib_values ) {
        # Use array to ensure consistant (ie not hash) ordering of attribs
        # The order comes from the meths list passes in.
        my @attr = map {
            my $val = $obj->$_;
            ($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val);
        } grep { defined $obj->$_ } @meths;
        $empty_tag ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
                   : $xml->startTag( [ $Namespace => $tag ], @attr );
    }
    else {
        $xml->startTag( [ $Namespace => $tag ] );
        xml_objAttr( $xml, $obj, @meths );
    }

    $xml->endTag( [ $Namespace => $tag ] ) if $end_tag;
}

# -------------------------------------------------------------------
# Takes an XML writer, a Schema::* object and a list of methods and
# adds the XML for those methods.
#
sub xml_objAttr {
    my ($xml, $obj, @methods) = @_;
    my $emit_empty            = $PArgs->{'emit_empty_tags'};

    for my $method ( @methods ) {
        my $val = $obj->$method;
        debug "        ".ref($obj)."->$method=",
              (defined $val ? "'$val'" : "<UNDEF>");
        next unless $emit_empty || defined $val;
        $val = '' if not defined $val;
        $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
        debug "        Adding Attr:".$method."='",$val,"'";
        $xml->dataElement( [ $Namespace => $method ], $val );
    }
}

1;

# -------------------------------------------------------------------
# The eyes of fire, the nostrils of air,
# The mouth of water, the beard of earth.
# William Blake
# -------------------------------------------------------------------

=pod

=head1 AUTHORS

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.

=head1 SEE ALSO

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

=cut
Commit	Line	Data
0a689100	1	package SQL::Translator::Producer::XML::SQLFairy;
	2
	3	# -------------------------------------------------------------------
f135f8f9	4	# $Id: SQLFairy.pm,v 1.11 2004-03-04 14:39:46 dlc Exp $
0a689100	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	7	# darren chamberlain <darren@cpan.org>,
	8	# Chris Mungall <cjm@fruitfly.org>,
	9	# Mark Addison <mark.addison@itn.co.uk>.
	10	#
	11	# This program is free software; you can redistribute it and/or
	12	# modify it under the terms of the GNU General Public License as
	13	# published by the Free Software Foundation; version 2.
	14	#
	15	# This program is distributed in the hope that it will be useful, but
	16	# WITHOUT ANY WARRANTY; without even the implied warranty of
	17	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	18	# General Public License for more details.
	19	#
	20	# You should have received a copy of the GNU General Public License
	21	# along with this program; if not, write to the Free Software
	22	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	23	# 02111-1307 USA
	24	# -------------------------------------------------------------------
	25
	26	=pod
	27
	28	=head1 NAME
	29
a7d50b44	30	SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format
0a689100	31
	32	=head1 SYNOPSIS
	33
	34	use SQL::Translator;
	35
	36	my $t = SQL::Translator->new(
	37	from => 'MySQL',
a7d50b44	38	to => 'XML-SQLFairy',
0a689100	39	filename => 'schema.sql',
	40	show_warnings => 1,
	41	add_drop_table => 1,
	42	);
	43
	44	print $t->translate;
	45
	46	=head1 ARGS
	47
	48	Takes the following extra producer args.
	49
	50	=over 4
	51
	52	=item * emit_empty_tags
	53
	54	Default is false, set to true to emit <foo></foo> style tags for undef values
	55	in the schema.
	56
	57	=item * attrib_values
	58
	59	Set true to use attributes for values of the schema objects instead of tags.
	60
	61	<!-- attrib_values => 0 -->
	62	<table>
	63	<name>foo</name>
	64	<order>1</order>
	65	</table>
	66
	67	<!-- attrib_values => 1 -->
	68	<table name="foo" order="1">
	69	</table>
	70
	71	=back
	72
	73	=head1 DESCRIPTION
	74
	75	Creates XML output of a schema.
	76
	77	=cut
	78
	79	use strict;
	80	use vars qw[ $VERSION @EXPORT_OK ];
f135f8f9	81	$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
0a689100	82
	83	use Exporter;
	84	use base qw(Exporter);
	85	@EXPORT_OK = qw(produce);
	86
	87	use IO::Scalar;
	88	use SQL::Translator::Utils qw(header_comment debug);
f135f8f9	89	BEGIN {
	90	# Will someone fix XML::Writer already?
	91	local $^W = 0;
	92	require XML::Writer;
	93	import XML::Writer;
	94	}
0a689100	95
	96	my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
	97	my $Name = 'sqlt';
375f0be1	98	my $PArgs = {};
0a689100	99
	100	sub produce {
	101	my $translator = shift;
	102	my $schema = $translator->schema;
	103	$PArgs = $translator->producer_args;
	104	my $io = IO::Scalar->new;
	105	my $xml = XML::Writer->new(
	106	OUTPUT => $io,
	107	NAMESPACES => 1,
	108	PREFIX_MAP => { $Namespace => $Name },
	109	DATA_MODE => 1,
	110	DATA_INDENT => 2,
	111	);
	112
	113	$xml->xmlDecl('UTF-8');
	114	$xml->comment(header_comment('', ''));
1caf2bb2	115	#$xml->startTag([ $Namespace => 'schema' ]);
	116	xml_obj($xml, $schema,
	117	tag => "schema", methods => [qw/name database/], end_tag => 0 );
0a689100	118
	119	#
	120	# Table
	121	#
	122	for my $table ( $schema->get_tables ) {
	123	debug "Table:",$table->name;
d3422086	124	xml_obj($xml, $table,
d3422086	125	tag => "table", methods => [qw/name order/], end_tag => 0 );
0a689100	126
	127	#
	128	# Fields
	129	#
	130	$xml->startTag( [ $Namespace => 'fields' ] );
	131	for my $field ( $table->get_fields ) {
	132	debug " Field:",$field->name;
d3422086	133	xml_obj($xml, $field,
	134	tag =>"field",
	135	end_tag => 1,
	136	methods =>[qw/name data_type size is_nullable default_value
	137	is_auto_increment is_primary_key is_foreign_key comments order
	138	/],
	139	);
0a689100	140	}
	141	$xml->endTag( [ $Namespace => 'fields' ] );
	142
	143	#
	144	# Indices
	145	#
	146	$xml->startTag( [ $Namespace => 'indices' ] );
	147	for my $index ( $table->get_indices ) {
	148	debug "Index:",$index->name;
d3422086	149	xml_obj($xml, $index,
	150	tag => "index",
	151	end_tag => 1,
	152	methods =>[qw/ name type fields options/],
	153	);
0a689100	154	}
	155	$xml->endTag( [ $Namespace => 'indices' ] );
	156
	157	#
	158	# Constraints
	159	#
	160	$xml->startTag( [ $Namespace => 'constraints' ] );
	161	for my $index ( $table->get_constraints ) {
	162	debug "Constraint:",$index->name;
d3422086	163	xml_obj($xml, $index,
	164	tag => "constraint",
	165	end_tag => 1,
	166	methods =>[qw/
	167	name type fields reference_table reference_fields
	168	on_delete on_update match_type expression options deferrable
	169	/],
	170	);
0a689100	171	}
	172	$xml->endTag( [ $Namespace => 'constraints' ] );
	173
	174	$xml->endTag( [ $Namespace => 'table' ] );
	175	}
d3422086	176
1e3867bf	177	#
	178	# Views
	179	#
	180	for my $foo ( $schema->get_views ) {
d3422086	181	xml_obj($xml, $foo, tag => "view",
1e3867bf	182	methods => [qw/name sql fields order/], end_tag => 1 );
1e3867bf	183	}
d3422086	184
1e3867bf	185	#
	186	# Tiggers
	187	#
	188	for my $foo ( $schema->get_triggers ) {
d3422086	189	xml_obj($xml, $foo, tag => "trigger",
	190	methods => [qw/name database_event action on_table perform_action_when
	191	fields order/], end_tag => 1 );
1e3867bf	192	}
0a689100	193
1e3867bf	194	#
	195	# Procedures
	196	#
	197	for my $foo ( $schema->get_procedures ) {
d3422086	198	xml_obj($xml, $foo, tag => "procedure",
1e3867bf	199	methods => [qw/name sql parameters owner comments order/], end_tag=>1 );
1e3867bf	200	}
d3422086	201
0a689100	202	$xml->endTag([ $Namespace => 'schema' ]);
	203	$xml->end;
	204
	205	return $io;
	206	}
	207
	208	# -------------------------------------------------------------------
1caf2bb2	209	#
	210	# TODO
	211	# - Doc this sub
	212	# - Should the Namespace be passed in instead of global? Pass in the same
	213	# as Writer ie [ NS => TAGNAME ]
	214	#
0a689100	215	sub xml_obj {
d3422086	216	my ($xml, $obj, %args) = @_;
	217	my $tag = $args{'tag'} \|\| '';
	218	my $end_tag = $args{'end_tag'} \|\| '';
	219	my $attrib_values = $PArgs->{'attrib_values'} \|\| '';
	220	my @meths = @{ $args{'methods'} };
	221	my $empty_tag = 0;
	222
	223	if ( $attrib_values and $end_tag ) {
	224	$empty_tag = 1;
	225	$end_tag = 0;
	226	}
	227
	228	if ( $attrib_values ) {
d671d3b9	229	# Use array to ensure consistant (ie not hash) ordering of attribs
d3422086	230	# The order comes from the meths list passes in.
	231	my @attr = map {
	232	my $val = $obj->$_;
	233	($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val);
	234	} grep { defined $obj->$_ } @meths;
446dfcbd	235	$empty_tag ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
d3422086	236	: $xml->startTag( [ $Namespace => $tag ], @attr );
	237	}
	238	else {
	239	$xml->startTag( [ $Namespace => $tag ] );
	240	xml_objAttr( $xml, $obj, @meths );
	241	}
	242
	243	$xml->endTag( [ $Namespace => $tag ] ) if $end_tag;
0a689100	244	}
	245
	246	# -------------------------------------------------------------------
	247	# Takes an XML writer, a Schema::* object and a list of methods and
	248	# adds the XML for those methods.
	249	#
	250	sub xml_objAttr {
	251	my ($xml, $obj, @methods) = @_;
	252	my $emit_empty = $PArgs->{'emit_empty_tags'};
	253
d3422086	254	for my $method ( @methods ) {
0a689100	255	my $val = $obj->$method;
	256	debug " ".ref($obj)."->$method=",
	257	(defined $val ? "'$val'" : "<UNDEF>");
	258	next unless $emit_empty \|\| defined $val;
	259	$val = '' if not defined $val;
	260	$val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
	261	debug " Adding Attr:".$method."='",$val,"'";
	262	$xml->dataElement( [ $Namespace => $method ], $val );
	263	}
	264	}
	265
	266	1;
	267
	268	# -------------------------------------------------------------------
	269	# The eyes of fire, the nostrils of air,
	270	# The mouth of water, the beard of earth.
	271	# William Blake
	272	# -------------------------------------------------------------------
	273
	274	=pod
	275
	276	=head1 AUTHORS
	277
d3422086	278	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
d3422086	279	Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
0a689100	280	Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
	281
	282	=head1 SEE ALSO
	283
a7d50b44	284	perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy,
0a689100	285	SQL::Translator::Schema, XML::Writer.
	286
	287	=cut