Commit | Line | Data |
b9d98887 |
1 | use MooseX::Declare; |
2 | role SQL::Translator::Producer::XML { |
3 | use MooseX::Types::Moose qw(HashRef); |
4 | use IO::Scalar; |
5 | #use SQL::Translator::Utils qw(header_comment debug); |
6 | BEGIN { |
7 | # Will someone fix XML::Writer already? |
8 | local $^W = 0; |
9 | require XML::Writer; |
10 | import XML::Writer; |
11 | } |
12 | |
13 | # Which schema object attributes (methods) to write as xml elements rather than |
14 | # as attributes. e.g. <comments>blah, blah...</comments> |
15 | my @MAP_AS_ELEMENTS = qw/sql comments action extra/; |
16 | |
17 | my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml'; |
18 | my $Name = 'sqlf'; |
19 | my $PArgs = {}; |
20 | my $no_comments; |
21 | |
22 | method produce { |
6d4d2c3a |
23 | my $translator = $self->translator; |
b9d98887 |
24 | my $schema = $translator->schema; |
25 | $no_comments = $translator->no_comments; |
26 | # $PArgs = $translator->producer_args; |
27 | my $newlines = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1; |
28 | my $indent = defined $PArgs->{indent} ? $PArgs->{indent} : 2; |
29 | my $io = IO::Scalar->new; |
30 | |
31 | # Setup the XML::Writer and set the namespace |
32 | my $prefix = ""; |
33 | $prefix = $Name if $PArgs->{add_prefix}; |
34 | $prefix = $PArgs->{prefix} if $PArgs->{prefix}; |
35 | my $xml = XML::Writer->new( |
36 | OUTPUT => $io, |
37 | NAMESPACES => 1, |
38 | PREFIX_MAP => { $Namespace => $prefix }, |
39 | DATA_MODE => $newlines, |
40 | DATA_INDENT => $indent, |
41 | ); |
42 | |
43 | # Start the document |
44 | $xml->xmlDecl('UTF-8'); |
45 | |
46 | # $xml->comment(header_comment('', '')) |
47 | # unless $no_comments; |
48 | |
49 | xml_obj($xml, $schema, |
8128778c |
50 | { tag => "schema", methods => [qw/name extra/], end_tag => 0 }); |
b9d98887 |
51 | |
52 | # |
53 | # Table |
54 | # |
55 | $xml->startTag( [ $Namespace => "tables" ] ); |
56 | for my $table ( $schema->get_tables ) { |
57 | # debug "Table:",$table->name; |
58 | xml_obj($xml, $table, |
59 | { tag => "table", |
8128778c |
60 | methods => [qw/name extra/], |
b9d98887 |
61 | end_tag => 0 } |
62 | ); |
63 | |
64 | # |
65 | # Fields |
66 | # |
67 | xml_obj_children( $xml, $table, |
68 | { tag => 'field', |
69 | methods =>[qw/ |
70 | name data_type size is_nullable default_value is_auto_increment |
8128778c |
71 | is_primary_key is_foreign_key extra comments |
b9d98887 |
72 | /], } |
b9d98887 |
73 | ); |
74 | |
75 | # |
76 | # Indices |
77 | # |
78 | xml_obj_children( $xml, $table, |
79 | { tag => 'index', |
80 | collection_tag => "indices", |
8128778c |
81 | methods => [qw/name type fields extra/], } |
b9d98887 |
82 | ); |
83 | |
84 | # |
85 | # Constraints |
86 | # |
87 | xml_obj_children( $xml, $table, |
88 | { tag => 'constraint', |
89 | # methods => [qw/ |
90 | # name type fields reference_table reference_fields |
91 | # on_delete on_update match_type expression options deferrable |
92 | # extra |
93 | # /], |
8128778c |
94 | methods => [qw/name type expression options deferrable extra/], } |
b9d98887 |
95 | ); |
96 | |
97 | # |
98 | # Comments |
99 | # |
100 | xml_obj_children( $xml, $table, |
101 | { tag => 'comment', |
8128778c |
102 | methods => [qw/ comments /], } |
b9d98887 |
103 | ); |
104 | |
105 | $xml->endTag( [ $Namespace => 'table' ] ); |
106 | } |
107 | $xml->endTag( [ $Namespace => 'tables' ] ); |
108 | |
109 | # |
110 | # Views |
111 | # |
112 | xml_obj_children( $xml, $schema, |
113 | { tag => 'view', |
8128778c |
114 | methods => [qw/name sql fields extra/], } |
b9d98887 |
115 | ); |
116 | |
117 | # |
118 | # Tiggers |
119 | # |
120 | xml_obj_children( $xml, $schema, |
121 | { tag => 'trigger', |
8128778c |
122 | methods => [qw/name database_events action on_table perform_action_when fields extra/], } |
b9d98887 |
123 | ); |
124 | |
125 | # |
126 | # Procedures |
127 | # |
128 | xml_obj_children( $xml, $schema, |
129 | { tag => 'procedure', |
8128778c |
130 | methods => [qw/name sql parameters owner comments extra/], } |
b9d98887 |
131 | ); |
132 | |
133 | $xml->endTag([ $Namespace => 'schema' ]); |
134 | $xml->end; |
135 | |
136 | return $io; |
137 | } |
138 | |
139 | |
140 | # |
141 | # Takes and XML::Write object, Schema::* parent object, the tag name, |
142 | # the collection name and a list of methods (of the children) to write as XML. |
143 | # The collection name defaults to the name with an s on the end and is used to |
144 | # work out the method to get the children with. eg a name of 'foo' gives a |
145 | # collection of foos and gets the members using ->get_foos. |
146 | # |
147 | #sub xml_obj_children { |
148 | method xml_obj_children($xml: $parent, HashRef $args?) { |
149 | # my ($xml,$parent) = (shift,shift); |
150 | |
151 | # my %args = @_; |
152 | my ($name,$collection_name,$methods) |
153 | = @{$args}{qw/tag collection_tag methods/}; |
154 | $collection_name ||= "${name}s"; |
155 | |
156 | my $meth; |
157 | if ( $collection_name eq 'comments' ) { |
158 | $meth = 'comments'; |
159 | } else { |
160 | $meth = "get_$collection_name"; |
161 | } |
162 | |
163 | my @kids = $parent->$meth; |
164 | #@kids || return; |
165 | $xml->startTag( [ $Namespace => $collection_name ] ); |
166 | |
167 | for my $obj ( @kids ) { |
168 | if ( $collection_name eq 'comments' ){ |
169 | $xml->dataElement( [ $Namespace => 'comment' ], $obj ); |
170 | } else { |
171 | xml_obj($xml, $obj, |
172 | { tag => "$name", |
173 | end_tag => 1, |
174 | methods => $methods, } |
175 | ); |
176 | } |
177 | } |
178 | $xml->endTag( [ $Namespace => $collection_name ] ); |
179 | } |
180 | |
181 | # |
182 | # Takes an XML::Writer, Schema::* object and list of method names |
183 | # and writes the obect out as XML. All methods values are written as attributes |
184 | # except for the methods listed in @MAP_AS_ELEMENTS which get written as child |
185 | # data elements. |
186 | # |
187 | # The attributes/tags are written in the same order as the method names are |
188 | # passed. |
189 | # |
190 | # TODO |
191 | # - Should the Namespace be passed in instead of global? Pass in the same |
192 | # as Writer ie [ NS => TAGNAME ] |
193 | # |
194 | my $elements_re = join("|", @MAP_AS_ELEMENTS); |
195 | $elements_re = qr/^($elements_re)$/; |
5eff9806 |
196 | |
b9d98887 |
197 | method xml_obj($xml: $obj, HashRef $args?) { |
b9d98887 |
198 | my $tag = $args->{'tag'} || ''; |
199 | my $end_tag = $args->{'end_tag'} || ''; |
200 | my @meths = @{ $args->{'methods'} }; |
201 | my $empty_tag = 0; |
202 | |
203 | # Use array to ensure consistant (ie not hash) ordering of attribs |
204 | # The order comes from the meths list passed in. |
205 | my @tags; |
206 | my @attr; |
207 | foreach ( grep { defined $obj->$_ } @meths ) { |
208 | my $what = m/$elements_re/ ? \@tags : \@attr; |
209 | my $val = $_ eq 'extra' |
210 | ? { $obj->$_ } |
211 | : $obj->$_; |
212 | $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val; |
213 | push @$what, $_ => $val; |
214 | }; |
215 | my $child_tags = @tags; |
216 | $end_tag && !$child_tags |
217 | ? $xml->emptyTag( [ $Namespace => $tag ], @attr ) |
218 | : $xml->startTag( [ $Namespace => $tag ], @attr ); |
5eff9806 |
219 | while ( my ($name,$val) = splice @tags,0,2 ) { |
b9d98887 |
220 | if ( ref $val eq 'HASH' ) { |
221 | $xml->emptyTag( [ $Namespace => $name ], |
222 | map { ($_, $val->{$_}) } sort keys %$val ); |
223 | } |
224 | else { |
225 | $xml->dataElement( [ $Namespace => $name ], $val ); |
226 | } |
227 | } |
228 | $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag; |
229 | } |
230 | } |