package SQL::Translator::Producer::XML::SQLFairy;
# -------------------------------------------------------------------
-# $Id: SQLFairy.pm,v 1.15 2004-07-08 23:39:38 grommit Exp $
-# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
# darren chamberlain <darren@cpan.org>,
# Chris Mungall <cjm@fruitfly.org>,
to => 'XML-SQLFairy',
filename => 'schema.sql',
show_warnings => 1,
- add_drop_table => 1,
);
print $t->translate;
=head1 DESCRIPTION
-Creates XML output of a schema, in SQLFairy format XML.
+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 http://sqlfairy.sourceforge.net/sqlfairy.xml namespace.
+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.
+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 a comma seperated list of values in the attribute.
+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.
-L<SQL::Translator::Schema::Field>'s extra attribute (a hash of arbitary data) is
+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.
<schema name="" database=""
xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">
- <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>
-
- <view name="email_list" fields="email" order="1">
- <sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
- </view>
+ <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>
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;
+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
+ $ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
=cut
use strict;
use vars qw[ $VERSION @EXPORT_OK ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
+$VERSION = '1.59';
use Exporter;
use base qw(Exporter);
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 $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};
DATA_INDENT => $indent,
);
+ # Start the document
$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 );
+ 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/], end_tag => 0 );
+ tag => "table",
+ methods => [qw/name order extra/],
+ 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 extra comments order
- /],
- );
- }
- $xml->endTag( [ $Namespace => '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->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' ] );
+ xml_obj_children( $xml, $table,
+ tag => 'index',
+ collection_tag => "indices",
+ methods => [qw/name type fields options extra/],
+ );
#
# 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_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
#
- for my $foo ( $schema->get_views ) {
- xml_obj($xml, $foo, tag => "view",
- methods => [qw/name sql fields order/], end_tag => 1 );
- }
+ xml_obj_children( $xml, $schema,
+ tag => 'view',
+ methods => [qw/name sql fields order extra/],
+ );
#
# Tiggers
#
- for my $foo ( $schema->get_triggers ) {
- xml_obj($xml, $foo, tag => "trigger",
+ xml_obj_children( $xml, $schema,
+ tag => 'trigger',
methods => [qw/name database_event action on_table perform_action_when
- fields order/], end_tag => 1 );
- }
+ fields order extra/],
+ );
#
# 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_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 Write, Schema::* object and list of method names
+# 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 comments, sql and action which get written as child data elements.
+# 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
+# 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 @tags;
my @attr;
foreach ( grep { defined $obj->$_ } @meths ) {
- my $what = m/^(sql|comments|action|extra)$/ ? \@tags : \@attr;
+ my $what = m/$elements_re/ ? \@tags : \@attr;
my $val = $_ eq 'extra'
? { $obj->$_ }
: $obj->$_;
=head1 SEE ALSO
-perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy,
-SQL::Translator::Schema, XML::Writer.
+L<perl(1)>, L<SQL::Translator>, L<SQL::Translator::Parser::XML::SQLFairy>,
+L<SQL::Translator::Schema>, L<XML::Writer>.
=cut
projects / dbsrgits/SQL-Translator.git / blobdiff