Mercurial > hg > xslscript
comparison xslscript.pl @ 6:d3340fdeadf6
XSLScript: better file names.
author | Maxim Dounin <mdounin@mdounin.ru> |
---|---|
date | Fri, 21 Feb 2014 18:53:17 +0400 |
parents | xsls.pl@2d6764d9980b |
children | 9a283d72ddc3 |
comparison
equal
deleted
inserted
replaced
5:2d6764d9980b | 6:d3340fdeadf6 |
---|---|
1 #!/usr/bin/perl | |
2 | |
3 # (C) Maxim Dounin | |
4 | |
5 # Convert from XSLScript to XSLT. | |
6 # | |
7 # Originally XSLScript was written by Paul Tchistopolskii. It is believed | |
8 # to be mostly identical to XSLT, but uses shorter syntax. Original | |
9 # implementation has major Java dependency, no longer supported and hard | |
10 # to find. | |
11 # | |
12 # This code doesn't pretend to be a full replacement, but rather an attempt | |
13 # to provide functionality needed for nginx documentation. | |
14 | |
15 ############################################################################### | |
16 | |
17 use warnings; | |
18 use strict; | |
19 | |
20 use Parse::RecDescent; | |
21 use Getopt::Long; | |
22 use Data::Dumper qw/Dumper/; | |
23 | |
24 ############################################################################### | |
25 | |
26 GetOptions( | |
27 "trace!" => \$::RD_TRACE, | |
28 "hint!" => \$::RD_HINT, | |
29 ) | |
30 or die "oops\n"; | |
31 | |
32 ############################################################################### | |
33 | |
34 my $grammar = <<'EOF'; | |
35 | |
36 # XSLTScript grammar, reconstructed | |
37 | |
38 startrule : item(s) eofile | |
39 { $return = $item[1]; 1 } | |
40 | |
41 item : "<!--" <commit> comment | |
42 | "!!" <commit> exclam_double | |
43 | "!{" <commit> exclam_xpath | |
44 | "!" name <commit> params | |
45 { $return = [ | |
46 "X:call-template", "name", $item{name}, [], | |
47 $item{params} | |
48 ]; 1 } | |
49 | "<%" <commit> instruction "%>" | |
50 { $return = $item{instruction}; 1 } | |
51 | "<" name attrs ">" <commit> item(s?) "</" name ">" | |
52 { $return = [ "tag", $item{name}, $item{attrs}, $item[6] ]; 1 } | |
53 | "<" <commit> name attrs "/" ">" | |
54 { $return = [ "tag", $item{name}, $item{attrs} ]; 1 } | |
55 | "X:variable" <commit> xvariable | |
56 | "X:var" <commit> xvariable | |
57 | "X:template" <commit> xtemplate | |
58 | "X:if" <commit> xif | |
59 | "X:param" <commit> xparam | |
60 | "X:for-each" <commit> xforeach | |
61 | "X:sort" <commit> xsort | |
62 | "X:when" <commit> xwhen | |
63 | "X:attribute" <commit> xattribute | |
64 | "X:output" <commit> xoutput | |
65 | "X:copy-of" <commit> xcopyof | |
66 | instruction <commit> attrs body | |
67 { $return = [ $item{instruction}, $item{attrs}, $item{body} ]; 1 } | |
68 | text | |
69 | <error> | |
70 | |
71 # list of simple instructions | |
72 | |
73 instruction : "X:stylesheet" | |
74 | "X:transform" | |
75 | "X:attribute-set" | |
76 | "X:element" | |
77 | "X:apply-templates" | |
78 | "X:choose" | |
79 | "X:otherwise" | |
80 | "X:value-of" | |
81 | "X:apply-imports" | |
82 | "X:number" | |
83 | "X:include" | |
84 | "X:import" | |
85 | "X:strip-space" | |
86 | "X:preserve-space" | |
87 | "X:copy" | |
88 | "X:text" | |
89 | "X:comment" | |
90 | "X:processing-instruction" | |
91 | "X:decimal-format" | |
92 | "X:namespace-alias" | |
93 | "X:key" | |
94 | "X:fallback" | |
95 | "X:message" | |
96 | |
97 # comments, <!-- ... --> | |
98 # not sure if it's something to be interpreted specially | |
99 # likely an artifact of our dump process | |
100 | |
101 comment : /((?!-->).)*/ms "-->" | |
102 { $return = ""; 1 } | |
103 | |
104 # special chars: ', ", {, }, \ | |
105 # if used in text, they needs to be escaped with backslash | |
106 | |
107 text : quoted | unreserved | "'" | "\"" | "{" | |
108 quoted : "\\" special | |
109 { $return = $item{special}; 1; } | |
110 special : "'" | "\"" | "\\" | "{" | "}" | |
111 unreserved : /[^'"\\{}<\s]+\s*/ | |
112 | |
113 # shortcuts: | |
114 # | |
115 # !! for X:apply-templates | |
116 # !{xpath-expression} for X:value-of select="xpath-expression"; | |
117 # !foo() for X:call-template name="foo" | |
118 | |
119 # !root (path = { !{ substring($DIRNAME, 2) } }) | |
120 # !root (path = "substring-after($path, '/')") | |
121 | |
122 exclam_double : value(?) params(?) attrs ";" | |
123 { $return = [ | |
124 "X:apply-templates", "select", $item[1][0], $item{attrs}, | |
125 $item[2][0] | |
126 ]; 1 } | |
127 | |
128 exclam_xpath : xpath "}" | |
129 { $return = [ | |
130 "X:value-of", "select", $item{xpath}, [] | |
131 ]; 1 } | |
132 xpath : /("[^"]*"|'[^']*'|[^}'"])*/ms | |
133 | |
134 # instruction attributes | |
135 # name="value" | |
136 | |
137 attrs : attr(s?) | |
138 attr : name "=" value | |
139 { $return = $item{name} . "=" . $item{value}; } | |
140 name : /[a-z0-9_:-]+/i | |
141 value : /"[^"]*"/ | |
142 | |
143 # template parameters | |
144 # ( bar="init", baz={markup} ) | |
145 | |
146 params : "(" param(s? /,/) ")" | |
147 { $return = $item[2]; 1 } | |
148 param : name "=" value | |
149 { $return = [ | |
150 "X:with-param", | |
151 "select", $item{value}, | |
152 "name", $item{name}, | |
153 [] | |
154 ]; 1 } | |
155 | name "=" <commit> "{" item(s) "}" | |
156 { $return = [ | |
157 "X:with-param", "name", $item{name}, [], | |
158 $item[5] | |
159 ]; 1 } | |
160 | name | |
161 { $return = [ | |
162 "X:param", "name", $item{name}, [] | |
163 ]; 1 } | |
164 | |
165 # instruction body | |
166 # ";" for empty body, "{ ... }" otherwise | |
167 | |
168 body : ";" | |
169 { $return = ""; } | |
170 | "{" <commit> item(s?) "}" | |
171 { $return = $item[3]; 1 } | |
172 | |
173 # special handling of some instructions | |
174 # X:if attribute is test= | |
175 | |
176 xif : value body "else" <commit> body | |
177 { $return = [ | |
178 "X:choose", [], [ | |
179 [ "X:when", "test", $item[1], [], $item[2] ], | |
180 [ "X:otherwise", [], $item[5] ] | |
181 ] | |
182 ]; 1 } | |
183 | value attrs body | |
184 { $return = [ | |
185 "X:if", "test", $item{value}, $item{attrs}, $item{body}, | |
186 ]; 1 } | |
187 | attrs body | |
188 { $return = [ | |
189 "X:if", $item{attrs}, $item{body}, | |
190 ]; 1 } | |
191 | <error> | |
192 | |
193 # X:template name(params) = "match" { | |
194 # X:template name( bar="init", baz={markup} ) = "match" mode="some" { | |
195 | |
196 xtemplate : name(?) params(?) ( "=" value )(?) attrs body | |
197 { $return = [ | |
198 "X:template", "name", $item[1][0], "match", $item[3][0], | |
199 $item{attrs}, | |
200 [ ($item[2][0] ? @{$item[2][0]} : ()), @{$item{body}} ] | |
201 ]; 1 } | |
202 | |
203 # X:var LINK = "/article/@link"; | |
204 # X:var year = { ... } | |
205 # semicolon is optional | |
206 | |
207 xvariable : name "=" value attrs body | |
208 { $return = [ | |
209 "X:variable", | |
210 "select", $item{value}, | |
211 "name", $item{name}, | |
212 $item{attrs}, $item{body} | |
213 ]; 1 } | |
214 | name "=" attrs body | |
215 { $return = [ | |
216 "X:variable", | |
217 "name", $item{name}, | |
218 $item{attrs}, $item{body} | |
219 ]; 1 } | |
220 | name "=" value | |
221 { $return = [ | |
222 "X:variable", | |
223 "select", $item{value}, | |
224 "name", $item{name}, | |
225 [] | |
226 ]; 1 } | |
227 | name "=" | |
228 { $return = [ | |
229 "X:variable", | |
230 "name", $item{name}, | |
231 [] | |
232 ]; 1 } | |
233 | <error> | |
234 | |
235 # X:param XML = "'../xml'"; | |
236 # X:param YEAR; | |
237 | |
238 xparam : name "=" value attrs body | |
239 { $return = [ | |
240 "X:param", | |
241 "select", $item{value}, | |
242 "name", $item{name}, | |
243 $item{attrs}, $item{body} | |
244 ]; 1 } | |
245 | name attrs body | |
246 { $return = [ | |
247 "X:param", "name", $item{name}, | |
248 $item{attrs}, $item{body} | |
249 ]; 1 } | |
250 | |
251 # X:for-each "section[@id and @name]" { ... } | |
252 # X:for-each "link", X:sort "@id" { | |
253 | |
254 xforeach : value attrs body | |
255 { $return = [ | |
256 "X:for-each", "select", $item{value}, $item{attrs}, $item{body} | |
257 ]; 1 } | |
258 | value attrs "," "X:sort" <commit> value attrs body | |
259 { $return = [ | |
260 "X:for-each", "select", $item[1], $item[2], [ | |
261 [ "X:sort", "select", $item[6], $item[7] ], | |
262 @{$item{body}} | |
263 ] | |
264 ]; 1 } | |
265 | |
266 # X:sort select | |
267 # X:sort "@id" | |
268 | |
269 xsort : value attrs body | |
270 { $return = [ | |
271 "X:sort", "select", $item{value}, $item{attrs}, $item{body} | |
272 ]; 1 } | |
273 | |
274 # X:when "position() = 1" { ... } | |
275 | |
276 xwhen : value attrs body | |
277 { $return = [ | |
278 "X:when", "test", $item{value}, $item{attrs}, $item{body} | |
279 ]; 1 } | |
280 | |
281 # X:attribute "href" { ... } | |
282 | |
283 xattribute : value attrs body | |
284 { $return = [ | |
285 "X:attribute", "name", $item{value}, $item{attrs}, $item{body} | |
286 ]; 1 } | |
287 | |
288 # X:output | |
289 # semicolon is optional | |
290 | |
291 xoutput : attrs body(?) | |
292 { $return = [ | |
293 "X:output", undef, undef, $item{attrs}, $item{body} | |
294 ]; 1 } | |
295 | |
296 # "X:copy-of" | |
297 # semicolon is optional | |
298 | |
299 xcopyof : value attrs body(?) | |
300 { $return = [ | |
301 "X:copy-of", "select", $item{value}, $item{attrs}, $item{body} | |
302 ]; 1 } | |
303 | |
304 # eof | |
305 | |
306 eofile : /^\Z/ | |
307 | |
308 EOF | |
309 | |
310 ############################################################################### | |
311 | |
312 sub format_tree { | |
313 my ($tree, $indent) = @_; | |
314 my $s = ''; | |
315 | |
316 if (!defined $indent) { | |
317 $indent = 0; | |
318 $s .= '<?xml version="1.0" encoding="utf-8"?>' . "\n"; | |
319 } | |
320 | |
321 my $space = " " x $indent; | |
322 | |
323 foreach my $el (@{$tree}) { | |
324 if (!defined $el) { | |
325 warn "Undefined element in output.\n"; | |
326 $s .= $space . "(undef)" . "\n"; | |
327 next; | |
328 } | |
329 | |
330 if (not ref($el) && defined $el) { | |
331 #$s .= $space . $el . "\n"; | |
332 $s .= $el; | |
333 next; | |
334 } | |
335 | |
336 die if ref($el) ne 'ARRAY'; | |
337 | |
338 my $tag = $el->[0]; | |
339 | |
340 if ($tag eq 'tag') { | |
341 my (undef, $name, $attrs, $body) = @{$el}; | |
342 | |
343 $s .= $space . "<" . join(" ", $name, @{$attrs}); | |
344 if ($body) { | |
345 my $t = format_tree($body, $indent + 1); | |
346 if ($t =~ /\n/) { | |
347 $s .= ">\n" . $t | |
348 . $space . "</$name>\n"; | |
349 } else { | |
350 $s .= ">$t</$name>\n"; | |
351 } | |
352 } else { | |
353 $s .= "/>\n"; | |
354 } | |
355 | |
356 next; | |
357 } | |
358 | |
359 if ($tag =~ m/^X:(.*)/) { | |
360 my $name = "xsl:" . $1; | |
361 my (undef, @a) = @{$el}; | |
362 my @attrs; | |
363 | |
364 while (@a) { | |
365 last if ref($a[0]) eq 'ARRAY'; | |
366 my $name = shift @a; | |
367 my $value = shift @a; | |
368 next unless defined $value; | |
369 $value = '"' . $value . '"' | |
370 unless $value =~ /^"/; | |
371 push @attrs, "$name=$value"; | |
372 } | |
373 | |
374 if ($name eq "xsl:stylesheet") { | |
375 push @attrs, 'xmlns:xsl="http://www.w3.org/1999/XSL/Transform"'; | |
376 push @attrs, 'version="1.0"'; | |
377 } | |
378 | |
379 my ($attrs, $body) = @a; | |
380 $attrs = [ @{$attrs}, @attrs ]; | |
381 | |
382 $s .= $space . "<" . join(" ", $name, @{$attrs}); | |
383 | |
384 if ($body && scalar @{$body} > 0) { | |
385 my $t = format_tree($body, $indent + 1); | |
386 if ($t =~ /\n/) { | |
387 $s .= ">\n" . $t | |
388 . $space . "</$name>\n"; | |
389 } else { | |
390 $s .= ">$t</$name>\n"; | |
391 } | |
392 } else { | |
393 $s .= "/>\n"; | |
394 } | |
395 | |
396 next; | |
397 } | |
398 | |
399 $s .= format_tree($el, $indent + 1); | |
400 } | |
401 | |
402 return $s; | |
403 } | |
404 | |
405 ############################################################################### | |
406 | |
407 my $parser = Parse::RecDescent->new($grammar) | |
408 or die "Failed to create parser.\n"; | |
409 | |
410 my $lines; | |
411 | |
412 { | |
413 local $/; | |
414 $lines = <>; | |
415 } | |
416 | |
417 my $tree = $parser->startrule($lines) | |
418 or die "Failed to parse $ARGV.\n"; | |
419 | |
420 #print Dumper($tree); | |
421 print format_tree($tree); | |
422 | |
423 ############################################################################### |