1: #!/usr/local/bin/perl -w 2: use strict; 4: use lib ("."); 5: use SGML::ElementMap; 7: use Data::Locations::Shell; 8: use Symbol; 10: my $dtddesc = $ARGV[0]; 11: my $of= $ARGV[1]; 12: my $sgml = new SGML::ElementMap; 14: die "$0 needs more updating to SGML::ElementMap : uses SPGrove data model"; 16: $sgml->element('',sub { 17: my ($sgml,$element) = @_; 18: $sgml->suppress_content; 19: }); 21: $sgml->cdata('',sub { 22: my ($sgml,$data) = @_; 23: $sgml->stack('content',$data); 24: }); 25: $sgml->pi('',sub { 26: my ($sgml,$data) = @_; 27: }); 29: $sgml->element('DTD',sub { 30: my ($sgml,$element) = @_; 31: my (%attspec,@entities,$el,$att,$out,$entout); 32: #$sgml->global('attribute list hash',\%attspec); 33: #$sgml->global('element list',\@elements); 34: $out = new Data::Locations::Shell($of); 35: $entout = $out->new; 36: $sgml->global('element print location',$out); 37: $sgml->global('entity list',\@entities); 38: $sgml->process_content_filt('entity references',{}); 39: #$sgml->global('entity print location')->dump; 40: { 41: my ($continue,%declared,$changed,$ok,$deps,$dep,$ent,$entspec,$spec); 42: #@entities = sort @entities; 43: $continue = 1; 44: %declared = (); 45: while ($continue) { 46: $continue = 0; 47: $changed = 0; 48: foreach $entspec (@entities) { 49: next unless defined $entspec; 50: ($ent,$deps,$spec) = @$entspec; 51: $ok = 1; 52: foreach $dep (@$deps) { 53: last unless ($ok = ($ok && $declared{$dep})); 54: } 55: if ($ok) { 56: $declared{$ent} = 1; 57: $changed = 1; 58: print $entout $spec; 59: $entspec = undef; 60: } else { 61: $continue = 1; 62: } 63: } 64: if ($continue && !$changed) { 65: warn "$0:ERROR:Entities cannot be ordered\n"; 66: last; 67: } 68: } 69: } 70: $sgml->global('element print location')->dump; 71: }); 73: $sgml->element('ELEMENT',sub { 74: my ($sgml,$element) = @_; 75: my ($model,$iden,$attrlist,$ref,$ellist,$out,$att); 76: ($model,$iden,$attrlist) = 77: $sgml->process_content_filt('model','','identifier','', 78: 'attribute list',[]); 79: $out = $sgml->global('element print location'); 80: print $out '<!ELEMENT ' . $iden ." " . $model . " >\n"; 81: if (@$attrlist > 0) { 82: #$ref = $sgml->global('attribute list hash'); 83: #$$ref{$iden} = $attrlist; 84: print $out "<!ATTLIST $iden\n"; 85: foreach $att (@$attrlist) { 86: print $out " " . $att . "\n"; 87: } 88: print $out ">\n"; 89: } 90: #$ellist = $sgml->global('element list'); 91: #push @$ellist,$iden; 92: }); 94: $sgml->element('MODEL-ABBREV',sub { 95: my ($sgml,$element) = @_; 96: my ($model,$iden,$ents,@ents,$decl); 97: ($model,$iden,$ents) = $sgml->process_content_filt('model','', 98: 'identifier','', 99: 'entity references',{}); 100: $model = substr $model,4; #strip off tag minimization 101: $decl = '<!ENTITY % ' . $iden .' "' . $model . "\" >\n"; 103: @ents = keys %$ents; 104: $ents = $sgml->global('entity list'); 105: push @$ents,[$iden,\@ents,$decl]; 106: }); 108: $sgml->element('ATTR-ABBREV',sub { 109: my ($sgml,$element) = @_; 110: my ($attrlist,$iden,$ref,$ents,@ents,$decl); 111: ($iden,$attrlist,$ents) = 112: $sgml->process_content_filt('identifier',"",'attribute list',[], 113: 'entity references',{}); 114: $decl = '<!ENTITY % '.$iden.' "'.join("\n ",@$attrlist)."\" >\n"; 115: @ents = keys %$ents; 116: $ents = $sgml->global('entity list'); 117: push @$ents,[$iden,\@ents,$decl]; 118: }); 121: $sgml->element('IDENTIFIER',sub { 122: my ($sgml,$element) = @_; 123: my ($content) = $sgml->process_content_filt('content',""); 124: $sgml->stack('identifier',$content); 125: }); 127: $sgml->element('MODEL',sub { 128: my ($sgml,$element) = @_; 129: my ($data,$model,$inc,$exc,$ref); 130: $data = ''; 131: ($model,$inc,$exc) = $sgml->process_content_filt('model','', 132: 'model inclusion','', 133: 'model exclusion',''); 134: #note: assume exactly 4 characters are added for tag minimization 135: if ($element->attr('REQ.START')->value eq 'REQ.START') { 136: $data .= '- '; 137: } else { 138: $data .= 'O '; 139: } 140: if ($element->attr('REQ.END')->value eq 'REQ.END' && $model ne 'EMPTY') { 141: $data .= '- '; 142: } else { 143: $data .= 'O '; 144: } 146: $data .= $model; #join '',@ 147: $data .= ' '.$inc if ($inc ne ''); 148: $data .= ' '.$exc if ($exc ne ''); 149: 150: $ref = $sgml->stackrefs('model'); 151: $$ref = $data; 152: }); 154: $sgml->element('SEQUENCE',sub { ModelGroup(',',@_); }); 155: $sgml->element('CHOICE',sub { ModelGroup('|',@_); }); 156: $sgml->element('SET',sub { ModelGroup('&',@_); }); 158: $sgml->element('INCLUDE',sub { 159: my ($sgml,$element) = @_; 160: my ($ref,$model); 161: ($model) = $sgml->process_content_filt('model',[]); 162: if (@$model > 0) { 163: $ref = $sgml->stackrefs('model inclusion'); 164: $$ref .= '+('.join(',',@$model).')'; 165: } 166: }); 168: $sgml->element('EXCLUDE',sub { 169: my ($sgml,$element) = @_; 170: my ($ref,$model); 171: ($model) = $sgml->process_content_filt('model',[]); 172: if (@$model > 0) { 173: $ref = $sgml->stackrefs('model exclusion'); 174: $$ref .= '-('.join(',',@$model).')'; 175: } 176: }); 178: $sgml->element('TAG',sub { 179: my ($sgml,$element) = @_; 180: my ($content,$spec,$model); 181: ($content) = $sgml->process_content_filt('content',''); 182: $spec = 0; 183: $spec |= 1 if ($element->attr('OCCUR.REQ')->value eq 'REQUIRED'); 184: $spec |= 2 if ($element->attr('OCCUR.REP')->value ne 'SINGLE'); 186: $model = $sgml->stackrefs('model'); 187: if (ref $$model) { 188: push @$$model,$content . ('?','','*','+')[$spec]; 189: } else { 190: $$model = '(' . $content . ')' . ('?','','*','+')[$spec]; 191: } 192: }); 194: $sgml->element('MODEL//ABBREV',sub { 195: my ($sgml,$element) = @_; 196: my ($content,$spec,$model,$ref); 197: ($content) = $sgml->process_content_filt('content',''); 198: $ref = $sgml->stack('entity references'); 199: $$ref{$content} = 1; 200: $content = '%' . $content . ';'; 201: $spec = 0; 202: $spec |= 1 if ($element->attr('OCCUR.REQ')->value eq 'REQUIRED'); 203: $spec |= 2 if ($element->attr('OCCUR.REP')->value ne 'SINGLE'); 205: $model = $sgml->stackrefs('model'); 206: if (ref $$model) { 207: push @$$model,('(','','(','(')[$spec] . $content . (')?','',')*',')+')[$spec]; 208: } else { 209: $$model = '(' . $content . ')' . ('?','','*','+')[$spec]; 210: } 211: }); 213: $sgml->element('PARSED',sub { 214: my ($sgml,$element) = @_; 215: my ($model); 216: $model = $sgml->stackrefs('model'); 217: if (ref $$model) { 218: push @$$model,'#PCDATA'; 219: } else { 220: $$model = '(#PCDATA)'; 221: } 222: }); 224: $sgml->element('UNPARSED',sub { ModelStatic('CDATA',@_); }); 225: $sgml->element('REPLACEABLE',sub { ModelStatic('RCDATA',@_); }); 226: $sgml->element('ANY',sub { ModelStatic('ANY',@_); }); 227: $sgml->element('EMPTY',sub { ModelStatic('EMPTY',@_); }); 230: $sgml->element('ATTRIBUTES',sub { 231: my ($sgml,$element) = @_; 232: if (defined $sgml->stack('attribute list')) { 233: $sgml->process_content; 234: } else { 235: $sgml->suppress_content; 236: } 237: }); 239: $sgml->element('ATTRIBUTES/ABBREV',sub { 240: my ($sgml,$element) = @_; 241: my ($attrlist,$content,$ref); 242: ($content) = $sgml->process_content_filt('content',''); 243: $ref = $sgml->stack('entity references'); 244: $$ref{$content} = 1; 245: $content = '%' . $content . ';'; 246: $attrlist = $sgml->stack('attribute list'); 247: push @$attrlist,$content; 248: }); 250: $sgml->element('ATTRIBUTE',sub { 251: my ($sgml,$element) = @_; 252: my ($iden,$valspec,$attrlist); 253: ($iden,$valspec) = $sgml->process_content_filt('identifier',"", 254: 'value specification',""); 255: $attrlist = $sgml->stack('attribute list'); 256: push @$attrlist,"$iden $valspec"; 257: #print "ATTR:<$iden $valspec >\n"; 258: }); 260: $sgml->element('VALUE',sub { 261: my ($sgml,$element) = @_; 262: $sgml->process_content; 263: }); 265: $sgml->element('VALUE//ABBREV',sub { 266: my ($sgml,$element) = @_; 267: my ($spec,$content,$ref); 268: ($content) = $sgml->process_content_filt('content',''); 269: $ref = $sgml->stack('entity references'); 270: $$ref{$content} = 1; 271: $content = '%' . $content . ';'; 272: $spec = $sgml->stack('value specification'); 273: if (ref $spec) { 274: push @$spec,$content; 275: } else { 276: $sgml->stack('value specification',$content); 277: } 278: }); 280: $sgml->element('SELECT',sub { 281: my ($sgml,$element) = @_; 282: my ($defval,$vallist,$spec,$deftype,$tok,$valtype); 283: ($vallist,$defval) = $sgml->process_content_filt('value specification',[], 284: 'default value',""); 285: $spec = ''; 286: $valtype = 'tok'; 287: foreach $tok (@$vallist) { 288: $spec .= "|$tok" if $spec ne ""; 289: $spec = "$tok" if $spec eq ""; 290: $valtype = 'cdata' if $tok eq ""; 291: } 292: $deftype = $element->attr('CONTENT-SPEC')->value; 293: if ($valtype eq 'tok') { 294: if ($deftype eq 'DEFAULT') { 295: $spec = "($defval|$spec) $defval"; 296: } elsif ($deftype eq 'CONSTANT') { 297: $spec = "NMTOKEN #FIXED $defval"; 298: } elsif ($deftype eq 'REQUIRED') { 299: $spec = "($spec) "."#REQUIRED"; 300: } else { 301: $spec = "--unhandled: $deftype/$spec--"; 302: } 303: } else { 304: if ($deftype eq 'DEFAULT') { 305: $spec = "CDATA \"$defval\""; 306: } elsif ($deftype eq 'CONSTANT') { 307: $spec = "CDATA #FIXED $defval"; 308: } elsif ($deftype eq 'REQUIRED') { 309: $spec = "CDATA "."#REQUIRED"; 310: } else { 311: $spec = "--unhandled: $deftype/$spec--"; 312: } 313: 314: } 315: $sgml->stack('value specification',$spec); 316: }); 318: $sgml->element('DEFAULT',sub { 319: my ($sgml,$element) = @_; 320: my ($val) = $sgml->process_content_filt('value specification',""); 321: $val =~ s/^(\S*\s+)//; 322: $sgml->stack('default value',$val); 323: }); 325: $sgml->element('VALUE//TOKEN',sub { 326: my ($sgml,$element) = @_; 327: my $deftype = $element->attr('CONTENT-SPEC')->value; 328: my $list = $element->attr('LIST')->value; 329: AttrValLeaf($sgml,'NMTOKEN',$deftype,$list); 330: }); 331: sub dummy { 332: my ($sgml,$element) = @_; 333: my ($content,$spec,$deftype); 334: ($content) = $sgml->process_content_filt('content',""); 335: $spec = $sgml->stack('value specification'); 336: if (ref $spec) { 337: push @$spec,$content; 338: } else { 339: $deftype = $element->attr('CONTENT-SPEC')->value; 340: if ($deftype eq 'DEFAULT') { 341: $content = "NMTOKEN $content"; 342: } elsif ($deftype eq 'CONSTANT') { 343: $content = "NMTOKEN #FIXED $content"; 344: } elsif ($deftype eq 'REQUIRED') { 345: $content = "NMTOKEN "."#REQUIRED"; 346: } else { 347: $content = "--unhandled: $deftype/$content--"; 348: } 349: $sgml->stack('value specification',$content); 350: } 351: } 352: $sgml->element('VALUE//DATA',sub { 353: my ($sgml,$element) = @_; 354: my ($content,$spec,$deftype); 355: ($content) = $sgml->process_content_filt('content',""); 356: $spec = $sgml->stack('value specification'); 357: if (ref $spec) { 358: push @$spec,''; 359: } else { 360: $deftype = $element->attr('CONTENT-SPEC')->value; 361: if ($deftype eq 'DEFAULT') { 362: $content = "CDATA \"$content\""; 363: } elsif ($deftype eq 'CONSTANT') { 364: $content = "CDATA #FIXED \"$content\""; 365: } elsif ($deftype eq 'REQUIRED') { 366: $content = "CDATA "."#REQUIRED"; 367: } else { 368: $content = "--unhandled: $deftype/$content--"; 369: } 370: $sgml->stack('value specification',$content); 371: } 372: }); 373: $sgml->element('VALUE//NUMBER',sub { 374: my ($sgml,$element) = @_; 375: my $deftype = $element->attr('CONTENT-SPEC')->value; 376: my $list = $element->attr('LIST')->value; 377: AttrValLeaf($sgml,'NUMBER',$deftype,$list); 378: }); 379: $sgml->element('VALUE//NAME',sub { 380: my ($sgml,$element) = @_; 381: my $deftype = $element->attr('CONTENT-SPEC')->value; 382: my $list = $element->attr('LIST')->value; 383: AttrValLeaf($sgml,'NMTOKEN',$deftype,$list); 384: }); 385: $sgml->element('VALUE//ID',sub { 386: my ($sgml,$element) = @_; 387: my $deftype = $element->attr('CONTENT-SPEC')->value; 388: my $list = $element->attr('LIST')->value; 389: AttrValLeaf($sgml,'ID',$deftype,$list); 390: }); 391: $sgml->element('VALUE//IDREF',sub { 392: my ($sgml,$element) = @_; 393: my $deftype = $element->attr('CONTENT-SPEC')->value; 394: my $list = $element->attr('LIST')->value; 395: AttrValLeaf($sgml,'IDREF',$deftype,$list); 396: }); 397: sub AttrValLeaf { 398: my ($sgml,$type,$deftype,$list) = @_; 399: my ($spec,$content); 400: ($content) = $sgml->process_content_filt('content',""); 401: $spec = $sgml->stack('value specification'); 402: if (ref $spec) { 403: push @$spec,$content; 404: } else { 405: $content = '"' . $content . '"' if ($type eq 'CDATA'); 406: $type .= 'S' if ($type ne 'CDATA' && $list eq 'LIST'); 407: if ($deftype eq 'DEFAULT') { 408: $content = "$type $content"; 409: } elsif ($deftype eq 'CONSTANT') { 410: $content = "$type #FIXED $content"; 411: } elsif ($deftype eq 'REQUIRED') { 412: $content = "$type "."#REQUIRED"; 413: } elsif ($deftype eq 'IMPLIABLE') { 414: $content = "$type "."#IMPLIED"; 415: } elsif ($deftype eq 'RUNNING') { 416: $content = "$type "."#CURRENT"; 417: } elsif ($deftype eq 'CONTENT-REF') { 418: $content = "$type "."#CONREF"; 419: } else { 420: $content = "--unhandled: $deftype/$content--"; 421: } 422: $sgml->stack('value specification',$content); 423: } 424: } 426: $sgml->element('ELEMENT-GROUP',sub { 427: my ($sgml,$element) = @_; 428: my ($iden,$ellist,$ents,@ents,$decl); 429: ($iden,$ellist,$ents) = 430: $sgml->process_content_filt('identifier','','element list',[], 431: 'entity references',{}); 432: $decl = '<!ENTITY % ' . $iden . ' "'.join('|',@$ellist)."\" >\n"; 433: @ents = keys %$ents; 434: $ents = $sgml->global('entity list'); 435: push @$ents,[$iden,\@ents,$decl]; 436: }); 438: $sgml->element('ELEMENT-GROUP//TAG',sub { 439: my ($sgml,$element) = @_; 440: my ($content,$list); 441: ($content) = $sgml->process_content_filt('content',''); 442: $list = $sgml->stack('element list'); 443: push @$list,$content; 444: }); 446: #$sgml->element('',sub { 447: # my ($sgml,$element) = @_; 448: # 449: #}); 451: $sgml->process_sgml_sysid($dtddesc); 453: exit 0; 455: sub ModelGroup { 456: my ($cn,$sgml,$element) = @_; 457: my ($model,$ref,$spec,$data); 458: ($model) = $sgml->process_content_filt('model',[]); 459: $spec = 0; 460: $spec |= 1 if ($element->attr('OCCUR.REQ')->value eq 'REQUIRED'); 461: $spec |= 2 if ($element->attr('OCCUR.REP')->value ne 'SINGLE'); 462: $data = '('.join($cn,@$model).')'; 463: $data .= ('?','','*','+')[$spec]; 464: $ref = $sgml->stackrefs('model'); 465: if (ref $$ref) { 466: push @$$ref,$data; 467: } else { 468: $$ref = $data; 469: } 470: } 471: sub ModelStatic { 472: my ($data,$sgml,$element) = @_; 473: my $model = $sgml->stackrefs('model'); 474: if (ref $$model) { 475: push @$$model,$data; 476: } else { 477: $$model = $data; 478: } 479: }