jabber-browse.el

   1 ;; jabber-browse.el - jabber browsing by JEP-0011
   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   (interactive (list (jabber-read-account)
  33                      (jabber-read-jid-completing "browse: " nil nil nil nil t)))
  34   (jabber-send-iq jc to
  35                   "get"
  36                   '(query ((xmlns . "jabber:iq:browse")))
  37                   #'jabber-process-data #'jabber-process-browse
  38                   #'jabber-process-data "Browse failed"))
  39
  40 ;; called from jabber-process-data
  41 (defun jabber-process-browse (jc xml-data)
  42   "Handle results from jabber:iq:browse requests."
  43   (dolist (item (jabber-xml-node-children xml-data))
  44     (when (and (listp item)
  45                (not (eq (jabber-xml-node-name item) 'ns)))
  46       (let ((jid (jabber-xml-get-attribute item 'jid))
  47             (beginning (point)))
  48         (cond
  49          ((or
  50            (eq (jabber-xml-node-name item) 'user)
  51            (string= (jabber-xml-get-attribute item 'category) "user"))
  52           (insert (jabber-propertize "$ USER"
  53                               'face 'jabber-title-medium)
  54                   "\n\n"))
  55          ((or
  56            (eq (jabber-xml-node-name item) 'service)
  57            (string= (jabber-xml-get-attribute item 'category) "service"))
  58           (insert (jabber-propertize "* SERVICE"
  59                               'face 'jabber-title-medium)
  60                   "\n\n"))
  61          ((or
  62            (eq (jabber-xml-node-name item) 'conference)
  63            (string= (jabber-xml-get-attribute item 'category) "conference"))
  64           (insert (jabber-propertize "@ CONFERENCE"
  65                               'face 'jabber-title-medium)
  66                   "\n\n"))
  67          (t
  68           ;; So far I've seen "server" and "directory", both in the node-name.
  69           ;; Those are actually service disco categories, but jabberd 2 seems
  70           ;; to use them for browse results as well.  It's not right (as in
  71           ;; JEP-0011), but it's reasonable.
  72           (let ((category (jabber-xml-get-attribute item 'category)))
  73             (if (= (length category) 0)
  74                 (setq category (jabber-xml-node-name item)))
  75             (insert (jabber-propertize (format "! OTHER: %s" category)
  76                                 'face 'jabber-title-medium)
  77                     "\n\n"))))
  78         (dolist (attr '((type . "Type:\t\t")
  79                         (jid . "JID:\t\t")
  80                         (name . "Name:\t\t")
  81                         (version . "Version:\t")))
  82           (let ((data (jabber-xml-get-attribute item (car attr))))
  83             (if (> (length data) 0)
  84                 (insert (cdr attr) data "\n"))))
  85
  86         (dolist (ns (jabber-xml-get-children item 'ns))
  87           (if (stringp (car (jabber-xml-node-children ns)))
  88               (insert "Namespace:\t" (car (jabber-xml-node-children ns)) "\n")))
  89
  90         (insert "\n")
  91         (put-text-property beginning (point) 'jabber-jid jid)
  92         (put-text-property beginning (point) 'jabber-account jc)
  93
  94         ;; XXX: Is this kind of recursion really needed?
  95         (if (listp (car (jabber-xml-node-children item)))
  96             (jabber-process-browse jc item))))))
  97
  98 (provide 'jabber-browse)
  99
 100 ;;; arch-tag: be01ab34-96eb-4fcb-aa35-a0d3e6c446c3