jabber-util.el

   1 ;; jabber-util.el - various utility functions    -*- coding: utf-8; -*-
   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 ;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org
   6
   7 ;; This file is a part of jabber.el.
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, write to the Free Software
  21 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  22
  23 (eval-when-compile (require 'cl))
  24 (condition-case nil
  25     (require 'password)
  26   (error nil))
  27
  28 (defvar jabber-jid-history nil
  29   "History of entered JIDs")
  30
  31 ;; Define `jabber-replace-in-string' somehow.
  32 (cond
  33  ;; Emacs 21 has replace-regexp-in-string.
  34  ((fboundp 'replace-regexp-in-string)
  35   (defsubst jabber-replace-in-string (str regexp newtext)
  36     (replace-regexp-in-string regexp newtext str t t)))
  37  ;; XEmacs has replace-in-string.  However, color-theme defines it as
  38  ;; well on Emacs 2x, so this check must be last.
  39  ((fboundp 'replace-in-string)
  40   ;; And the version in color-theme takes only three arguments.  Check
  41   ;; just to be sure.
  42   (condition-case nil
  43       (replace-in-string "foobar" "foo" "bar" t)
  44     (wrong-number-of-arguments
  45      (error "`replace-in-string' doesn't accept fourth argument")))
  46   (defsubst jabber-replace-in-string (str regexp newtext)
  47     (replace-in-string str regexp newtext t)))
  48  (t
  49   (error "No implementation of `jabber-replace-in-string' available")))
  50
  51 ;;; XEmacs compatibility.  Stolen from ibuffer.el
  52 (if (fboundp 'propertize)
  53     (defalias 'jabber-propertize 'propertize)
  54   (defun jabber-propertize (string &rest properties)
  55     "Return a copy of STRING with text properties added.
  56
  57  [Note: this docstring has been copied from the Emacs 21 version]
  58
  59 First argument is the string to copy.
  60 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
  61 properties to add to the result."
  62     (let ((str (copy-sequence string)))
  63       (add-text-properties 0 (length str)
  64                            properties
  65                            str)
  66       str)))
  67
  68 (unless (fboundp 'bound-and-true-p)
  69   (defmacro bound-and-true-p (var)
  70     "Return the value of symbol VAR if it is bound, else nil."
  71     `(and (boundp (quote ,var)) ,var)))
  72
  73 ;;; more XEmacs compatibility
  74 ;;; Preserve input method when entering a minibuffer
  75 (if (featurep 'xemacs)
  76     ;; I don't know how to do this
  77     (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value)
  78       (read-string prompt initial-contents history default-value))
  79   (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value)
  80     (read-string prompt initial-contents history default-value t)))
  81
  82 (unless (fboundp 'delete-and-extract-region)
  83   (defsubst delete-and-extract-region (start end)
  84     (prog1
  85         (buffer-substring start end)
  86       (delete-region start end))))
  87
  88 (unless (fboundp 'access-file)
  89   (defsubst access-file (filename error-message)
  90     (unless (file-readable-p filename)
  91       (error error-message))))
  92
  93 (if (fboundp 'float-time)
  94     (defalias 'jabber-float-time 'float-time)
  95   (defun jabber-float-time (&optional specified-time)
  96     (unless specified-time
  97       (setq specified-time (current-time)))
  98     ;; second precision is good enough for us
  99     (+ (* 65536.0 (car specified-time))
 100        (cadr specified-time))))
 101
 102 (cond
 103  ((fboundp 'cancel-timer)
 104   (defalias 'jabber-cancel-timer 'cancel-timer))
 105  ((fboundp 'delete-itimer)
 106   (defalias 'jabber-cancel-timer 'delete-itimer))
 107  (t
 108   (error "No `cancel-timer' function found")))
 109
 110 (defun jabber-concat-rosters ()
 111   "Concatenate the rosters of all connected accounts."
 112   (apply #'append
 113          (mapcar
 114           (lambda (jc)
 115             (plist-get (fsm-get-state-data jc) :roster))
 116           jabber-connections)))
 117
 118 (defun jabber-connection-jid (jc)
 119   "Return the full JID of the given connection."
 120   (let ((sd (fsm-get-state-data jc)))
 121     (concat (plist-get sd :username) "@"
 122             (plist-get sd :server) "/"
 123             (plist-get sd :resource))))
 124
 125 (defun jabber-connection-bare-jid (jc)
 126   "Return the bare JID of the given connection."
 127   (let ((sd (fsm-get-state-data jc)))
 128     (concat (plist-get sd :username) "@"
 129             (plist-get sd :server))))
 130
 131 (defun jabber-find-active-connection (dead-jc)
 132   "Given a dead connection, find an active connection to the same account.
 133 Return nil if none found."
 134   (let ((jid (jabber-connection-bare-jid dead-jc)))
 135     (dolist (jc jabber-connections)
 136       (when (string= jid (jabber-connection-bare-jid jc))
 137         (return jc)))))
 138
 139 (defun jabber-jid-username (string)
 140   "return the username portion of a JID, or nil if no username"
 141   (when (string-match "\\(.*\\)@.*\\(/.*\\)?" string)
 142     (match-string 1 string)))
 143
 144 (defun jabber-jid-user (string)
 145   "return the user (username@server) portion of a JID"
 146   ;;transports don't have @, so don't require it
 147   ;;(string-match ".*@[^/]*" string)
 148   (string-match "[^/]*" string)
 149   (match-string 0 string))
 150
 151 (defun jabber-jid-server (string)
 152   "Return the server portion of a JID."
 153   (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" string)
 154   (match-string 2 string))
 155
 156 (defun jabber-jid-rostername (string)
 157   "return the name of the user, if given in roster, else nil"
 158   (let ((user (jabber-jid-symbol string)))
 159     (if (> (length (get user 'name)) 0)
 160         (get user 'name))))
 161
 162 (defun jabber-jid-displayname (string)
 163   "return the name of the user, if given in roster, else username@server"
 164   (or (jabber-jid-rostername string)
 165       (jabber-jid-user (if (symbolp string)
 166                            (symbol-name string)
 167                          string))))
 168
 169 (defun jabber-jid-resource (string)
 170   "return the resource portion of a JID, or nil if there is none."
 171   (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" string)
 172     (match-string 3 string)))
 173
 174 (defun jabber-jid-symbol (string)
 175   "return the symbol for the given JID"
 176   ;; If it's already a symbol, just return it.
 177   (if (symbolp string)
 178       string
 179     ;; XXX: "downcase" is poor man's nodeprep.  See XMPP CORE.
 180     (intern (downcase (jabber-jid-user string)) jabber-jid-obarray)))
 181
 182 (defun jabber-my-jid-p (jc jid)
 183   "Return non-nil if the specified JID is in jabber-account-list (modulo resource). JC arg placed for compatibility and may be removed in future."
 184   (member (jabber-jid-user jid) (mapcar (lambda (x) (jabber-jid-user (car x))) jabber-account-list)))
 185
 186 (defun jabber-read-jid-completing (prompt &optional subset require-match default resource)
 187   "read a jid out of the current roster from the minibuffer.
 188 If SUBSET is non-nil, it should be a list of symbols from which
 189 the JID is to be selected, instead of using the entire roster.
 190 If REQUIRE-MATCH is non-nil, the JID must be in the list used.
 191 If DEFAULT is non-nil, it's used as the default value, otherwise
 192 the default is inferred from context.
 193 RESOURCE is one of the following:
 194
 195 nil         Accept full or bare JID, as entered
 196 full        Turn bare JIDs to full ones with highest-priority resource
 197 bare-or-muc Turn full JIDs to bare ones, except for in MUC"
 198   (let ((jid-at-point (or
 199                        (and default
 200                             ;; default can be either a symbol or a string
 201                             (if (symbolp default)
 202                                 (symbol-name default)
 203                               default))
 204                        (get-text-property (point) 'jabber-jid)
 205                        (bound-and-true-p jabber-chatting-with)
 206                        (bound-and-true-p jabber-group)))
 207         (completion-ignore-case t)
 208         (jid-completion-table (mapcar #'(lambda (item)
 209                                           (cons (symbol-name item) item))
 210                                       (or subset (jabber-concat-rosters))))
 211         chosen)
 212     (dolist (item (or subset (jabber-concat-rosters)))
 213       (if (get item 'name)
 214           (push (cons (get item 'name) item) jid-completion-table)))
 215     ;; if the default is not in the allowed subset, it's not a good default
 216     (if (and subset (not (assoc jid-at-point jid-completion-table)))
 217         (setq jid-at-point nil))
 218     (let ((input
 219            (completing-read (concat prompt
 220                                     (if jid-at-point
 221                                         (format "(default %s) " jid-at-point)))
 222                             jid-completion-table
 223                             nil require-match nil 'jabber-jid-history jid-at-point)))
 224       (setq chosen
 225             (if (and input (assoc-ignore-case input jid-completion-table))
 226                 (symbol-name (cdr (assoc-ignore-case input jid-completion-table)))
 227               (and (not (zerop (length input)))
 228                    input))))
 229
 230     (when chosen
 231       (case resource
 232         (full
 233          ;; If JID is bare, add the highest-priority resource.
 234          (if (jabber-jid-resource chosen)
 235              chosen
 236            (let ((highest-resource (get (jabber-jid-symbol chosen) 'resource)))
 237              (if highest-resource
 238                  (concat chosen "/" highest-resource)
 239                chosen))))
 240         (bare-or-muc
 241          ;; If JID is full and non-MUC, remove resource.
 242          (if (null (jabber-jid-resource chosen))
 243              chosen
 244            (let ((bare (jabber-jid-user chosen)))
 245              (if (assoc bare *jabber-active-groupchats*)
 246                  chosen
 247                bare))))
 248         (t
 249          chosen)))))
 250
 251 (defun jabber-read-node (prompt)
 252   "Read node name, taking default from disco item at point."
 253   (let ((node-at-point (get-text-property (point) 'jabber-node)))
 254     (read-string (concat prompt
 255                          (if node-at-point
 256                              (format "(default %s) " node-at-point)))
 257                  node-at-point)))
 258
 259 (defun jabber-password-key (bare-jid)
 260   "Construct key for `password' library from BARE-JID."
 261   (concat "xmpp:" bare-jid))
 262
 263 (defun jabber-read-password (bare-jid)
 264   "Read Jabber password from minibuffer."
 265   (let ((prompt (format "Jabber password for %s: " bare-jid)))
 266     (if (fboundp 'password-read)
 267         ;; Need to copy the password, as sasl.el wants to erase it.
 268         (copy-sequence
 269          (password-read prompt (jabber-password-key bare-jid)))
 270       (read-passwd prompt))))
 271
 272 (defun jabber-cache-password (bare-jid password)
 273   "Cache PASSWORD for BARE-JID."
 274   (when (fboundp 'password-cache-add)
 275     (password-cache-add (jabber-password-key bare-jid) password)))
 276
 277 (defun jabber-uncache-password (bare-jid)
 278   "Uncache cached password for BARE-JID.
 279 Useful if the password proved to be wrong."
 280   (interactive (list (jabber-jid-user
 281                       (completing-read "Forget password of account: " jabber-account-list))))
 282   (when (fboundp 'password-cache-remove)
 283     (password-cache-remove (jabber-password-key bare-jid))))
 284
 285 (defun jabber-read-account (&optional always-ask)
 286   "Ask for which connected account to use.
 287 If ALWAYS-ASK is nil and there is only one account, return that
 288 account."
 289   (let ((completions
 290          (mapcar (lambda (c)
 291                    (cons
 292                     (jabber-connection-bare-jid c)
 293                     c))
 294                  jabber-connections)))
 295     (cond
 296      ((null jabber-connections)
 297       (error "Not connected to Jabber"))
 298      ((and (null (cdr jabber-connections)) (not always-ask))
 299       ;; only one account
 300       (car jabber-connections))
 301      (t
 302       (or
 303        ;; if there is a jabber-account property at point,
 304        ;; present it as default value
 305        (cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account)))
 306                      (when (and at-point
 307                                 (memq at-point jabber-connections))
 308                        (jabber-connection-bare-jid at-point))) completions))
 309        (let* ((default
 310                 (or
 311                  ;; if the buffer is associated with a connection, use it
 312                  (when (and jabber-buffer-connection
 313                             (memq jabber-buffer-connection jabber-connections))
 314                    (jabber-connection-bare-jid jabber-buffer-connection))
 315                  ;; else, use the first connection in the list
 316                  (caar completions)))
 317               (input (completing-read
 318                       (concat "Select Jabber account (default "
 319                               default
 320                               "): ")
 321                       completions nil t nil nil
 322                       default)))
 323          (cdr (assoc input completions))))))))
 324
 325 (defun jabber-iq-query (xml-data)
 326   "Return the query part of an IQ stanza.
 327 An IQ stanza may have zero or one query child, and zero or one <error/> child.
 328 The query child is often but not always <query/>."
 329   (let (query)
 330     (dolist (x (jabber-xml-node-children xml-data))
 331       (if (and
 332            (listp x)
 333            (not (eq (jabber-xml-node-name x) 'error)))
 334           (setq query x)))
 335     query))
 336
 337 (defun jabber-iq-error (xml-data)
 338   "Return the <error/> part of an IQ stanza, if any."
 339   (car (jabber-xml-get-children xml-data 'error)))
 340
 341 (defun jabber-iq-xmlns (xml-data)
 342   "Return the namespace of an IQ stanza, i.e. the namespace of its query part."
 343   (jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns))
 344
 345 (defun jabber-x-delay (xml-data)
 346   "Return timestamp given a <x/> tag in namespace jabber:x:delay.
 347 Return nil if no such data available."
 348   (when (and (eq (jabber-xml-node-name xml-data) 'x)
 349              (string= (jabber-xml-get-attribute xml-data 'xmlns) "jabber:x:delay"))
 350     (let ((stamp (jabber-xml-get-attribute xml-data 'stamp)))
 351       (if (and (stringp stamp)
 352                (= (length stamp) 17))
 353           (jabber-parse-legacy-time stamp)))))
 354
 355 (defun jabber-parse-legacy-time (timestamp)
 356   "Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal time value."
 357   (let ((year (string-to-number (substring timestamp 0 4)))
 358         (month (string-to-number (substring timestamp 4 6)))
 359         (day (string-to-number (substring timestamp 6 8)))
 360         (hour (string-to-number (substring timestamp 9 11)))
 361         (minute (string-to-number (substring timestamp 12 14)))
 362         (second (string-to-number (substring timestamp 15 17))))
 363     (encode-time second minute hour day month year 0)))
 364
 365 (defun jabber-encode-legacy-time (timestamp)
 366   "Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)."
 367   (if (featurep 'xemacs)
 368       ;; XEmacs doesn't have `universal' argument to format-time-string,
 369       ;; so we have to do it ourselves.
 370       (format-time-string "%Y%m%dT%H:%M:%S"
 371                           (time-subtract timestamp
 372                                          (list 0 (car (current-time-zone)))))
 373     (format-time-string "%Y%m%dT%H:%M:%S" timestamp t)))
 374
 375 (defun jabber-encode-time (time)
 376   "Convert TIME to a string by JEP-0082.
 377 TIME is in a format accepted by `format-time-string'."
 378   (let ((time-zone-offset (nth 0 (current-time-zone))))
 379     (if (null time-zone-offset)
 380         ;; no time zone information available; pretend it's UTC
 381         (format-time-string "%Y-%m-%dT%H:%M:%SZ" time)
 382       (let* ((positivep (>= time-zone-offset 0))
 383              (hours (/ (abs time-zone-offset) 3600))
 384              (minutes (/ (% (abs time-zone-offset) 3600) 60)))
 385         (format "%s%s%02d:%02d" (format-time-string "%Y-%m-%dT%H:%M:%S" time)
 386                 (if positivep "+" "-") hours minutes)))))
 387
 388 (defun jabber-parse-time (time)
 389   "Parse the DateTime encoded in TIME according to JEP-0082."
 390   (let* ((year (string-to-number (substring time 0 4)))
 391          (month (string-to-number (substring time 5 7)))
 392          (day (string-to-number (substring time 8 10)))
 393          (hour (string-to-number (substring time 11 13)))
 394          (minute (string-to-number (substring time 14 16)))
 395          (second (string-to-number (substring time 17 19)))
 396          ;; fractions are optional
 397          (fraction (if (eq (aref time 19) ?.)
 398                        (string-to-number (substring time 20 23))))
 399          (timezone (substring time (if fraction 23 19))))
 400     ;; timezone is either Z (UTC) or [+-]HH:MM
 401     (let ((timezone-seconds
 402            (if (string= timezone "Z")
 403                0
 404              (* (if (eq (aref timezone 0) ?+) 1 -1)
 405                 (* 60 (+ (* 60 (string-to-number (substring timezone 1 3)))
 406                          (string-to-number (substring timezone 4 6))))))))
 407       (encode-time second minute hour day month year timezone-seconds))))
 408
 409 (defun jabber-report-success (jc xml-data context)
 410   "IQ callback reporting success or failure of the operation.
 411 CONTEXT is a string describing the action.
 412 \"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in
 413 the echo area."
 414   (let ((type (jabber-xml-get-attribute xml-data 'type)))
 415     (message (concat context
 416                      (if (string= type "result")
 417                          " succeeded"
 418                        (concat
 419                         " failed: "
 420                         (let ((the-error (jabber-iq-error xml-data)))
 421                           (if the-error
 422                               (jabber-parse-error the-error)
 423                             "No error message given"))))))))
 424
 425 (defconst jabber-error-messages
 426   (list
 427    (cons 'bad-request "Bad request")
 428    (cons 'conflict "Conflict")
 429    (cons 'feature-not-implemented "Feature not implemented")
 430    (cons 'forbidden "Forbidden")
 431    (cons 'gone "Gone")
 432    (cons 'internal-server-error "Internal server error")
 433    (cons 'item-not-found "Item not found")
 434    (cons 'jid-malformed "JID malformed")
 435    (cons 'not-acceptable "Not acceptable")
 436    (cons 'not-allowed "Not allowed")
 437    (cons 'not-authorized "Not authorized")
 438    (cons 'payment-required "Payment required")
 439    (cons 'recipient-unavailable "Recipient unavailable")
 440    (cons 'redirect "Redirect")
 441    (cons 'registration-required "Registration required")
 442    (cons 'remote-server-not-found "Remote server not found")
 443    (cons 'remote-server-timeout "Remote server timeout")
 444    (cons 'resource-constraint "Resource constraint")
 445    (cons 'service-unavailable "Service unavailable")
 446    (cons 'subscription-required "Subscription required")
 447    (cons 'undefined-condition "Undefined condition")
 448    (cons 'unexpected-request "Unexpected request"))
 449   "String descriptions of XMPP stanza errors")
 450
 451 (defconst jabber-legacy-error-messages
 452   (list
 453    (cons 302 "Redirect")
 454    (cons 400 "Bad request")
 455    (cons 401 "Unauthorized")
 456    (cons 402 "Payment required")
 457    (cons 403 "Forbidden")
 458    (cons 404 "Not found")
 459    (cons 405 "Not allowed")
 460    (cons 406 "Not acceptable")
 461    (cons 407 "Registration required")
 462    (cons 408 "Request timeout")
 463    (cons 409 "Conflict")
 464    (cons 500 "Internal server error")
 465    (cons 501 "Not implemented")
 466    (cons 502 "Remote server error")
 467    (cons 503 "Service unavailable")
 468    (cons 504 "Remote server timeout")
 469    (cons 510 "Disconnected"))
 470   "String descriptions of legacy errors (JEP-0086)")
 471
 472 (defun jabber-parse-error (error-xml)
 473   "Parse the given <error/> tag and return a string fit for human consumption.
 474 See secton 9.3, Stanza Errors, of XMPP Core, and JEP-0086, Legacy Errors."
 475   (let ((error-type (jabber-xml-get-attribute error-xml 'type))
 476         (error-code (jabber-xml-get-attribute error-xml 'code))
 477         condition text)
 478     (if error-type
 479         ;; If the <error/> tag has a type element, it is new-school.
 480         (dolist (child (jabber-xml-node-children error-xml))
 481           (when (string=
 482                  (jabber-xml-get-attribute child 'xmlns)
 483                  "urn:ietf:params:xml:ns:xmpp-stanzas")
 484             (if (eq (jabber-xml-node-name child) 'text)
 485                 (setq text (car (jabber-xml-node-children child)))
 486               (setq condition
 487                     (or (cdr (assq (jabber-xml-node-name child) jabber-error-messages))
 488                         (symbol-name (jabber-xml-node-name child)))))))
 489       (setq condition (or (cdr (assq (string-to-number error-code) jabber-legacy-error-messages))
 490                           error-code))
 491       (setq text (car (jabber-xml-node-children error-xml))))
 492     (concat condition
 493             (if text (format ": %s" text)))))
 494
 495 (defun jabber-error-condition (error-xml)
 496   "Parse the given <error/> tag and return the condition symbol."
 497   (catch 'condition
 498     (dolist (child (jabber-xml-node-children error-xml))
 499       (when (string=
 500                  (jabber-xml-get-attribute child 'xmlns)
 501                  "urn:ietf:params:xml:ns:xmpp-stanzas")
 502         (throw 'condition (jabber-xml-node-name child))))))
 503
 504 (defvar jabber-stream-error-messages
 505   (list
 506    (cons 'bad-format "Bad XML format")
 507    (cons 'bad-namespace-prefix "Bad namespace prefix")
 508    (cons 'conflict "Conflict")
 509    (cons 'connection-timeout "Connection timeout")
 510    (cons 'host-gone "Host gone")
 511    (cons 'host-unknown "Host unknown")
 512    (cons 'improper-addressing "Improper addressing") ; actually only s2s
 513    (cons 'internal-server-error "Internal server error")
 514    (cons 'invalid-from "Invalid from")
 515    (cons 'invalid-id "Invalid id")
 516    (cons 'invalid-namespace "Invalid namespace")
 517    (cons 'invalid-xml "Invalid XML")
 518    (cons 'not-authorized "Not authorized")
 519    (cons 'policy-violation "Policy violation")
 520    (cons 'remote-connection-failed "Remote connection failed")
 521    (cons 'resource-constraint "Resource constraint")
 522    (cons 'restricted-xml "Restricted XML")
 523    (cons 'see-other-host "See other host")
 524    (cons 'system-shutdown "System shutdown")
 525    (cons 'undefined-condition "Undefined condition")
 526    (cons 'unsupported-encoding "Unsupported encoding")
 527    (cons 'unsupported-stanza-type "Unsupported stanza type")
 528    (cons 'unsupported-version "Unsupported version")
 529    (cons 'xml-not-well-formed "XML not well formed"))
 530   "String descriptions of XMPP stream errors")
 531
 532 (defun jabber-stream-error-condition (error-xml)
 533   "Return the condition of a <stream:error/> tag."
 534   ;; as we don't know the node name of the condition, we have to
 535   ;; search for it.
 536   (dolist (node (jabber-xml-node-children error-xml))
 537     (when (and (string= (jabber-xml-get-attribute node 'xmlns)
 538                         "urn:ietf:params:xml:ns:xmpp-streams")
 539                (assq (jabber-xml-node-name node)
 540                      jabber-stream-error-messages))
 541       (return (jabber-xml-node-name node)))))
 542
 543 (defun jabber-parse-stream-error (error-xml)
 544   "Parse the given <stream:error/> tag and return a sting fit for human consumption."
 545   (let ((text-node (car (jabber-xml-get-children error-xml 'text)))
 546         (condition (jabber-stream-error-condition error-xml)))
 547     (concat (if condition (cdr (assq condition jabber-stream-error-messages))
 548               "Unknown stream error")
 549             (if (and text-node (stringp (car (jabber-xml-node-children text-node))))
 550                 (concat ": " (car (jabber-xml-node-children text-node)))))))
 551
 552 (put 'jabber-error
 553      'error-conditions
 554      '(error jabber-error))
 555 (put 'jabber-error
 556      'error-message
 557      "Jabber error")
 558
 559 (defun jabber-signal-error (error-type condition &optional text app-specific)
 560   "Signal an error to be sent by Jabber.
 561 ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\"
 562 and \"wait\".
 563 CONDITION is a symbol denoting a defined XMPP condition.
 564 TEXT is a string to be sent in the error message, or nil for no text.
 565 APP-SPECIFIC is a list of extra XML tags.
 566
 567 See section 9.3 of XMPP Core."
 568   (signal 'jabber-error
 569           (list error-type condition text app-specific)))
 570
 571 (defun jabber-unhex (string)
 572   "Convert a hex-encoded UTF-8 string to Emacs representation.
 573 For example, \"ji%C5%99i@%C4%8Dechy.example/v%20Praze\" becomes
 574 \"jiři@čechy.example/v Praze\"."
 575   (decode-coding-string (url-unhex-string string) 'utf-8))
 576
 577 (defun jabber-handle-uri (uri &rest ignored-args)
 578   "Handle XMPP links according to draft-saintandre-xmpp-iri-04.
 579 See Info node `(jabber)XMPP URIs'."
 580   (interactive "sEnter XMPP URI: ")
 581
 582   (when (string-match "//" uri)
 583     (error "URIs with authority part are not supported"))
 584
 585   ;; This regexp handles three cases:
 586   ;; xmpp:romeo@montague.net
 587   ;; xmpp:romeo@montague.net?roster
 588   ;; xmpp:romeo@montague.net?roster;name=Romeo%20Montague;group=Lovers
 589   (unless (string-match "^xmpp:\\([^?]+\\)\\(\\?\\([a-z]+\\)\\(;\\(.*\\)\\)?\\)?" uri)
 590     (error "Invalid XMPP URI '%s'" uri))
 591
 592   ;; We start by raising the Emacs frame.
 593   (raise-frame)
 594
 595   (let ((jid (jabber-unhex (match-string 1 uri)))
 596         (method (match-string 3 uri))
 597         (args (let ((text (match-string 5 uri)))
 598                 ;; If there are arguments...
 599                 (when text
 600                   ;; ...split the pairs by ';'...
 601                   (let ((pairs (split-string text ";")))
 602                     (mapcar (lambda (pair)
 603                               ;; ...and split keys from values by '='.
 604                               (destructuring-bind (key value)
 605                                   (split-string pair "=")
 606                                 ;; Values can be hex-coded.
 607                                 (cons key (jabber-unhex value))))
 608                             pairs))))))
 609     ;; The full list of methods is at
 610     ;; <URL:http://www.jabber.org/registrar/querytypes.html>.
 611     (cond
 612      ;; Join an MUC.
 613      ((string= method "join")
 614       (jabber-groupchat-join
 615        (jabber-read-account) jid (jabber-muc-read-my-nickname jid) t))
 616      ;; Register with a service.
 617      ((string= method "register")
 618       (jabber-get-register (jabber-read-account) jid))
 619      ;; Run an ad-hoc command
 620      ((string= method "command")
 621       ;; XXX: does the 'action' attribute make sense?
 622       (jabber-ahc-execute-command
 623        (jabber-read-account) jid (cdr (assoc "node" args))))
 624      ;; Everything else: open a chat buffer.
 625      (t
 626       (jabber-chat-with (jabber-read-account) jid)))))
 627
 628 (defun url-xmpp (url)
 629   "Handle XMPP URLs from internal Emacs functions."
 630   ;; XXX: This parsing roundtrip is redundant, and the parser of the
 631   ;; url package might lose information.
 632   (jabber-handle-uri (url-recreate-url url)))
 633
 634 (defun string>-numerical (s1 s2)
 635   "Return t if first arg string is more than second in numerical order."
 636   (cond ((string= s1 s2) nil)
 637         ((> (length s1) (length s2)) t)
 638         ((< (length s1) (length s2)) nil)
 639         ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil)
 640         ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t)
 641         (t (string>-numerical (substring s1 1) (substring s2 1)))))
 642
 643 (provide 'jabber-util)
 644
 645 ;;; arch-tag: cfbb73ac-e2d7-4652-a08d-dc789bcded8a