home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / HTML / dtd2pm.pl < prev    next >
Encoding:
Perl Script  |  1996-09-17  |  6.2 KB  |  244 lines
  1. #!/local/bin/perl -w
  2.  
  3. # This is a crude hack to parse the HTML DTDs in order to generate
  4. # a HTML parser in perl.  The output is a perl structure that describe
  5. # the same releationships as the DTD.  This script in known to work
  6. # on the HTML 3.2 of Tuesday 23-Apr-96, but it might need some
  7. # tweaks if that DTD use more sophisticated SGML features.
  8. #
  9. # Author: Gisle Aas
  10. #
  11. # $Id: dtd2pm.pl,v 1.3 1996/09/17 12:40:27 aas Exp $
  12. #
  13. # Disclaimer: I am not an SGML expert and don't really understand how
  14. # to read those damn DTDs.
  15.  
  16. $VERBOSE = 0;
  17.  
  18. undef($/);
  19. $DTD = "HTML32.dtd";
  20.  
  21. open(DTD, $DTD) or die "Can't open $DTD: $!";
  22. $_ = <DTD>;
  23. close(DTD);
  24. $| = 1;
  25.  
  26. ($intro) = /<!\s*--(.*?)--\s*>/s;
  27.  
  28. #print $_;
  29.  
  30. while (s/^\s*<!//) {
  31.    if (s/^(\[.*?\])>//s) {  # ignore <![......]> constructs
  32.     #print "Skip: <!$1>\n";
  33.         next;
  34.    }
  35.  
  36.    s/^([^>]*)>//;
  37.    $c = $1;
  38.    while (1) {
  39.       $c =~ s/--.*?--//gs;  # remove comments
  40.       if ($c =~ /--/) {
  41.           # we really did read to little
  42.           s/([^>]*)>//;
  43.           $c .= $1
  44.       } else {
  45.           last;
  46.       }
  47.    }
  48.  
  49.    $c =~ s/^\s+//;
  50.    $c =~ s/\s+$//;
  51.    next unless length $c;  # only comments
  52.  
  53.    #$c =~ s/\s+/ /g;
  54.  
  55.    print "C: $c\n" if $VERBOSE;
  56.    while (s/^\s*([^\s<]+)//) {
  57.       print "T: $1\n" if $VERBOSE;
  58.    }
  59.  
  60.    if ($c =~ /^ENTITY\s+(%\s*)?(\S+)\s+(.*)/is) {
  61.        my($percent, $key, $val) = ($1, lc($2), $3);
  62.        if ($percent) {
  63.           $key = "%$key";
  64.        } else {
  65.           $key = "&$key";
  66.           $val =~ s/CDATA\s+//;
  67.        }
  68.        $val =~ s/^"//s;
  69.        $val =~ s/"$//s;
  70.        $val =~ s/(%[\w\.\-]+);?/$entity{lc $1} || $1/eg;
  71.  
  72.        $entity{$key} = $val;
  73.        #print "E: $key => $val\n";
  74.    } else {
  75.        # Expand entities
  76.        $c =~ s/(%[\w\.\-]+);?/$entity{lc $1} || $1/eg;
  77.        #print "C: $c\n"
  78.        if ($c =~ /^ELEMENT\s+\(([^\)]+)\)\s+([-O])\s+([-O])\s+(.*)/is) {
  79.           my($elems, $start, $stop, $content) = (lc $1, $2, $3, lc $4);
  80.       for ($elems, $content) {
  81.           s/\s+//g;
  82.       }
  83.           $content =~ s/(\#pcdata)\b/\U$1/g;
  84.           for $elem (split(/\|/, $elems)) {
  85.              $element{$elem} = [$start, $stop, $content];
  86.           }
  87.        } elsif ($c =~ /^ELEMENT\s+(\S+)\s+([-O])\s+([-O])\s+(.*)/is) {
  88.           my($elem, $start, $stop, $content) = (lc $1, $2, $3, lc $4);
  89.           $content =~ s/\s+//g;
  90.           $content =~ s/(\#pcdata)\b/\U$1/g;
  91.       $element{$elem} =  [$start, $stop, $content];
  92.  
  93.        } elsif ($c =~ s/^ATTLIST\s+\(([^\)]+)\)\s+//) {
  94.           my $elems = lc $1;
  95.       $elems =~ s/\s+//g;
  96.           my $attrs = parse_attrs($c);
  97.           for $elem (split(/\|/, $elems)) {
  98.           $attr{$elem} = $attrs;
  99.           }
  100.        } elsif ($c =~ s/^ATTLIST\s+(\S+)\s+//) {
  101.           $attr{lc $1} = parse_attrs($c);
  102.        } else {
  103.           print STDERR "?: $c\n";
  104.        }
  105.    }
  106. }
  107.  
  108. # is there anything left?
  109. s/^\s+//;
  110. print STDERR "?: ", substr($_, 0, 200), "\n" if length $_;
  111.  
  112.  
  113. # At this point, we have initialized the %element, %attr arrays.
  114. # Their content is as described here:
  115. #
  116. #  %element = ( tag => [ $start, $end, $content ],
  117. #               ...
  118. #             );
  119. #
  120. #  %attr    = ( tag => {
  121. #                         attr => [ $values, $default ],
  122. #                         ...
  123. #                      },
  124. #               ...
  125. #             );
  126. #
  127. # The %entity hash is also available, but should not be of much use
  128. # now.
  129.  
  130.  
  131. # Dump result to stdout so that it is useful to a perl program.
  132.  
  133. print "##### Do not edit!!  Auto-generated from $DTD\n\n";
  134.  
  135. print "package HTML::DTD;  # <!DOCTYPE HTML PUBLIC \"$entity{'%html.version'}\">\n\n";
  136. $intro =~ s/^[ \t]*/\# /gm;
  137. print "$intro\n\n";
  138.  
  139.  
  140. my @all_tags = sort keys %element;
  141. my @empty = ();
  142. my @optional_end_tag = ();
  143. my @optional_start_tag = ();
  144. for (@all_tags) {
  145.    push(@empty, $_) if $element{$_}[2] eq 'empty';
  146.    push(@optional_end_tag, $_) if $element{$_}[2] ne 'empty' and
  147.                                   $element{$_}[1] ne '-';
  148.    push(@optional_start_tag, $_) if $element{$_}[0] ne '-';
  149. }
  150.  
  151. print "\@all_tags = qw(@all_tags);\n";
  152. print "\@empty = qw(@empty);\n";
  153. print "\@optional_end_tag = qw(@optional_end_tag);\n";
  154. print "\@optional_start_tag = qw(@optional_start_tag);\n";
  155. print <<'EOT';
  156.  
  157.  
  158. # The %elem hash is indexed by lowercase tag identifiers.  Each element is
  159. # an anonymouse hash with the following values:
  160. #
  161. #    'content': Describes the content that can be present within this
  162. #               element.  This value is missing if the element should
  163. #               always be empty.
  164. #
  165. #    'optend':  True if the end tag for this element is optional
  166. #
  167. #    'attr':    A hash that describes the attributes of this element.
  168. #               Each element in this hash is a anonymous array with
  169. #               two values: allowed values; default value
  170. #    
  171. EOT
  172.  
  173. print "\n%elem = (\n";
  174.  
  175. @boolean_attr = ();
  176.  
  177. for (@all_tags) {
  178.    my $e = $_;
  179.    $e = "'$e'" if $e eq 'tr' || $e eq 'link' || $e eq 'sub';  # these are perl keywords
  180.    printf "%-4s => {\n", $e;
  181.    print "\t  content => '$element{$_}[2]',\n" if $element{$_}[2] ne 'empty';
  182.    print "\t  optend => 1,\n" if $element{$_}[1] ne '-';
  183.    if (exists $attr{$_}) {
  184.        print "\t  attr => {\n";
  185.        for $a (sort keys %{$attr{$_}}) {
  186.        my @a = @{$attr{$_}{$a}};
  187.        print "\t\t\t$a => [", join(",", map {qq("$_")} @a), "],\n";
  188.        push(@boolean_attr, "$_\t=> '$a'") if $a eq $attr{$_}{$a}[0];
  189.        }
  190.        print "\t\t  },\n";
  191.    }
  192.    print "\t},\n";
  193. }
  194.  
  195. print ");\n";
  196.  
  197. print "\n\n\%boolean_attr = (\n";
  198. for (@boolean_attr) {
  199.     print " $_,\n";
  200. }
  201. print ");\n";
  202.  
  203. print "\n1;\n";
  204.  
  205.  
  206. exit;
  207. #-----------------------------------------------------------------------
  208.  
  209. sub parse_attrs  # Parse the <!ATTLIST elem ...> content
  210. {
  211.     my $a = shift;
  212.     my %a = ();
  213.     #print "---$a---\n";
  214.     while ($a =~ /\S/) {
  215.     $a =~ s/^\s*(\S+)\s*//;
  216.     my $key = $1;
  217.     my ($val, $default);
  218.     if ($a =~ s/^\(([^\)]+)\)//) {
  219.         $val = $1;
  220.             $val =~ s/\s+//g;
  221.     } elsif ($a =~ s/^(\S+)//) {
  222.         $val = $1;
  223.     } else {
  224.         die "Missing values";
  225.     }
  226.         $val = lc($val) unless $val =~ /^[A-Z]+$/;
  227.         $val =~ s/^"(.*)"$/$1/;
  228.     
  229.         $a =~ s/^\s+//;
  230.         if ($a =~ s/^(\#FIXED\s+\'[^\']+\')//) {
  231.         $default = $1;
  232.     } elsif ($a =~ s/^(\S+)//) {
  233.         $default = $1;
  234.     } else {
  235.         die "Missing default";
  236.     }
  237.     $default = lc($default) unless $default =~ /^[\#\"]/;
  238.         $default =~ s/^"(.*)"$/$1/;
  239.  
  240.     $a{$key} = [$val, $default];
  241.     }
  242.     \%a;
  243. }
  244.