1 package SQL::Translator::Producer::SqlfXML;
3 # -------------------------------------------------------------------
4 # $Id: SqlfXML.pm,v 1.4 2003-08-14 12:03:00 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>
10 # This program is free software; you can redistribute it and/or
11 # modify it under the terms of the GNU General Public License as
12 # published by the Free Software Foundation; version 2.
14 # This program is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 # General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
23 # -------------------------------------------------------------------
27 use vars qw[ $VERSION ];
28 $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
31 use base qw(Exporter);
32 our @EXPORT_OK = qw(produce);
35 use SQL::Translator::Utils qw(header_comment);
38 my $namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
42 our ($translator,$PArgs,$schema);
44 sub debug { $translator->debug(@_,"\n"); } # Shortcut.
48 $PArgs = $translator->producer_args;
49 $schema = $translator->schema;
51 my $io = IO::Scalar->new;
52 my $xml = XML::Writer->new(
55 PREFIX_MAP => { $namespace => $name },
60 $xml->xmlDecl('UTF-8');
61 $xml->comment(header_comment('', ''));
62 $xml->startTag([ $namespace => 'schema' ]);
67 for my $table ( $schema->get_tables ) {
68 debug "Table:",$table->name;
70 tag => "table", methods => [qw/name order/], end_tag => 0 );
75 $xml->startTag( [ $namespace => 'fields' ] );
76 for my $field ( $table->get_fields ) {
77 debug " Field:",$field->name;
81 methods =>[qw/name data_type default_value is_auto_increment
82 is_primary_key is_nullable is_foreign_key order size
86 $xml->endTag( [ $namespace => 'fields' ] );
91 $xml->startTag( [ $namespace => 'indices' ] );
92 for my $index ( $table->get_indices ) {
93 debug "Index:",$index->name;
97 methods =>[qw/fields name options type/],
100 $xml->endTag( [ $namespace => 'indices' ] );
105 $xml->startTag( [ $namespace => 'constraints' ] );
106 for my $index ( $table->get_constraints ) {
107 debug "Constraint:",$index->name;
108 xml_obj($xml, $index,
112 deferrable expression fields match_type name
113 options on_delete on_update reference_fields
114 reference_table type/],
117 $xml->endTag( [ $namespace => 'constraints' ] );
119 $xml->endTag( [ $namespace => 'table' ] );
122 $xml->endTag([ $namespace => 'schema' ]);
129 my ($xml, $obj, %args) = @_;
130 my $tag = $args{tag};
131 my @meths = @{$args{methods}};
132 my $attrib_values = $PArgs->{attrib_values};
134 my $end_tag = $args{end_tag};
135 if ( $attrib_values and $end_tag ) {
140 if ( $attrib_values ) {
143 ($_ => ref($val) eq 'ARRAY' ? join(", ",@$val) : $val);
145 foreach (keys %attr) { delete $attr{$_} unless defined $attr{$_}; }
146 $empty_tag ? $xml->emptyTag( [ $namespace => $tag ], %attr )
147 : $xml->startTag( [ $namespace => $tag ], %attr );
150 $xml->startTag( [ $namespace => $tag ] );
151 xml_objAttr($xml,$obj, @meths);
153 $xml->endTag( [ $namespace => $tag ] ) if $end_tag;
157 # Takes an xml writer, a Schema::* object and a list of methods and adds the
158 # XML for those methods.
160 my ($xml, $obj, @methods) = @_;
161 my $emit_empty = $PArgs->{emit_empty_tags};
162 for my $method (@methods) {
163 my $val = $obj->$method;
164 debug " ".ref($obj)."->$method=",
165 (defined $val ? "'$val'" : "<UNDEF>");
166 next unless $emit_empty || defined $val;
167 $val = "" if not defined $val;
168 $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
169 debug " Adding Attr:".$method."='",$val,"'";
170 $xml->dataElement( [ $namespace => $method ], $val );
174 } # End of our scoped bit
178 # -------------------------------------------------------------------
179 # The eyes of fire, the nostrils of air,
180 # The mouth of water, the beard of earth.
182 # -------------------------------------------------------------------
186 SQL::Translator::Producer::SqlfXML - XML output
192 my $translator = SQL::Translator->new(
196 print = $obj->translate(
199 filename => "fooschema.sql",
204 Takes the following extra producer args.
206 =item emit_empty_tags
208 Default is false, set to true to emit <foo></foo> style tags for undef values
213 Set true to use attributes for values of the schema objects instead of tags.
215 <!-- attrib_values => 0 -->
221 <!-- attrib_values => 1 -->
222 <table name="foo" order="1">
227 Creates XML output of a schema.
233 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
234 darren chamberlain E<lt>darren@cpan.orgE<gt>,
235 mark addison E<lt>mark.addison@itn.co.ukE<gt>,
239 perl(1), SQL::Translator, SQL::Translator::Parser::SqlfXML,
240 SQL::Translator::Schema, XML::Writer.