home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / DTDDecls.pm < prev    next >
Encoding:
Perl POD Document  |  2002-01-29  |  15.0 KB  |  544 lines
  1. # $Id: DTDDecls.pm,v 1.4 2002/01/29 21:00:26 matt Exp $
  2.  
  3. package XML::SAX::PurePerl;
  4.  
  5. use strict;
  6. use XML::SAX::PurePerl::Productions qw($NameChar $SingleChar);
  7.  
  8. sub elementdecl {
  9.     my ($self, $reader) = @_;
  10.     
  11.     if ($reader->match_string('<!ELEMENT')) {
  12.         $self->skip_whitespace($reader) ||
  13.             $self->parser_error("No whitespace after ELEMENT declaration", $reader);
  14.         
  15.         my $name = $self->Name($reader);
  16.         
  17.         $self->skip_whitespace($reader) ||
  18.             $self->parser_error("No whitespace after ELEMENT's name", $reader);
  19.             
  20.         $self->contentspec($reader, $name);
  21.         
  22.         $self->skip_whitespace($reader);
  23.         
  24.         $reader->match('>') ||
  25.             $self->parser_error("Closing angle bracket not found on ELEMENT declaration", $reader);
  26.         
  27.         return 1;
  28.     }
  29.     
  30.     return 0;
  31. }
  32.  
  33. sub contentspec {
  34.     my ($self, $reader, $name) = @_;
  35.     
  36.     my $model;
  37.     if ($reader->match_string('EMPTY')) {
  38.         $model = 'EMPTY';
  39.     }
  40.     elsif ($reader->match_string('ANY')) {
  41.         $model = 'ANY';
  42.     }
  43.     else {
  44.         $model = $self->Mixed_or_children($reader);
  45.     }
  46.  
  47.     if ($model) {
  48.         # call SAX callback now.
  49.         $self->element_decl({Name => $name, Model => $model});
  50.         return 1;
  51.     }
  52.     
  53.     $self->parser_error("contentspec not found in ELEMENT declaration", $reader);
  54. }
  55.  
  56. sub Mixed_or_children {
  57.     my ($self, $reader) = @_;
  58.  
  59.     my $model;
  60.     if ($reader->match('(')) {
  61.         $model = '(';
  62.         
  63.         $self->skip_whitespace($reader);
  64.         
  65.         if ($reader->match_string('#PCDATA')) {
  66.             return $self->Mixed($reader);
  67.         }
  68.  
  69.         # not matched - must be Children
  70.         $reader->buffer('(');
  71.         return $self->children($reader);
  72.     }
  73.  
  74.     return;
  75. }
  76.  
  77. # Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' '*' )
  78. #               | ( '(' S* PCDATA S* ')' )
  79. sub Mixed {
  80.     my ($self, $reader) = @_;
  81.  
  82.     # Mixed_or_children already matched '(' S* '#PCDATA'
  83.  
  84.     my $model = '(#PCDATA';
  85.             
  86.     $self->skip_whitespace($reader);
  87.  
  88.     my %seen;
  89.     
  90.     while ($reader->match('|')) {
  91.         $self->skip_whitespace($reader);
  92.  
  93.         my $name = $self->Name($reader) || 
  94.             $self->parser_error("No 'Name' after Mixed content '|'", $reader);
  95.  
  96.         if ($seen{$name}) {
  97.             $self->parser_error("Element '$name' has already appeared in this group", $reader);
  98.         }
  99.         $seen{$name}++;
  100.  
  101.         $model .= "|$name";
  102.         
  103.         $self->skip_whitespace($reader);
  104.     }
  105.  
  106.     $reader->match(')') || $self->parser_error("no closing bracket on mixed content", $reader);
  107.  
  108.     $model .= ")";
  109.  
  110.     if ($reader->match('*')) {
  111.         $model .= "*";
  112.     }
  113.     
  114.     return $model;
  115. }
  116.  
  117. # [[47]] Children ::= ChoiceOrSeq Cardinality?
  118. # [[48]] Cp ::= ( QName | ChoiceOrSeq ) Cardinality?
  119. #       ChoiceOrSeq ::= '(' S* Cp ( Choice | Seq )? S* ')'
  120. # [[49]] Choice ::= ( S* '|' S* Cp )+
  121. # [[50]] Seq    ::= ( S* ',' S* Cp )+
  122. #        // Children ::= (Choice | Seq) Cardinality?
  123. #        // Cp ::= ( QName | Choice | Seq) Cardinality?
  124. #        // Choice ::= '(' S* Cp ( S* '|' S* Cp )+ S* ')'
  125. #        // Seq    ::= '(' S* Cp ( S* ',' S* Cp )* S* ')'
  126. # [[51]] Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' MixedCardinality )
  127. #                | ( '(' S* PCDATA S* ')' )
  128. #        Cardinality ::= '?' | '+' | '*'
  129. #        MixedCardinality ::= '*'
  130. sub children {
  131.     my ($self, $reader) = @_;
  132.     
  133.     return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader);    
  134. }
  135.  
  136. sub ChoiceOrSeq {
  137.     my ($self, $reader) = @_;
  138.     
  139.     $reader->match('(') || $self->parser_error("choice/seq contains no opening bracket", $reader);
  140.     
  141.     my $model = '(';
  142.     
  143.     $self->skip_whitespace($reader);
  144.  
  145.     $model .= $self->Cp($reader);
  146.  
  147.     if (my $choice = $self->Choice($reader)) {
  148.         $model .= $choice;
  149.     }
  150.     else {
  151.         $model .= $self->Seq($reader);
  152.     }
  153.  
  154.     $self->skip_whitespace($reader);
  155.  
  156.     $reader->match(')') || $self->parser_error("choice/seq contains no closing bracket", $reader);
  157.  
  158.     $model .= ')';
  159.     
  160.     return $model;
  161. }
  162.  
  163. sub Cardinality {
  164.     my ($self, $reader) = @_;
  165.     # cardinality is always optional
  166.     if ($reader->match('?')) {
  167.         return '?';
  168.     }
  169.     if ($reader->match('+')) {
  170.         return '+';
  171.     }
  172.     if ($reader->match('*')) {
  173.         return '*';
  174.     }
  175.     return '';
  176. }
  177.  
  178. sub Cp {
  179.     my ($self, $reader) = @_;
  180.  
  181.     my $model;
  182.     if (my $name = $self->Name($reader)) {
  183.         return $name . $self->Cardinality($reader);
  184.     }
  185.     return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader);
  186. }
  187.  
  188. sub Choice {
  189.     my ($self, $reader) = @_;
  190.     
  191.     my $model = '';
  192.     $self->skip_whitespace($reader);
  193.     while ($reader->match('|')) {
  194.         $self->skip_whitespace($reader);
  195.         $model .= '|';
  196.         $model .= $self->Cp($reader);
  197.         $self->skip_whitespace($reader);
  198.     }
  199.  
  200.     return $model;
  201. }
  202.  
  203. sub Seq {
  204.     my ($self, $reader) = @_;
  205.     
  206.     my $model = '';
  207.     $self->skip_whitespace($reader);
  208.     while ($reader->match(',')) {
  209.         $self->skip_whitespace($reader);
  210.         $model .= ',';
  211.         $model .= $self->Cp($reader);
  212.         $self->skip_whitespace($reader);
  213.     }
  214.  
  215.     return $model;
  216. }
  217.  
  218. sub AttlistDecl {
  219.     my ($self, $reader) = @_;
  220.     
  221.     if ($reader->match_string('<!ATTLIST')) {
  222.         # It's an attlist
  223.         
  224.         $self->skip_whitespace($reader) || 
  225.             $self->parser_error("No whitespace after ATTLIST declaration", $reader);
  226.         my $name = $self->Name($reader);
  227.  
  228.         $self->AttDefList($reader, $name);
  229.  
  230.         $self->skip_whitespace($reader);
  231.         $reader->match('>') ||
  232.             $self->parser_error("Closing angle bracket not found on ATTLIST declaration", $reader);
  233.         return 1;
  234.     }
  235.     
  236.     return 0;
  237. }
  238.  
  239. sub AttDefList {
  240.     my ($self, $reader, $name) = @_;
  241.  
  242.     1 while $self->AttDef($reader, $name);
  243. }
  244.  
  245. sub AttDef {
  246.     my ($self, $reader, $el_name) = @_;
  247.  
  248.     $self->skip_whitespace($reader) || return 0;
  249.     my $att_name = $self->Name($reader) || return 0;
  250.     $self->skip_whitespace($reader) || 
  251.         $self->parser_error("No whitespace after Name in attribute definition", $reader);
  252.     my $att_type = $self->AttType($reader);
  253.  
  254.     $self->skip_whitespace($reader) ||
  255.         $self->parser_error("No whitespace after AttType in attribute definition", $reader);
  256.     my ($default, $value) = $self->DefaultDecl($reader);
  257.     
  258.     # fire SAX event here!
  259.     $self->attribute_decl({
  260.             eName => $el_name, 
  261.             aName => $att_name, 
  262.             Type => $att_type, 
  263.             ValueDefault => $default, 
  264.             Value => $value,
  265.             });
  266.     return 1;
  267. }
  268.  
  269. sub AttType {
  270.     my ($self, $reader) = @_;
  271.  
  272.     return $self->StringType($reader) ||
  273.             $self->TokenizedType($reader) ||
  274.             $self->EnumeratedType($reader) ||
  275.             $self->parser_error("Can't match AttType", $reader);
  276. }
  277.  
  278. sub StringType {
  279.     my ($self, $reader) = @_;
  280.     if ($reader->match_string('CDATA')) {
  281.         return 'CDATA';
  282.     }
  283.     return;
  284. }
  285.  
  286. sub TokenizedType {
  287.     my ($self, $reader) = @_;
  288.     if ($reader->match_string('IDREFS')) {
  289.         return 'IDREFS';
  290.     }
  291.     if ($reader->match_string('IDREF')) {
  292.         return 'IDREF';
  293.     }
  294.     if ($reader->match_string('ID')) {
  295.         return 'ID';
  296.     }
  297.     if ($reader->match_string('ENTITIES')) {
  298.         return 'ENTITIES';
  299.     }
  300.     if ($reader->match_string('ENTITY')) {
  301.         return 'ENTITY';
  302.     }
  303.     if ($reader->match_string('NMTOKENS')) {
  304.         return 'NMTOKENS';
  305.     }
  306.     if ($reader->match_string('NMTOKEN')) {
  307.         return 'NMTOKEN';
  308.     }
  309.     return;
  310. }
  311.  
  312. sub EnumeratedType {
  313.     my ($self, $reader) = @_;
  314.     return $self->NotationType($reader) || $self->Enumeration($reader);
  315. }
  316.  
  317. sub NotationType {
  318.     my ($self, $reader) = @_;
  319.     if ($reader->match_string('NOTATION')) {
  320.         $self->skip_whitespace($reader) ||
  321.             $self->parser_error("No whitespace after NOTATION", $reader);
  322.         $reader->match('(') ||
  323.             $self->parser_error("No opening bracket in notation section", $reader);
  324.         $self->skip_whitespace($reader);
  325.         my $model = 'NOTATION (';
  326.         my $name = $self->Name($reader) ||
  327.             $self->parser_error("No name in notation section", $reader);
  328.         $model .= $name;
  329.         $self->skip_whitespace($reader);
  330.         while ($reader->match('|')) {
  331.             $model .= '|';
  332.             $self->skip_whitespace($reader);
  333.             my $name = $self->Name($reader) ||
  334.                 $self->parser_error("No name in notation section", $reader);
  335.             $model .= $name;
  336.             $self->skip_whitespace($reader);
  337.         }
  338.         $reader->match(')') || 
  339.             $self->parser_error("No closing bracket in notation section", $reader);
  340.         $model .= ')';
  341.  
  342.         return $model;
  343.     }
  344.     return;
  345. }
  346.  
  347. sub Enumeration {
  348.     my ($self, $reader) = @_;
  349.     if ($reader->match('(')) {
  350.         $self->skip_whitespace($reader);
  351.         my $model = '(';
  352.         my $nmtoken = $self->Nmtoken($reader) ||
  353.             $self->parser_error("No Nmtoken in enumerated declaration", $reader);
  354.         $model .= $nmtoken;
  355.         $self->skip_whitespace($reader);
  356.         while ($reader->match('|')) {
  357.             $model .= '|';
  358.             $self->skip_whitespace($reader);
  359.             my $nmtoken = $self->Nmtoken($reader) ||
  360.                 $self->parser_error("No Nmtoken in enumerated declaration", $reader);
  361.             $model .= $nmtoken;
  362.             $self->skip_whitespace($reader);
  363.         }
  364.         $reader->match(')') ||
  365.             $self->parser_error("No closing bracket in enumerated declaration", $reader);
  366.         $model .= ')';
  367.  
  368.         return $model;
  369.     }
  370.     return;
  371. }
  372.  
  373. sub Nmtoken {
  374.     my ($self, $reader) = @_;
  375.     $reader->consume($NameChar);
  376.     return $reader->consumed;
  377. }
  378.  
  379. sub DefaultDecl {
  380.     my ($self, $reader) = @_;
  381.     if ($reader->match_string('#REQUIRED')) {
  382.         return '#REQUIRED';
  383.     }
  384.     if ($reader->match_string('#IMPLIED')) {
  385.         return '#IMPLIED';
  386.     }
  387.     my $model = '';
  388.     if ($reader->match_string('#FIXED')) {
  389.         $self->skip_whitespace($reader) || $self->parser_error(
  390.                 "no whitespace after FIXED specifier", $reader);
  391.         my $value = $self->AttValue($reader);
  392.         return "#FIXED", $value;
  393.     }
  394.     my $value = $self->AttValue($reader);
  395.     return undef, $value;
  396. }
  397.  
  398. sub EntityDecl {
  399.     my ($self, $reader) = @_;
  400.     
  401.     if ($reader->match_string('<!ENTITY')) {
  402.         $self->skip_whitespace($reader) || $self->parser_error(
  403.             "No whitespace after ENTITY declaration", $reader);
  404.         
  405.         $self->PEDecl($reader) || $self->GEDecl($reader);
  406.         
  407.         $self->skip_whitespace($reader);
  408.         $reader->match('>') || $self->parser_error("No closing '>' in entity definition", $reader);
  409.         
  410.         return 1;
  411.     }
  412.     return 0;
  413. }
  414.  
  415. sub GEDecl {
  416.     my ($self, $reader) = @_;
  417.  
  418.     my $name = $self->Name($reader) || $self->parser_error("No entity name given", $reader);
  419.     $self->skip_whitespace($reader) || $self->parser_error("No whitespace after entity name", $reader);
  420.  
  421.     # TODO: ExternalID calls lexhandler method. Wrong place for it.
  422.     my $value;
  423.     if ($value = $self->ExternalID($reader)) {
  424.         $value .= $self->NDataDecl($reader);
  425.     }
  426.     else {
  427.         $value = $self->EntityValue($reader);
  428.     }
  429.  
  430.     if ($self->{ParseOptions}{entities}{$name}) {
  431.         warn("entity $name already exists\n");
  432.     } else {
  433.         $self->{ParseOptions}{entities}{$name} = 1;
  434.         $self->{ParseOptions}{expanded_entity}{$name} = $value; # ???
  435.     }
  436.     # do callback?
  437.     return 1;
  438. }
  439.  
  440. sub PEDecl {
  441.     my ($self, $reader) = @_;
  442.     
  443.     $reader->match('%') || return 0;
  444.     $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity marker", $reader);
  445.     my $name = $self->Name($reader) || $self->parser_error("No parameter entity name given", $reader);
  446.     $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity name", $reader);
  447.     my $value = $self->ExternalID($reader) ||
  448.                 $self->EntityValue($reader) ||
  449.                 $self->parser_error("PE is not a value or an external resource", $reader);
  450.     # do callback?
  451.     return 1;
  452. }
  453.  
  454. my $quotre = qr/[^%&\"]/;
  455. my $aposre = qr/[^%&\']/;
  456.  
  457. sub EntityValue {
  458.     my ($self, $reader) = @_;
  459.     
  460.     my $quote = '"';
  461.     my $re = $quotre;
  462.     if (!$reader->match($quote)) {
  463.         $quote = "'";
  464.         $re = $aposre;
  465.         $reader->match($quote) ||
  466.                 $self->parser_error("Not a quote character", $reader);
  467.     }
  468.     
  469.     my $value = '';
  470.     
  471.     while (1) {
  472.         if ($reader->consume($re)) {
  473.             $value .= $reader->consumed;
  474.         }
  475.         elsif ($reader->match('&')) {
  476.             # if it's a char ref, expand now:
  477.             if ($reader->match('#')) {
  478.                 my $char;
  479.                 my $ref;
  480.                 if ($reader->match('x')) {
  481.                     $reader->consume(qr/[0-9a-fA-F]/) ||
  482.                         $self->parser_error("Hex character reference contains illegal characters", $reader);
  483.                     $ref = $reader->consumed;
  484.                     $char = chr_ref(hex($ref));
  485.                     $ref = "x$ref";
  486.                 }
  487.                 else {
  488.                     $reader->consume(qr/[0-9]/) ||
  489.                         $self->parser_error("Decimal character reference contains illegal characters", $reader);
  490.                     $ref = $reader->consumed;
  491.                     $char = chr($ref);
  492.                 }
  493.                 $reader->match(';') ||
  494.                     $self->parser_error("No semi-colon found after character reference", $reader);
  495.                 if ($char !~ $SingleChar) { # match a single character
  496.                     $self->parser_error("Character reference '&#$ref;' refers to an illegal XML character ($char)", $reader);
  497.                 }
  498.                 $value .= $char;
  499.             }
  500.             else {
  501.                 # entity refs in entities get expanded later, so don't parse now.
  502.                 $value .= '&';
  503.             }
  504.         }
  505.         elsif ($reader->match('%')) {
  506.             $value .= $self->PEReference($reader);
  507.         }
  508.         elsif ($reader->match($quote)) {
  509.             # end of attrib
  510.             last;
  511.         }
  512.         else {
  513.             $self->parser_error("Invalid character in attribute value", $reader);
  514.         }
  515.     }
  516.     
  517.     return $value;
  518. }
  519.  
  520. sub NDataDecl {
  521.     my ($self, $reader) = @_;
  522.     $self->skip_whitespace($reader) || return '';
  523.     $reader->match_string("NDATA") || return '';
  524.     $self->skip_whitespace($reader) || $self->parser_error("No whitespace after NDATA declaration", $reader);
  525.     my $name = $self->Name($reader) || $self->parser_error("NDATA declaration lacks a proper Name", $reader);
  526.     return " NDATA $name";
  527. }
  528.  
  529. sub NotationDecl {
  530.     my ($self, $reader) = @_;
  531.     
  532.     if ($reader->match_string('<!NOTATION')) {
  533.         $self->skip_whitespace($reader) ||
  534.             $self->parser_error("No whitespace after NOTATION declaration", $reader);
  535.         $reader->consume(qr/[^>]/); # FIXME
  536.         $reader->match('>'); # FIXME
  537.         $self->notation_decl({Name => "FIXME", SystemId => "FIXME", PublicId => "FIXME" });
  538.         return 1;
  539.     }
  540.     return 0;
  541. }
  542.  
  543. 1;
  544.