basis/xml/name/name.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See https://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>>
  28     [ ns-stack get assoc-stack ]
  29     [ nonexist-ns ] ?unless >>url drop ;
  30
  31 : push-ns ( hash -- )
  32     ns-stack get push ;
  33
  34 : pop-ns ( -- )
  35     ns-stack get pop* ;
  36
  37 : init-ns-stack ( -- )
  38     V{ H{
  39         { "xml" "http://www.w3.org/XML/1998/namespace" }
  40         { "xmlns" "http://www.w3.org/2000/xmlns" }
  41         { "" "" }
  42     } } clone
  43     ns-stack set ;
  44
  45 : tag-ns ( name attrs-alist -- name attrs )
  46     dup attrs>ns push-ns
  47     [ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
  48
  49 : valid-name? ( str -- ? )
  50     [ f ] [
  51         version-1.0? swap {
  52             [ first name-start? ]
  53             [ rest-slice [ name-char? ] with all? ]
  54         } 2&&
  55     ] if-empty ;
  56
  57 <PRIVATE
  58
  59 : valid-name-start? ( str -- ? )
  60     [ f ] [ version-1.0? swap first name-start? ] if-empty ;
  61
  62 : maybe-name ( space main -- name/f )
  63     2dup {
  64         [ drop valid-name-start? ]
  65         [ nip valid-name-start? ]
  66     } 2&& [ f <name> ] [ 2drop f ] if ;
  67
  68 : prefixed-name ( str -- name/f )
  69     CHAR: : over index [
  70         CHAR: : 2over 1 + swap index-from
  71         [ 2drop f ]
  72         [ [ head ] [ 1 + tail ] 2bi maybe-name ]
  73         if
  74     ] [ drop f ] if* ;
  75
  76 : interpret-name ( str -- name )
  77     [ prefixed-name ] [ <simple-name> ] ?unless ;
  78
  79 PRIVATE>
  80
  81 : take-name ( -- string )
  82     version-1.0? '[ _ swap name-char? not ] take-until ;
  83
  84 : parse-name ( -- name )
  85     take-name interpret-name ;
  86
  87 : parse-name-starting ( string -- name )
  88     take-name append interpret-name ;
  89
  90 : take-system-id ( -- system-id )
  91     parse-quote <system-id> ;
  92
  93 : take-public-id ( -- public-id )
  94     parse-quote parse-quote <public-id> ;
  95
  96 : (take-external-id) ( token -- external-id )
  97     pass-blank {
  98         { "SYSTEM" [ take-system-id ] }
  99         { "PUBLIC" [ take-public-id ] }
 100         [ bad-external-id ]
 101     } case ;
 102
 103 : take-word ( -- string )
 104     [ blank? ] take-until ;
 105
 106 : take-external-id ( -- external-id )
 107     take-word (take-external-id) ;