Commit | Line | Data |
0a689100 |
1 | package SQL::Translator::Producer::XML::SQLFairy; |
2 | |
3 | # ------------------------------------------------------------------- |
f135f8f9 |
4 | # $Id: SQLFairy.pm,v 1.11 2004-03-04 14:39:46 dlc Exp $ |
0a689100 |
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>. |
10 | # |
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. |
14 | # |
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. |
19 | # |
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 |
23 | # 02111-1307 USA |
24 | # ------------------------------------------------------------------- |
25 | |
26 | =pod |
27 | |
28 | =head1 NAME |
29 | |
a7d50b44 |
30 | SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format |
0a689100 |
31 | |
32 | =head1 SYNOPSIS |
33 | |
34 | use SQL::Translator; |
35 | |
36 | my $t = SQL::Translator->new( |
37 | from => 'MySQL', |
a7d50b44 |
38 | to => 'XML-SQLFairy', |
0a689100 |
39 | filename => 'schema.sql', |
40 | show_warnings => 1, |
41 | add_drop_table => 1, |
42 | ); |
43 | |
44 | print $t->translate; |
45 | |
46 | =head1 ARGS |
47 | |
48 | Takes the following extra producer args. |
49 | |
50 | =over 4 |
51 | |
52 | =item * emit_empty_tags |
53 | |
54 | Default is false, set to true to emit <foo></foo> style tags for undef values |
55 | in the schema. |
56 | |
57 | =item * attrib_values |
58 | |
59 | Set true to use attributes for values of the schema objects instead of tags. |
60 | |
61 | <!-- attrib_values => 0 --> |
62 | <table> |
63 | <name>foo</name> |
64 | <order>1</order> |
65 | </table> |
66 | |
67 | <!-- attrib_values => 1 --> |
68 | <table name="foo" order="1"> |
69 | </table> |
70 | |
71 | =back |
72 | |
73 | =head1 DESCRIPTION |
74 | |
75 | Creates XML output of a schema. |
76 | |
77 | =cut |
78 | |
79 | use strict; |
80 | use vars qw[ $VERSION @EXPORT_OK ]; |
f135f8f9 |
81 | $VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; |
0a689100 |
82 | |
83 | use Exporter; |
84 | use base qw(Exporter); |
85 | @EXPORT_OK = qw(produce); |
86 | |
87 | use IO::Scalar; |
88 | use SQL::Translator::Utils qw(header_comment debug); |
f135f8f9 |
89 | BEGIN { |
90 | # Will someone fix XML::Writer already? |
91 | local $^W = 0; |
92 | require XML::Writer; |
93 | import XML::Writer; |
94 | } |
0a689100 |
95 | |
96 | my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml'; |
97 | my $Name = 'sqlt'; |
375f0be1 |
98 | my $PArgs = {}; |
0a689100 |
99 | |
100 | sub produce { |
101 | my $translator = shift; |
102 | my $schema = $translator->schema; |
103 | $PArgs = $translator->producer_args; |
104 | my $io = IO::Scalar->new; |
105 | my $xml = XML::Writer->new( |
106 | OUTPUT => $io, |
107 | NAMESPACES => 1, |
108 | PREFIX_MAP => { $Namespace => $Name }, |
109 | DATA_MODE => 1, |
110 | DATA_INDENT => 2, |
111 | ); |
112 | |
113 | $xml->xmlDecl('UTF-8'); |
114 | $xml->comment(header_comment('', '')); |
1caf2bb2 |
115 | #$xml->startTag([ $Namespace => 'schema' ]); |
116 | xml_obj($xml, $schema, |
117 | tag => "schema", methods => [qw/name database/], end_tag => 0 ); |
0a689100 |
118 | |
119 | # |
120 | # Table |
121 | # |
122 | for my $table ( $schema->get_tables ) { |
123 | debug "Table:",$table->name; |
d3422086 |
124 | xml_obj($xml, $table, |
125 | tag => "table", methods => [qw/name order/], end_tag => 0 ); |
0a689100 |
126 | |
127 | # |
128 | # Fields |
129 | # |
130 | $xml->startTag( [ $Namespace => 'fields' ] ); |
131 | for my $field ( $table->get_fields ) { |
132 | debug " Field:",$field->name; |
d3422086 |
133 | xml_obj($xml, $field, |
134 | tag =>"field", |
135 | end_tag => 1, |
136 | methods =>[qw/name data_type size is_nullable default_value |
137 | is_auto_increment is_primary_key is_foreign_key comments order |
138 | /], |
139 | ); |
0a689100 |
140 | } |
141 | $xml->endTag( [ $Namespace => 'fields' ] ); |
142 | |
143 | # |
144 | # Indices |
145 | # |
146 | $xml->startTag( [ $Namespace => 'indices' ] ); |
147 | for my $index ( $table->get_indices ) { |
148 | debug "Index:",$index->name; |
d3422086 |
149 | xml_obj($xml, $index, |
150 | tag => "index", |
151 | end_tag => 1, |
152 | methods =>[qw/ name type fields options/], |
153 | ); |
0a689100 |
154 | } |
155 | $xml->endTag( [ $Namespace => 'indices' ] ); |
156 | |
157 | # |
158 | # Constraints |
159 | # |
160 | $xml->startTag( [ $Namespace => 'constraints' ] ); |
161 | for my $index ( $table->get_constraints ) { |
162 | debug "Constraint:",$index->name; |
d3422086 |
163 | xml_obj($xml, $index, |
164 | tag => "constraint", |
165 | end_tag => 1, |
166 | methods =>[qw/ |
167 | name type fields reference_table reference_fields |
168 | on_delete on_update match_type expression options deferrable |
169 | /], |
170 | ); |
0a689100 |
171 | } |
172 | $xml->endTag( [ $Namespace => 'constraints' ] ); |
173 | |
174 | $xml->endTag( [ $Namespace => 'table' ] ); |
175 | } |
d3422086 |
176 | |
1e3867bf |
177 | # |
178 | # Views |
179 | # |
180 | for my $foo ( $schema->get_views ) { |
d3422086 |
181 | xml_obj($xml, $foo, tag => "view", |
1e3867bf |
182 | methods => [qw/name sql fields order/], end_tag => 1 ); |
183 | } |
d3422086 |
184 | |
1e3867bf |
185 | # |
186 | # Tiggers |
187 | # |
188 | for my $foo ( $schema->get_triggers ) { |
d3422086 |
189 | xml_obj($xml, $foo, tag => "trigger", |
190 | methods => [qw/name database_event action on_table perform_action_when |
191 | fields order/], end_tag => 1 ); |
1e3867bf |
192 | } |
0a689100 |
193 | |
1e3867bf |
194 | # |
195 | # Procedures |
196 | # |
197 | for my $foo ( $schema->get_procedures ) { |
d3422086 |
198 | xml_obj($xml, $foo, tag => "procedure", |
1e3867bf |
199 | methods => [qw/name sql parameters owner comments order/], end_tag=>1 ); |
200 | } |
d3422086 |
201 | |
0a689100 |
202 | $xml->endTag([ $Namespace => 'schema' ]); |
203 | $xml->end; |
204 | |
205 | return $io; |
206 | } |
207 | |
208 | # ------------------------------------------------------------------- |
1caf2bb2 |
209 | # |
210 | # TODO |
211 | # - Doc this sub |
212 | # - Should the Namespace be passed in instead of global? Pass in the same |
213 | # as Writer ie [ NS => TAGNAME ] |
214 | # |
0a689100 |
215 | sub xml_obj { |
d3422086 |
216 | my ($xml, $obj, %args) = @_; |
217 | my $tag = $args{'tag'} || ''; |
218 | my $end_tag = $args{'end_tag'} || ''; |
219 | my $attrib_values = $PArgs->{'attrib_values'} || ''; |
220 | my @meths = @{ $args{'methods'} }; |
221 | my $empty_tag = 0; |
222 | |
223 | if ( $attrib_values and $end_tag ) { |
224 | $empty_tag = 1; |
225 | $end_tag = 0; |
226 | } |
227 | |
228 | if ( $attrib_values ) { |
d671d3b9 |
229 | # Use array to ensure consistant (ie not hash) ordering of attribs |
d3422086 |
230 | # The order comes from the meths list passes in. |
231 | my @attr = map { |
232 | my $val = $obj->$_; |
233 | ($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val); |
234 | } grep { defined $obj->$_ } @meths; |
446dfcbd |
235 | $empty_tag ? $xml->emptyTag( [ $Namespace => $tag ], @attr ) |
d3422086 |
236 | : $xml->startTag( [ $Namespace => $tag ], @attr ); |
237 | } |
238 | else { |
239 | $xml->startTag( [ $Namespace => $tag ] ); |
240 | xml_objAttr( $xml, $obj, @meths ); |
241 | } |
242 | |
243 | $xml->endTag( [ $Namespace => $tag ] ) if $end_tag; |
0a689100 |
244 | } |
245 | |
246 | # ------------------------------------------------------------------- |
247 | # Takes an XML writer, a Schema::* object and a list of methods and |
248 | # adds the XML for those methods. |
249 | # |
250 | sub xml_objAttr { |
251 | my ($xml, $obj, @methods) = @_; |
252 | my $emit_empty = $PArgs->{'emit_empty_tags'}; |
253 | |
d3422086 |
254 | for my $method ( @methods ) { |
0a689100 |
255 | my $val = $obj->$method; |
256 | debug " ".ref($obj)."->$method=", |
257 | (defined $val ? "'$val'" : "<UNDEF>"); |
258 | next unless $emit_empty || defined $val; |
259 | $val = '' if not defined $val; |
260 | $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val; |
261 | debug " Adding Attr:".$method."='",$val,"'"; |
262 | $xml->dataElement( [ $Namespace => $method ], $val ); |
263 | } |
264 | } |
265 | |
266 | 1; |
267 | |
268 | # ------------------------------------------------------------------- |
269 | # The eyes of fire, the nostrils of air, |
270 | # The mouth of water, the beard of earth. |
271 | # William Blake |
272 | # ------------------------------------------------------------------- |
273 | |
274 | =pod |
275 | |
276 | =head1 AUTHORS |
277 | |
d3422086 |
278 | Ken Y. Clark E<lt>kclark@cpan.orgE<gt>, |
279 | Darren Chamberlain E<lt>darren@cpan.orgE<gt>, |
0a689100 |
280 | Mark Addison E<lt>mark.addison@itn.co.ukE<gt>. |
281 | |
282 | =head1 SEE ALSO |
283 | |
a7d50b44 |
284 | perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy, |
0a689100 |
285 | SQL::Translator::Schema, XML::Writer. |
286 | |
287 | =cut |