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

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

# -------------------------------------------------------------------
# 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,
  );

  print $t->translate;

=head1 DESCRIPTION

Creates XML output of a schema, in the flavor of XML used natively by the
SQLFairy project (L<SQL::Translator>). This format is detailed here.

The XML lives in the C<http://sqlfairy.sourceforge.net/sqlfairy.xml> namespace.
With a root element of <schema>.

Objects in the schema are mapped to tags of the same name as the objects class
(all lowercase).

The attributes of the objects (e.g. $field->name) are mapped to attributes of
the tag, except for sql, comments and action, which get mapped to child data
elements.

List valued attributes (such as the list of fields in an index)
get mapped to comma seperated lists of values in the attribute.

Child objects, such as a tables fields, get mapped to child tags wrapped in a
set of container tags using the plural of their contained classes name.

An objects's extra attribute (a hash of arbitary data) is
mapped to a tag called extra, with the hash of data as attributes, sorted into
alphabetical order.

e.g.

    <schema name="" database=""
      xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">

      <tables>
        <table name="Story" order="1">
          <fields>
            <field name="id" data_type="BIGINT" size="20"
              is_nullable="0" is_auto_increment="1" is_primary_key="1"
              is_foreign_key="0" order="3">
              <extra ZEROFILL="1" />
              <comments></comments>
            </field>
            <field name="created" data_type="datetime" size="0"
              is_nullable="1" is_auto_increment="0" is_primary_key="0"
              is_foreign_key="0" order="1">
              <extra />
              <comments></comments>
            </field>
            ...
          </fields>
          <indices>
            <index name="foobar" type="NORMAL" fields="foo,bar" options="" />
          </indices>
        </table>
      </tables>

      <views>
        <view name="email_list" fields="email" order="1">
          <sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
        </view>
      </views>

    </schema>

To see a complete example of the XML translate one of your schema :)

  $ sqlt -f MySQL -t XML-SQLFairy schema.sql

=head1 ARGS

=over 4

=item add_prefix

Set to true to use the default namespace prefix of 'sqlf', instead of using
the default namespace for
C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>

e.g.

 <!-- add_prefix=0 -->
 <field name="foo" />

 <!-- add_prefix=1 -->
 <sqlf:field name="foo" />

=item prefix

Set to the namespace prefix you want to use for the
C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>

e.g.

 <!-- prefix='foo' -->
 <foo:field name="foo" />

=item newlines

If true (the default) inserts newlines around the XML, otherwise the schema is
written on one line.

=item indent

When using newlines the number of whitespace characters to use as the indent.
Default is 2, set to 0 to turn off indenting.

=back

=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. The old producer could produce attribute only or data element
only versions. While this allowed 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 above.

This version of the producer will now only produce the new style XML.
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[ $VERSION @EXPORT_OK ];
$VERSION = '1.59';

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;
}

# Which schema object attributes (methods) to write as xml elements rather than
# as attributes. e.g. <comments>blah, blah...</comments>
my @MAP_AS_ELEMENTS = qw/sql comments action extra/;


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

sub produce {
    my $translator  = shift;
    my $schema      = $translator->schema;
    $no_comments    = $translator->no_comments;
    $PArgs          = $translator->producer_args;
    my $newlines    = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
    my $indent      = defined $PArgs->{indent}   ? $PArgs->{indent}   : 2;
    my $io          = IO::Scalar->new;

    # Setup the XML::Writer and set the namespace
    my $prefix = "";
    $prefix    = $Name            if $PArgs->{add_prefix};
    $prefix    = $PArgs->{prefix} if $PArgs->{prefix};
    my $xml         = XML::Writer->new(
        OUTPUT      => $io,
        NAMESPACES  => 1,
        PREFIX_MAP  => { $Namespace => $prefix },
        DATA_MODE   => $newlines,
        DATA_INDENT => $indent,
    );

    # Start the document
    $xml->xmlDecl('UTF-8');

    $xml->comment(header_comment('', ''))
      unless $no_comments;

    xml_obj($xml, $schema,
        tag => "schema", methods => [qw/name database extra/], end_tag => 0 );

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

        #
        # Fields
        #
        xml_obj_children( $xml, $table,
            tag   => 'field',
            methods =>[qw/
                name data_type size is_nullable default_value is_auto_increment
                is_primary_key is_foreign_key extra comments order
            /],
        );

        #
        # Indices
        #
        xml_obj_children( $xml, $table,
            tag   => 'index',
            collection_tag => "indices",
            methods => [qw/name type fields options extra/],
        );

        #
        # Constraints
        #
        xml_obj_children( $xml, $table,
            tag   => 'constraint',
            methods => [qw/
                name type fields reference_table reference_fields
                on_delete on_update match_type expression options deferrable
                extra
            /],
        );

        #
        # Comments
        #
        xml_obj_children( $xml, $table,
            tag   => 'comment',
            collection_tag => "comments",
            methods => [qw/
                comments
            /],
        );

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

    #
    # Views
    #
    xml_obj_children( $xml, $schema,
        tag   => 'view',
        methods => [qw/name sql fields order extra/],
    );

    #
    # Tiggers
    #
    xml_obj_children( $xml, $schema,
        tag    => 'trigger',
        methods => [qw/name database_events action on_table perform_action_when
            fields order extra/],
    );

    #
    # Procedures
    #
    xml_obj_children( $xml, $schema,
        tag   => 'procedure',
        methods => [qw/name sql parameters owner comments order extra/],
    );

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

    return $io;
}


#
# Takes and XML::Write object, Schema::* parent object, the tag name,
# the collection name and a list of methods (of the children) to write as XML.
# The collection name defaults to the name with an s on the end and is used to
# work out the method to get the children with. eg a name of 'foo' gives a
# collection of foos and gets the members using ->get_foos.
#
sub xml_obj_children {
    my ($xml,$parent) = (shift,shift);
    my %args = @_;
    my ($name,$collection_name,$methods)
        = @args{qw/tag collection_tag methods/};
    $collection_name ||= "${name}s";

    my $meth;
    if ( $collection_name eq 'comments' ) {
      $meth = 'comments';
    } else {
      $meth = "get_$collection_name";
    }

    my @kids = $parent->$meth;
    #@kids || return;
    $xml->startTag( [ $Namespace => $collection_name ] );

    for my $obj ( @kids ) {
        if ( $collection_name eq 'comments' ){
            $xml->dataElement( [ $Namespace => 'comment' ], $obj );
        } else {
            xml_obj($xml, $obj,
                tag     => "$name",
                end_tag => 1,
                methods => $methods,
            );
        }
    }
    $xml->endTag( [ $Namespace => $collection_name ] );
}

#
# Takes an XML::Writer, Schema::* object and list of method names
# and writes the obect out as XML. All methods values are written as attributes
# except for the methods listed in @MAP_AS_ELEMENTS which get written as child
# data elements.
#
# The attributes/tags are written in the same order as the method names are
# passed.
#
# TODO
# - Should the Namespace be passed in instead of global? Pass in the same
#   as Writer ie [ NS => TAGNAME ]
#
my $elements_re = join("|", @MAP_AS_ELEMENTS);
$elements_re = qr/^($elements_re)$/;
sub xml_obj {
    my ($xml, $obj, %args) = @_;
    my $tag                = $args{'tag'}              || '';
    my $end_tag            = $args{'end_tag'}          || '';
    my @meths              = @{ $args{'methods'} };
    my $empty_tag          = 0;

    # Use array to ensure consistant (ie not hash) ordering of attribs
    # The order comes from the meths list passed in.
    my @tags;
    my @attr;
    foreach ( grep { defined $obj->$_ } @meths ) {
        my $what = m/$elements_re/ ? \@tags : \@attr;
        my $val = $_ eq 'extra'
            ? { $obj->$_ }
            : $obj->$_;
        $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
        push @$what, $_ => $val;
    };
    my $child_tags = @tags;
    $end_tag && !$child_tags
        ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
        : $xml->startTag( [ $Namespace => $tag ], @attr );
    while ( my ($name,$val) = splice @tags,0,2 ) {
        if ( ref $val eq 'HASH' ) {
             $xml->emptyTag( [ $Namespace => $name ],
                 map { ($_, $val->{$_}) } sort keys %$val );
        }
        else {
            $xml->dataElement( [ $Namespace => $name ], $val );
        }
    }
    $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
}

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

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

=cut
Commit	Line	Data
0a689100	1	package SQL::Translator::Producer::XML::SQLFairy;
	2
	3	# -------------------------------------------------------------------
0a689100	4	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	5	# darren chamberlain <darren@cpan.org>,
	6	# Chris Mungall <cjm@fruitfly.org>,
	7	# Mark Addison <mark.addison@itn.co.uk>.
	8	#
	9	# This program is free software; you can redistribute it and/or
	10	# modify it under the terms of the GNU General Public License as
	11	# published by the Free Software Foundation; version 2.
	12	#
	13	# This program is distributed in the hope that it will be useful, but
	14	# WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	16	# General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	21	# 02111-1307 USA
	22	# -------------------------------------------------------------------
	23
	24	=pod
	25
	26	=head1 NAME
	27
a7d50b44	28	SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format
0a689100	29
	30	=head1 SYNOPSIS
	31
	32	use SQL::Translator;
	33
	34	my $t = SQL::Translator->new(
	35	from => 'MySQL',
a7d50b44	36	to => 'XML-SQLFairy',
0a689100	37	filename => 'schema.sql',
0a689100	38	show_warnings => 1,
0a689100	39	);
	40
	41	print $t->translate;
	42
b89a67a0	43	=head1 DESCRIPTION
0a689100	44
91f28468	45	Creates XML output of a schema, in the flavor of XML used natively by the
91f28468	46	SQLFairy project (L<SQL::Translator>). This format is detailed here.
0a689100	47
91f28468	48	The XML lives in the C<http://sqlfairy.sourceforge.net/sqlfairy.xml> namespace.
b89a67a0	49	With a root element of <schema>.
0a689100	50
91f28468	51	Objects in the schema are mapped to tags of the same name as the objects class
91f28468	52	(all lowercase).
0a689100	53
b89a67a0	54	The attributes of the objects (e.g. $field->name) are mapped to attributes of
	55	the tag, except for sql, comments and action, which get mapped to child data
	56	elements.
0a689100	57
b89a67a0	58	List valued attributes (such as the list of fields in an index)
91f28468	59	get mapped to comma seperated lists of values in the attribute.
0a689100	60
b89a67a0	61	Child objects, such as a tables fields, get mapped to child tags wrapped in a
b89a67a0	62	set of container tags using the plural of their contained classes name.
0a689100	63
0eebe059	64	An objects's extra attribute (a hash of arbitary data) is
e0a0c3e1	65	mapped to a tag called extra, with the hash of data as attributes, sorted into
	66	alphabetical order.
	67
b89a67a0	68	e.g.
0a689100	69
b89a67a0	70	<schema name="" database=""
b89a67a0	71	xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">
0a689100	72
91f28468	73	<tables>
	74	<table name="Story" order="1">
	75	<fields>
	76	<field name="id" data_type="BIGINT" size="20"
	77	is_nullable="0" is_auto_increment="1" is_primary_key="1"
	78	is_foreign_key="0" order="3">
	79	<extra ZEROFILL="1" />
	80	<comments></comments>
	81	</field>
	82	<field name="created" data_type="datetime" size="0"
	83	is_nullable="1" is_auto_increment="0" is_primary_key="0"
	84	is_foreign_key="0" order="1">
	85	<extra />
	86	<comments></comments>
	87	</field>
	88	...
	89	</fields>
	90	<indices>
	91	<index name="foobar" type="NORMAL" fields="foo,bar" options="" />
	92	</indices>
	93	</table>
	94	</tables>
	95
	96	<views>
	97	<view name="email_list" fields="email" order="1">
	98	<sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
	99	</view>
	100	</views>
b89a67a0	101
	102	</schema>
	103
	104	To see a complete example of the XML translate one of your schema :)
	105
	106	$ sqlt -f MySQL -t XML-SQLFairy schema.sql
	107
	108	=head1 ARGS
0a689100	109
983ed646	110	=over 4
	111
	112	=item add_prefix
	113
	114	Set to true to use the default namespace prefix of 'sqlf', instead of using
	115	the default namespace for
	116	C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>
	117
	118	e.g.
	119
	120	<!-- add_prefix=0 -->
	121	<field name="foo" />
	122
	123	<!-- add_prefix=1 -->
	124	<sqlf:field name="foo" />
	125
	126	=item prefix
	127
	128	Set to the namespace prefix you want to use for the
	129	C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>
	130
	131	e.g.
	132
	133	<!-- prefix='foo' -->
	134	<foo:field name="foo" />
	135
e0a0c3e1	136	=item newlines
	137
	138	If true (the default) inserts newlines around the XML, otherwise the schema is
	139	written on one line.
	140
	141	=item indent
	142
	143	When using newlines the number of whitespace characters to use as the indent.
	144	Default is 2, set to 0 to turn off indenting.
	145
983ed646	146	=back
0a689100	147
4a268a6c	148	=head1 LEGACY FORMAT
	149
	150	The previous version of the SQLFairy XML allowed the attributes of the the
	151	schema objects to be written as either xml attributes or as data elements, in
	152	any combination. The old producer could produce attribute only or data element
	153	only versions. While this allowed for lots of flexibility in writing the XML
	154	the result is a great many possible XML formats, not so good for DTD writing,
	155	XPathing etc! So we have moved to a fixed version described above.
	156
	157	This version of the producer will now only produce the new style XML.
91f28468	158	To convert your old format files simply pass them through the translator :)
4a268a6c	159
91f28468	160	$ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
4a268a6c	161
0a689100	162	=cut
	163
	164	use strict;
da06ac74	165	use vars qw[ $VERSION @EXPORT_OK ];
4ab3763d	166	$VERSION = '1.59';
0a689100	167
	168	use Exporter;
	169	use base qw(Exporter);
	170	@EXPORT_OK = qw(produce);
	171
	172	use IO::Scalar;
	173	use SQL::Translator::Utils qw(header_comment debug);
f135f8f9	174	BEGIN {
	175	# Will someone fix XML::Writer already?
	176	local $^W = 0;
	177	require XML::Writer;
	178	import XML::Writer;
	179	}
0a689100	180
23735f6a	181	# Which schema object attributes (methods) to write as xml elements rather than
	182	# as attributes. e.g. <comments>blah, blah...</comments>
	183	my @MAP_AS_ELEMENTS = qw/sql comments action extra/;
	184
	185
	186
0a689100	187	my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
b89a67a0	188	my $Name = 'sqlf';
375f0be1	189	my $PArgs = {};
f8622fbb	190	my $no_comments;
0a689100	191
	192	sub produce {
	193	my $translator = shift;
	194	my $schema = $translator->schema;
f8622fbb	195	$no_comments = $translator->no_comments;
0a689100	196	$PArgs = $translator->producer_args;
983ed646	197	my $newlines = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
983ed646	198	my $indent = defined $PArgs->{indent} ? $PArgs->{indent} : 2;
0a689100	199	my $io = IO::Scalar->new;
983ed646	200
23735f6a	201	# Setup the XML::Writer and set the namespace
983ed646	202	my $prefix = "";
	203	$prefix = $Name if $PArgs->{add_prefix};
	204	$prefix = $PArgs->{prefix} if $PArgs->{prefix};
0a689100	205	my $xml = XML::Writer->new(
	206	OUTPUT => $io,
	207	NAMESPACES => 1,
983ed646	208	PREFIX_MAP => { $Namespace => $prefix },
	209	DATA_MODE => $newlines,
	210	DATA_INDENT => $indent,
0a689100	211	);
0a689100	212
23735f6a	213	# Start the document
0a689100	214	$xml->xmlDecl('UTF-8');
f8622fbb	215
	216	$xml->comment(header_comment('', ''))
	217	unless $no_comments;
	218
1caf2bb2	219	xml_obj($xml, $schema,
0eebe059	220	tag => "schema", methods => [qw/name database extra/], end_tag => 0 );
0a689100	221
	222	#
	223	# Table
	224	#
87c5565e	225	$xml->startTag( [ $Namespace => "tables" ] );
0a689100	226	for my $table ( $schema->get_tables ) {
0a689100	227	debug "Table:",$table->name;
d3422086	228	xml_obj($xml, $table,
87c5565e	229	tag => "table",
0eebe059	230	methods => [qw/name order extra/],
87c5565e	231	end_tag => 0
87c5565e	232	);
0a689100	233
	234	#
	235	# Fields
	236	#
87c5565e	237	xml_obj_children( $xml, $table,
	238	tag => 'field',
	239	methods =>[qw/
	240	name data_type size is_nullable default_value is_auto_increment
	241	is_primary_key is_foreign_key extra comments order
	242	/],
	243	);
0a689100	244
	245	#
	246	# Indices
	247	#
87c5565e	248	xml_obj_children( $xml, $table,
	249	tag => 'index',
	250	collection_tag => "indices",
0eebe059	251	methods => [qw/name type fields options extra/],
87c5565e	252	);
0a689100	253
	254	#
	255	# Constraints
	256	#
87c5565e	257	xml_obj_children( $xml, $table,
	258	tag => 'constraint',
	259	methods => [qw/
	260	name type fields reference_table reference_fields
	261	on_delete on_update match_type expression options deferrable
0eebe059	262	extra
87c5565e	263	/],
87c5565e	264	);
0a689100	265
7c71eaab	266	#
	267	# Comments
	268	#
	269	xml_obj_children( $xml, $table,
	270	tag => 'comment',
	271	collection_tag => "comments",
	272	methods => [qw/
	273	comments
	274	/],
	275	);
	276
0a689100	277	$xml->endTag( [ $Namespace => 'table' ] );
0a689100	278	}
87c5565e	279	$xml->endTag( [ $Namespace => 'tables' ] );
d3422086	280
1e3867bf	281	#
	282	# Views
	283	#
87c5565e	284	xml_obj_children( $xml, $schema,
87c5565e	285	tag => 'view',
0eebe059	286	methods => [qw/name sql fields order extra/],
87c5565e	287	);
d3422086	288
1e3867bf	289	#
	290	# Tiggers
	291	#
87c5565e	292	xml_obj_children( $xml, $schema,
87c5565e	293	tag => 'trigger',
222094af	294	methods => [qw/name database_events action on_table perform_action_when
0eebe059	295	fields order extra/],
87c5565e	296	);
0a689100	297
1e3867bf	298	#
	299	# Procedures
	300	#
87c5565e	301	xml_obj_children( $xml, $schema,
87c5565e	302	tag => 'procedure',
0eebe059	303	methods => [qw/name sql parameters owner comments order extra/],
87c5565e	304	);
d3422086	305
0a689100	306	$xml->endTag([ $Namespace => 'schema' ]);
	307	$xml->end;
	308
	309	return $io;
	310	}
	311
87c5565e	312
	313	#
	314	# Takes and XML::Write object, Schema::* parent object, the tag name,
	315	# the collection name and a list of methods (of the children) to write as XML.
	316	# The collection name defaults to the name with an s on the end and is used to
	317	# work out the method to get the children with. eg a name of 'foo' gives a
	318	# collection of foos and gets the members using ->get_foos.
	319	#
	320	sub xml_obj_children {
	321	my ($xml,$parent) = (shift,shift);
	322	my %args = @_;
	323	my ($name,$collection_name,$methods)
	324	= @args{qw/tag collection_tag methods/};
	325	$collection_name \|\|= "${name}s";
7c71eaab	326
	327	my $meth;
	328	if ( $collection_name eq 'comments' ) {
	329	$meth = 'comments';
	330	} else {
	331	$meth = "get_$collection_name";
	332	}
87c5565e	333
	334	my @kids = $parent->$meth;
	335	#@kids \|\| return;
	336	$xml->startTag( [ $Namespace => $collection_name ] );
7c71eaab	337
87c5565e	338	for my $obj ( @kids ) {
7c71eaab	339	if ( $collection_name eq 'comments' ){
	340	$xml->dataElement( [ $Namespace => 'comment' ], $obj );
	341	} else {
	342	xml_obj($xml, $obj,
	343	tag => "$name",
	344	end_tag => 1,
	345	methods => $methods,
	346	);
	347	}
87c5565e	348	}
	349	$xml->endTag( [ $Namespace => $collection_name ] );
	350	}
	351
1caf2bb2	352	#
23735f6a	353	# Takes an XML::Writer, Schema::* object and list of method names
b89a67a0	354	# and writes the obect out as XML. All methods values are written as attributes
87c5565e	355	# except for the methods listed in @MAP_AS_ELEMENTS which get written as child
87c5565e	356	# data elements.
b89a67a0	357	#
23735f6a	358	# The attributes/tags are written in the same order as the method names are
b89a67a0	359	# passed.
	360	#
	361	# TODO
1caf2bb2	362	# - Should the Namespace be passed in instead of global? Pass in the same
	363	# as Writer ie [ NS => TAGNAME ]
	364	#
23735f6a	365	my $elements_re = join("\|", @MAP_AS_ELEMENTS);
23735f6a	366	$elements_re = qr/^($elements_re)$/;
0a689100	367	sub xml_obj {
d3422086	368	my ($xml, $obj, %args) = @_;
	369	my $tag = $args{'tag'} \|\| '';
	370	my $end_tag = $args{'end_tag'} \|\| '';
d3422086	371	my @meths = @{ $args{'methods'} };
	372	my $empty_tag = 0;
	373
b89a67a0	374	# Use array to ensure consistant (ie not hash) ordering of attribs
	375	# The order comes from the meths list passed in.
	376	my @tags;
	377	my @attr;
	378	foreach ( grep { defined $obj->$_ } @meths ) {
23735f6a	379	my $what = m/$elements_re/ ? \@tags : \@attr;
e0a0c3e1	380	my $val = $_ eq 'extra'
	381	? { $obj->$_ }
	382	: $obj->$_;
0a689100	383	$val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
b89a67a0	384	push @$what, $_ => $val;
	385	};
	386	my $child_tags = @tags;
	387	$end_tag && !$child_tags
	388	? $xml->emptyTag( [ $Namespace => $tag ], @attr )
	389	: $xml->startTag( [ $Namespace => $tag ], @attr );
	390	while ( my ($name,$val) = splice @tags,0,2 ) {
e0a0c3e1	391	if ( ref $val eq 'HASH' ) {
	392	$xml->emptyTag( [ $Namespace => $name ],
	393	map { ($_, $val->{$_}) } sort keys %$val );
	394	}
	395	else {
	396	$xml->dataElement( [ $Namespace => $name ], $val );
	397	}
0a689100	398	}
b89a67a0	399	$xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
0a689100	400	}
	401
	402	1;
	403
	404	# -------------------------------------------------------------------
	405	# The eyes of fire, the nostrils of air,
	406	# The mouth of water, the beard of earth.
	407	# William Blake
	408	# -------------------------------------------------------------------
	409
	410	=pod
	411
	412	=head1 AUTHORS
	413
d3422086	414	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
d3422086	415	Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
0a689100	416	Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
	417
	418	=head1 SEE ALSO
	419
91f28468	420	L<perl(1)>, L<SQL::Translator>, L<SQL::Translator::Parser::XML::SQLFairy>,
91f28468	421	L<SQL::Translator::Schema>, L<XML::Writer>.
0a689100	422
0a689100	423	=cut