/[suikacvs]/markup/tool/mkdtds.pl
Suika

Contents of /markup/tool/mkdtds.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations) (download)
Sun Jun 20 04:54:27 2004 UTC (20 years, 5 months ago) by wakaba
Branch: MAIN
Changes since 1.3: +112 -27 lines
File MIME type: text/plain
xsi support

1 #!/usr/bin/perl
2 use strict;
3 our $SCRIPT_NAME = 'mkdtds';
4 our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
5 {require Message::Markup::SuikaWikiConfig20::Parser;
6
7 my $parser = new Message::Markup::SuikaWikiConfig20::Parser;
8 local $/ = undef;
9 my $src = $parser->parse_text (scalar <>);
10 my $Info = {};
11
12 for my $src ($src->get_attribute ('ModuleSet')
13 || $src->get_attribute ('DocumentType')) {
14 for (qw/Description/) {
15 $Info->{$_} = $src->get_attribute_value ($_);
16 }
17 for (qw/Name ID Copyright BaseURI Version/) {
18 $Info->{$_} = normalize_wsp ($src->get_attribute_value ($_));
19 }
20 $Info->{realname} = $Info->{Name};
21 $Info->{Name} .= ' ' . $Info->{Version} if length $Info->{Version};
22 $Info->{ns} = $src->get_attribute ('Namespace');
23 }
24
25 for (@{$src->child_nodes}) {
26 if ($_->local_name eq 'Attribute') {
27 attrib_module ($_, $Info);
28 } elsif ($_->local_name eq 'Datatype') {
29 datatype_module ($_, $Info);
30 } elsif ($_->local_name eq 'Notation') {
31 notation_module ($_, $Info);
32 } elsif ($_->local_name eq 'Module') {
33 submodule ($_, $Info);
34 } elsif ($_->local_name eq 'Model') {
35 model_module ($_, $Info);
36 $Info->{has_model} = 1;
37 } elsif ($_->local_name eq 'Driver') {
38 dtd_driver ($_, $Info);
39 }
40 }
41
42 if (ref $src->get_attribute ('ModuleSet')) {
43 qname_module ($src->get_attribute ('ModuleSet'), $Info);
44 }
45 exit}
46
47 sub normalize_wsp ($;%) {
48 my $s = shift;
49 $s =~ s/\s+/ /g;
50 $s =~ s/^ +//;
51 $s =~ s/ +$//;
52 $s;
53 }
54 sub make_paragraphs ($;%) {
55 my ($para, %opt) = @_;
56 join "\n\n", map {
57 my $s = $_;
58 $s =~ s/\n+$//g;
59 $s =~ s/\n/\n$opt{indent}/g;
60 $opt{indent}.$s;
61 } grep {length} @$para;
62 }
63
64 sub dot_padding ($%) {
65 my ($s, %opt) = @_;
66 if ($opt{length} - length $s > 0) {
67 return $s . ( ($opt{dot} or q(.)) x ($opt{length} - length $s) );
68 } else {
69 return $s;
70 }
71 }
72
73 sub submodule_id_of ($$;%) {
74 my ($src, $Info, %opt) = @_;
75 my $id = $src->get_attribute_value ('ID') || $opt{default};
76 unless ($id) {
77 die "$0: Submodule identifier not specified";
78 }
79 $id;
80 }
81 sub xml_datatype_of ($$;%) {
82 my ($src, $Info, %opt) = @_;
83 my $type = $src->get_attribute_value ('XMLType') || $opt{default};
84 $type =~ s/\s+//g;
85 $type;
86 }
87 sub system_id_of ($$;%) {
88 my ($src, $Info, %opt) = @_;
89 my $sysid = $src->get_attribute_value ('SYSTEM');
90 if ($sysid =~ /<([^>]+)>/) {
91 return $1;
92 } else {
93 return $opt{base}.($sysid || $opt{default});
94 }
95 }
96 sub external_id_of ($$;%) {
97 my ($src, $Info, %opt) = @_;
98 my $sysid = system_id_of ($src, $Info, %opt);
99 my $pubid = $src->get_attribute_value ('PUBLIC');
100 if ($pubid) {
101 if ($sysid) {
102 return qq(PUBLIC "$pubid"\n\t "$sysid");
103 } else {
104 return qq(PUBLIC "$pubid");
105 }
106 } else {
107 return qq(SYSTEM "$sysid");
108 }
109 }
110 sub name_of ($$;%) {
111 my ($src, $Info, %opt) = @_;
112 unless (ref $src) {require Carp; Carp::croak ('$src undefined')}
113 my $name = $src->get_attribute_value ($opt{key} || 'Name');
114 if ($name =~ /^:(.+)/) { ## Global namespace
115 return $1;
116 } elsif ($name =~ /([^:]+):(.+)/) { ## Named space
117 return $1.($opt{delim}||'.').$2;
118 } else { ## Default namespace
119 return $Info->{ID}.($opt{delim}||'.').$name;
120 }
121 }
122 sub local_name_of ($$;%) {
123 my ($src, $Info, %opt) = @_;
124 my $name = $src->get_attribute_value ($opt{key} || 'Name');
125 if ($name =~ /^:(.+)/) { ## Global namespace
126 return $1;
127 } elsif ($name =~ /[^:]+:(.+)/) { ## Named space
128 return $1;
129 } else { ## Default namespace
130 return $name;
131 }
132 }
133 sub set_name_of ($$;%) {
134 my ($src, $Info, %opt) = @_;
135 my $name = $src->get_attribute_value ($opt{key} || 'Name');
136 if ($name =~ /^:.+/) { ## Global namespace
137 return 'XHTML';
138 } elsif ($name =~ /([^:]+):.+/) { ## Named space
139 return $1;
140 } else { ## Default namespace
141 return $Info->{ID};
142 }
143 }
144 sub class_name_of ($$;%) {
145 my ($src, $Info, %opt) = @_;
146 my $name = name_of ($src, $Info, %opt);
147 unless ($name =~ /\.(class|mix|content|datatype)$/) {
148 $name .= '.class';
149 }
150 $name;
151 }
152 sub convert_content_model ($$;%) {
153 my ($src, $Info, %opt) = @_;
154 my $model = $src->get_attribute_value ($opt{key} || 'Content') || $opt{default};
155 $model =~ s/\s//g;
156 my $nonsymbol = qr/[^%#?,\$;()+*|:]/;
157 $model =~ s/(?<![%#.])((?:\$|\b)$nonsymbol+(?::$nonsymbol+)?|\$?:$nonsymbol+|"[^"]+")/get_model_token ($1, $Info)/ge;
158 $model;
159 }
160 sub sparalit ($) {
161 my $s = paralit (shift);
162 $s =~ s/&/&#x26;/g;
163 $s =~ s/%/&#x25;/g;
164 $s;
165 }
166 sub paralit ($) {
167 my $s = shift;
168 if ($s =~ /"/) {
169 if ($s =~ /'/) {
170 $s =~ s/'/&#x27;/g;
171 return qq("$s");
172 } else {
173 return qq('$s');
174 }
175 } else {
176 return qq("$s");
177 }
178 }
179 sub description ($$;%) {
180 my ($src, $Info, %opt) = @_;
181 my $desc = $src->get_attribute_value ('Description');
182 $desc =~ s/\n/\n /g;
183 unless ($desc) {
184 $desc = {
185 load_module => {
186 AttributeModule => q/Common Attributes Module/,
187 DatatypeModule => q/Datatypes Module/,
188 NotationModule => q/Notation Module/,
189 QNameModule => q/QName Module/,
190 },
191 }->{$opt{context}}->{$opt{id} || $src->get_attribute_value ($opt{id_key}||'ID')};
192 }
193 $desc = qq(<!-- $desc -->\n) if $desc;
194 $desc;
195 }
196 sub xml_condition_section ($$;%) {
197 my ($condition, $content, %opt) = @_;
198 qq(<![%$condition;[\n)
199 . $content
200 . qq(<!-- end of $condition -->]]>\n);
201 }
202 sub xml_parameter_ENTITY ($%) {
203 my ($name, %opt) = @_;
204 qq(<!ENTITY % $name @{[paralit $opt{value}]}>\n);
205 }
206
207 sub entity_declaration ($$;%) {
208 my ($src, $Info, %opt) = @_;
209 my $val;
210 if ($src->get_attribute_value ('ID')
211 || $src->get_attribute_value ('SYSTEM')
212 || $src->get_attribute_value ('PUBLIC')) {
213 $val = "\n\t".external_id_of ($src, $Info, default => $src->get_attribute_value ('ID'));
214 } elsif (ref $src->get_attribute ('Declaration')) {
215 $val = "\n\t".sparalit submodule_declarations ($src->get_attribute ('Declaration'), $Info);
216 } else {
217 $val = paralit $src->get_attribute_value ('EntityValue');
218 }
219 my $s = <<EOH;
220 @{[description ($src, $Info)]}<!ENTITY @{[$opt{param}?'% ':'']}@{[$src->get_attribute_value ('Name')]} $val>
221
222 EOH
223 $s;
224 }
225
226 sub dtd_driver ($$) {
227 my ($src, $Info) = @_;
228 my $s = '';
229 my %s;
230 my @module_set;
231 for my $src (@{$src->child_nodes}) {
232 if ($src->local_name eq 'Module') {
233 $s .= dtd_driver_load_module ($src, $Info);
234 } elsif ($src->local_name eq 'DTD') {
235 $s .= dtd_driver_load_dtd ($src, $Info);
236 } elsif ($src->local_name eq 'ModuleSet') {
237 push @module_set, $src;
238 } elsif ($src->local_name =~ /^(?:QName|Attribute|Datatype|Notation)Module/) {
239 $s{$src->local_name} .= dtd_driver_load_module ($src, $Info);
240 } elsif ($src->local_name eq 'IfModuleSet') {
241 $s .= qq(<![%@{[$src->get_attribute_value ('ModuleSet')]}.module;[\n);
242 $s .= submodule_declarations ($src, $Info);
243 $s .= qq(]]>\n);
244 } elsif ($src->local_name eq 'GeneralEntity') {
245 $s .= entity_declaration ($src, $Info, param => 0);
246 } elsif ($src->local_name eq 'ParameterEntity') {
247 $s .= entity_declaration ($src, $Info, param => 1);
248 }
249 }
250
251 $s{ModelModule} = $src->get_attribute_value ('NoModelModule') ? '' :
252 $Info->{has_model} ? <<EOH : '';
253 <!-- Document Model module -->
254 <!ENTITY % $Info->{ID}-model.module "INCLUDE">
255 <![%$Info->{ID}-model.module;[
256 <!ENTITY % $Info->{ID}-model.decl
257 'SYSTEM "$Info->{ID}-model.mod"'>
258 <!ENTITY % $Info->{ID}-model.mod %$Info->{ID}-model.decl;>
259 %$Info->{ID}-model.mod;]]>
260
261 EOH
262
263 $s = dtd_driver_module_sets (\@module_set, $Info)
264 . $s{QNameModule}.$s{DatatypeModule}.$s{NotationModule}.$s{AttributeModule}
265 . $s{ModelModule}
266 .$s;
267 make_dtd ($src, $Info, $src->get_attribute_value ('ID'), $s);
268 }
269
270 sub dtd_driver_module_sets ($$) {
271 my ($srces, $Info) = @_;
272 my @src = map {{src => $_}} @$srces;
273 my $s = qq(<!-- Switchers to include/ignore each vocabulary -->\n);
274 for my $module_set (@src) {
275 $module_set->{ID} = $module_set->{src}->get_attribute_value ('ID') || 'XHTML';
276 $s .= qq(<!ENTITY % $module_set->{ID}.module "@{[$module_set->{src}->get_attribute_value ('Default') > 0 ? 'INCLUDE' : 'IGNORE']}">\n);
277 }
278 $s .= qq(\n<!-- Namespace names -->\n);
279 for my $module_set (@src) {
280 $module_set->{ns} = $module_set->{src}->get_attribute ('Namespace');
281 $s .= qq(<!ENTITY % $module_set->{ID}.xmlns "@{[$module_set->{ns}->get_attribute_value ('Name')]}">\n);
282 }
283 $s .= qq(\n<!-- Base URIs for the relavant DTD modules -->\n);
284 for my $module_set (@src) {
285 $s .= qq(<!ENTITY % $module_set->{ID}.sysid.base "@{[$module_set->{src}->get_attribute_value ('BaseURI')]}">\n);
286 }
287 $s .= qq(\n<!-- Namespace prefix -->\n);
288 $s .= qq(<!ENTITY % NS.prefixed "@{[$Info->{ns}->get_attribute_value ('UsePrefix') > 0 ? 'INCLUDE' : 'IGNORE']}">\n);
289 for my $module_set (@src) {
290 $s .= qq(<!ENTITY % $module_set->{ID}.prefix "@{[$module_set->{ns}->get_attribute_value ('DefaultPrefix')]}">\n);
291 $s .= qq(<!ENTITY % $module_set->{ID}.prefixed "@{[$module_set->{ns}->get_attribute_value ('UsePrefix') > 0 ? 'INCLUDE' : $module_set->{ns}->get_attribute_value ('UsePrefix') < 0 ? 'IGNORE' : '%NS.prefixed;']}">\n);
292 }
293 $s .= qq(\n<!-- a URI reference -->\n<!ENTITY % URI.datatype "CDATA">\n);
294 $s .= qq(\n<!-- Placefolders for foreign namespace declarations -->\n);
295 for my $module_set (@src) {
296 $s .= qq(<!ENTITY % $module_set->{ID}.xmlns.extra.attrib "">\n);
297 }
298 $s .= qq(\n<!-- Namespace declarations -->\n);
299 for my $module_set (@src) {
300 $s .= qq(<![%$module_set->{ID}.module;[
301 <![%$module_set->{ID}.prefixed;[
302 <!ENTITY % $module_set->{ID}.xmlns.decl.attrib
303 "xmlns:%$module_set->{ID}.prefix; %URI.datatype; #FIXED '%$module_set->{ID}.xmlns;'">
304 ]]>
305 <!ENTITY % $module_set->{ID}.xmlns.decl.attrib
306 "xmlns %URI.datatype; #FIXED '%$module_set->{ID}.xmlns;'">
307 ]]>
308 <!ENTITY % $module_set->{ID}.xmlns.decl.attrib "">\n\n);
309 }
310 $s .= <<EOH;
311 <!-- Declare a parameter entity %XSI.prefix as a prefix to use for
312 XML Schema Instance attributes. -->
313 <!ENTITY % XSI.prefix "xsi">
314
315 <!ENTITY % XSI.pfx "%XSI.prefix;:">
316
317 <!ENTITY % XSI.xmlns "http://www.w3.org/2001/XMLSchema-instance">
318
319 <!-- Declare a parameter entity %XSI.xmlns.attrib as support for
320 the schemaLocation attribute. -->
321 <!ENTITY % XSI.xmlns.attrib
322 "xmlns:%XSI.prefix; %URI.datatype; #FIXED '%XSI.xmlns;'">
323 EOH
324 $s .= qq(\n<!ENTITY % NS.decl.attrib
325 ").join ("\n\t", (map {qq(%$_->{ID}.xmlns.decl.attrib;)} @src),
326 map {qq(%$_->{ID}.xmlns.extra.attrib;)} @src)
327 .qq(\n\t%XSI.xmlns.attrib;">\n);
328 $s .= qq(\n);
329 for my $module_set (@src) {
330 $s .= qq(<!ENTITY % $module_set->{ID}.xmlns.attrib "%NS.decl.attrib;">\n);
331 }
332 $s .= qq(\n\n);
333 $s;
334 }
335
336 sub dtd_driver_load_module ($$) {
337 my ($src, $Info) = @_;
338 my $module_name = name_of ($src, $Info, key => 'ID');
339 my $module_hyphen_name = name_of ($src, $Info, key => 'ID', delim => '-');
340 my $module_set_name = set_name_of ($src, $Info, key => 'ID');
341 my $module_id = local_name_of ($src, $Info, key => 'ID');
342
343 my $s .= <<EOH;
344 @{[description ($src, $Info, context => 'load_module', id => $src->local_name)]}<![%$module_set_name.module;[
345 <!ENTITY % $module_name.module "@{[$src->get_attribute_value ('Default') >= 0 ? 'INCLUDE' : 'IGNORE']}">
346 <![%$module_name.module;[
347 @{[submodule_declarations ($src, $Info)]}<!ENTITY % $module_name.decl
348 @{[paralit external_id_of ($src, $Info, default => qq($module_hyphen_name.mod), base => qq(%$module_set_name.sysid.base;))]}>
349 <!ENTITY % $module_name.mod %$module_name.decl;>
350 %$module_name.mod;]]>
351 ]]>
352
353 EOH
354 $s;
355 }
356
357 sub dtd_driver_load_dtd ($$) {
358 my ($src, $Info) = @_;
359 my $module_set_name = $src->get_attribute_value ('ID');
360
361 my $s .= <<EOH;
362 @{[description ($src, $Info)]}<![%$module_set_name.module;[
363 @{[submodule_declarations ($src, $Info)]}<!ENTITY % $module_set_name.dtd.sysid "@{[system_id_of ($src, $Info, default => $src->get_attribute_value ('ID').'.dtd', base => qq(%$module_set_name.sysid.base;))]}">
364 @{[do{
365 my $pubid = $src->get_attribute_value ('PUBLIC');
366 if ($pubid) {
367 qq(<!ENTITY % $module_set_name.dtd.fpi "$pubid">\n<!ENTITY % $module_set_name.dtd.fpi.defined "INCLUDE">\n);
368 } else {
369 qq(<!ENTITY % $module_set_name.dtd.fpi "">\n<!ENTITY % $module_set_name.dtd.fpi.defined "IGNORE">\n);
370 }
371 }]}
372 <![%$module_set_name.dtd.fpi.defined;[
373 <!ENTITY % $module_set_name.dtd.decl
374 'PUBLIC "%$module_set_name.dtd.fpi;"
375 "%$module_set_name.dtd.sysid;"'>
376 ]]>
377 <!ENTITY % $module_set_name.dtd.decl
378 'SYSTEM "%$module_set_name.dtd.sysid;"'>
379 <!ENTITY % $module_set_name.dtd %$module_set_name.dtd.decl;>
380 %$module_set_name.dtd;]]>
381
382 EOH
383 $s;
384 }
385
386 sub model_module ($$) {
387 my ($src, $Info) = @_;
388 my $s = '';
389 for my $src (@{$src->child_nodes}) {
390 if ($src->local_name eq 'Class') {
391 $s .= qq(@{[description ($src, $Info)]}<!ENTITY % @{[class_name_of ($src, $Info)]} @{[paralit convert_content_model ($src, $Info)]}>\n\n);
392 } elsif ($src->local_name eq 'Content') {
393 $s .= element_content_def ($src, $Info);
394 }
395 }
396 make_module ($src, $Info, submodule_id_of ($src, $Info, default => 'model'), $s);
397 }
398
399 sub datatype_module ($$) {
400 my ($src, $Info) = @_;
401 my $s = '';
402 for my $src (@{$src->child_nodes}) {
403 if ($src->local_name eq 'Type') {
404 $s .= qq(@{[get_desc ($src, $Info)]}<!ENTITY % @{[name_of ($src, $Info)]}.datatype "@{[xml_datatype_of ($src, $Info, default => 'CDATA')]}">\n\n);
405 }
406 }
407 make_module ($src, $Info, submodule_id_of ($src, $Info, default => 'datatype'), $s);
408 }
409
410 sub notation_module ($$) {
411 my ($src, $Info) = @_;
412 my $s = '';
413 for my $src (@{$src->child_nodes}) {
414 if ($src->local_name eq 'Notation') {
415 $s .= qq(@{[get_desc ($src, $Info)]}<!NOTATION @{[name_of ($src, $Info)]} @{[external_id_of ($src, $Info)]}>\n\n);
416 }
417 }
418 make_module ($src, $Info, submodule_id_of ($src, $Info, default => 'notation'), $s);
419 }
420
421 sub qname_module ($$) {
422 my ($src, $Info) = @_;
423 my $ID = $Info->{ID};
424 my $ns = $src->get_attribute ('Namespace');
425 my $s = <<EOH;
426 <!ENTITY % NS.prefixed "@{[$ns->get_attribute_value ('UsePrefix')==1?
427 q(INCLUDE):q(IGNORE)]}">
428
429 <!-- Section A: XML Namespace Framework :::::::::::::::::::::::::: -->
430
431 <!-- 1. Declare a %$ID.prefixed; conditional section keyword, used
432 to activate namespace prefixing. -->
433 <!ENTITY % $ID.prefixed "@{[$ns->get_attribute_value ('UsePrefix')==1?
434 q(INCLUDE):
435 $ns->get_attribute_value ('UsePrefix')==-1?
436 q(IGNORE):
437 q(%NS.prefixed;)]}">
438
439 <!ENTITY % $ID.global.attrs.prefixed "@{[$ns->get_attribute_value ('UsePrefix')==1?
440 q(INCLUDE):
441 $ns->get_attribute_value ('UsePrefix')==-1?
442 q(IGNORE):
443 q(%NS.prefixed;)]}">
444
445 <!ENTITY % $ID.xsi.attrs "INCLUDE">
446
447 <!-- 2. Declare a parameter entity %$ID.xmlns; containing
448 the URI reference used to identity the namespace. -->
449 <!ENTITY % $ID.xmlns "@{[$ns->get_attribute_value ('Name')]}">
450
451 <!-- 3. Declare parameter entity %$ID.prefix; containing
452 the default namespace prefix string to use when prefixing
453 is enabled. This may be overridden in the DTD driver or the
454 internal subset of a document instance.
455
456 NOTE: As specified in XML Namespace speficications, the namespace
457 prefix serves as a proxy for the URI reference, and is not in itself
458 significant. -->
459 <!ENTITY % $ID.prefix "@{[$ns->get_attribute_value ('DefaultPrefix')]}">
460
461 <!-- 4. Declare parameter entity %$ID.pfx; containing the
462 colonized prefix (e.g, '%$ID.prefix;:') used when
463 prefixing is active, an empty string when it is not. -->
464 <![%$ID.prefixed;[
465 <!ENTITY % $ID.pfx "%$ID.prefix;:">
466 ]]>
467 <!ENTITY % $ID.pfx "">
468
469 <!-- declare qualified name extensions here ............ -->
470 <!ENTITY % ${ID}-qname-extra.mod "">
471 %${ID}-qname-extra.mod;
472
473 <!-- 5. The parameter entity %$ID.xmlns.extra.attrib; may be
474 redeclared to contain any foreign namespace declaration
475 attributes for namespaces embedded. The default
476 is an empty string. -->
477 <!ENTITY % $ID.xmlns.extra.attrib "">
478
479 <!-- The parameter entity %URI.datatype; should already be defined in
480 Datatype module. -->
481 <!ENTITY % URI.datatype; "CDATA">
482
483 <![%$ID.prefixed;[
484 <!ENTITY % $ID.xmlns.decl.attrib
485 "xmlns:%$ID.prefix; %URI.datatype; #FIXED '%$ID.xmlns;'">
486 ]]>
487 <!ENTITY % $ID.xmlns.decl.attrib
488 "xmlns %URI.datatype; #FIXED '%$ID.xmlns;'">
489
490 <!-- Declare a parameter entity %XSI.prefix as a prefix to use for
491 XML Schema Instance attributes. -->
492 <!ENTITY % XSI.prefix "xsi">
493
494 <!ENTITY % XSI.pfx "%XSI.prefix;:">
495
496 <!ENTITY % XSI.xmlns "http://www.w3.org/2001/XMLSchema-instance">
497
498 <!-- Declare a parameter entity %XSI.xmlns.attrib as support for
499 the schemaLocation attribute. -->
500 <!ENTITY % XSI.xmlns.attrib
501 "xmlns:%XSI.prefix; %URI.datatype; #FIXED '%XSI.xmlns;'">
502
503 <![%$ID.prefixed;[
504 <!ENTITY % NS.decl.attrib
505 "%$ID.xmlns.decl.attrib;
506 %$ID.xmlns.extra.attrib;
507 %XSI.xmlns.attrib;">
508 ]]>
509 <!ENTITY % NS.decl.attrib
510 "%$ID.xmlns.extra.attrib;
511 %XSI.xmlns.attrib;">
512
513 <!-- Declare a parameter entity containing all XML namespace declaration
514 attributes used, including a default xmlns declaration when prefixing
515 is inactive. -->
516 <![%$ID.prefixed;[
517 <!ENTITY % $ID.xmlns.attrib
518 "%NS.decl.attrib;">
519 ]]>
520 <!ENTITY % $ID.xmlns.attrib
521 "%$ID.xmlns.decl.attrib;
522 %NS.decl.attrib;">
523
524 <!-- @{[dot_padding qq(Section B: $Info->{realname} Qualified Names ),
525 length => 71-9, dot => q(:)]} -->
526
527 <!-- placeholder for qualified name redeclarations -->
528 <!ENTITY % ${ID}-qname.redecl "">
529 %${ID}-qname.redecl;
530
531 <!-- 6. This section declare parameter entities used to provide
532 namespace-qualified names for all element types and global
533 attribute names. -->
534 EOH
535 for my $lname (sort keys %{$Info->{QName}}) {
536 $s .= qq(<!ENTITY % )
537 . (dot_padding qq($Info->{ID}.$lname.qname),
538 length => 15 + length ($Info->{ID}), dot => ' ')
539 . qq( "%$Info->{ID}.pfx;$lname">\n);
540 }
541 $s .= qq(\n);
542 for my $lname (sort keys %{$Info->{QNameA}}) {
543 $s .= qq(<!ENTITY % )
544 . (dot_padding qq($Info->{ID}.$lname.attrib.qname),
545 length => 15 + length ($Info->{ID}), dot => ' ')
546 . qq( "%$Info->{ID}.prefix;:$lname">\n);
547 }
548 $s .= qq(\n);
549 for my $lname (sort keys %{$Info->{QNameB}}) {
550 $s .= qq(<!ENTITY % )
551 . (dot_padding qq($Info->{ID}.$lname.attribute.qname),
552 length => 15 + length ($Info->{ID}), dot => ' ')
553 . qq( "%$Info->{ID}.pfx;$lname">\n);
554 }
555 make_module ($src->get_attribute ('QName', make_new_node => 1), $Info, 'qname', $s);
556 }
557
558 sub get_name ($$;$) {
559 my ($src, $Info, $key) = @_;
560 my $name = $src->get_attribute_value ($key || 'Name');
561 if ($name =~ /^:(.+)/) {
562 $name = $1;
563 } elsif ($name =~ /([^:]+):(.+)/) {
564 $name = qq($1.$2);
565 } else {
566 $name = qq($Info->{ID}.$name);
567 }
568 $name;
569 }
570
571 sub get_qname ($$) {
572 my ($src, $Info) = @_;
573 my $name = $src->get_attribute_value ('Name');
574 if ($name =~ /"([^"]+)"/) {
575 $name = qq($1);
576 } elsif ($name =~ /^:(.+)/) {
577 $name = qq(%$1.qname;);
578 } elsif ($name =~ /([^:]+):(.+)/) {
579 $name = qq(%$1.$2.qname;);
580 } elsif ($name =~ /\{([^{}]+)\}/) {
581 $Info->{QNameB}->{$1} = 1;
582 $name = qq(%$Info->{ID}.$1.attribute.qname;);
583 } else {
584 $Info->{QNameA}->{$name} = 1;
585 $name = qq(%$Info->{ID}.$name.attrib.qname;);
586 }
587 $name;
588 }
589
590 sub get_atype ($$) {
591 my ($src, $Info) = @_;
592 my $name = $src->get_attribute_value ('Type');
593 if ($name =~ /^:(.+)/) {
594 $name = qq(%$1.datatype;);
595 } elsif ($name =~ /([^:]+):(.+)/) {
596 $name = qq(%$1.$2.datatype;);
597 } elsif ($name =~ /"([^"]+)"/) {
598 $name = qq($1);
599 } else {
600 $name = qq(%$Info->{ID}.$name.datatype;);
601 }
602 $name;
603 }
604
605 sub get_adefault ($$) {
606 my ($src, $Info) = @_;
607 my $name = $src->get_attribute_value ('Default');
608 if (defined $name) {
609 } else {
610 $name = qq(#IMPLIED);
611 }
612 $name;
613 }
614
615 sub get_desc ($$;%) {
616 my ($src, $Info, %opt) = @_;
617 my $desc = $src->get_attribute_value ('Description');
618 $desc =~ s/\n/\n /g;
619 if (length $desc) {
620 $desc = qq($opt{prefix}$desc);
621 $desc .= q( ) if $opt{padding_length};
622 $desc = q(<!-- ).(dot_padding $desc, length => $opt{padding_length},
623 dot => $opt{padding_dot}).qq( -->\n);
624 } elsif (length $opt{default}) {
625 $desc = $opt{default};
626 $desc .= q( ) if $opt{padding_length};
627 $desc = q(<!-- ).(dot_padding $desc, length => $opt{padding_length},
628 dot => $opt{padding_dot}).qq( -->\n);
629 }
630 $desc;
631 }
632
633 sub attset_def ($$) {
634 my ($src, $Info) = @_;
635 my $name = get_name ($src, $Info);
636 my $s .= qq(@{[get_desc ($src, $Info)]}<!ENTITY % $name.attrib\n\t);
637 my @s;
638 if ($name eq qq($Info->{ID}.common)) {
639 push @s, qq(%$Info->{ID}.common.extra.attrib;);
640 push @s, qq(%$Info->{ID}.xmlns.attrib;);
641 }
642 for my $src (@{$src->child_nodes}) {
643 ## Attribute Definition
644 if ($src->local_name eq 'Attribute') {
645 push @s, attrib_def ($src, $Info);
646 ## Reference to Attribute Definition
647 } elsif ($src->local_name eq 'ref') {
648 push @s, attrib_ref ($src, $Info);
649 } elsif ($src->local_name eq 'REF') {
650 push @s, attrib_REF ($src, $Info);
651 }
652 }
653 $s .= paralit join "\n\t", @s;
654 $s .= qq(>\n\n);
655 $s;
656 }
657
658 sub attrib_module ($$) {
659 my ($src, $Info) = @_;
660 my $s = <<EOH;
661 <!ENTITY % $Info->{ID}.common.extra.attrib "">
662
663 EOH
664 my $output_common = 0;
665 for my $src (@{$src->child_nodes}) {
666 ## Attributes Set
667 if ($src->local_name eq 'Attribute' or $src->local_name eq 'AttributeSet') {
668 $s .= attset_def ($src, $Info);
669 $output_common = 1 if get_name ($src, $Info) eq qq($Info->{ID}.common);
670 }
671 }
672 unless ($output_common) {
673 $s .= <<EOH;
674 <!ENTITY % $Info->{ID}.common.attrib
675 "%$Info->{ID}.common.extra.attrib;
676 %$Info->{ID}.xmlns.attrib;">
677
678 EOH
679 }
680 make_module ($src, $Info, ($src->get_attribute_value ('ID') || 'attribs'), $s);
681 }
682
683 sub attrib_def ($$) {
684 my ($src, $Info) = @_;
685 my $s = qq(@{[get_qname ($src, $Info)]} @{[get_atype ($src, $Info)]} @{[get_adefault ($src, $Info)]});
686 $s;
687 }
688
689 sub attrib_ref ($$) {
690 my ($src, $Info) = @_;
691 my $name = $src->value;
692 if ($name =~ /^:(.+)/) {
693 $name = $1;
694 } elsif ($name =~ /([^:]+):(.+)/) {
695 $name = qq($1.$2);
696 } else {
697 $name = qq($Info->{ID}.$name);
698 }
699 qq(%$name.attrib;);
700 }
701
702 sub attrib_REF ($$) {
703 my ($src, $Info) = @_;
704 {
705 'xml:base' => q<xml:base %URI.datatype; #IMPLIED>,
706 'xml:lang' => q<xml:lang %LanguageCode.datatype; #IMPLIED>,
707 'xml:space' => q<xml:space (default|preserve) #IMPLIED>,
708 'xsi:nil' => q<%XSI.prefix;:nil (true|false|1|0) #IMPLIED>,
709 'xsi:noNamespaceSchemaLocation' => q<%XSI.prefix;:noNamespaceSchemaLocation CDATA #IMPLIED>,
710 'xsi:schemaLocation' => q<%XSI.prefix;:schemaLocation CDATA #IMPLIED>,
711 'xsi:type' => q<%XSI.prefix;:type NMTOKEN #IMPLIED>,
712 }->{$src->value};
713 }
714
715 sub submodule ($$) {
716 my ($src, $Info) = @_;
717 local $Info->{elements} = [];
718 my $s = submodule_declarations ($src, $Info);
719 make_module ($src, $Info, $src->get_attribute_value ('ID'), $s);
720 }
721
722 sub submodule_declarations ($$) {
723 my ($src, $Info) = @_;
724 my $s = '';
725 for my $src (@{$src->child_nodes}) {
726 if ($src->local_name eq 'Element') {
727 $s .= element_def ($src, $Info);
728 } elsif ($src->local_name eq 'Attribute') {
729 $s .= attlist_def ($src, $Info);
730 } elsif ($src->local_name eq 'AttributeSet') {
731 $s .= attset_def ($src, $Info);
732 } elsif ($src->local_name eq 'Class') {
733 $s .= qq(@{[description ($src, $Info)]}<!ENTITY % @{[class_name_of ($src, $Info)]} @{[paralit convert_content_model ($src, $Info)]}>\n\n);
734 } elsif ($src->local_name eq 'Content') {
735 $s .= element_content_def ($src, $Info);
736 } elsif ($src->local_name eq 'IfModuleSet') {
737 $s .= qq(<![%@{[$src->get_attribute_value ('ModuleSet')]}.module;[\n);
738 $s .= submodule_declarations ($src, $Info);
739 $s .= qq(<!-- end of -->]]>\n);
740 } elsif ($src->local_name eq 'ElementSwitch') {
741 $s .= qq(<!ENTITY % @{[name_of ($src, $Info)]}.element "@{[$src->get_attribute_value ('Use')>0?'INCLUDE':'IGNORE']}">\n);
742 } elsif ($src->local_name eq 'AttributeSwitch') {
743 $s .= qq(<!ENTITY % @{[name_of ($src, $Info)]}.attlist "@{[$src->get_attribute_value ('Use')>0?'INCLUDE':'IGNORE']}">\n);
744 } elsif ($src->local_name eq 'ModuleSwitch') {
745 $s .= qq(<!ENTITY % @{[name_of ($src, $Info)]}.module "@{[$src->get_attribute_value ('Use')>0?'INCLUDE':'IGNORE']}">\n);
746 } elsif ($src->local_name eq 'GeneralEntity') {
747 $s .= entity_declaration ($src, $Info, param => 0);
748 } elsif ($src->local_name eq 'ParameterEntity') {
749 $s .= entity_declaration ($src, $Info, param => 1);
750 }
751 }
752 $s;
753 }
754
755 sub element_content_def ($$) {
756 my ($src, $Info) = @_;
757 qq(<!ENTITY % @{[name_of ($src, $Info, key => 'ElementType')]}.content @{[paralit convert_content_model ($src, $Info, default => 'EMPTY')]}>\n);
758 }
759
760 sub element_def ($$) {
761 my ($src, $Info) = @_;
762 my $name = get_name ($src, $Info);
763 my $mname = $name =~ /^\Q$Info->{ID}.\E/ ? $name : qq($Info->{ID}.$name);
764 my $short_name = $name;
765 if ($name =~ /^\Q$Info->{ID}\E\.(.+)/) {
766 $Info->{QName}->{$1} = 1;
767 push @{$Info->{elements}}, $1;
768 $short_name = $1;
769 }
770 my $s = get_desc $src, $Info, prefix => qq($short_name: ),
771 padding_length => 51, padding_dot => q(.),
772 default => qq($short_name);
773 $s .= "\n";
774 $s .= xml_parameter_ENTITY qq($mname.element), value => 'INCLUDE';
775 $s .= xml_condition_section (qq($mname.element) =>
776 xml_parameter_ENTITY
777 (qq($name.content),
778 value => convert_content_model ($src, $Info, default => 'EMPTY'))
779 . xml_parameter_ENTITY (qq($name.qname), value => $short_name)
780 . qq(<!ELEMENT %$name.qname; %$name.content;>\n));
781 $s .= "\n";
782 $s .= attlist_def (scalar $src->get_attribute ('Attribute', make_new_node => 1), $Info, $mname);
783 $s;
784 }
785
786 sub get_model_token ($$) {
787 my ($name, $Info) = @_;
788 my $suffix = '.qname';
789 if ($name =~ s/^\$//) {
790 $suffix = $name =~ /\.(?:mix|class|content|datatype)$/ ? '' : '.class';
791 }
792 if ($name =~ /^:(.+)/) {
793 $name = qq(%$1$suffix;);
794 } elsif ($name =~ /([^:]+):(.+)/) {
795 $name = qq(%$1.$2$suffix;);
796 } elsif ($name =~ /"([^"]+)"/) {
797 $name = qq($1);
798 } else {
799 $name = qq(%$Info->{ID}.$name$suffix;);
800 }
801 $name;
802 }
803
804 sub attlist_def ($$;$) {
805 my ($src, $Info, $name) = @_;
806 $name ||= get_name ($src, $Info, 'ElementType');
807 my $mname = get_name ($src, $Info);
808 $mname = ($name =~ /^\Q$Info->{ID}.\E/ ? $name : qq($Info->{ID}.$name))
809 if $mname eq "$Info->{ID}.";
810 $Info->{QName}->{$1} = 1 if $name =~ /^\Q$Info->{ID}\E\.(.+)/;
811 my $s = qq(<!ATTLIST %$name.qname;);
812 for my $src (@{$src->child_nodes}) {
813 ## Attribute Definition
814 if ($src->local_name eq 'Attribute') {
815 $s .= "\n\t". attrib_def ($src, $Info);
816 ## Reference to Attribute Definition
817 } elsif ($src->local_name eq 'ref') {
818 $s .= "\n\t". attrib_ref ($src, $Info);
819 } elsif ($src->local_name eq 'REF') {
820 $s .= "\n\t". attrib_REF ($src, $Info);
821 }
822 }
823 if ($_[2]) {
824 $s .= qq(\n\t%$Info->{ID}.common.attrib;);
825 }
826 $s .= qq(>\n);
827 qq(@{[description ($src, $Info)]}<!ENTITY % $mname.attlist "INCLUDE">\n)
828 . xml_condition_section (qq($mname.attlist) => $s)
829 . "\n";
830 }
831
832 sub make_module ($$$$;%) {
833 my ($src, $Info, $id, $s, %opt) = @_;
834 my $name = $src->get_attribute_value ('Name')
835 || {arch => q/Base Architecture/,
836 attribs => q/Common Attributes/,
837 blkphras => q/Block Phrasal/,
838 blkpres => q/Block Presentation/,
839 blkstruct => q/Block Structural/,
840 charent => q/Character Entities/,
841 datatype => q/Datatypes/,
842 framework => q/Modular Framework/,
843 inlphras => q/Inline Phrasal/,
844 inlpres => q/Inline Presentation/,
845 inlstruct => q/Inline Structural/,
846 legacy => q/Legacy Markup/,
847 list => q/Lists/,
848 meta => q/Metainformation/,
849 model => q/Document Model/,
850 notations => q/Notations/,
851 pres => q/Presentation/,
852 qname => q/QName (Qualified Name)/,
853 struct => q/Document Structure/,
854 text => q/Text/,
855 }->{$id}
856 || $id;
857 return unless $s;
858
859 my $r = <<EOH;
860 <!-- ...................................................................... -->
861 <!-- @{[do{
862 my $s = qq($Info->{Name} $name Module );
863 if (70 - length $s > 0) {
864 $s = dot_padding $s, length => 70, dot => q(.);
865 } else {
866 $s = qq( $name Module );
867 $s = qq($Info->{Name}\n ) . dot_padding $s, length => 70, dot => q(.);
868 }
869 $s;
870 }]} -->
871 <!-- file: $Info->{ID}-$id.mod
872
873 @{[make_paragraphs [$Info->{Description}], indent => q< >]}
874
875 Copyright @{[(gmtime)[5]+1900]} $Info->{Copyright}, All Rights Reserved.
876
877 Permission to use, copy, modify and distribute this DTD and its
878 accompanying documentation for any purpose and without fee is hereby
879 granted in perpetuity, provided that the above copyright notice and
880 this paragraph appear in all copies. The copyright holders make no
881 representation about the suitability of the DTD for any purpose.
882
883 It is provided "as is" without expressed or implied warranty.
884
885 Revision: @{[sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
886 (gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3,2,1,0]
887 ]} (Generated by $SCRIPT_NAME/$VERSION)
888
889 This DTD module is identified by the SYSTEM identifier:
890
891 SYSTEM "$Info->{BaseURI}$Info->{ID}-$id.mod"
892
893 ...................................................................... -->
894
895 EOH
896 ## TODO: Support PUBLIC identifier.
897
898 ## Module description
899 my @para = ({
900 arch => (join "\n",
901 q!This optional module includes declarations that enable to be used!,
902 q!as a base architecture according to the 'Architectural Forms Definition!,
903 q!Requirements' (Annex A.3, ISO/IEC 10744, 2nd edition). For more!,
904 q!information on use of architectural forms, see the HyTime web site at!,
905 q!<http://www.hytime.org/>.!),
906 attribs => q/This module declares many of the common attributes./,
907 blkphras => qq/This module declares the element types and their attributes used\n/.
908 q/to support block-level phrasal markup./,
909 blkpres => qq/This module declares the element types and their attributes used\n/.
910 q/to support block-level presentational markup./,
911 blkstruct => qq/This module declares the element types and their attributes used\n/.
912 q/to support block-level structural markup./,
913 charent => q/This module declares the set of character entities./,
914 datatype => q/This module defines containers for the datatypes./,
915 framework => qq/This module imstantiates the modules needed to support\n/.
916 q/the modularization model./,
917 inlphras => qq/This module declares the element types and their attributes used\n/.
918 q/to support inline phrasal markup./,
919 inlpres => qq/This module declares the element types and their attributes used\n/.
920 q/to support inline presentational markup./,
921 inlstruct => qq/This module declares the element types and their attributes used\n/.
922 q/to support inline structural markup./,
923 legacy => q/This module declares additional markup that is considered obsolete./,
924 list => qq/This module declares the list-oriented element types\n/.
925 q/and their attributes./,
926 meta => qq/This module declares the element types and their attributes\n/.
927 q/to support metainformation markup./,
928 model => qq/This model describes the groupings of element types that\n/.
929 q/make up common content models./,
930 pres => qq/This module declares the element types and their attributes used\n/.
931 q/to support presentational markup./,
932 qname => (join "\n",
933 q!This module is contained in two parts, labeled Section 'A' and 'B':!,
934 q!!,
935 q! Section A declares parameter entities to support namespace-qualified!,
936 q! names, namespace declarations, and name prefixing.!,
937 q!!,
938 q! Section B declares parameter entities used to provide namespace-qualified!,
939 q! names for all element types and global attribute names.!),
940 struct => qq/This module defines the major structural element types and\n/.
941 q/their attributes./,
942 }->{$id}, $src->get_attribute_value ('Description'));
943 unshift @para, ' '.join ', ', sort @{$Info->{elements}||[]} if @{$Info->{elements}||[]};
944 if (@para) {
945 $name = qq($Info->{realname} QName (Qualified Name) Module)
946 if $id eq 'qname';
947 $r .= <<EOH;
948 <!-- $name
949
950 @{[make_paragraphs \@para, indent => ' ']}
951 -->
952
953 EOH
954 }
955
956 $r .= $s;
957
958 $r .= qq(\n<!-- end of $Info->{ID}-$id.mod -->\n);
959
960 my $file = qq"$Info->{ID}-$id.mod";
961 open FILE, '>', $file or die "$0: $file: $!";
962 print FILE $r;
963 close FILE;
964 print STDERR "$0: $file created\n";
965 }
966
967 sub make_dtd ($$$$) {
968 my ($src, $Info, $id, $s) = @_;
969 $id = "-$id" if $id;
970
971 my $r = <<EOH;
972 <!-- ....................................................................... -->
973 <!-- @{[ dot_padding "$Info->{Name} DTD ", length => 71, dot => q(.) ]} -->
974 <!-- file: $Info->{ID}.dtd
975 -->
976
977 <!-- $Info->{Name} DTD
978
979 @{[make_paragraphs [$Info->{Description}], indent => q< >]}
980
981 Copyright @{[(gmtime)[5]+1900]} $Info->{Copyright}, All Rights Reserved.
982
983 Permission to use, copy, modify and distribute this DTD and its
984 accompanying documentation for any purpose and without fee is hereby
985 granted in perpetuity, provided that the above copyright notice and
986 this paragraph appear in all copies. The copyright holders make no
987 representation about the suitability of the DTD for any purpose.
988
989 It is provided "as is" without expressed or implied warranty.
990
991 Revision: @{[sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
992 (gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3,2,1,0]]}
993
994 -->
995 <!-- This is the driver file for the $Info->{Name} DTD.
996
997 This DTD is identified by the SYSTEM identifier:
998
999 SYSTEM "$Info->{BaseURI}$Info->{ID}$id.dtd"
1000 -->
1001
1002 EOH
1003
1004 $r .= $s;
1005
1006 $r .= qq(\n<!-- end of $Info->{ID}$id.dtd -->\n);
1007
1008 my $file = qq"$Info->{ID}$id.dtd";
1009 open FILE, '>', $file or die "$0: $file: $!";
1010 print FILE $r;
1011 close FILE;
1012 print STDERR "$0: $file created\n";
1013 }
1014
1015
1016 =head1 NAME
1017
1018 mkdtds.pl - Modularized XML Document Type Definition (DTD) Generator
1019
1020 =head1 DESCRIPTION
1021
1022 This script generates XML DTD module implementations and/or DTD drivers,
1023 that can be used with modularized XHTML DTDs.
1024
1025 =head1 USAGE
1026
1027 $ perl mkdtds.pl driver.dds
1028 mkdtds.pl: driver.dtd created
1029 mkdtds.pl: driver-model.mod created
1030
1031 $ perl mkdtds.pl moduleset.dms
1032 mkdtds.pl: moduleset-datatype.mod created
1033 mkdtds.pl: moduleset-attrib.mod created
1034 mkdtds.pl: moduleset-module1.mod created
1035
1036 =head1 DTD SOURCE FORMAT
1037
1038 (((See examples on <http://suika.fam.cx/gate/cvs/markup/>)))
1039
1040 =head1 REQUIRED MODULES
1041
1042 This script uses C<Message::Markup::SuikaWikiConfig20::Node> and
1043 C<Message::Markup::SuikaWikiConfig20::Parser>. Please retrive it from
1044 <http://suika.fam.cx/gate/cvs/messaging/manakai/lib/Message/Markup/SuikaWikiConfig20/>
1045 and put into your C<lib> directory.
1046
1047 =head1 AUTHOR
1048
1049 Wakaba <w@suika.fam.cx>
1050
1051 =head1 LICENSE
1052
1053 Copyright 2003-2004 Wakaba <w@suika.fam.cx>
1054
1055 This program is free software; you can redistribute it and/or
1056 modify it under the same terms as Perl itself.
1057
1058 Note that author claims no copyright with regard to DTD modules/drivers generated
1059 by this script. Author(s) of DTD modules/drivers should explicily state their
1060 license terms in them and their documentation (if any).
1061
1062 =cut

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24