Mercurial > hg > xslscript

comparison xsls.pl @ 4:eb959dce273b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
XSLScript: tree construction and printing. In its current form the script is able to process at least article.xsl, and produces a result with a minimal non-significant diff with article.xslt produced with original Java code.
author Maxim Dounin <mdounin@mdounin.ru>
date Fri, 21 Feb 2014 14:26:14 +0400
parents 0fa786e03744
children 2d6764d9980b
comparison
equal deleted inserted replaced
3:0fa786e03744 4:eb959dce273b
39 { $return = $item[1]; 1 } 39 { $return = $item[1]; 1 }
40 40
41 item : "<!--" <commit> comment 41 item : "<!--" <commit> comment
42 | "!!" <commit> exclam_double 42 | "!!" <commit> exclam_double
43 | "!{" <commit> exclam_xpath 43 | "!{" <commit> exclam_xpath
44 | "!" name <commit> exclam_name 44 | "!" name <commit> params
45 { $return = [
46 "X:call-template", "name", $item{name}, [],
47 $item{params}
48 ]; 1 }
45 | "<%" <commit> instruction "%>" 49 | "<%" <commit> instruction "%>"
46 { $return = $item{instruction}; 1 } 50 { $return = $item{instruction}; 1 }
47 | "<" name attrs ">" <commit> item(s?) "</" name ">" 51 | "<" name attrs ">" <commit> item(s?) "</" name ">"
48 { $return = ::format_tag($item{name}, $item{attrs}, $item[6]); 1 } 52 { $return = [ "tag", $item{name}, $item{attrs}, $item[6] ]; 1 }
49 | "<" <commit> name attrs "/" ">" 53 | "<" <commit> name attrs "/" ">"
50 { $return = ::format_tag($item{name}, $item{attrs}); 1 } 54 { $return = [ "tag", $item{name}, $item{attrs} ]; 1 }
51 | "X:variable" <commit> xvariable 55 | "X:variable" <commit> xvariable
52 | "X:var" <commit> xvariable 56 | "X:var" <commit> xvariable
53 | "X:template" <commit> xtemplate 57 | "X:template" <commit> xtemplate
54 | "X:if" <commit> xif 58 | "X:if" <commit> xif
55 | "X:param" <commit> xparam 59 | "X:param" <commit> xparam
58 | "X:when" <commit> xwhen 62 | "X:when" <commit> xwhen
59 | "X:attribute" <commit> xattribute 63 | "X:attribute" <commit> xattribute
60 | "X:output" <commit> xoutput 64 | "X:output" <commit> xoutput
61 | "X:copy-of" <commit> xcopyof 65 | "X:copy-of" <commit> xcopyof
62 | instruction <commit> attrs body 66 | instruction <commit> attrs body
63 { $return = ::format_instruction( 67 { $return = [ $item{instruction}, $item{attrs}, $item{body} ]; 1 }
64 $item{instruction}, $item{attrs}, $item{body});
65 1 }
66 | text 68 | text
67 | <error> 69 | <error>
68 70
69 # list of simple instructions 71 # list of simple instructions
70 72
116 118
117 # !root (path = { !{ substring($DIRNAME, 2) } }) 119 # !root (path = { !{ substring($DIRNAME, 2) } })
118 # !root (path = "substring-after($path, '/')") 120 # !root (path = "substring-after($path, '/')")
119 121
120 exclam_double : value(?) params(?) attrs ";" 122 exclam_double : value(?) params(?) attrs ";"
121 { $return = ::format_apply($item{value}, $item{params}, $item{attrs}); 1 } 123 { $return = [
122 124 "X:apply-templates", "select", $item{value}, $item{attrs},
123 exclam_xpath : xpath(s?) "}" 125 $item{params}
124 xpath : /[^}'"]+/ 126 ]; 1 }
125 | /"[^"]*"/ 127
126 | /'[^']*'/ 128 exclam_xpath : xpath "}"
127 129 { $return = [
128 exclam_name : params 130 "X:value-of", "select", $item{xpath}, []
131 ]; 1 }
132 xpath : /("[^"]*"|'[^']*'|[^}'"])*/ms
129 133
130 # instruction attributes 134 # instruction attributes
131 # name="value" 135 # name="value"
132 136
133 attrs : attr(s?) 137 attrs : attr(s?)
134 attr : name "=" value 138 attr : name "=" value
139 { $return = $item{name} . "=" . $item{value}; }
135 name : /[a-z0-9_:-]+/i 140 name : /[a-z0-9_:-]+/i
136 value : /"[^"]*"/ 141 value : /"[^"]*"/
137 142
138 # template parameters 143 # template parameters
139 # ( bar="init", baz={markup} ) 144 # ( bar="init", baz={markup} )
140 145
141 params : "(" param(s /,/) ")" 146 params : "(" param(s /,/) ")"
142 { $return = $item[2]; 1 } 147 { $return = $item[2]; 1 }
143 param : name "=" value 148 param : name "=" value
149 { $return = [
150 "X:with-param",
151 "select", $item{value},
152 "name", $item{name},
153 []
154 ]; 1 }
144 | name "=" <commit> "{" item(s) "}" 155 | name "=" <commit> "{" item(s) "}"
156 { $return = [
157 "X:with-param", "name", $item{name}, [],
158 $item{item}
159 ]; 1 }
145 | name 160 | name
161 { $return = [
162 "X:with-param", "name", $item{name}, []
163 ]; 1 }
146 164
147 # instruction body 165 # instruction body
148 # ";" for empty body, "{ ... }" otherwise 166 # ";" for empty body, "{ ... }" otherwise
149 167
150 body : ";" 168 body : ";"
151 { $return = ""; } 169 { $return = ""; }
152 | "{" <commit> item(s?) "}" 170 | "{" <commit> item(s?) "}"
153 { $return = join("\n", @{$item[3]}); 1 } 171 { $return = $item[3]; 1 }
154 172
155 # special handling of some instructions 173 # special handling of some instructions
156 # X:if attribute is test= 174 # X:if attribute is test=
157 175
158 xif : value(?) attrs body "else" <commit> body 176 xif : value body "else" <commit> body
159 | value(?) attrs 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[1], $item{attrs}, $item{body},
186 ]; 1 }
187 | attrs body
188 { $return = [
189 "X:if", $item{attrs}, $item{body},
190 ]; 1 }
160 | <error> 191 | <error>
161 192
162 # X:template name(params) = "match" { 193 # X:template name(params) = "match" {
163 # X:template name( bar="init", baz={markup} ) = "match" mode="some" { 194 # X:template name( bar="init", baz={markup} ) = "match" mode="some" {
164 195
165 xtemplate : name(?) params(?) ( "=" value )(?) 196 xtemplate : name(?) params(?) ( "=" value )(?) attrs body
166 attrs body 197 { $return = [
198 "X:template", "name", $item[1][0], "match", $item[3][0],
199 $item{attrs},
200 [ ($item{params} ? @{$item{params}} : ()), @{$item{body}} ]
201 ]; 1 }
167 202
168 # X:var LINK = "/article/@link"; 203 # X:var LINK = "/article/@link";
169 # X:var year = { ... } 204 # X:var year = { ... }
170 # semicolon is optional 205 # semicolon is optional
171 206
172 xvariable : name "=" value(?) attrs body 207 xvariable : name "=" value attrs body
173 | name "=" value(?) 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 }
174 | <error> 233 | <error>
175 234
176 # X:param XML = "'../xml'"; 235 # X:param XML = "'../xml'";
177 # X:param YEAR; 236 # X:param YEAR;
178 237
179 xparam : name ("=" value)(?) attrs body 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 }
180 250
181 # X:for-each "section[@id and @name]" { ... } 251 # X:for-each "section[@id and @name]" { ... }
182 # X:for-each "link", X:sort "@id" { 252 # X:for-each "link", X:sort "@id" {
183 253
184 xforeach : value attrs body 254 xforeach : value attrs body
185 { $return = ::format_instruction_value( 255 { $return = [
186 "X:for-each", "select", $item{value}, $item{attrs}, $item{body}); 256 "X:for-each", "select", $item{value}, $item{attrs}, $item{body}
187 1 } 257 ]; 1 }
188 | value attrs "," "X:sort" <commit> value attrs body 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 }
189 265
190 # X:sort select 266 # X:sort select
191 # X:sort "@id" 267 # X:sort "@id"
192 268
193 xsort : value attrs body 269 xsort : value attrs body
194 { $return = ::format_instruction_value( 270 { $return = [
195 "X:sort", "select", $item{value}, $item{attrs}, $item{body}); 271 "X:sort", "select", $item{value}, $item{attrs}, $item{body}
196 1 } 272 ]; 1 }
197 273
198 # X:when "position() = 1" { ... } 274 # X:when "position() = 1" { ... }
199 275
200 xwhen : value attrs body 276 xwhen : value attrs body
201 { $return = ::format_instruction_value( 277 { $return = [
202 "X:when", "test", $item{value}, $item{attrs}, $item{body}); 278 "X:when", "test", $item{value}, $item{attrs}, $item{body}
203 1 } 279 ]; 1 }
204 280
205 # X:attribute "href" { ... } 281 # X:attribute "href" { ... }
206 282
207 xattribute : value attrs body 283 xattribute : value attrs body
208 { $return = ::format_instruction_value( 284 { $return = [
209 "X:attribute", "name", $item{value}, $item{attrs}, $item{body}); 285 "X:attribute", "name", $item{value}, $item{attrs}, $item{body}
210 1 } 286 ]; 1 }
211 287
212 # X:output 288 # X:output
213 # semicolon is optional 289 # semicolon is optional
214 290
215 xoutput : attrs body(?) 291 xoutput : attrs body(?)
216 { $return = ::format_instruction( 292 { $return = [
217 "X:output", $item{attrs}, $item{body}); 293 "X:output", undef, undef, $item{attrs}, $item{body}
218 1 } 294 ]; 1 }
219 295
220 # "X:copy-of" 296 # "X:copy-of"
221 # semicolon is optional 297 # semicolon is optional
222 298
223 xcopyof : value attrs body(?) 299 xcopyof : value attrs body(?)
224 { $return = ::format_instruction_value( 300 { $return = [
225 "X:copy-of", "select", $item{value}, $item{attrs}, $item{body}); 301 "X:copy-of", "select", $item{value}, $item{attrs}, $item{body}
226 1 } 302 ]; 1 }
227 303
228 # eof 304 # eof
229 305
230 eofile : /^\Z/ 306 eofile : /^\Z/
231 307
232 EOF 308 EOF
233 309
234 ############################################################################### 310 ###############################################################################
235 311
236 # helper formatting functions, used by grammar 312 sub format_tree {
237 313 my ($tree, $indent) = @_;
238 sub format_instruction { 314 my $s = '';
239 my ($instruction, $attrs, $body) = @_; 315
240 my $s = "<"; 316 $indent ||= 0;
241 317 my $space = " " x $indent;
242 $instruction =~ s/^X:/xsl:/; 318
243 319 foreach my $el (@{$tree}) {
244 $s .= join(" ", $instruction, @{$attrs}); 320 if (!defined $el) {
245 321 $s .= $space . "(undef)" . "\n";
246 if ($body) { 322 next;
247 $s .= ">\n" . $body . "\n</" . $instruction . ">\n"; 323 }
248 } else { 324
249 $s .= "/>\n"; 325 if (not ref($el) && defined $el) {
326 $s .= $space . $el . "\n";
327 next;
328 }
329
330 die if ref($el) ne 'ARRAY';
331
332 my $tag = $el->[0];
333
334 if ($tag eq 'tag') {
335 my (undef, $name, $attrs, $body) = @{$el};
336
337 $s .= $space . "<" . join(" ", $name, @{$attrs});
338 if ($body) {
339 $s .= ">\n";
340 $s .= format_tree($body, $indent + 1);
341 $s .= $space . "</$name>\n";
342 } else {
343 $s .= "/>\n";
344 }
345
346 next;
347 }
348
349 if ($tag =~ m/^X:(.*)/) {
350 my $name = "xsl:" . $1;
351 my (undef, @a) = @{$el};
352 my @attrs;
353
354 while (@a) {
355 last if ref($a[0]) eq 'ARRAY';
356 my $name = shift @a;
357 my $value = shift @a;
358 next unless defined $value;
359 $value = '"' . $value . '"'
360 unless $value =~ /^"/;
361 push @attrs, "$name=$value";
362 }
363
364 if ($name eq "xsl:stylesheet") {
365 $s .= '<?xml version="1.0" encoding="utf-8"?>' . "\n";
366 push @attrs, 'xmlns:xsl="http://www.w3.org/1999/XSL/Transform"';
367 push @attrs, 'version="1.0"';
368 }
369
370 my ($attrs, $body) = @a;
371 $attrs = [ @{$attrs}, @attrs ];
372
373 $s .= $space . "<" . join(" ", $name, @{$attrs});
374
375 if ($body) {
376 $s .= ">\n";
377 $s .= format_tree($body, $indent + 1);
378 $s .= $space . "</$name>\n";
379 } else {
380 $s .= "/>\n\n";
381 }
382
383 next;
384 }
385
386 $s .= format_tree($el, $indent + 1);
250 } 387 }
251 388
252 return $s; 389 return $s;
253 }
254
255 sub format_instruction_value {
256 my ($instruction, $name, $value, $attrs, $body) = @_;
257 my $s = "<";
258
259 if ($value) {
260 push(@{$attrs}, "$name=$value");
261 }
262
263 return format_instruction($instruction, $attrs, $body);
264 }
265
266 sub format_tag {
267 my ($tag, $attrs, $body) = @_;
268 my $s = "\n<";
269
270 $s .= join(" ", $tag, @{$attrs});
271
272 $body = join("\n", @{$body});
273
274 if ($body) {
275 $s .= ">" . $body . "\n</" . $tag . ">\n";
276 } else {
277 $s .= "/>\n";
278 }
279
280 return $s;
281 }
282
283 sub format_apply {
284 my ($select, $params, $attrs) = @_;
285 my $s = "\n<";
286 my $tag = "xsl:apply-templates";
287
288 if ($select) {
289 unshift "select=$select", @{$attrs};
290 }
291
292 $s .= join(" ", $tag, @{$attrs});
293
294 if ($params) {
295 $params = join("\n", @{$params});
296 $s .= ">\n" . $params . "\n</" . $tag . ">\n";
297 } else {
298 $s .= "/>\n";
299 }
300 } 390 }
301 391
302 ############################################################################### 392 ###############################################################################
303 393
304 my $parser = Parse::RecDescent->new($grammar) 394 my $parser = Parse::RecDescent->new($grammar)
315 or die "Failed to parse $ARGV.\n"; 405 or die "Failed to parse $ARGV.\n";
316 406
317 #print Dumper($tree); 407 #print Dumper($tree);
318 #print join("\n", @{$tree}); 408 #print join("\n", @{$tree});
319 409
320 ############################################################################### 410 print format_tree($tree);
321 ############################################################################### 411
412 ###############################################################################