X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FSQL-Translator.git;a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FXML%2FSQLFairy.pm;h=ce9e151fa57fdc177e250ccf688a24b49c3bf73c;hp=625e66f68e4b9edf4c4c2756c95a6775cf83f672;hb=c0ec0e22d3f0e3852c00daac5ef5763010b410c3;hpb=d3422086e661d79a28578bdd9ca64bfedc68fee5 diff --git a/lib/SQL/Translator/Producer/XML/SQLFairy.pm b/lib/SQL/Translator/Producer/XML/SQLFairy.pm index 625e66f..ce9e151 100644 --- a/lib/SQL/Translator/Producer/XML/SQLFairy.pm +++ b/lib/SQL/Translator/Producer/XML/SQLFairy.pm @@ -1,28 +1,5 @@ package SQL::Translator::Producer::XML::SQLFairy; -# ------------------------------------------------------------------- -# $Id: SQLFairy.pm,v 1.10 2004-01-29 21:49:19 grommit Exp $ -# ------------------------------------------------------------------- -# Copyright (C) 2003 Ken Y. Clark , -# darren chamberlain , -# Chris Mungall , -# Mark Addison . -# -# 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 @@ -38,161 +15,272 @@ SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format to => 'XML-SQLFairy', filename => 'schema.sql', show_warnings => 1, - add_drop_table => 1, ); print $t->translate; -=head1 ARGS +=head1 DESCRIPTION -Takes the following extra producer args. +Creates XML output of a schema, in the flavor of XML used natively by the +SQLFairy project (L). This format is detailed here. + +The XML lives in the C namespace. +With a root element of . + +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 separated 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' extra attribute (a hash of arbitrary data) is +mapped to a tag called extra, with the hash of data as attributes, sorted into +alphabetical order. + +e.g. + + + + + + + + + + + + + + + ... + + + + +
+ + + + + SELECT email FROM Basic WHERE email IS NOT NULL + + + + + +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 * emit_empty_tags +=item add_prefix + +Set to true to use the default namespace prefix of 'sqlf', instead of using +the default namespace for +C + +e.g. + + + + + + + +=item prefix + +Set to the namespace prefix you want to use for the +C + +e.g. -Default is false, set to true to emit style tags for undef values -in the schema. + + -=item * attrib_values +=item newlines -Set true to use attributes for values of the schema objects instead of tags. +If true (the default) inserts newlines around the XML, otherwise the schema is +written on one line. - - - foo - 1 -
+=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 DESCRIPTION +=head1 LEGACY FORMAT + +The previous version of the SQLFairy XML allowed the attributes of 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 :) -Creates XML output of a schema. + $ 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.10 $ =~ /(\d+)\.(\d+)/; +use warnings; +our @EXPORT_OK; +our $VERSION = '1.59'; use Exporter; use base qw(Exporter); @EXPORT_OK = qw(produce); -use IO::Scalar; use SQL::Translator::Utils qw(header_comment debug); -use XML::Writer; +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. blah, blah... +my @MAP_AS_ELEMENTS = qw/sql comments action extra/; + + my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml'; -my $Name = 'sqlt'; +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 $io = IO::Scalar->new; + my $newlines = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1; + my $indent = defined $PArgs->{indent} ? $PArgs->{indent} : 2; + + # Setup the XML::Writer and set the namespace + my $io; + my $prefix = ""; + $prefix = $Name if $PArgs->{add_prefix}; + $prefix = $PArgs->{prefix} if $PArgs->{prefix}; my $xml = XML::Writer->new( - OUTPUT => $io, + OUTPUT => \$io, NAMESPACES => 1, - PREFIX_MAP => { $Namespace => $Name }, - DATA_MODE => 1, - DATA_INDENT => 2, + PREFIX_MAP => { $Namespace => $prefix }, + DATA_MODE => $newlines, + DATA_INDENT => $indent, ); + # Start the document $xml->xmlDecl('UTF-8'); - $xml->comment(header_comment('', '')); - #$xml->startTag([ $Namespace => 'schema' ]); + + $xml->comment(header_comment('', '')) + unless $no_comments; + 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 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", - methods => [qw/name database_event action on_table perform_action_when - fields order/], end_tag => 1 ); - } + xml_obj_children( $xml, $schema, + tag => 'trigger', + methods => [qw/name database_events action on_table perform_action_when + fields order extra scope/], + ); # # 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; @@ -200,62 +288,94 @@ sub produce { 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. # -# TODO -# - Doc this sub +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 object 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 $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'" : ""); - next unless $emit_empty || defined $val; - $val = '' if not defined $val; + # Use array to ensure consistent (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; - debug " Adding Attr:".$method."='",$val,"'"; - $xml->dataElement( [ $Namespace => $method ], $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; @@ -270,13 +390,13 @@ sub xml_objAttr { =head1 AUTHORS -Ken Y. Clark Ekclark@cpan.orgE, +Ken Youens-Clark Ekclark@cpan.orgE, Darren Chamberlain Edarren@cpan.orgE, Mark Addison Emark.addison@itn.co.ukE. =head1 SEE ALSO -perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy, -SQL::Translator::Schema, XML::Writer. +C, L, L, +L, L. =cut