basis/xml/dtd/dtd.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml.tokenize xml.data xml.state kernel sequences ascii
   4 fry xml.errors combinators hashtables namespaces xml.entities
   5 strings ;
   6 IN: xml.dtd
   7
   8 : take-word ( -- string )
   9     [ get-char blank? ] take-until ;
  10
  11 : take-decl-contents ( -- first second )
  12     pass-blank take-word pass-blank ">" take-string ;
  13
  14 : take-element-decl ( -- element-decl )
  15     take-decl-contents <element-decl> ;
  16
  17 : take-attlist-decl ( -- attlist-decl )
  18     take-decl-contents <attlist-decl> ;
  19
  20 : take-notation-decl ( -- notation-decl )
  21     take-decl-contents <notation-decl> ;
  22
  23 : take-until-one-of ( seps -- str sep )
  24     '[ get-char _ member? ] take-until get-char ;
  25
  26 : take-system-id ( -- system-id )
  27     parse-quote <system-id> close ;
  28
  29 : take-public-id ( -- public-id )
  30     parse-quote parse-quote <public-id> close ;
  31
  32 UNION: dtd-acceptable
  33     directive comment instruction ;
  34
  35 : (take-external-id) ( token -- external-id )
  36     pass-blank {
  37         { "SYSTEM" [ take-system-id ] }
  38         { "PUBLIC" [ take-public-id ] }
  39         [ bad-external-id ]
  40     } case ;
  41
  42 : take-external-id ( -- external-id )
  43     take-word (take-external-id) ;
  44
  45 : only-blanks ( str -- )
  46     [ blank? ] all? [ bad-decl ] unless ;
  47 : take-entity-def ( var -- entity-name entity-def )
  48     [
  49         take-word pass-blank get-char {
  50             { CHAR: ' [ parse-quote ] }
  51             { CHAR: " [ parse-quote ] }
  52             [ drop take-external-id ]
  53         } case
  54    ] dip '[ swap _ [ ?set-at ] change ] 2keep ;
  55
  56 : take-entity-decl ( -- entity-decl )
  57     pass-blank get-char {
  58         { CHAR: % [ next pass-blank pe-table take-entity-def t ] }
  59         [ drop extra-entities take-entity-def f ]
  60     } case close <entity-decl> ;
  61
  62 : take-inner-directive ( string -- directive )
  63     {
  64         { "ELEMENT" [ take-element-decl ] }
  65         { "ATTLIST" [ take-attlist-decl ] }
  66         { "ENTITY" [ take-entity-decl ] }
  67         { "NOTATION" [ take-notation-decl ] }
  68         [ bad-directive ]
  69     } case ;