source: 1dwg/trunk/archives/cansas-2007/dtd2xsd.pl @ 7

Last change on this file since 7 was 7, checked in by prjemian, 13 years ago

use trunk,tags,branches

File size: 19.8 KB
Line 
1#! perl
2#
3# by Dan Connolly http://www.w3.org/People/Connolly/ connolly@w3.org
4#    Bert Bos http://www.w3.org/People/Bos/ <bert@w3.org>
5#    Yuichi Koike
6#    Mary Holstege (holstege@mathling.com)
7# initial hack by DC Apr 2000, based on dtd2bnf by BB Mar 1998;
8# major revision to Apr 2000 make it actually usable by YK;
9# tweaks by DC; major update Jan 2001 by MH
10#
11# see Log since then at end.
12# $Id: dtd2xsd.pl,v 1.17 2001/01/19 05:59:12 connolly Exp $
13
14use strict;
15
16# Handling command line argument
17my $targetNS = "http://www.w3.org/namespace/";
18my $prefix = "t";
19my $alias = 0;
20my $file = "";
21my %SimpleTypes;
22my @AttrGroupPatterns;
23my @ModelGroupPatterns;
24my @SubstitutionGroupPatterns;
25my %SubstitutionGroup;
26
27my %Mixed;
28my %ModelGroup;
29my $mapping_file;
30my $pcdata_flag = 0;
31my $pcdata_simpletype = "string";
32my $debug = 0;
33
34while ($#ARGV >= 0) {
35         my $para = shift(@ARGV);
36         if ($para eq "-ns") {
37                  $targetNS = shift(@ARGV);
38         } elsif ($para eq "-prefix") {
39                  $prefix = shift(@ARGV);
40         } elsif ($para eq "-alias") {
41                  $alias = 1;
42         } elsif ($para eq "-pcdata") {
43                  # Treat #PCDATA by itself as being string (or other simple type
44                  # if so designated in the mapping file)
45                  $pcdata_flag = 1;
46         } elsif ($para eq "-mapfile") {
47                  $mapping_file = shift(@ARGV);
48         } elsif ($para eq "-simpletype") {
49                  my($pat) = shift(@ARGV);
50                  my($b) = shift(@ARGV);
51                  $SimpleTypes{$pat} = $b;
52         } elsif ($para eq "-attrgroup") {
53                  push(@AttrGroupPatterns, shift(@ARGV));
54         } elsif ($para eq "-modelgroup") {
55                  push(@ModelGroupPatterns, shift(@ARGV));
56         } elsif ($para eq "-substgroup") {
57                  push(@SubstitutionGroupPatterns, shift(@ARGV));
58         } elsif ($para eq "-debug") {
59                  $debug = 1;
60         } else {
61                  $file = $para;
62         }
63}
64
65# Alias dictionary: defaults
66my %alias_dic;
67$alias_dic{"URI"} = "uriReference";
68$alias_dic{"LANG"} = "language";
69$alias_dic{"NUMBER"} = "nonNegativeInteger";
70$alias_dic{"Date"} = "date";
71$alias_dic{"Boolean"} = "boolean";
72
73if ( $mapping_file )
74{
75         print STDERR "Open mapping $mapping_file ";
76         if ( !open( MAPPINGS, "<$mapping_file" ) )
77         {
78                  print STDERR "unsuccessful.\n";
79         }
80         else {
81                  print STDERR "successful.\n";
82                  while ( <MAPPINGS> ) {
83                                chop;
84                                if ( /^alias\s+([^ \t]+)\s*=\s*([^ \t]+)\s*/i ) {
85                                         $alias_dic{$1} = $2;
86                                }
87                                elsif ( /^simpletype\s+([^ \t]+)\s*=\s*([^ \t]+)\s*/i ) {
88                                         $SimpleTypes{$1} = $2;
89                                }
90                                elsif ( /^attrgroup\s+([^ \t]+)\s*/i ) {
91                                         push( @AttrGroupPatterns, $1 );
92                                }
93                                elsif ( /^modelgroup\s+([^ \t]+)\s*/i ) {
94                                         push( @ModelGroupPatterns, $1 );
95                                }
96                                elsif ( /^substgroup\s+([^ \t]+)\s*/i ) {
97                                         push( @SubstitutionGroupPatterns, $1 );
98                                }
99                                elsif ( /^pcdata\s+([^ \t]+)\s*/i ) {
100                                         ## BUGLET: doesn't pay attention to prefix; just a special alias
101                                         $pcdata_simpletype = $1;
102                                }
103                  }
104         }
105
106         foreach my $key (keys(%alias_dic)) 
107         {
108                  print STDERR "Alias \%$key to $alias_dic{$key}\n"
109                  }
110}
111
112# Variable declaration
113my $linelen = 72;
114
115my $PROG = substr($0, rindex($0, "/") + 1);
116my $USAGE = "Usage: $PROG file\n";
117
118my $str = "(?:\"([^\"]*)\"|\'([^\']*)\')";
119my %pent;                               # Parameter entities
120my %attributes;                 # Attribute lists
121my @element;                    # Elements in source order
122my %model;                              # Content models
123
124# Main
125$/ = undef;
126
127# Open file, remove comment and include external entity
128my $buf = openFile($file);
129
130# Alias treatment
131my $alias_ident = "_alias_";
132if ($alias eq 1) {
133         foreach my $key (keys(%alias_dic)) {
134                  my $aliaskey = sprintf("%s%s%s", $alias_ident, $key, $alias_ident);
135                  $buf =~ s/\%$key;/$aliaskey/gsie;
136         }
137}
138
139
140# store all parameter entities
141while ($buf =~ s/<!ENTITY\s+%\s+(\S+)\s+$str\s*>//sie) {
142    my($n, $repltext) = ($1, $2.$3);
143    my ($pat);
144
145    next if $pent{$n}; # only the first declaration of an entity counts
146
147    foreach $pat (keys %SimpleTypes){
148                  if ($n =~ /^$pat$/){
149                                $buf .= " <!_DATATYPE $n $SimpleTypes{$pat} $repltext> ";
150                                $pent{$n} = "#DATATYPEREF $n";
151                                undef $n;
152                                last;
153                  }
154    }
155
156    foreach $pat (@AttrGroupPatterns){
157                  if ($n =~ /^$pat$/){
158                                $buf .= " <!_ATTRGROUP $n $repltext> ";
159                                $pent{$n} = "#ATTRGROUPREF $n";
160                                undef $n;
161                                last;
162                  }
163    }
164
165    foreach $pat (@ModelGroupPatterns){
166                  if ($n =~ /^$pat$/){
167                                $buf .= " <!_MODELGROUP $n $repltext> ";
168                                $pent{$n} = "#MODELGROUPREF $n";
169                                undef $n;
170                                last;
171                  }
172    }
173
174    foreach $pat (@SubstitutionGroupPatterns){
175                  if ($n =~ /^$pat$/){
176                                $buf .= " <!_SUBSTGROUP $n $repltext> ";
177                                $pent{$n} = "#SUBSTGROUPREF $n";
178                                undef $n;
179                                last;
180                  }
181
182    }
183
184    $pent{$n}=$repltext if $n;
185}
186
187# remove all general entities
188$buf =~ s/<!ENTITY\s+.*?>//gsie;
189
190# loop until parameter entities fully expanded
191my $i;
192do {
193         # count # of substitutions
194         $i = 0;
195         # expand parameter entities
196         $buf =~ s/%([a-zA-Z0-9_\.-]+);?/$i++,$pent{$1}/gse;
197} while ($i != 0);
198
199# treat conditional sections
200while($buf =~ s/<!\[\s*?INCLUDE\s*?\[(.*)\]\]>/\1/gsie) {};
201while($buf =~ s/<!\[\s*?IGNORE\s*?\[.*\]\]>//gsie) {};
202
203# store attribute lists
204$buf =~ s/<!ATTLIST\s+(\S+)\s+(.*?)>/store_att($1, $2)/gsie;
205
206# store content models
207$buf =~ s/<!ELEMENT\s+(\S+)\s+(.+?)>/store_elt($1, $2)/gsie;
208
209#print "<?xml version='1.0'?>\n";
210print "<schema
211  xmlns='http://www.w3.org/2001/XMLSchema'
212  targetNamespace='$targetNS'
213  xmlns:$prefix='$targetNS'>\n";
214
215# find maximum length of non-terminals
216#my $maxlen = max(map(length, @element)) + 4;
217
218# write simple type declarations
219$buf =~ s/<!_DATATYPE\s+(\S+)\s+(\S+)\s+(.+?)>/write_simpleType($1, $2, $3)/gsie;
220
221# write attribute groups
222$buf =~ s/<!_ATTRGROUP\s+(\S+)\s+(.+?)>/write_attrGroup($1, $2)/gsie;
223
224# write model groups
225$buf =~ s/<!_MODELGROUP\s+(\S+)\s+(.+?)>/write_modelGroup($1, $2)/gsie;
226
227# write subsitution groups
228$buf =~ s/<!_SUBSTGROUP\s+(\S+)\s+(.+?)>/write_substitutionGroup($1, $2)/gsie;
229
230
231my($e);
232
233# loop over elements, writing XML schema
234foreach $e (@element) {
235         my $h = $model{$e};
236         my $h2 = $attributes{$e};
237         my @model = @$h;
238         my $isSimple = ($pcdata_flag eq 1) && ($model[1] eq '#PCDATA') &&
239                  ( ($#model eq 2) || 
240                         ( ($#model eq 3) && ($model[3] eq '*') ) );
241
242         my $substGroup = $SubstitutionGroup{$e};
243         if ( $substGroup )
244         {
245                  $substGroup = " substitutionGroup='$substGroup'";
246         }
247
248         # print rule for element $e
249         if ( $isSimple && ! $h2 )
250         {
251                  # Assume (#PCDATA) is string
252                  print "\n <element name='$e' type='$pcdata_simpletype'$substGroup>\n";
253         }
254         else {
255                  print "\n <element name='$e'$substGroup>\n";
256         }
257
258         if ( $isSimple )
259         {
260                  # Assume (#PCDATA) is string
261                  if ( $h2 ) 
262                  {
263                                print "  <complexType>\n";
264                                print "  <simpleContent>\n";
265                                print "  <extension base='string'>\n";
266                  }
267         }
268
269         else {
270                  # print rule for $e's content model
271                  print "  <complexType";
272                  if ($model[0] eq 'EMPTY') {
273                                if (! $h2 ) {
274                                         print "/>\n";
275                                } else {
276                                         print ">\n";
277                                }
278                  } 
279                  elsif ( $model[0] eq 'ANY' )
280                  {
281                                print ">\n";
282                                print "   <sequence>\n";
283                                print "   <any namespace='$targetNS'/>\n";
284                                print "   </sequence>\n";
285                  }
286                  else {
287                                if ( $debug eq 1 ) {
288                                         print STDERR "==mixed? @model\n"; #@@
289                                }
290                                if (&isMixed(@model)) {
291                                         print " mixed='true'>\n";
292                                }
293                                else {
294                                         print ">\n";
295                                }
296
297                                my @list = &makeChildList('', @model);
298                                &printChildList(3, @list);
299                  }
300         }
301
302         # print rule for $e's attributes
303         if (! $h2) {
304                  # nothing
305         } else {
306                  &printAttrDecls(@$h2);
307                  if ( $isSimple ) {
308                                print "   </extension>\n";
309                                print "   </simpleContent>\n";
310                  }
311         }
312
313         if ( !$h2 && $isSimple ) {
314                  # Do nothing
315         }
316         elsif ($h2 || $model[0] ne 'EMPTY') {
317                  print "  </complexType>\n";
318         }
319
320         print " </element>\n";
321}
322
323print "</schema>\n";
324exit;
325
326sub printSpace
327{
328         my ($num) = $_[0];
329         for (my $i=0; $i<$num; $i++) {
330                  print " ";
331         }
332}
333
334sub printChildList
335{
336         my ($num, @list) = @_;
337
338         my @currentTag = ();
339         for (my $i=0; $i<= $#list; $i++) {
340                  my $n = $list[$i];
341
342                  if ($n eq 0 || $n eq 1 || $n eq 2 || $n eq 3) {
343                                if ( ($pcdata_flag eq 0) && ($n eq 0 || $n eq 1) && $list[$i+1] eq 20)
344                                {
345                                         # The whole list is 0 20 or 1 20; i.e. (#PCDATA) or (#PCDATA)*.
346                                         # Don't generate a sequence child; mixed handles all this.
347                                }
348                                else {
349#            my $do_it_flag = 1;
350                                         if ( $currentTag[$#currentTag] eq "" && $n eq 0 )
351                                         {
352                                                  push(@currentTag, "");
353#                                        my $n_1 = $list[$i+1];
354#                                        if ( $n_1 eq 10 || $n_1 eq 11 || $n_1 eq 12 || $n_1 eq 13 )
355#                                        {
356#                                                 # do nothing: we have a phantom sequence wrapping a choice
357#                                                 # that we want to not want to appear. OTOH we want a top
358#                                                 # level sequence in other cases.
359#                                                 $do_it_flag = 0;
360#                                        }
361                                         }
362
363#                               if ( $do_it_flag eq 1 )
364#  {
365                                         printSpace($num); $num++;
366                                         print "<sequence";
367                                         if ($n eq 1) {
368                                                  print " minOccurs='0' maxOccurs='unbounded'";
369                                         } elsif ($n eq 2) {
370                                                  print " maxOccurs='unbounded'";
371                                         } elsif ($n eq 3) {
372                                                  print " minOccurs='0' maxOccurs='1'";
373                                         }
374                                         print ">\n";
375                                         push(@currentTag, "sequence");
376                                }
377#}
378                  } elsif ($n eq 10 || $n eq 11 || $n eq 12 || $n eq 13) {
379                                printSpace($num); $num++;
380                                print "<choice";
381                                if ($n eq 11) {
382                                         print " minOccurs='0' maxOccurs='unbounded'";
383                                } elsif ($n eq 12) {
384                                         print " maxOccurs='unbounded'";
385                                } elsif ($n eq 13) {
386                                         print " minOccurs='0' maxOccurs='1'";
387                                }
388                                print ">\n";
389                                push(@currentTag, "choice");
390                  } elsif ($n eq 20) {
391                                my $tag = pop(@currentTag);
392                                if ($tag ne "") {
393                                         $num--; printSpace($num);
394                                         print "</", $tag, ">\n";
395                                }
396                  } else {
397                                printSpace($num);
398                                if ($n eq '#MODELGROUPREF') {
399                                         print "<group ref='$prefix:$list[++$i]'";
400                                }
401                                elsif ($n eq '#SUBSTGROUPREF') {
402                                         print "<element ref='$prefix:$list[++$i]'";
403                                } else {
404                                         print "<element ref='$prefix:$n'";
405                                }
406
407                                if ($currentTag[$#currentTag] ne "choice") {
408                                         if ($list[$i+1] eq "+") {
409                                                  print " maxOccurs='unbounded'";
410                                                  $i++;
411                                         } elsif ($list[$i+1] eq "?") {
412                                                  print " minOccurs='0' maxOccurs='1'";
413                                                  $i++;
414                                         } elsif ($list[$i+1] eq "*") {
415                                                  print " minOccurs='0' maxOccurs='unbounded'";
416                                                  $i++;
417                                         }
418                                }
419                                print "/>\n";
420                  }
421         }
422}
423
424sub makeChildList {
425         my ($groupName, @model) = @_;
426         my @ret = ();
427         my @brace = ();
428         for (my $i=0; $i<=$#model; $i++) {
429                  my $n = $model[$i];
430
431                  if ($n eq "(") {
432                                push(@ret, 0);
433                                push(@brace, $#ret);
434                  } elsif ($n eq ")") {
435                                if ($model[$i+1] eq "*") {
436                                         $ret[$brace[$#brace]] += 1;
437                                         $i++;
438                                } elsif ($model[$i+1] eq "+") {
439                                         $ret[$brace[$#brace]] += 2;
440                                         $i++;
441                                } elsif ($model[$i+1] eq "?") {
442                                         $ret[$brace[$#brace]] += 3;
443                                         $i++;
444                                }
445                                pop(@brace);
446                                push(@ret, 20);
447                  } elsif ($n eq ",") {
448                                $ret[$brace[$#brace]] = 0;
449                  } elsif ($n eq "|") {
450                                $ret[$brace[$#brace]] = 10;
451                  } elsif ($n eq "#PCDATA") {
452                                if ($model[$i+1] eq "|") {
453                                         $i++;
454                                }
455                                if($groupName){
456                                         $Mixed{$groupName} = 1;
457                                }
458                  } else {
459                                push(@ret, $n);
460                  }
461         }
462
463         # "( ( a | b | c )* )" gets mapped to "0 10 a b c 20 20" which will generate
464         # a spurious sequence element. This is not too harmful when this is an
465         # element content model, but with model groups it is incorrect.
466         # In general we need to strip off 0 20 from the ends when it is redundant.
467         # Redundant means: there is some other group that bounds the whole list.
468         # Note that it gets a little tricky:
469         # ( (a|b),(c|d) ) gets mapped to "0 10 a b 20 10 c d 20 20". If one
470         # naively chops off the 0 and 20 on the groups that there is a 10 on one
471         # end and a 20 on the other, one loses the bounding sequence, which is
472         # required in this case.
473         #
474         if ( $ret[0] eq 0 && $ret[$#ret] eq 20 && $ret[$#ret-1] eq 20 &&
475                        ( $ret[1] eq 0 || $ret[1] eq 1 || $ret[1] eq 2 || $ret[1] eq 3 ||
476                          $ret[1] eq 10 || $ret[1] eq 11 || $ret[1] eq 12 || $ret[1] eq 13 )
477                        )
478         {
479                  # OK, it is possible that the 0 20 is redundant. Now scan for balance:
480                  # All interim 20 between the proposed new start and the proposed new
481                  # final one should be at level 1 or above.
482                  my $depth = 0;
483                  my $redundant_paren = 1;  # Assume redundant until proved otherwise
484                  for ( my $i = 1; $i <= $#ret-1; $i++ )
485                  {
486                                if ( $ret[$i] eq 20 )
487                                {
488                                         $depth--;
489                                         if ( $i < $#ret-1 && $depth < 1 )
490                                         {
491                                                  $redundant_paren = 0;
492                                                  print STDERR "i=$i,depth=$depth\n";
493                                         }
494                                }
495                                elsif ( $ret[$i] eq 0 || 
496                                                  $ret[$i] eq 1 || 
497                                                  $ret[$i] eq 2 || 
498                                                  $ret[$i] eq 3 ||
499                                                  $ret[$i] eq 10 || 
500                                                  $ret[$i] eq 11 || 
501                                                  $ret[$i] eq 12 || 
502                                                  $ret[$i] eq 13 
503                                                  )
504                                {
505                                         $depth++;
506                                }
507                  }  # for
508
509                  if ( $redundant_paren eq 1 )
510                  {
511                                print STDERR "Truncating @ret\n";
512                                @ret = @ret[1..$#ret-1];
513                  }
514         }
515
516         if ( $debug eq 1 ) {
517                  print STDERR "@model to @ret\n";
518         }
519         return @ret;
520}
521
522
523sub printAttrDecls{
524    my @atts = @_;
525
526    for (my $i = 0; $i <= $#atts; $i++) {
527                  if ($atts[$i] eq '#ATTRGROUPREF'){
528                                print "   <attributeGroup ref='$prefix:$atts[$i+1]'/>\n";
529                                $i ++;
530                  } else {
531                                # attribute name
532                                print "   <attribute name='$atts[$i]'";
533
534                                # attribute type
535                                my @enume;
536                                $i++;
537                                if ($atts[$i] eq "(") {
538                                         # like `attname ( yes | no ) #REQUIRED`
539                                         $i++;
540                                         while ($atts[$i] ne ")") {
541                                                  if ($atts[$i] ne "|") {
542                                                                push(@enume, $atts[$i]);
543                                                  }
544                                                  $i++;
545                                         }
546                                } elsif ($atts[$i] eq '#DATATYPEREF'){
547                                         print " type='$prefix:$atts[++$i]'";
548                                } elsif ($alias eq 1 && $atts[$i] =~ s/$alias_ident//gsie) {
549                                         # alias special
550                                         print " type='$alias_dic{$atts[$i]}'";
551                                } elsif ($atts[$i] =~ /ID|IDREF|ENTITY|NOTATION|IDREFS|ENTITIES|NMTOKEN|NMTOKENS/) {
552                                         # common type for DTD and Schema
553                                         print " type='$atts[$i]'";
554                                } else {
555                                         # `attname CDATA #REQUIRED`
556                                         print " type='string'";
557                                }
558
559                                $i++;
560
561                                # #FIXED
562                                if($atts[$i] eq "#FIXED") {
563                                         $i++;
564                                         print " use='fixed' value='$atts[$i]'/>\n";
565                                } else {
566                                         # minOccurs
567                                         if ($atts[$i] eq "#REQUIRED") {
568                                                  print " use='required'";
569                                         } elsif ($atts[$i] eq "#IMPLIED") {
570                                                  print " use='optional'";
571                                         } else {
572                                                  print " use='default' value='$atts[$i]'";
573                                         }
574
575                                         # enumerate
576                                         if ($#enume eq -1) {
577                                                  print "/>\n";
578                                         } else {
579                                                  print ">\n";
580                                                  print "    <simpleType>\n";
581                                                  print "     <restriction base='string'>\n";
582                                                  &write_enum(@enume);
583                                                  print "     </restriction>\n";
584                                                  print "    </simpleType>\n";
585                                                  print "   </attribute>\n";
586                                         }
587                                }
588                  }
589    }
590}
591
592sub write_enum{
593    my(@enume) = @_;
594
595    for (my $j = 0; $j <= $#enume; $j++) {
596                  print "      <enumeration value='$enume[$j]'/>\n";
597    }
598}
599
600
601# Parse a string into an array of "words".
602# Words are whitespace-separated sequences of non-whitespace characters,
603# or quoted strings ("" or ''), with the quotes removed.
604# HACK: added () stuff for attlist stuff
605# Parse words for attribute list
606sub parsewords {
607         my $line = $_[0];
608         $line =~ s/(\(|\)|\|)/ $1 /g;
609         my @words = ();
610
611         while ($line ne '') {
612                  if ($line =~ /^\s+/) {
613                                # Skip whitespace
614                  } elsif ($line =~ /^\"((?:[^\"]|\\\")*)\"/) {
615                                push(@words, $1);
616                  } elsif ($line =~ /^\'((?:[^\']|\\\')*)\'/) {
617                                push(@words, $1);
618                  } elsif ($line =~ /^\S+/) {
619                                push(@words, $&);
620                  } else {
621                                die "Cannot happen\n";
622                  }
623                  $line = $';
624         }
625    return @words;
626}
627
628# Store content model, return empty string
629sub store_elt
630{
631         my ($name, $model) = @_;
632         $model =~ s/\s+/ /gso;
633         push(@element, $name);
634
635         my @words;
636         while ($model =~ s/^\s*(\(|\)|,|\+|\?|\||[\w_\.-]+|\#\w+|\*)//) {
637                  push(@words, $1);
638         };
639         $model{$name} = [ @words ];
640         return '';
641}
642
643
644# Store attribute list, return empty string
645sub store_att
646{
647         my ($element, $atts) = @_;
648         my @words = parsewords($atts);
649         $attributes{$element} = [ @words ];
650         return '';
651}
652
653sub write_simpleType{
654    my($n, $b, $stuff) = @_;
655    my @words = parsewords($stuff);
656
657    print "\n  <simpleType name='$n'>\n";
658    print "   <restriction base='$b'>\n";
659#    print STDERR "\n==stuff:\n$stuff \n\n===\n", join('|', @words);
660
661    my $i = 0;
662    my @enume;
663
664    if ($words[$i] eq "(") {
665                  $i++;
666                  while ($words[$i] ne ")") {
667                                if ($words[$i] ne "|") {
668                                         push(@enume, $words[$i]);
669                                }
670                                $i++;
671                  }
672                  write_enum(@enume);
673    }
674
675         print "   </restriction>\n";
676    print "  </simpleType>\n";
677}
678
679sub write_attrGroup{
680    my($n, $stuff) = @_;
681    my @words = parsewords($stuff);
682
683    print "\n  <attributeGroup name='$n'>\n";
684#    print STDERR "\n==stuff:\n$stuff \n\n===\n", join('|', @words);
685    printAttrDecls(@words);
686    print "  </attributeGroup>\n";
687}
688
689sub write_modelGroup{
690    my($n, $stuff) = @_;
691    my @words = parsewords($stuff);
692
693    print "\n  <group name='$n'>\n";
694    print "<!-- $stuff -->\n";
695
696    my @list = &makeChildList($n, '(', @words, ')');
697    &printChildList(3, @list);
698
699    $ModelGroup{$n} = \@list;
700
701    print "  </group>\n";
702}
703
704sub write_substitutionGroup
705{
706    my($n, $stuff) = @_;
707    my @words = parsewords($stuff);
708
709    print "\n  <element name='$n' abstract='true'>\n";
710
711    my @list = &makeChildList($n, '(', @words, ')');
712         for ( my $i = 0; $i < $#list; $i++ )
713         {
714                  $SubstitutionGroup{ $list[$i] } = $n;
715         }
716
717    print "  </element>\n";
718}
719
720sub isMixed{
721    my(@model) = @_;
722         my $isSimple = ($pcdata_flag eq 1) && ($model[1] eq '#PCDATA') &&
723                  ( ($#model eq 2) || 
724                         ( ($#model eq 3) && ($model[3] eq '*') ) );
725
726         if ( $debug eq 1 ) {
727                  print STDERR "++ mixed? @model\n"; #@@
728         }
729
730         if ( $isSimple )
731         {
732                  if ( $debug eq 1 ) 
733                  {
734                                print STDERR "++ no; simple type. @model\n"; #@@
735                  }
736                  return 0;
737         }
738
739    my($i);
740
741    for ($i = 0; $i <= $#model; $i++) {
742                  if ( $model[$i] eq '#PCDATA' ||
743                                 ($model[$i] eq '#MODELGROUPREF' && $Mixed{$model[$i+1]}) ||
744                                 ($model[$i] eq '#SUBSTGROUPREF' && $Mixed{$model[$i+1]}) )
745                  {
746                                if ( $debug eq 1 ) {
747                                         print STDERR "++ yes! $i @model\n"; #@@
748                                }
749                                return 1;
750                  }
751    }
752
753         if ( $debug eq 1 ) {
754                  print STDERR "++ no. @model\n"; #@@
755         }
756
757    return 0;
758}
759
760# Return maximum value of an array of numbers
761sub max
762{
763         my $max = $_[0];
764         foreach my $i (@_) {
765                  if ($i > $max) {$max = $i;}
766         }
767         return $max;
768}
769
770
771# 1) Open file
772# 2) Remove comment, processing instructions, and general entities
773# 3) Include external parameter entities recursively
774# 4) Return the contents of opened file
775sub openFile {
776         my $file = $_[0];
777
778         my %extent;
779         my $bufbuf;
780         if ($file ne "") {
781                  print STDERR "open $file ";
782                  if(! open AAA, $file) {
783                                print STDERR " failed!!\n";
784                                return "";
785                  }
786                  print STDERR " successful\n";
787                  $bufbuf = <AAA>;
788         } else {
789                  print STDERR "open STDIN successful\n";
790                  $bufbuf = <>;
791         }
792
793         # remove comments
794         $bufbuf =~ s/<!--.*?-->//gso;
795
796         # remove processing instructions
797         $bufbuf =~ s/<\?.*?>//gso;
798
799         # store external parameter entities
800         while ($bufbuf =~ s/<!ENTITY\s+%\s+(\S+)\s+PUBLIC\s+$str\s+$str.*?>//sie) {
801                  $extent{$1} = $4.$5;
802         }
803         while ($bufbuf =~ s/<!ENTITY\s+%\s+(\S+)\s+SYSTEM\s+$str.*?>//sie) {
804                  $extent{$1} = $2.$3;
805         }
806
807         # read external entity files
808         foreach my $key (keys(%extent)) {
809                  $bufbuf =~ s/%$key;/openFile($extent{$key})/gsie;
810         }
811
812         return $bufbuf;
813}
814
815# $Log: dtd2xsd.pl,v $
816# Revision 1.17  2001/01/19 05:59:12  connolly
817# more changelog stuff; link to MH's announcement etc.
818#
819# Revision 1.16  2001/01/19 05:55:56  connolly
820# added Log at end
821#
822# Changes: 2001/01/10
823# Date:      Thu, 11 Jan 2001 14:51:44 -0800
824# From:      Mary Holstege <holstege@mathling.com>
825# To:        xml-dev@lists.xml.org
826# Subject:   [ANN] Updated version of DTD to XML Schema tool
827# http://lists.xml.org/archives/xml-dev/200101/msg00481.html
828# http://www.mathling.com/xmlschema/
829# Switch to CR syntax
830# Support external mapping file for type aliases, simple types, model and
831#    attribute groups
832# Map ANY correctly to wildcard rather than element 'ANY'
833# Support treating lead PCDATA as string or other aliased simple type instead
834# of as mixed content (may be more appropriate for data-oriented DTDs)
835#    e.g. <!ELEMENT title (#PCDATA)> => <element name="title" type="string"/>
836# Support subsitution groups.
Note: See TracBrowser for help on using the repository browser.