| 1 |
use strict;
|
| 2 |
{require SuikaWiki::Markup::SuikaWikiConfig20::Parser;
|
| 3 |
|
| 4 |
my $parser = new SuikaWiki::Markup::SuikaWikiConfig20::Parser;
|
| 5 |
local $/ = undef;
|
| 6 |
my $src = $parser->parse_text (scalar <>);
|
| 7 |
my $Info = {};
|
| 8 |
|
| 9 |
for my $src ($src->get_attribute ('ModuleSet')
|
| 10 |
|| $src->get_attribute ('DocumentType')) {
|
| 11 |
for (qw/ID Copyright BaseURI/) {
|
| 12 |
$Info->{$_} = $src->get_attribute_value ($_);
|
| 13 |
}
|
| 14 |
$Info->{Name} = $src->get_attribute_value ('Name')
|
| 15 |
.' '.$src->get_attribute_value ('Version');
|
| 16 |
$Info->{ns} = $src->get_attribute ('Namespace');
|
| 17 |
}
|
| 18 |
|
| 19 |
for (@{$src->child_nodes}) {
|
| 20 |
if ($_->local_name eq 'Attribute') {
|
| 21 |
attrib_module ($_, $Info);
|
| 22 |
} elsif ($_->local_name eq 'Datatype') {
|
| 23 |
datatype_module ($_, $Info);
|
| 24 |
} elsif ($_->local_name eq 'Notation') {
|
| 25 |
notation_module ($_, $Info);
|
| 26 |
} elsif ($_->local_name eq 'Module') {
|
| 27 |
submodule ($_, $Info);
|
| 28 |
} elsif ($_->local_name eq 'Model') {
|
| 29 |
model_module ($_, $Info);
|
| 30 |
} elsif ($_->local_name eq 'Driver') {
|
| 31 |
dtd_driver ($_, $Info);
|
| 32 |
}
|
| 33 |
}
|
| 34 |
|
| 35 |
if (ref $src->get_attribute ('ModuleSet')) {
|
| 36 |
qname_module ($src->get_attribute ('ModuleSet'), $Info);
|
| 37 |
}
|
| 38 |
exit}
|
| 39 |
|
| 40 |
sub submodule_id_of ($$;%) {
|
| 41 |
my ($src, $Info, %opt) = @_;
|
| 42 |
my $id = $src->get_attribute_value ('ID') || $opt{default};
|
| 43 |
unless ($id) {
|
| 44 |
die "$0: Submodule identifier not specified";
|
| 45 |
}
|
| 46 |
$id;
|
| 47 |
}
|
| 48 |
sub xml_datatype_of ($$;%) {
|
| 49 |
my ($src, $Info, %opt) = @_;
|
| 50 |
my $type = $src->get_attribute_value ('XMLType') || $opt{default};
|
| 51 |
$type =~ s/\s+//g;
|
| 52 |
$type;
|
| 53 |
}
|
| 54 |
sub external_id_of ($$;%) {
|
| 55 |
my ($src, $Info, %opt) = @_;
|
| 56 |
my $sysid = $opt{base}.($src->get_attribute_value ('SYSTEM') || $opt{default});
|
| 57 |
my $pubid = $src->get_attribute_value ('PUBLIC');
|
| 58 |
if ($pubid) {
|
| 59 |
if ($sysid) {
|
| 60 |
return qq(PUBLIC "$pubid"\n\t "$sysid");
|
| 61 |
} else {
|
| 62 |
return qq(PUBLIC "$pubid");
|
| 63 |
}
|
| 64 |
} else {
|
| 65 |
return qq(SYSTEM "$sysid");
|
| 66 |
}
|
| 67 |
}
|
| 68 |
sub name_of ($$;%) {
|
| 69 |
my ($src, $Info, %opt) = @_;
|
| 70 |
unless (ref $src) {require Carp; Carp::croak ('$src undefined')}
|
| 71 |
my $name = $src->get_attribute_value ($opt{key} || 'Name');
|
| 72 |
if ($name =~ /^:(.+)/) { ## Global namespace
|
| 73 |
return $1;
|
| 74 |
} elsif ($name =~ /([^:]+):(.+)/) { ## Named space
|
| 75 |
return $1.($opt{delim}||'.').$2;
|
| 76 |
} else { ## Default namespace
|
| 77 |
return $Info->{ID}.($opt{delim}||'.').$name;
|
| 78 |
}
|
| 79 |
}
|
| 80 |
sub local_name_of ($$;%) {
|
| 81 |
my ($src, $Info, %opt) = @_;
|
| 82 |
my $name = $src->get_attribute_value ($opt{key} || 'Name');
|
| 83 |
if ($name =~ /^:(.+)/) { ## Global namespace
|
| 84 |
return $1;
|
| 85 |
} elsif ($name =~ /[^:]+:(.+)/) { ## Named space
|
| 86 |
return $1;
|
| 87 |
} else { ## Default namespace
|
| 88 |
return $name;
|
| 89 |
}
|
| 90 |
}
|
| 91 |
sub set_name_of ($$;%) {
|
| 92 |
my ($src, $Info, %opt) = @_;
|
| 93 |
my $name = $src->get_attribute_value ($opt{key} || 'Name');
|
| 94 |
if ($name =~ /^:.+/) { ## Global namespace
|
| 95 |
return 'XHTML';
|
| 96 |
} elsif ($name =~ /([^:]+):.+/) { ## Named space
|
| 97 |
return $1;
|
| 98 |
} else { ## Default namespace
|
| 99 |
return $Info->{ID};
|
| 100 |
}
|
| 101 |
}
|
| 102 |
sub class_name_of ($$;%) {
|
| 103 |
my ($src, $Info, %opt) = @_;
|
| 104 |
my $name = name_of ($src, $Info, %opt);
|
| 105 |
unless ($name =~ /\.(class|mix|content|datatype)$/) {
|
| 106 |
$name .= '.class';
|
| 107 |
}
|
| 108 |
$name;
|
| 109 |
}
|
| 110 |
sub convert_content_model ($$;%) {
|
| 111 |
my ($src, $Info, %opt) = @_;
|
| 112 |
my $model = $src->get_attribute_value ($opt{key} || 'Content') || $opt{default};
|
| 113 |
$model =~ s/\s//g;
|
| 114 |
my $nonsymbol = qr/[^%#?,\$;()+*|:]/;
|
| 115 |
$model =~ s/(?<![%#.])((?:\$|\b)$nonsymbol+(?::$nonsymbol+)?|\$?:$nonsymbol+|"[^"]+")/get_model_token ($1, $Info)/ge;
|
| 116 |
$model;
|
| 117 |
}
|
| 118 |
sub paralit ($) {
|
| 119 |
my $s = shift;
|
| 120 |
if ($s =~ /"/) {
|
| 121 |
if ($s =~ /'/) {
|
| 122 |
$s =~ s/'/'/g;
|
| 123 |
return qq("$s");
|
| 124 |
} else {
|
| 125 |
return qq('$s');
|
| 126 |
}
|
| 127 |
} else {
|
| 128 |
return qq("$s");
|
| 129 |
}
|
| 130 |
}
|
| 131 |
sub description ($$;%) {
|
| 132 |
my ($src, $Info, %opt) = @_;
|
| 133 |
my $desc = $src->get_attribute_value ('Description');
|
| 134 |
$desc =~ s/\n/\n /g;
|
| 135 |
unless ($desc) {
|
| 136 |
$desc = {
|
| 137 |
load_module => {
|
| 138 |
AttributeModule => q/Common Attributes Module/,
|
| 139 |
DatatypeModule => q/Datatypes Module/,
|
| 140 |
NotationModule => q/Notation Module/,
|
| 141 |
QNameModule => q/QName Module/,
|
| 142 |
},
|
| 143 |
}->{$opt{context}}->{$opt{id} || $src->get_attribute_value ($opt{id_key}||'ID')};
|
| 144 |
}
|
| 145 |
$desc = qq(<!-- $desc -->\n) if $desc;
|
| 146 |
$desc;
|
| 147 |
}
|
| 148 |
|
| 149 |
|
| 150 |
sub dtd_driver ($$) {
|
| 151 |
my ($src, $Info) = @_;
|
| 152 |
my $s = '';
|
| 153 |
my %s;
|
| 154 |
my @module_set;
|
| 155 |
for my $src (@{$src->child_nodes}) {
|
| 156 |
if ($src->local_name eq 'Module') {
|
| 157 |
$s .= dtd_driver_load_module ($src, $Info);
|
| 158 |
} elsif ($src->local_name eq 'ModuleSet') {
|
| 159 |
push @module_set, $src;
|
| 160 |
} elsif ($src->local_name =~ /^(?:QName|Attribute|Datatype|Notation)Module/) {
|
| 161 |
$s{$src->local_name} .= dtd_driver_load_module ($src, $Info);
|
| 162 |
} elsif ($src->local_name eq 'IfModuleSet') {
|
| 163 |
$s .= qq(<![%@{[$src->get_attribute_value ('ModuleSet')]}.module;[\n);
|
| 164 |
$s .= submodule_declarations ($src, $Info);
|
| 165 |
$s .= qq(]]>\n);
|
| 166 |
} elsif ($src->local_name eq 'GeneralEntity') {
|
| 167 |
$s .= qq(@{[description ($src, $Info)]}<!ENTITY @{[$src->get_attribute_value ('Name')]} @{[paralit $src->get_attribute_value ('EntityValue')]}>\n\n);
|
| 168 |
} elsif ($src->local_name eq 'ParameterEntity') {
|
| 169 |
$s .= qq(@{[description ($src, $Info)]}<!ENTITY % @{[$src->get_attribute_value ('Name')]} @{[paralit $src->get_attribute_value ('EntityValue')]}>\n\n);
|
| 170 |
}
|
| 171 |
}
|
| 172 |
|
| 173 |
$s{ModelModule} = <<EOH;
|
| 174 |
<!-- Document Model module -->
|
| 175 |
<!ENTITY % $Info->{ID}-model.module "INCLUDE">
|
| 176 |
<![%$Info->{ID}-model.module;[
|
| 177 |
<!ENTITY % $Info->{ID}-model.decl
|
| 178 |
'SYSTEM "$Info->{ID}-model.mod"'>
|
| 179 |
<!ENTITY % $Info->{ID}-model.mod %$Info->{ID}-model.decl;>
|
| 180 |
%$Info->{ID}-model.mod;]]>
|
| 181 |
|
| 182 |
EOH
|
| 183 |
|
| 184 |
$s = dtd_driver_module_sets (\@module_set, $Info)
|
| 185 |
. $s{QNameModule}.$s{DatatypeModule}.$s{NotationModule}.$s{AttributeModule}
|
| 186 |
. $s{ModelModule}
|
| 187 |
.$s;
|
| 188 |
make_dtd ($src, $Info, $src->get_attribute_value ('ID'), $s);
|
| 189 |
}
|
| 190 |
|
| 191 |
sub dtd_driver_module_sets ($$) {
|
| 192 |
my ($srces, $Info) = @_;
|
| 193 |
my @src = map {{src => $_}} @$srces;
|
| 194 |
my $s = qq(<!-- Switchers to include/ignore each vocabulary -->\n);
|
| 195 |
for my $module_set (@src) {
|
| 196 |
$module_set->{ID} = $module_set->{src}->get_attribute_value ('ID') || 'XHTML';
|
| 197 |
$s .= qq(<!ENTITY % $module_set->{ID}.module "@{[$module_set->{src}->get_attribute_value ('Default') > 0 ? 'INCLUDE' : 'IGNORE']}">\n);
|
| 198 |
}
|
| 199 |
$s .= qq(\n<!-- Namespace names -->\n);
|
| 200 |
for my $module_set (@src) {
|
| 201 |
$module_set->{ns} = $module_set->{src}->get_attribute ('Namespace');
|
| 202 |
$s .= qq(<!ENTITY % $module_set->{ID}.xmlns "@{[$module_set->{ns}->get_attribute_value ('Name')]}">\n);
|
| 203 |
}
|
| 204 |
$s .= qq(\n<!-- Base URIs for the relavant DTD modules -->\n);
|
| 205 |
for my $module_set (@src) {
|
| 206 |
$s .= qq(<!ENTITY % $module_set->{ID}.sysid.base "@{[$module_set->{src}->get_attribute_value ('BaseURI')]}">\n);
|
| 207 |
}
|
| 208 |
$s .= qq(\n<!-- Namespace prefix -->\n);
|
| 209 |
$s .= qq(<!ENTITY % NS.prefixed "@{[$Info->{ns}->get_attribute_value ('UsePrefix') > 0 ? 'INCLUDE' : 'IGNORE']}">\n);
|
| 210 |
for my $module_set (@src) {
|
| 211 |
$s .= qq(<!ENTITY % $module_set->{ID}.prefix "@{[$module_set->{ns}->get_attribute_value ('DefaultPrefix')]}">\n);
|
| 212 |
$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);
|
| 213 |
}
|
| 214 |
$s .= qq(\n<!-- a URI reference -->\n<!ENTITY % URI.datatype "CDATA">\n);
|
| 215 |
$s .= qq(\n<!-- Placefolders for foreign namespace declarations -->\n);
|
| 216 |
for my $module_set (@src) {
|
| 217 |
$s .= qq(<!ENTITY % $module_set->{ID}.xmlns.extra.attrib "">\n);
|
| 218 |
}
|
| 219 |
$s .= qq(\n<!-- Namespace declarations -->\n);
|
| 220 |
for my $module_set (@src) {
|
| 221 |
$s .= qq(<![%$module_set->{ID}.module;[
|
| 222 |
<![%$module_set->{ID}.prefixed;[
|
| 223 |
<!ENTITY % $module_set->{ID}.xmlns.decl.attrib
|
| 224 |
"xmlns:%$module_set->{ID}.prefix; %URI.datatype; #FIXED '%$module_set->{ID}.xmlns;'">
|
| 225 |
]]>
|
| 226 |
<!ENTITY % $module_set->{ID}.xmlns.decl.attrib
|
| 227 |
"xmlns %URI.datatype; #FIXED '%$module_set->{ID}.xmlns;'">
|
| 228 |
]]>
|
| 229 |
<!ENTITY % $module_set->{ID}.xmlns.decl.attrib "">\n\n);
|
| 230 |
}
|
| 231 |
$s .= qq(\n<!ENTITY % NS.decl.attrib
|
| 232 |
").join ("\n\t", (map {qq(%$_->{ID}.xmlns.decl.attrib;)} @src),
|
| 233 |
map {qq(%$_->{ID}.xmlns.extra.attrib;)} @src).qq(">\n);
|
| 234 |
$s .= qq(\n);
|
| 235 |
for my $module_set (@src) {
|
| 236 |
$s .= qq(<!ENTITY % $module_set->{ID}.xmlns.attrib "%NS.decl.attrib;">\n);
|
| 237 |
}
|
| 238 |
$s .= qq(\n\n);
|
| 239 |
$s;
|
| 240 |
}
|
| 241 |
|
| 242 |
sub dtd_driver_load_module ($$) {
|
| 243 |
my ($src, $Info) = @_;
|
| 244 |
my $module_name = name_of ($src, $Info, key => 'ID');
|
| 245 |
my $module_hyphen_name = name_of ($src, $Info, key => 'ID', delim => '-');
|
| 246 |
my $module_set_name = set_name_of ($src, $Info, key => 'ID');
|
| 247 |
my $module_id = local_name_of ($src, $Info, key => 'ID');
|
| 248 |
|
| 249 |
my $s .= <<EOH;
|
| 250 |
@{[description ($src, $Info, context => 'load_module', id => $src->local_name)]}<![%$module_set_name.module;[
|
| 251 |
<!ENTITY % $module_name.module "INCLUDE">
|
| 252 |
<![%$module_name.module;[
|
| 253 |
@{[submodule_declarations ($src, $Info)]}<!ENTITY % $module_name.decl
|
| 254 |
@{[paralit external_id_of ($src, $Info, default => qq($module_hyphen_name.mod), base => qq(%$module_set_name.sysid.base;))]}>
|
| 255 |
<!ENTITY % $module_name.mod %$module_name.decl;>
|
| 256 |
%$module_name.mod;]]>
|
| 257 |
]]>
|
| 258 |
|
| 259 |
EOH
|
| 260 |
$s;
|
| 261 |
}
|
| 262 |
sub model_module ($$) {
|
| 263 |
my ($src, $Info) = @_;
|
| 264 |
my $s = '';
|
| 265 |
for my $src (@{$src->child_nodes}) {
|
| 266 |
if ($src->local_name eq 'Class') {
|
| 267 |
$s .= qq(@{[get_desc ($src, $Info)]}<!ENTITY % @{[class_name_of ($src, $Info)]} @{[paralit convert_content_model ($src, $Info)]}>\n\n);
|
| 268 |
} elsif ($src->local_name eq 'Content') {
|
| 269 |
$s .= element_content_def ($src, $Info);
|
| 270 |
}
|
| 271 |
}
|
| 272 |
make_module ($src, $Info, submodule_id_of ($src, $Info, default => 'model'), $s);
|
| 273 |
}
|
| 274 |
|
| 275 |
sub datatype_module ($$) {
|
| 276 |
my ($src, $Info) = @_;
|
| 277 |
my $s = '';
|
| 278 |
for my $src (@{$src->child_nodes}) {
|
| 279 |
if ($src->local_name eq 'Type') {
|
| 280 |
$s .= qq(@{[get_desc ($src, $Info)]}<!ENTITY % @{[name_of ($src, $Info)]}.datatype "@{[xml_datatype_of ($src, $Info, default => 'CDATA')]}">\n\n);
|
| 281 |
}
|
| 282 |
}
|
| 283 |
make_module ($src, $Info, submodule_id_of ($src, $Info, default => 'datatype'), $s);
|
| 284 |
}
|
| 285 |
|
| 286 |
sub notation_module ($$) {
|
| 287 |
my ($src, $Info) = @_;
|
| 288 |
my $s = '';
|
| 289 |
for my $src (@{$src->child_nodes}) {
|
| 290 |
if ($src->local_name eq 'Notation') {
|
| 291 |
$s .= qq(@{[get_desc ($src, $Info)]}<!NOTATION @{[name_of ($src, $Info)]} @{[external_id_of ($src, $Info)]}>\n\n);
|
| 292 |
}
|
| 293 |
}
|
| 294 |
make_module ($src, $Info, submodule_id_of ($src, $Info, default => 'notation'), $s);
|
| 295 |
}
|
| 296 |
|
| 297 |
sub qname_module ($$) {
|
| 298 |
my ($src, $Info) = @_;
|
| 299 |
my $ID = $Info->{ID};
|
| 300 |
my $ns = $src->get_attribute ('Namespace');
|
| 301 |
my $s = <<EOH;
|
| 302 |
<!ENTITY % NS.prefixed "@{[$ns->get_attribute_value ('UsePrefix')==1?
|
| 303 |
q(INCLUDE):q(IGNORE)]}">
|
| 304 |
<!ENTITY % $ID.prefixed "@{[$ns->get_attribute_value ('UsePrefix')==1?
|
| 305 |
q(INCLUDE):
|
| 306 |
$ns->get_attribute_value ('UsePrefix')==-1?
|
| 307 |
q(IGNORE):
|
| 308 |
q(%NS.prefixed;)]}">
|
| 309 |
<!ENTITY % $ID.xmlns "@{[$ns->get_attribute_value ('Name')]}">
|
| 310 |
<!ENTITY % $ID.prefix "@{[$ns->get_attribute_value ('DefaultPrefix')]}">
|
| 311 |
<![%$ID.prefixed;[
|
| 312 |
<!ENTITY % $ID.pfx "%$ID.prefix;:">
|
| 313 |
]]>
|
| 314 |
<!ENTITY % $ID.pfx "">
|
| 315 |
<!ENTITY % $ID.xmlns.extra.attrib "">
|
| 316 |
|
| 317 |
<![%$ID.prefixed;[
|
| 318 |
<!ENTITY % $ID.xmlns.decl.attrib
|
| 319 |
"xmlns:%$ID.prefix; %URI.datatype; #FIXED '%$ID.xmlns;'">
|
| 320 |
]]>
|
| 321 |
<!ENTITY % $ID.xmlns.decl.attrib
|
| 322 |
"xmlns %URI.datatype; #FIXED '%$ID.xmlns;'">
|
| 323 |
|
| 324 |
<![%$ID.prefixed;[
|
| 325 |
<!ENTITY % NS.decl.attrib
|
| 326 |
"%$ID.xmlns.decl.attrib;
|
| 327 |
%$ID.xmlns.extra.attrib;">
|
| 328 |
]]>
|
| 329 |
<!ENTITY % NS.decl.attrib
|
| 330 |
"%$ID.xmlns.extra.attrib;">
|
| 331 |
|
| 332 |
<![%$ID.prefixed;[
|
| 333 |
<!ENTITY % $ID.xmlns.attrib
|
| 334 |
"%NS.decl.attrib;">
|
| 335 |
]]>
|
| 336 |
<!ENTITY % $ID.xmlns.attrib
|
| 337 |
"%$ID.xmlns.decl.attrib;
|
| 338 |
%NS.decl.attrib;">
|
| 339 |
|
| 340 |
EOH
|
| 341 |
for my $lname (keys %{$Info->{QName}}) {
|
| 342 |
$s .= qq(<!ENTITY % $Info->{ID}.$lname.qname "%$Info->{ID}.pfx;$lname">\n);
|
| 343 |
}
|
| 344 |
$s .= qq(\n);
|
| 345 |
for my $lname (keys %{$Info->{QNameA}}) {
|
| 346 |
$s .= qq(<!ENTITY % $Info->{ID}.$lname.attrib.qname "%$Info->{ID}.prefix;:$lname">\n);
|
| 347 |
}
|
| 348 |
$s .= qq(\n);
|
| 349 |
for my $lname (keys %{$Info->{QNameB}}) {
|
| 350 |
$s .= qq(<!ENTITY % $Info->{ID}.$lname.attribute.qname "%$Info->{ID}.pfx;$lname">\n);
|
| 351 |
}
|
| 352 |
make_module ($src, $Info, 'qname', $s);
|
| 353 |
}
|
| 354 |
|
| 355 |
sub get_name ($$;$) {
|
| 356 |
my ($src, $Info, $key) = @_;
|
| 357 |
my $name = $src->get_attribute_value ($key || 'Name');
|
| 358 |
if ($name =~ /^:(.+)/) {
|
| 359 |
$name = $1;
|
| 360 |
} elsif ($name =~ /([^:]+):(.+)/) {
|
| 361 |
$name = qq($1.$2);
|
| 362 |
} else {
|
| 363 |
$name = qq($Info->{ID}.$name);
|
| 364 |
}
|
| 365 |
$name;
|
| 366 |
}
|
| 367 |
|
| 368 |
sub get_qname ($$) {
|
| 369 |
my ($src, $Info) = @_;
|
| 370 |
my $name = $src->get_attribute_value ('Name');
|
| 371 |
if ($name =~ /"([^"]+)"/) {
|
| 372 |
$name = qq($1);
|
| 373 |
} elsif ($name =~ /^:(.+)/) {
|
| 374 |
$name = qq(%$1.qname;);
|
| 375 |
} elsif ($name =~ /([^:]+):(.+)/) {
|
| 376 |
$name = qq(%$1.$2.qname;);
|
| 377 |
} elsif ($name =~ /\{([^{}]+)\}/) {
|
| 378 |
$Info->{QNameB}->{$1} = 1;
|
| 379 |
$name = qq(%$Info->{ID}.$1.attribute.qname;);
|
| 380 |
} else {
|
| 381 |
$Info->{QNameA}->{$name} = 1;
|
| 382 |
$name = qq(%$Info->{ID}.$name.attrib.qname;);
|
| 383 |
}
|
| 384 |
$name;
|
| 385 |
}
|
| 386 |
|
| 387 |
sub get_atype ($$) {
|
| 388 |
my ($src, $Info) = @_;
|
| 389 |
my $name = $src->get_attribute_value ('Type');
|
| 390 |
if ($name =~ /^:(.+)/) {
|
| 391 |
$name = qq(%$1.datatype;);
|
| 392 |
} elsif ($name =~ /([^:]+):(.+)/) {
|
| 393 |
$name = qq(%$1.$2.datatype;);
|
| 394 |
} elsif ($name =~ /"([^"]+)"/) {
|
| 395 |
$name = qq($1);
|
| 396 |
} else {
|
| 397 |
$name = qq(%$Info->{ID}.$name.datatype;);
|
| 398 |
}
|
| 399 |
$name;
|
| 400 |
}
|
| 401 |
|
| 402 |
sub get_adefault ($$) {
|
| 403 |
my ($src, $Info) = @_;
|
| 404 |
my $name = $src->get_attribute_value ('Default');
|
| 405 |
if (defined $name) {
|
| 406 |
} else {
|
| 407 |
$name = qq(#IMPLIED);
|
| 408 |
}
|
| 409 |
$name;
|
| 410 |
}
|
| 411 |
|
| 412 |
sub get_desc ($$) {
|
| 413 |
my ($src, $Info) = @_;
|
| 414 |
my $desc = $src->get_attribute_value ('Description');
|
| 415 |
$desc =~ s/\n/\n /g;
|
| 416 |
$desc = qq(<!-- $desc -->\n) if $desc;
|
| 417 |
$desc;
|
| 418 |
}
|
| 419 |
|
| 420 |
sub attset_def ($$) {
|
| 421 |
my ($src, $Info) = @_;
|
| 422 |
my $name = get_name ($src, $Info);
|
| 423 |
my $s .= qq(@{[get_desc ($src, $Info)]}<!ENTITY % $name.attrib\n\t);
|
| 424 |
my @s;
|
| 425 |
if ($name eq qq($Info->{ID}.common)) {
|
| 426 |
push @s, qq(%$Info->{ID}.common.extra.attrib;);
|
| 427 |
push @s, qq(%$Info->{ID}.xmlns.attrib;);
|
| 428 |
}
|
| 429 |
for my $src (@{$src->child_nodes}) {
|
| 430 |
## Attribute Definition
|
| 431 |
if ($src->local_name eq 'Attribute') {
|
| 432 |
push @s, attrib_def ($src, $Info);
|
| 433 |
## Reference to Attribute Definition
|
| 434 |
} elsif ($src->local_name eq 'ref') {
|
| 435 |
push @s, attrib_ref ($src, $Info);
|
| 436 |
} elsif ($src->local_name eq 'REF') {
|
| 437 |
push @s, attrib_REF ($src, $Info);
|
| 438 |
}
|
| 439 |
}
|
| 440 |
$s .= paralit join "\n\t", @s;
|
| 441 |
$s .= qq(>\n\n);
|
| 442 |
$s;
|
| 443 |
}
|
| 444 |
|
| 445 |
sub attrib_module ($$) {
|
| 446 |
my ($src, $Info) = @_;
|
| 447 |
my $s = <<EOH;
|
| 448 |
<!ENTITY % $Info->{ID}.common.extra.attrib "">
|
| 449 |
|
| 450 |
EOH
|
| 451 |
my $output_common = 0;
|
| 452 |
for my $src (@{$src->child_nodes}) {
|
| 453 |
## Attributes Set
|
| 454 |
if ($src->local_name eq 'Attribute' or $src->local_name eq 'AttributeSet') {
|
| 455 |
$s .= attset_def ($src, $Info);
|
| 456 |
$output_common = 1 if get_name ($src, $Info) eq qq($Info->{ID}.common);
|
| 457 |
}
|
| 458 |
}
|
| 459 |
unless ($output_common) {
|
| 460 |
$s .= <<EOH;
|
| 461 |
<!ENTITY % $Info->{ID}.common.attrib
|
| 462 |
"%$Info->{ID}.common.extra.attrib;
|
| 463 |
%$Info->{ID}.xmlns.attrib;">
|
| 464 |
|
| 465 |
EOH
|
| 466 |
}
|
| 467 |
make_module ($src, $Info, ($src->get_attribute_value ('ID') || 'attribs'), $s);
|
| 468 |
}
|
| 469 |
|
| 470 |
sub attrib_def ($$) {
|
| 471 |
my ($src, $Info) = @_;
|
| 472 |
my $s = qq(@{[get_qname ($src, $Info)]} @{[get_atype ($src, $Info)]} @{[get_adefault ($src, $Info)]});
|
| 473 |
$s;
|
| 474 |
}
|
| 475 |
|
| 476 |
sub attrib_ref ($$) {
|
| 477 |
my ($src, $Info) = @_;
|
| 478 |
my $name = $src->value;
|
| 479 |
if ($name =~ /^:(.+)/) {
|
| 480 |
$name = $1;
|
| 481 |
} elsif ($name =~ /([^:]+):(.+)/) {
|
| 482 |
$name = qq($1.$2);
|
| 483 |
} else {
|
| 484 |
$name = qq($Info->{ID}.$name);
|
| 485 |
}
|
| 486 |
qq(%$name.attrib;);
|
| 487 |
}
|
| 488 |
|
| 489 |
sub attrib_REF ($$) {
|
| 490 |
my ($src, $Info) = @_;
|
| 491 |
{
|
| 492 |
'xml:base' => q<xml:base %URI.datatype; #IMPLIED>,
|
| 493 |
'xml:lang' => q<xml:lang %LanguageCode.datatype; #IMPLIED>,
|
| 494 |
'xml:space' => q<xml:space (default|preserve) #IMPLIED>,
|
| 495 |
}->{$src->value};
|
| 496 |
}
|
| 497 |
|
| 498 |
sub submodule ($$) {
|
| 499 |
my ($src, $Info) = @_;
|
| 500 |
my $s = submodule_declarations ($src, $Info);
|
| 501 |
make_module ($src, $Info, $src->get_attribute_value ('ID'), $s);
|
| 502 |
}
|
| 503 |
|
| 504 |
sub submodule_declarations ($$) {
|
| 505 |
my ($src, $Info) = @_;
|
| 506 |
my $s = '';
|
| 507 |
for my $src (@{$src->child_nodes}) {
|
| 508 |
if ($src->local_name eq 'Element') {
|
| 509 |
$s .= element_def ($src, $Info);
|
| 510 |
} elsif ($src->local_name eq 'Attribute') {
|
| 511 |
$s .= attlist_def ($src, $Info);
|
| 512 |
} elsif ($src->local_name eq 'AttributeSet') {
|
| 513 |
$s .= attset_def ($src, $Info);
|
| 514 |
} elsif ($src->local_name eq 'Content') {
|
| 515 |
$s .= element_content_def ($src, $Info);
|
| 516 |
} elsif ($src->local_name eq 'IfModuleSet') {
|
| 517 |
$s .= qq(<![%@{[$src->get_attribute_value ('ModuleSet')]}.module;[\n);
|
| 518 |
$s .= submodule_declarations ($src, $Info);
|
| 519 |
$s .= qq(]]>\n);
|
| 520 |
} elsif ($src->local_name eq 'ElementSwitch') {
|
| 521 |
$s .= qq(<!ENTITY % @{[name_of ($src, $Info)]}.element "@{[$src->get_attribute_value ('Use')>0?'INCLUDE':'IGNORE']}">\n);
|
| 522 |
} elsif ($src->local_name eq 'AttributeSwitch') {
|
| 523 |
$s .= qq(<!ENTITY % @{[name_of ($src, $Info)]}.attlist "@{[$src->get_attribute_value ('Use')>0?'INCLUDE':'IGNORE']}">\n);
|
| 524 |
} elsif ($src->local_name eq 'ParameterEntity') {
|
| 525 |
$s .= qq(@{[description ($src, $Info)]}<!ENTITY % @{[$src->get_attribute_value ('Name')]} @{[paralit $src->get_attribute_value ('EntityValue')]}>\n);
|
| 526 |
}
|
| 527 |
}
|
| 528 |
$s;
|
| 529 |
}
|
| 530 |
|
| 531 |
sub element_content_def ($$) {
|
| 532 |
my ($src, $Info) = @_;
|
| 533 |
qq(<!ENTITY % @{[name_of ($src, $Info, key => 'ElementType')]}.content @{[paralit convert_content_model ($src, $Info, default => 'EMPTY')]}>\n);
|
| 534 |
}
|
| 535 |
|
| 536 |
sub element_def ($$) {
|
| 537 |
my ($src, $Info) = @_;
|
| 538 |
my $name = get_name ($src, $Info);
|
| 539 |
my $mname = $name =~ /^\Q$Info->{ID}.\E/ ? $name : qq($Info->{ID}.$name);
|
| 540 |
$Info->{QName}->{$1} = 1 if $name =~ /^\Q$Info->{ID}\E\.(.+)/;
|
| 541 |
my $s = <<EOH;
|
| 542 |
@{[get_desc ($src, $Info)]}<!ENTITY % $mname.element "INCLUDE">
|
| 543 |
<![%$mname.element;[
|
| 544 |
<!ENTITY % $name.content @{[paralit convert_content_model ($src, $Info, default => 'EMPTY')]}>
|
| 545 |
<!ELEMENT %$name.qname; %$name.content;>
|
| 546 |
]]>
|
| 547 |
EOH
|
| 548 |
$s .= attlist_def (scalar $src->get_attribute ('Attribute', make_new_node => 1), $Info, $mname);
|
| 549 |
$s;
|
| 550 |
}
|
| 551 |
|
| 552 |
sub get_model_token ($$) {
|
| 553 |
my ($name, $Info) = @_;
|
| 554 |
my $suffix = '.qname';
|
| 555 |
if ($name =~ s/^\$//) {
|
| 556 |
$suffix = $name =~ /\.(?:mix|class|content|datatype)$/ ? '' : '.class';
|
| 557 |
}
|
| 558 |
if ($name =~ /^:(.+)/) {
|
| 559 |
$name = qq(%$1$suffix;);
|
| 560 |
} elsif ($name =~ /([^:]+):(.+)/) {
|
| 561 |
$name = qq(%$1.$2$suffix;);
|
| 562 |
} elsif ($name =~ /"([^"]+)"/) {
|
| 563 |
$name = qq($1);
|
| 564 |
} else {
|
| 565 |
$name = qq(%$Info->{ID}.$name$suffix;);
|
| 566 |
}
|
| 567 |
$name;
|
| 568 |
}
|
| 569 |
|
| 570 |
sub attlist_def ($$;$) {
|
| 571 |
my ($src, $Info, $name) = @_;
|
| 572 |
$name ||= get_name ($src, $Info, 'ElementType');
|
| 573 |
my $mname = get_name ($src, $Info);
|
| 574 |
$mname = ($name =~ /^\Q$Info->{ID}.\E/ ? $name : qq($Info->{ID}.$name))
|
| 575 |
if $mname eq "$Info->{ID}.";
|
| 576 |
$Info->{QName}->{$1} = 1 if $name =~ /^\Q$Info->{ID}\E\.(.+)/;
|
| 577 |
my $s = qq(@{[description ($src, $Info)]}<!ENTITY % $mname.attlist "INCLUDE">
|
| 578 |
<![%$mname.attlist;[
|
| 579 |
<!ATTLIST %$name.qname;);
|
| 580 |
for my $src (@{$src->child_nodes}) {
|
| 581 |
## Attribute Definition
|
| 582 |
if ($src->local_name eq 'Attribute') {
|
| 583 |
$s .= "\n\t". attrib_def ($src, $Info);
|
| 584 |
## Reference to Attribute Definition
|
| 585 |
} elsif ($src->local_name eq 'ref') {
|
| 586 |
$s .= "\n\t". attrib_ref ($src, $Info);
|
| 587 |
} elsif ($src->local_name eq 'REF') {
|
| 588 |
$s .= "\n\t". attrib_REF ($src, $Info);
|
| 589 |
}
|
| 590 |
}
|
| 591 |
if ($_[2]) {
|
| 592 |
$s .= qq(\n\t%$Info->{ID}.common.attrib;);
|
| 593 |
}
|
| 594 |
$s .= qq(>
|
| 595 |
]]>
|
| 596 |
|
| 597 |
);
|
| 598 |
$s;
|
| 599 |
}
|
| 600 |
|
| 601 |
sub make_module ($$$$) {
|
| 602 |
my ($src, $Info, $id, $s) = @_;
|
| 603 |
my $name = $src->get_attribute_value ('Name')
|
| 604 |
|| {attribs => q/Common Attributes/,
|
| 605 |
datatype => q/Datatypes/,
|
| 606 |
model => q/Document Model/,
|
| 607 |
qname => q/QName/,
|
| 608 |
struct => q/Structual/,
|
| 609 |
}->{$id}
|
| 610 |
|| $id;
|
| 611 |
|
| 612 |
my $r = <<EOH;
|
| 613 |
<!-- $Info->{Name} : $name Module
|
| 614 |
|
| 615 |
Copyright @{[(gmtime)[5]+1900]} $Info->{Copyright}
|
| 616 |
Revision: @{[sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
|
| 617 |
(gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3,2,1,0]]}
|
| 618 |
|
| 619 |
SYSTEM "$Info->{BaseURI}$Info->{ID}-$id.mod"
|
| 620 |
-->
|
| 621 |
|
| 622 |
EOH
|
| 623 |
|
| 624 |
$r .= $s;
|
| 625 |
|
| 626 |
$r .= qq(\n<!-- end of $Info->{ID}-$id.mod -->\n);
|
| 627 |
|
| 628 |
my $file = qq"$Info->{ID}-$id.mod";
|
| 629 |
open FILE, '>', $file or die "$0: $file: $!";
|
| 630 |
print FILE $r;
|
| 631 |
close FILE;
|
| 632 |
print STDERR "$0: $file created\n";
|
| 633 |
}
|
| 634 |
|
| 635 |
sub make_dtd ($$$$) {
|
| 636 |
my ($src, $Info, $id, $s) = @_;
|
| 637 |
$id = "-$id" if $id;
|
| 638 |
|
| 639 |
my $r = <<EOH;
|
| 640 |
<!-- $Info->{Name} : Document Type Definition
|
| 641 |
|
| 642 |
Copyright @{[(gmtime)[5]+1900]} $Info->{Copyright}
|
| 643 |
Revision: @{[sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
|
| 644 |
(gmtime)[5]+1900, (gmtime)[4]+1, (gmtime)[3,2,1,0]]}
|
| 645 |
|
| 646 |
SYSTEM "$Info->{BaseURI}$Info->{ID}$id.dtd"
|
| 647 |
-->
|
| 648 |
|
| 649 |
EOH
|
| 650 |
|
| 651 |
$r .= $s;
|
| 652 |
|
| 653 |
$r .= qq(\n<!-- end of $Info->{ID}$id.dtd -->\n);
|
| 654 |
|
| 655 |
my $file = qq"$Info->{ID}$id.dtd";
|
| 656 |
open FILE, '>', $file or die "$0: $file: $!";
|
| 657 |
print FILE $r;
|
| 658 |
close FILE;
|
| 659 |
print STDERR "$0: $file created\n";
|
| 660 |
}
|
| 661 |
|
| 662 |
|
| 663 |
=head1 NAME
|
| 664 |
|
| 665 |
mkdtds.pl --- Moduralized XML Document Type Definition Generator
|
| 666 |
|
| 667 |
=head1 DESCRIPTION
|
| 668 |
|
| 669 |
This script can be used to generate XML DTD modules and driver
|
| 670 |
which is interoperable with XHTML DTD modules.
|
| 671 |
|
| 672 |
=head1 USAGE
|
| 673 |
|
| 674 |
$ perl mkdtds.pl driver.dds
|
| 675 |
mkdtds.pl: driver.dtd created
|
| 676 |
mkdtds.pl: driver-model.mod created
|
| 677 |
|
| 678 |
$ perl mkdtds.pl moduleset.dms
|
| 679 |
mkdtds.pl: moduleset-datatype.mod created
|
| 680 |
mkdtds.pl: moduleset-attrib.mod created
|
| 681 |
mkdtds.pl: moduleset-module1.mod created
|
| 682 |
|
| 683 |
=head1 DTD SOURCE FORMAT
|
| 684 |
|
| 685 |
(((See examples on <http://suika.fam.cx/gate/cvs/markup/>)))
|
| 686 |
|
| 687 |
=head1 REQUIRED MODULE
|
| 688 |
|
| 689 |
This script uses SuikaWiki::Markup::SuikaWikiConfig20 and
|
| 690 |
SuikaWiki::Markup::SuikaWikiConfig20::Parser.
|
| 691 |
Please get it from <http://suika.fam.cx/gate/cvs/suikawiki/script/lib/>
|
| 692 |
and put into your lib directory.
|
| 693 |
|
| 694 |
=head1 AUTHOR
|
| 695 |
|
| 696 |
Wakaba <w@suika.fam.cx>
|
| 697 |
|
| 698 |
=head1 LICENSE
|
| 699 |
|
| 700 |
Copyright 2003 Wakaba <w@suika.fam.cx>
|
| 701 |
|
| 702 |
This program is free software; you can redistribute it and/or
|
| 703 |
modify it under the same terms as Perl itself.
|
| 704 |
|
| 705 |
Note that author claims no right about DTD modules generated by this script.
|
| 706 |
Author(s) of DTD modules should be explicily state their license terms.
|
| 707 |
|
| 708 |
=cut
|
Parent Directory
| 
Revision Log