basis/xml/name/name.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors ascii assocs combinators
   4 combinators.short-circuit kernel make math namespaces sequences
   5 xml.char-classes xml.data xml.errors xml.state xml.tokenize ;
   6 IN: xml.name
   7
   8 ! XML namespace processing: ns = namespace
   9
  10 ! A stack of hashtables
  11 SYMBOL: ns-stack
  12
  13 : attrs>ns ( attrs-alist -- hash )
  14     ! this should check to make sure URIs are valid
  15     [
  16         [
  17             swap dup space>> "xmlns" =
  18             [ main>> ,, ]
  19             [
  20                 T{ name f "" "xmlns" f } names-match?
  21                 [ "" ,, ] [ drop ] if
  22             ] if
  23         ] assoc-each
  24     ] { } make f like ;
  25
  26 : add-ns ( name -- )
  27     dup space>> dup ns-stack get assoc-stack
  28     [ ] [ nonexist-ns ] ?if >>url drop ;
  29
  30 : push-ns ( hash -- )
  31     ns-stack get push ;
  32
  33 : pop-ns ( -- )
  34     ns-stack get pop* ;
  35
  36 : init-ns-stack ( -- )
  37     V{ H{
  38         { "xml" "http://www.w3.org/XML/1998/namespace" }
  39         { "xmlns" "http://www.w3.org/2000/xmlns" }
  40         { "" "" }
  41     } } clone
  42     ns-stack set ;
  43
  44 : tag-ns ( name attrs-alist -- name attrs )
  45     dup attrs>ns push-ns
  46     [ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
  47
  48 : valid-name? ( str -- ? )
  49     [ f ] [
  50         version-1.0? swap {
  51             [ first name-start? ]
  52             [ rest-slice [ name-char? ] with all? ]
  53         } 2&&
  54     ] if-empty ;
  55
  56 <PRIVATE
  57
  58 : valid-name-start? ( str -- ? )
  59     [ f ] [ version-1.0? swap first name-start? ] if-empty ;
  60
  61 : maybe-name ( space main -- name/f )
  62     2dup {
  63         [ drop valid-name-start? ]
  64         [ nip valid-name-start? ]
  65     } 2&& [ f <name> ] [ 2drop f ] if ;
  66
  67 : prefixed-name ( str -- name/f )
  68     CHAR: : over index [
  69         CHAR: : 2over 1 + swap index-from
  70         [ 2drop f ]
  71         [ [ head ] [ 1 + tail ] 2bi maybe-name ]
  72         if
  73     ] [ drop f ] if* ;
  74
  75 : interpret-name ( str -- name )
  76     dup prefixed-name [ ] [ <simple-name> ] ?if ;
  77
  78 PRIVATE>
  79
  80 : take-name ( -- string )
  81     version-1.0? '[ _ swap name-char? not ] take-until ;
  82
  83 : parse-name ( -- name )
  84     take-name interpret-name ;
  85
  86 : parse-name-starting ( string -- name )
  87     take-name append interpret-name ;
  88
  89 : take-system-id ( -- system-id )
  90     parse-quote <system-id> ;
  91
  92 : take-public-id ( -- public-id )
  93     parse-quote parse-quote <public-id> ;
  94
  95 : (take-external-id) ( token -- external-id )
  96     pass-blank {
  97         { "SYSTEM" [ take-system-id ] }
  98         { "PUBLIC" [ take-public-id ] }
  99         [ bad-external-id ]
 100     } case ;
 101
 102 : take-word ( -- string )
 103     [ blank? ] take-until ;
 104
 105 : take-external-id ( -- external-id )
 106     take-word (take-external-id) ;