djavu-asus/elpa/jabber-20230715.456/jabber-browse.el

   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