1 package SQL::Translator::Producer::XML::SQLFairy;
3 # -------------------------------------------------------------------
4 # $Id: SQLFairy.pm,v 1.5 2003-10-17 13:39:01 grommit Exp $
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>.
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.
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.
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
24 # -------------------------------------------------------------------
30 SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format
36 my $t = SQL::Translator->new(
39 filename => 'schema.sql',
48 Takes the following extra producer args.
52 =item * emit_empty_tags
54 Default is false, set to true to emit <foo></foo> style tags for undef values
59 Set true to use attributes for values of the schema objects instead of tags.
61 <!-- attrib_values => 0 -->
67 <!-- attrib_values => 1 -->
68 <table name="foo" order="1">
75 Creates XML output of a schema.
80 use vars qw[ $VERSION @EXPORT_OK ];
81 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
84 use base qw(Exporter);
85 @EXPORT_OK = qw(produce);
88 use SQL::Translator::Utils qw(header_comment debug);
91 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
96 my $translator = shift;
97 my $schema = $translator->schema;
98 $PArgs = $translator->producer_args;
99 my $io = IO::Scalar->new;
100 my $xml = XML::Writer->new(
103 PREFIX_MAP => { $Namespace => $Name },
108 $xml->xmlDecl('UTF-8');
109 $xml->comment(header_comment('', ''));
110 #$xml->startTag([ $Namespace => 'schema' ]);
111 xml_obj($xml, $schema,
112 tag => "schema", methods => [qw/name database/], end_tag => 0 );
117 for my $table ( $schema->get_tables ) {
118 debug "Table:",$table->name;
119 xml_obj($xml, $table,
120 tag => "table", methods => [qw/name order/], end_tag => 0 );
125 $xml->startTag( [ $Namespace => 'fields' ] );
126 for my $field ( $table->get_fields ) {
127 debug " Field:",$field->name;
128 xml_obj($xml, $field,
131 methods =>[qw/name data_type default_value is_auto_increment
132 is_primary_key is_nullable is_foreign_key order size
137 $xml->endTag( [ $Namespace => 'fields' ] );
142 $xml->startTag( [ $Namespace => 'indices' ] );
143 for my $index ( $table->get_indices ) {
144 debug "Index:",$index->name;
145 xml_obj($xml, $index,
148 methods =>[qw/fields name options type/],
151 $xml->endTag( [ $Namespace => 'indices' ] );
156 $xml->startTag( [ $Namespace => 'constraints' ] );
157 for my $index ( $table->get_constraints ) {
158 debug "Constraint:",$index->name;
159 xml_obj($xml, $index,
163 deferrable expression fields match_type name
164 options on_delete on_update reference_fields
165 reference_table type/],
168 $xml->endTag( [ $Namespace => 'constraints' ] );
170 $xml->endTag( [ $Namespace => 'table' ] );
173 $xml->endTag([ $Namespace => 'schema' ]);
179 # -------------------------------------------------------------------
183 # - Should the Namespace be passed in instead of global? Pass in the same
184 # as Writer ie [ NS => TAGNAME ]
187 my ($xml, $obj, %args) = @_;
188 my $tag = $args{'tag'} || '';
189 my $end_tag = $args{'end_tag'} || '';
190 my $attrib_values = $PArgs->{'attrib_values'} || '';
191 my @meths = @{ $args{'methods'} };
194 if ( $attrib_values and $end_tag ) {
199 if ( $attrib_values ) {
202 ($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val);
204 foreach ( keys %attr ) { delete $attr{$_} unless defined $attr{$_}; }
205 $empty_tag ? $xml->emptyTag( [ $Namespace => $tag ], %attr )
206 : $xml->startTag( [ $Namespace => $tag ], %attr );
209 $xml->startTag( [ $Namespace => $tag ] );
210 xml_objAttr( $xml, $obj, @meths );
213 $xml->endTag( [ $Namespace => $tag ] ) if $end_tag;
216 # -------------------------------------------------------------------
217 # Takes an XML writer, a Schema::* object and a list of methods and
218 # adds the XML for those methods.
221 my ($xml, $obj, @methods) = @_;
222 my $emit_empty = $PArgs->{'emit_empty_tags'};
224 for my $method ( @methods ) {
225 my $val = $obj->$method;
226 debug " ".ref($obj)."->$method=",
227 (defined $val ? "'$val'" : "<UNDEF>");
228 next unless $emit_empty || defined $val;
229 $val = '' if not defined $val;
230 $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
231 debug " Adding Attr:".$method."='",$val,"'";
232 $xml->dataElement( [ $Namespace => $method ], $val );
238 # -------------------------------------------------------------------
239 # The eyes of fire, the nostrils of air,
240 # The mouth of water, the beard of earth.
242 # -------------------------------------------------------------------
248 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
249 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
250 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
254 perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy,
255 SQL::Translator::Schema, XML::Writer.