jabber-xml.el

   1 ;; jabber-xml.el - XML functions
   2
   3 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22 (require 'xml)
  23 (require 'jabber-util)
  24 (eval-when-compile
  25   (require 'cl))
  26
  27 (defun jabber-escape-xml (str)
  28   "escape strings for xml"
  29   (if (stringp str)
  30       (let ((newstr (concat str)))
  31         ;; Form feeds might appear in code you copy, etc.  Nevertheless,
  32         ;; it's invalid XML.
  33         (setq newstr (jabber-replace-in-string newstr "\f" "\n"))
  34         ;; Other control characters are also illegal, except for
  35         ;; tab, CR, and LF.
  36         (setq newstr (jabber-replace-in-string newstr "[\000-\010\013\014\016-\037]" " "))
  37         (setq newstr (jabber-replace-in-string newstr "&" "&amp;"))
  38         (setq newstr (jabber-replace-in-string newstr "<" "&lt;"))
  39         (setq newstr (jabber-replace-in-string newstr ">" "&gt;"))
  40         (setq newstr (jabber-replace-in-string newstr "'" "&apos;"))
  41         (setq newstr (jabber-replace-in-string newstr "\"" "&quot;"))
  42         newstr)
  43     str))
  44
  45 (defun jabber-unescape-xml (str)
  46   "unescape xml strings"
  47   ;; Eventually this can be done with `xml-substitute-special', but the
  48   ;; version in xml.el of GNU Emacs 21.3 is buggy.
  49   (if (stringp str)
  50       (let ((newstr str))
  51         (setq newstr (jabber-replace-in-string newstr "&quot;" "\""))
  52         (setq newstr (jabber-replace-in-string newstr "&apos;" "'"))
  53         (setq newstr (jabber-replace-in-string newstr "&gt;" ">"))
  54         (setq newstr (jabber-replace-in-string newstr "&lt;" "<"))
  55         (setq newstr (jabber-replace-in-string newstr "&amp;" "&"))
  56         newstr)
  57     str))
  58
  59 (defun jabber-sexp2xml (sexp)
  60   "converts an SEXP in the format (tagname ((attribute-name . attribute-value)...) children...) and converts it to well-formatted xml."
  61   (cond
  62    ((stringp sexp)
  63     (jabber-escape-xml sexp))
  64    ((listp (car sexp))
  65     (let ((xml ""))
  66       (dolist (tag sexp)
  67         (setq xml (concat xml (jabber-sexp2xml tag))))
  68       xml))
  69    ;; work around bug in old versions of xml.el, where ("") can appear
  70    ;; as children of a node
  71    ((and (consp sexp)
  72          (stringp (car sexp))
  73          (zerop (length (car sexp))))
  74     "")
  75    (t
  76     (let ((xml ""))
  77       (setq xml (concat "<"
  78                         (symbol-name (car sexp))))
  79       (dolist (attr (cadr sexp))
  80         (if (consp attr)
  81             (setq xml (concat xml
  82                               (format " %s='%s'"
  83                                       (symbol-name (car attr))
  84                                       (jabber-escape-xml (cdr attr)))))))
  85       (if (cddr sexp)
  86           (progn
  87             (setq xml (concat xml ">"))
  88             (dolist (child (cddr sexp))
  89               (setq xml (concat xml
  90                                 (jabber-sexp2xml child))))
  91             (setq xml (concat xml
  92                               "</"
  93                               (symbol-name (car sexp))
  94                               ">")))
  95         (setq xml (concat xml
  96                           "/>")))
  97       xml))))
  98
  99 (defun jabber-xml-skip-tag-forward (&optional dont-recurse-into-stream)
 100   "Skip to end of tag or matching closing tag if present.
 101 Return t iff after a closing tag, otherwise throws an 'unfinished
 102 tag with value nil.
 103 If DONT-RECURSE-INTO-STREAM is true, stop after an opening
 104 <stream:stream> tag.
 105
 106 The version of `sgml-skip-tag-forward' in Emacs 21 isn't good
 107 enough for us."
 108   (skip-chars-forward "^<")
 109   (cond
 110    ((looking-at "<!\\[CDATA\\[")
 111     (if (search-forward "]]>" nil t)
 112         (goto-char (match-end 0))
 113       (throw 'unfinished nil)))
 114    ((looking-at "<\\([^ \t\n/>]+\\)\\([ \t\n]+[^=]+='[^']*'\\|[ \t\n]+[^=]+=\"[^\"]*\"\\)*")
 115     (let ((node-name (match-string 1)))
 116       (goto-char (match-end 0))
 117       (cond
 118        ((looking-at "/>")
 119         (goto-char (match-end 0))
 120         t)
 121        ((looking-at ">")
 122         (forward-char 1)
 123         (unless (and dont-recurse-into-stream (equal node-name "stream:stream"))
 124           (loop
 125            do (skip-chars-forward "^<")
 126            until (looking-at (regexp-quote (concat "</" node-name ">")))
 127            do (jabber-xml-skip-tag-forward))
 128           (goto-char (match-end 0)))
 129         t)
 130        (t
 131         (throw 'unfinished nil)))))
 132    (t
 133     (throw 'unfinished nil))))
 134
 135 (defsubst jabber-xml-node-name (node)
 136   "Return the tag associated with NODE.
 137 The tag is a lower-case symbol."
 138   (if (listp node) (car node)))
 139
 140 (defsubst jabber-xml-node-attributes (node)
 141   "Return the list of attributes of NODE.
 142 The list can be nil."
 143   (if (listp node) (nth 1 node)))
 144
 145 (defsubst jabber-xml-node-children (node)
 146   "Return the list of children of NODE.
 147 This is a list of nodes, and it can be nil."
 148   (let ((children (cddr node)))
 149     ;; Work around a bug in early versions of xml.el
 150     (if (equal children '(("")))
 151         nil
 152       children)))
 153
 154 (defun jabber-xml-get-children (node child-name)
 155   "Return the children of NODE whose tag is CHILD-NAME.
 156 CHILD-NAME should be a lower case symbol."
 157   (let ((match ()))
 158     (dolist (child (jabber-xml-node-children node))
 159       (if child
 160           (if (equal (jabber-xml-node-name child) child-name)
 161               (push child match))))
 162     (nreverse match)))
 163
 164 ;; `xml-get-attribute' returns "" if the attribute is not found, which
 165 ;; is not very useful.  Therefore, we use `xml-get-attribute-or-nil'
 166 ;; if present, or emulate its behavior.
 167 (eval-and-compile
 168   (if (fboundp 'xml-get-attribute-or-nil)
 169       (defsubst jabber-xml-get-attribute (node attribute)
 170         "Get from NODE the value of ATTRIBUTE.
 171 Return nil if the attribute was not found."
 172         (when (consp node)
 173           (xml-get-attribute-or-nil node attribute)))
 174     (defsubst jabber-xml-get-attribute (node attribute)
 175       "Get from NODE the value of ATTRIBUTE.
 176 Return nil if the attribute was not found."
 177       (when (consp node)
 178         (let ((result (xml-get-attribute node attribute)))
 179           (and (> (length result) 0) result))))))
 180
 181 (defsubst jabber-xml-get-xmlns (node)
 182   "Get \"xmlns\" attribute of NODE, or nil if not present."
 183   (jabber-xml-get-attribute node 'xmlns))
 184
 185 (defun jabber-xml-path (xml-data path)
 186   "Find sub-node of XML-DATA according to PATH.
 187 PATH is a vaguely XPath-inspired list.  Each element can be:
 188
 189 a symbol     go to first child node with this node name
 190 cons cell    car is string containing namespace URI,
 191              cdr is string containing node name.  Find
 192              first matching child node.
 193 any string   character data of this node"
 194   (let ((node xml-data))
 195     (while (and path node)
 196       (let ((step (car path)))
 197         (cond
 198          ((symbolp step)
 199           (setq node (car (jabber-xml-get-children node step))))
 200          ((consp step)
 201           ;; This will be easier with namespace-aware use
 202           ;; of xml.el.  It will also be more correct.
 203           ;; Now, it only matches explicit namespace declarations.
 204           (setq node
 205                 (dolist (x (jabber-xml-get-children node (intern (cdr step))))
 206                   (when (string= (jabber-xml-get-attribute x 'xmlns)
 207                                  (car step))
 208                     (return x)))))
 209          ((stringp step)
 210           (setq node (car (jabber-xml-node-children node)))
 211           (unless (stringp node)
 212             (setq node nil)))
 213          (t
 214           (error "Unknown path step: %s" step))))
 215       (setq path (cdr path)))
 216     node))
 217
 218 (defmacro jabber-xml-let-attributes (attributes xml-data &rest body)
 219   "Bind variables to the same-name attribute values in XML-DATA."
 220   `(let ,(mapcar #'(lambda (attr)
 221                      (list attr `(jabber-xml-get-attribute ,xml-data ',attr)))
 222                  attributes)
 223      ,@body))
 224 (put 'jabber-xml-let-attributes 'lisp-indent-function 2)
 225
 226 (defun jabber-xml-resolve-namespace-prefixes (xml-data &optional default-ns prefixes)
 227   (let ((node-name (jabber-xml-node-name xml-data))
 228         (attrs (jabber-xml-node-attributes xml-data)))
 229     (setq prefixes (jabber-xml-merge-namespace-declarations attrs prefixes))
 230
 231     ;; If there is an xmlns attribute, it is the new default
 232     ;; namespace.
 233     (let ((xmlns (jabber-xml-get-xmlns xml-data)))
 234       (when xmlns
 235         (setq default-ns xmlns)))
 236     ;; Now, if the node name has a prefix, replace it and add an
 237     ;; "xmlns" attribute.  Slightly ugly, but avoids the need to
 238     ;; change all the rest of jabber.el at once.
 239     (let ((node-name-string (symbol-name node-name)))
 240       (when (string-match "\\(.*\\):\\(.*\\)" node-name-string)
 241         (let* ((prefix (match-string 1 node-name-string))
 242                (unprefixed (match-string 2 node-name-string))
 243                (ns (assoc prefix prefixes)))
 244           (if (null ns)
 245               ;; This is not supposed to happen...
 246               (message "jabber-xml-resolve-namespace-prefixes: Unknown prefix in %s" node-name-string)
 247             (setf (car xml-data) (intern unprefixed))
 248             (setf (cadr xml-data) (cons (cons 'xmlns (cdr ns)) (delq 'xmlns attrs)))))))
 249     ;; And iterate through all child elements.
 250     (mapc (lambda (x)
 251             (when (listp x)
 252               (jabber-xml-resolve-namespace-prefixes x default-ns prefixes)))
 253           (jabber-xml-node-children xml-data))
 254     xml-data))
 255
 256 (defun jabber-xml-merge-namespace-declarations (attrs prefixes)
 257   ;; First find any xmlns:foo attributes..
 258   (dolist (attr attrs)
 259     (let ((attr-name (symbol-name (car attr))))
 260       (when (string-match "xmlns:" attr-name)
 261         (let ((prefix (substring attr-name (match-end 0)))
 262               (ns-uri (cdr attr)))
 263           ;; A slightly complicated dance to never change the
 264           ;; original value of prefixes (since the caller depends on
 265           ;; it), but also to avoid excessive copying (which remove
 266           ;; always does).  Might need to profile and tweak this for
 267           ;; performance.
 268           (setq prefixes
 269                 (cons (cons prefix ns-uri)
 270                         (if (assoc prefix prefixes)
 271                             (remove (assoc prefix prefixes) prefixes)
 272                           prefixes)))))))
 273   prefixes)
 274
 275 (provide 'jabber-xml)
 276
 277 ;;; arch-tag: ca206e65-7026-4ee8-9af2-ff6a9c5af98a