X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FXML%2FSQLFairy.pm;h=7db90bdad0c8607a152c4c076a381bbf351cd34f;hb=4a268a6c214c18c5753762ad59fa1a2430ede61a;hp=a26a663aeea9cc25c6772813f10da2274d5ef8e7;hpb=a7d50b447384c5b1d86f6162ff87166fe2662e7b;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/XML/SQLFairy.pm b/lib/SQL/Translator/Producer/XML/SQLFairy.pm index a26a663..7db90bd 100644 --- a/lib/SQL/Translator/Producer/XML/SQLFairy.pm +++ b/lib/SQL/Translator/Producer/XML/SQLFairy.pm @@ -1,7 +1,7 @@ package SQL::Translator::Producer::XML::SQLFairy; # ------------------------------------------------------------------- -# $Id: SQLFairy.pm,v 1.2 2003-08-22 22:22:19 kycl4rk Exp $ +# $Id: SQLFairy.pm,v 1.13 2004-07-08 19:34:29 grommit Exp $ # ------------------------------------------------------------------- # Copyright (C) 2003 Ken Y. Clark , # darren chamberlain , @@ -43,42 +43,85 @@ SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format print $t->translate; -=head1 ARGS +=head1 DESCRIPTION -Takes the following extra producer args. +Creates XML output of a schema, in SQLFairy format XML. -=over 4 +The XML lives in the http://sqlfairy.sourceforge.net/sqlfairy.xml namespace. +With a root element of . -=item * emit_empty_tags +Objects in the schema are mapped to tags of the same name as the objects class. -Default is false, set to true to emit style tags for undef values -in the schema. +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. -=item * attrib_values +List valued attributes (such as the list of fields in an index) +get mapped to a comma seperated list of values in the attribute. -Set true to use attributes for values of the schema objects instead of tags. +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. - - - foo - 1 -
+e.g. - - -
+ -=back + -=head1 DESCRIPTION + + + + + + + + ... + + + + + + +
+ + + 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 -Creates XML output of a schema. +=head1 ARGS + +Doesn't take any extra arguments. + +=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 = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/; use Exporter; use base qw(Exporter); @@ -86,11 +129,16 @@ use base qw(Exporter); 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; +} my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml'; -my $Name = 'sqlt'; -my $PArgs; +my $Name = 'sqlf'; +my $PArgs = {}; sub produce { my $translator = shift; @@ -107,15 +155,17 @@ sub produce { $xml->xmlDecl('UTF-8'); $xml->comment(header_comment('', '')); - $xml->startTag([ $Namespace => 'schema' ]); + #$xml->startTag([ $Namespace => 'schema' ]); + xml_obj($xml, $schema, + tag => "schema", methods => [qw/name database/], end_tag => 0 ); # # Table # for my $table ( $schema->get_tables ) { debug "Table:",$table->name; - xml_obj($xml, $table, - tag => "table", methods => [qw/name order/], end_tag => 0 ); + xml_obj($xml, $table, + tag => "table", methods => [qw/name order/], end_tag => 0 ); # # Fields @@ -123,13 +173,13 @@ sub produce { $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 default_value is_auto_increment - is_primary_key is_nullable is_foreign_key order size - /], - ); + 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' ] ); @@ -139,11 +189,11 @@ sub produce { $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/fields name options type/], - ); + xml_obj($xml, $index, + tag => "index", + end_tag => 1, + methods =>[qw/ name type fields options/], + ); } $xml->endTag( [ $Namespace => 'indices' ] ); @@ -153,20 +203,45 @@ sub produce { $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/ - deferrable expression fields match_type name - options on_delete on_update reference_fields - reference_table type/], - ); + 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->endTag( [ $Namespace => 'table' ] ); } + # + # Views + # + for my $foo ( $schema->get_views ) { + xml_obj($xml, $foo, tag => "view", + methods => [qw/name sql fields order/], end_tag => 1 ); + } + + # + # 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 ); + } + + # + # 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->endTag([ $Namespace => 'schema' ]); $xml->end; @@ -174,54 +249,43 @@ sub produce { } # ------------------------------------------------------------------- -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 ) { - my %attr = map { - my $val = $obj->$_; - ($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val); - } @meths; - foreach ( keys %attr ) { delete $attr{$_} unless defined $attr{$_}; } - $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; +# Takes an XML Write, 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. +# +# 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 ] +# +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/^sql|comments|action$/ ? \@tags : \@attr; + my $val = $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 ) { + $xml->dataElement( [ $Namespace => $name ], $val ); } + $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag; } 1; @@ -236,8 +300,8 @@ sub xml_objAttr { =head1 AUTHORS -Ken Y. Clark Ekclark@cpan.orgE, -Darren Chamberlain Edarren@cpan.orgE, +Ken Y. Clark Ekclark@cpan.orgE, +Darren Chamberlain Edarren@cpan.orgE, Mark Addison Emark.addison@itn.co.ukE. =head1 SEE ALSO