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: }