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

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

# -------------------------------------------------------------------
# Copyright (C) 2003-9 SQLFair Authors.
#
# 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.60';

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