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

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

# -------------------------------------------------------------------
# $Id: SQLFairy.pm 1440 2009-01-17 16:31:57Z jawnsy $
# -------------------------------------------------------------------
# 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[ @EXPORT_OK ];

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

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