Mercurial > hg > xslscript

comparison xslscript.pl @ 6:d3340fdeadf6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 ###############################################################################