basis/xml/name/name.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces accessors xml.tokenize xml.data assocs
   4 xml.errors xml.char-classes combinators.short-circuit splitting
   5 fry xml.state sequences combinators ascii ;
   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>> set ]
  19             [
  20                 T{ name f "" "xmlns" f } names-match?
  21                 [ "" set ] [ drop ] if
  22             ] if
  23         ] assoc-each
  24     ] { } make-assoc f like ;
  25
  26 : add-ns ( name -- )
  27     dup space>> dup ns-stack get assoc-stack
  28     [ nip ] [ 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 : prefixed-name ( str -- name/f )
  57     ":" split dup length 2 = [
  58         [ [ valid-name? ] all? ]
  59         [ first2 f <name> ] bi and
  60     ] [ drop f ] if ;
  61
  62 : interpret-name ( str -- name )
  63     dup prefixed-name [ ] [
  64         dup valid-name?
  65         [ <simple-name> ] [ bad-name ] if
  66     ] ?if ;
  67
  68 : take-name ( -- string )
  69     version-1.0? '[ _ swap name-char? not ] take-until ;
  70
  71 : parse-name ( -- name )
  72     take-name interpret-name ;
  73
  74 : parse-name-starting ( string -- name )
  75     take-name append interpret-name ;
  76
  77 : take-system-id ( -- system-id )
  78     parse-quote <system-id> ;
  79
  80 : take-public-id ( -- public-id )
  81     parse-quote parse-quote <public-id> ;
  82
  83 : (take-external-id) ( token -- external-id )
  84     pass-blank {
  85         { "SYSTEM" [ take-system-id ] }
  86         { "PUBLIC" [ take-public-id ] }
  87         [ bad-external-id ]
  88     } case ;
  89
  90 : take-word ( -- string )
  91     [ blank? ] take-until ;
  92
  93 : take-external-id ( -- external-id )
  94     take-word (take-external-id) ;