| | 1 | ;; jabber-browse.el - jabber browsing by JEP-0011 -*- lexical-binding: t; -*- |
| | 2 | |
| | 3 | ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net |
| | 4 | ;; Copyright (C) 2003, 2004 - Magnus Henoch - mange@freemail.hu |
| | 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 'jabber-iq) |
| | 23 | (require 'jabber-xml) |
| | 24 | (require 'jabber-util) |
| | 25 | |
| | 26 | ;; jabber.el can perform browse requests, but will not answer them. |
| | 27 | |
| | 28 | (add-to-list 'jabber-jid-info-menu |
| | 29 | (cons "Send browse query" 'jabber-get-browse)) |
| | 30 | (defun jabber-get-browse (jc to) |
| | 31 | "Send a browse infoquery request to someone. |
| | 32 | |
| | 33 | JC is the Jabber connection." |
| | 34 | (interactive (list (jabber-read-account) |
| | 35 | (jabber-read-jid-completing "browse: " nil nil nil nil t))) |
| | 36 | (jabber-send-iq jc to |
| | 37 | "get" |
| | 38 | '(query ((xmlns . "jabber:iq:browse"))) |
| | 39 | #'jabber-process-data #'jabber-process-browse |
| | 40 | #'jabber-process-data "Browse failed")) |
| | 41 | |
| | 42 | ;; called from jabber-process-data |
| | 43 | (defun jabber-process-browse (jc xml-data) |
| | 44 | "Handle results from jabber:iq:browse requests. |
| | 45 | |
| | 46 | JC is the Jabber connection. |
| | 47 | XML-DATA is the parsed tree data from the stream (stanzas) |
| | 48 | obtained from `xml-parse-region'." |
| | 49 | (dolist (item (jabber-xml-node-children xml-data)) |
| | 50 | (when (and (listp item) |
| | 51 | (not (eq (jabber-xml-node-name item) 'ns))) |
| | 52 | (let ((jid (jabber-xml-get-attribute item 'jid)) |
| | 53 | (beginning (point))) |
| | 54 | (cond |
| | 55 | ((or |
| | 56 | (eq (jabber-xml-node-name item) 'user) |
| | 57 | (string= (jabber-xml-get-attribute item 'category) "user")) |
| | 58 | (insert (jabber-propertize "$ USER" |
| | 59 | 'face 'jabber-title-medium) |
| | 60 | "\n\n")) |
| | 61 | ((or |
| | 62 | (eq (jabber-xml-node-name item) 'service) |
| | 63 | (string= (jabber-xml-get-attribute item 'category) "service")) |
| | 64 | (insert (jabber-propertize "* SERVICE" |
| | 65 | 'face 'jabber-title-medium) |
| | 66 | "\n\n")) |
| | 67 | ((or |
| | 68 | (eq (jabber-xml-node-name item) 'conference) |
| | 69 | (string= (jabber-xml-get-attribute item 'category) "conference")) |
| | 70 | (insert (jabber-propertize "@ CONFERENCE" |
| | 71 | 'face 'jabber-title-medium) |
| | 72 | "\n\n")) |
| | 73 | (t |
| | 74 | ;; So far I've seen "server" and "directory", both in the node-name. |
| | 75 | ;; Those are actually service disco categories, but jabberd 2 seems |
| | 76 | ;; to use them for browse results as well. It's not right (as in |
| | 77 | ;; XEP-0011), but it's reasonable. |
| | 78 | (let ((category (jabber-xml-get-attribute item 'category))) |
| | 79 | (if (= (length category) 0) |
| | 80 | (setq category (jabber-xml-node-name item))) |
| | 81 | (insert (jabber-propertize (format "! OTHER: %s" category) |
| | 82 | 'face 'jabber-title-medium) |
| | 83 | "\n\n")))) |
| | 84 | (dolist (attr '((type . "Type:\t\t") |
| | 85 | (jid . "JID:\t\t") |
| | 86 | (name . "Name:\t\t") |
| | 87 | (version . "Version:\t"))) |
| | 88 | (let ((data (jabber-xml-get-attribute item (car attr)))) |
| | 89 | (if (> (length data) 0) |
| | 90 | (insert (cdr attr) data "\n")))) |
| | 91 | |
| | 92 | (dolist (ns (jabber-xml-get-children item 'ns)) |
| | 93 | (if (stringp (car (jabber-xml-node-children ns))) |
| | 94 | (insert "Namespace:\t" (car (jabber-xml-node-children ns)) "\n"))) |
| | 95 | |
| | 96 | (insert "\n") |
| | 97 | (put-text-property beginning (point) 'jabber-jid jid) |
| | 98 | (put-text-property beginning (point) 'jabber-account jc) |
| | 99 | |
| | 100 | ;; XXX: Is this kind of recursion really needed? |
| | 101 | (if (listp (car (jabber-xml-node-children item))) |
| | 102 | (jabber-process-browse jc item)))))) |
| | 103 | |
| | 104 | (provide 'jabber-browse) |
| | 105 | |
| | 106 | ;;; arch-tag: be01ab34-96eb-4fcb-aa35-a0d3e6c446c3 |
projects / config.git / blame_incremental