Commit | Line | Data |
ecc14773 |
1 | use warnings; |
2 | use strict; |
87615710 |
3 | use Test::More; |
ecc14773 |
4 | use Test::Exception; |
5 | use Test::Differences; |
6 | use FindBin qw/$Bin/; |
7 | |
8 | use SQL::Translator; |
454486e0 |
9 | |
ecc14773 |
10 | ### Set $ENV{SQLTTEST_RT_DEBUG} = 1 for more output |
11 | |
12 | # What tests to run - parser/producer name, and optional args |
13 | my $plan = [ |
14 | # { |
15 | # engine => 'XML', |
16 | # req => 'XML::LibXML', |
17 | # }, |
18 | { |
19 | engine => 'YAML', |
20 | }, |
d2b1a222 |
21 | { |
22 | engine => 'SQLite', |
23 | producer_args => {}, |
24 | parser_args => {}, |
25 | }, |
26 | { |
27 | engine => 'MySQL', |
28 | producer_args => {}, |
29 | parser_args => {}, |
30 | }, |
e4b196db |
31 | { |
32 | engine => 'MySQL', |
33 | name => 'MySQL 5.0', |
34 | producer_args => { mysql_version => 5 }, |
35 | parser_args => { mysql_parser_version => 5 }, |
36 | }, |
37 | { |
38 | engine => 'MySQL', |
39 | name => 'MySQL 5.1', |
40 | producer_args => { mysql_version => '5.1' }, |
41 | parser_args => { mysql_parser_version => '5.1' }, |
42 | }, |
454486e0 |
43 | { |
44 | engine => 'PostgreSQL', |
45 | producer_args => {}, |
46 | parser_args => {}, |
47 | }, |
ecc14773 |
48 | # { |
49 | # engine => 'SQLServer', |
50 | # producer_args => {}, |
51 | # parser_args => {}, |
52 | # }, |
53 | |
54 | # { |
55 | # engine => 'Oracle', |
56 | # producer_args => {}, |
57 | # parser_args => {}, |
58 | # todo => 'Needs volunteers', |
59 | # }, |
60 | # { |
61 | # engine => 'Sybase', |
62 | # producer_args => {}, |
63 | # parser_args => {}, |
64 | # todo => 'Needs volunteers', |
65 | # }, |
66 | # { |
67 | # engine => 'DB2', |
68 | # producer_args => {}, |
69 | # parser_args => {}, |
70 | # todo => 'Needs volunteers', |
71 | # }, |
72 | |
73 | # There is no Access producer |
74 | # { |
75 | # engine => 'Access', |
76 | # producer_args => {}, |
77 | # parser_args => {}, |
78 | # }, |
79 | ]; |
80 | |
81 | |
82 | # This data file has the right mix of table/view/procedure/trigger |
83 | # definitions, and lists enough quirks to trip up most combos |
84 | my $base_file = "$Bin/data/roundtrip_autogen.yaml"; |
85 | open (my $base_fh, '<', $base_file) or die "$base_file: $!"; |
86 | |
87 | my $base_t = SQL::Translator->new; |
454486e0 |
88 | $base_t->$_ (1) for qw/add_drop_table no_comments/; |
ecc14773 |
89 | |
454486e0 |
90 | my $base_schema = $base_t->translate( |
ecc14773 |
91 | parser => 'YAML', |
92 | data => do { local $/; <$base_fh>; }, |
93 | ) or die $base_t->error; |
94 | |
95 | #assume there is at least one table |
96 | my $string_re = { |
97 | XML => qr/<tables>\s*<table/, |
98 | YAML => qr/\A---\n.+tables\:/s, |
99 | SQL => qr/^\s*CREATE TABLE/m, |
100 | }; |
101 | |
102 | for my $args (@$plan) { |
103 | SKIP: { |
104 | $args->{name} ||= $args->{engine}; |
105 | |
106 | my @req = ref $args->{req} ? @{$args->{req}} : $args->{req}||(); |
454486e0 |
107 | my @missing; |
ecc14773 |
108 | for (@req) { |
109 | eval "require $_"; |
110 | push @missing, $_ if ($@); |
111 | } |
112 | if (@missing) { |
113 | skip sprintf ('Need %s for %s roundtrip test', |
114 | join (', ', @missing), |
115 | $args->{name}, |
116 | ); |
117 | } |
118 | |
119 | TODO: { |
120 | local $TODO = $args->{todo} if $args->{todo}; |
121 | |
122 | lives_ok ( |
ecc14773 |
123 | sub { check_roundtrip ($args, $base_t, $base_schema) }, |
ecc14773 |
124 | "Round trip for $args->{name} did not throw an exception", |
125 | ); |
126 | } |
127 | } |
128 | } |
87615710 |
129 | done_testing; |
ecc14773 |
130 | |
ecc14773 |
131 | sub check_roundtrip { |
ecc14773 |
132 | my ($args, $base_t, $base_schema) = @_; |
133 | |
134 | # create some output from the submitted schema |
d2b1a222 |
135 | |
454486e0 |
136 | my $base_out = $base_t->translate( |
ecc14773 |
137 | data => $base_schema, |
138 | producer => $args->{engine}, |
139 | # producer_args => $args->{producer_args}, |
140 | ); |
141 | |
142 | like ( |
143 | $base_out, |
144 | $string_re->{$args->{engine}} || $string_re->{SQL}, |
145 | "Received some meaningful output from the first $args->{name} production", |
146 | ) or do { |
147 | diag ( _gen_diag ($base_t->error) ); |
148 | return; |
149 | }; |
150 | |
151 | # parse the sql back |
d2b1a222 |
152 | my $parser_t = SQL::Translator->new; |
153 | $parser_t->$_(1) for qw/add_drop_table no_comments/; |
ecc14773 |
154 | my $mid_schema = $parser_t->translate ( |
155 | data => $base_out, |
156 | parser => $args->{engine}, |
157 | # parser_args => $args->{parser_args}, |
158 | ); |
454486e0 |
159 | |
ecc14773 |
160 | isa_ok ($mid_schema, 'SQL::Translator::Object::Schema', "First $args->{name} parser pass produced a schema:") |
161 | or do { |
162 | diag (_gen_diag ( $parser_t->error, $base_out ) ); |
163 | return; |
164 | }; |
165 | |
166 | # schemas should be comparable at least as far as table/field numbers go |
167 | is_deeply ( |
168 | _get_table_info ($mid_schema->get_tables), |
169 | _get_table_info ($base_schema->get_tables), |
170 | "Schema tables generally match afer $args->{name} parser trip", |
171 | ) or return; |
172 | |
173 | # and produce sql once again |
174 | |
175 | # Producing a schema with a Translator different from the one the schema was generated |
176 | # from does not work. This is arguably a bug, 61translator_agnostic.t works with that |
177 | # my $producer_t = SQL::Translator->new; |
178 | # $producer_t->$_ (1) for qw/add_drop_table no_comments/; |
179 | |
180 | # my $rt_sql = $producer_t->translate ( |
181 | # data => $mid_schema, |
182 | # producer => $args->{engine}, |
183 | # producer_args => $args->{producer_args}, |
184 | # ); |
185 | |
186 | my $rt_out = $parser_t->translate ( |
187 | data => $mid_schema, |
188 | producer => $args->{engine}, |
189 | # producer_args => $args->{producer_args}, |
190 | ); |
191 | |
192 | like ( |
193 | $rt_out, |
194 | $string_re->{$args->{engine}} || $string_re->{SQL}, |
195 | "Received some meaningful output from the second $args->{name} production", |
196 | ) or do { |
197 | diag ( _gen_diag ( $parser_t->error ) ); |
198 | return; |
199 | }; |
200 | |
201 | # the two sql strings should be identical |
202 | my $msg = "$args->{name} SQL roundtrip successful - SQL statements match"; |
203 | $ENV{SQLTTEST_RT_DEBUG} #stringify below because IO::Scalar does not behave nice |
204 | ? eq_or_diff ("$rt_out", "$base_out", $msg) |
205 | : ok ("$rt_out" eq "$base_out", $msg) |
206 | ; |
207 | } |
208 | |
209 | sub _get_table_info { |
210 | my @tables = @_; |
211 | |
212 | my @info; |
213 | |
454486e0 |
214 | for my $t (@tables) { |
ecc14773 |
215 | push @info, { |
216 | name => $t->name, |
217 | fields => [ |
218 | map { $_->name } ($t->get_fields), |
219 | ], |
220 | }; |
221 | } |
222 | |
223 | return \@info; |
224 | } |
225 | |
226 | # takes an error string and an optional output block |
227 | # returns the string conctenated with a line-numbered block for |
228 | # easier reading |
229 | sub _gen_diag { |
230 | my ($err, $out) = @_; |
231 | |
232 | return 'Unknown error' unless $err; |
233 | |
234 | |
235 | if ($out and $ENV{SQLTTEST_RT_DEBUG}) { |
236 | my @lines; |
237 | for (split /\n/, $out) { |
238 | push @lines, sprintf ('%03d: %s', |
239 | scalar @lines + 1, |
240 | $_, |
241 | ); |
242 | } |
243 | |
244 | return "$err\n\n" . join ("\n", @lines); |
245 | } |
246 | |
247 | return $err; |
248 | } |