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
  25 (defun jabber-escape-xml (str)
  26   "escape strings for xml"
  27   (if (stringp str)
  28       (let ((newstr (concat str)))
  29         ;; Form feeds might appear in code you copy, etc.  Nevertheless,
  30         ;; it's invalid XML.
  31         (setq newstr (jabber-replace-in-string newstr "\f" "\n"))
  32         ;; Other control characters are also illegal, except for
  33         ;; tab, CR, and LF.
  34         (setq newstr (jabber-replace-in-string newstr "[\000-\010\013\014\016-\037]" " "))
  35         (setq newstr (jabber-replace-in-string newstr "&" "&amp;"))
  36         (setq newstr (jabber-replace-in-string newstr "<" "&lt;"))
  37         (setq newstr (jabber-replace-in-string newstr ">" "&gt;"))
  38         (setq newstr (jabber-replace-in-string newstr "'" "&apos;"))
  39         (setq newstr (jabber-replace-in-string newstr "\"" "&quot;"))
  40         newstr)
  41     str))
  42
  43 (defun jabber-unescape-xml (str)
  44   "unescape xml strings"
  45   ;; Eventually this can be done with `xml-substitute-special', but the
  46   ;; version in xml.el of GNU Emacs 21.3 is buggy.
  47   (if (stringp str)
  48       (let ((newstr str))
  49         (setq newstr (jabber-replace-in-string newstr "&quot;" "\""))
  50         (setq newstr (jabber-replace-in-string newstr "&apos;" "'"))
  51         (setq newstr (jabber-replace-in-string newstr "&gt;" ">"))
  52         (setq newstr (jabber-replace-in-string newstr "&lt;" "<"))
  53         (setq newstr (jabber-replace-in-string newstr "&amp;" "&"))
  54         newstr)
  55     str))
  56
  57 (defun jabber-sexp2xml (sexp)
  58   "converts an SEXP in the format (tagname ((attribute-name . attribute-value)...) children...) and converts it to well-formatted xml."
  59   (cond
  60    ((stringp sexp)
  61     (jabber-escape-xml sexp))
  62    ((listp (car sexp))
  63     (let ((xml ""))
  64       (dolist (tag sexp)
  65         (setq xml (concat xml (jabber-sexp2xml tag))))
  66       xml))
  67    ;; work around bug in old versions of xml.el, where ("") can appear
  68    ;; as children of a node
  69    ((and (consp sexp)
  70          (stringp (car sexp))
  71          (zerop (length (car sexp))))
  72     "")
  73    (t
  74     (let ((xml ""))
  75       (setq xml (concat "<"
  76                         (symbol-name (car sexp))))
  77       (dolist (attr (cadr sexp))
  78         (if (consp attr)
  79             (setq xml (concat xml
  80                               (format " %s='%s'"
  81                                       (symbol-name (car attr))
  82                                       (jabber-escape-xml (cdr attr)))))))
  83       (if (cddr sexp)
  84           (progn
  85             (setq xml (concat xml ">"))
  86             (dolist (child (cddr sexp))
  87               (setq xml (concat xml
  88                                 (jabber-sexp2xml child))))
  89             (setq xml (concat xml
  90                               "</"
  91                               (symbol-name (car sexp))
  92                               ">")))
  93         (setq xml (concat xml
  94                           "/>")))
  95       xml))))
  96
  97 (defun jabber-xml-skip-tag-forward (&optional dont-recurse-into-stream)
  98   "Skip to end of tag or matching closing tag if present.
  99 Return t iff after a closing tag, otherwise throws an 'unfinished
 100 tag with value nil.
 101 If DONT-RECURSE-INTO-STREAM is true, stop after an opening
 102 <stream:stream> tag.
 103
 104 The version of `sgml-skip-tag-forward' in Emacs 21 isn't good
 105 enough for us."
 106   (skip-chars-forward "^<")
 107   (cond
 108    ((looking-at "<!\\[CDATA\\[")
 109     (if (search-forward "]]>" nil t)
 110         (goto-char (match-end 0))
 111       (throw 'unfinished nil)))
 112    ((looking-at "<\\([^ \t\n/>]+\\)\\([ \t\n]+[^=]+='[^']*'\\|[ \t\n]+[^=]+=\"[^\"]*\"\\)*")
 113     (let ((node-name (match-string 1)))
 114       (goto-char (match-end 0))
 115       (cond
 116        ((looking-at "/>")
 117         (goto-char (match-end 0))
 118         t)
 119        ((looking-at ">")
 120         (forward-char 1)
 121         (unless (and dont-recurse-into-stream (equal node-name "stream:stream"))
 122           (loop
 123            do (skip-chars-forward "^<")
 124            until (looking-at (regexp-quote (concat "</" node-name ">")))
 125            do (jabber-xml-skip-tag-forward))
 126           (goto-char (match-end 0)))
 127         t)
 128        (t
 129         (throw 'unfinished nil)))))
 130    (t
 131     (throw 'unfinished nil))))
 132
 133 (defsubst jabber-xml-node-name (node)
 134   "Return the tag associated with NODE.
 135 The tag is a lower-case symbol."
 136   (if (listp node) (car node)))
 137
 138 (defsubst jabber-xml-node-attributes (node)
 139   "Return the list of attributes of NODE.
 140 The list can be nil."
 141   (if (listp node) (nth 1 node)))
 142
 143 (defsubst jabber-xml-node-children (node)
 144   "Return the list of children of NODE.
 145 This is a list of nodes, and it can be nil."
 146   (let ((children (cddr node)))
 147     ;; Work around a bug in early versions of xml.el
 148     (if (equal children '(("")))
 149         nil
 150       children)))
 151
 152 (defun jabber-xml-get-children (node child-name)
 153   "Return the children of NODE whose tag is CHILD-NAME.
 154 CHILD-NAME should be a lower case symbol."
 155   (let ((match ()))
 156     (dolist (child (jabber-xml-node-children node))
 157       (if child
 158           (if (equal (jabber-xml-node-name child) child-name)
 159               (push child match))))
 160     (nreverse match)))
 161
 162 ;; `xml-get-attribute' returns "" if the attribute is not found, which
 163 ;; is not very useful.  Therefore, we use `xml-get-attribute-or-nil'
 164 ;; if present, or emulate its behavior.
 165 (eval-and-compile
 166   (if (fboundp 'xml-get-attribute-or-nil)
 167       (defsubst jabber-xml-get-attribute (node attribute)
 168         "Get from NODE the value of ATTRIBUTE.
 169 Return nil if the attribute was not found."
 170         (when (consp node)
 171           (xml-get-attribute-or-nil node attribute)))
 172     (defsubst jabber-xml-get-attribute (node attribute)
 173       "Get from NODE the value of ATTRIBUTE.
 174 Return nil if the attribute was not found."
 175       (when (consp node)
 176         (let ((result (xml-get-attribute node attribute)))
 177           (and (> (length result) 0) result))))))
 178
 179 (defsubst jabber-xml-get-xmlns (node)
 180   "Get \"xmlns\" attribute of NODE, or nil if not present."
 181   (jabber-xml-get-attribute node 'xmlns))
 182
 183 (defun jabber-xml-path (xml-data path)
 184   "Find sub-node of XML-DATA according to PATH.
 185 PATH is a vaguely XPath-inspired list.  Each element can be:
 186
 187 a symbol     go to first child node with this node name
 188 cons cell    car is string containing namespace URI,
 189              cdr is string containing node name.  Find
 190              first matching child node.
 191 any string   character data of this node"
 192   (let ((node xml-data))
 193     (while (and path node)
 194       (let ((step (car path)))
 195         (cond
 196          ((symbolp step)
 197           (setq node (car (jabber-xml-get-children node step))))
 198          ((consp step)
 199           ;; This will be easier with namespace-aware use
 200           ;; of xml.el.  It will also be more correct.
 201           ;; Now, it only matches explicit namespace declarations.
 202           (setq node
 203                 (dolist (x (jabber-xml-get-children node (intern (cdr step))))
 204                   (when (string= (jabber-xml-get-attribute x 'xmlns)
 205                                  (car step))
 206                     (return x)))))
 207          ((stringp step)
 208           (setq node (car (jabber-xml-node-children node)))
 209           (unless (stringp node)
 210             (setq node nil)))
 211          (t
 212           (error "Unknown path step: %s" step))))
 213       (setq path (cdr path)))
 214     node))
 215
 216 (defmacro jabber-xml-let-attributes (attributes xml-data &rest body)
 217   "Bind variables to the same-name attribute values in XML-DATA."
 218   `(let ,(mapcar #'(lambda (attr)
 219                      (list attr `(jabber-xml-get-attribute ,xml-data ',attr)))
 220                  attributes)
 221      ,@body))
 222 (put 'jabber-xml-let-attributes 'lisp-indent-function 2)
 223
 224 (provide 'jabber-xml)
 225
 226 ;;; arch-tag: ca206e65-7026-4ee8-9af2-ff6a9c5af98a