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

   1 ;;; jabber-chatstate.el --- Chat state notification (XEP-0085) implementation  -*- lexical-binding: t; -*-
   2
   3 ;; Author: Ami Fischman <ami@fischman.org>
   4 ;; (based entirely on jabber-events.el by Magnus Henoch <mange@freemail.hu>)
   5
   6 ;; This file is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2, or (at your option)
   9 ;; any later version.
  10
  11 ;; This file is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 ;; Boston, MA 02111-1307, USA.
  20
  21 ;; TODO
  22 ;; - Currently only active/composing notifications are /sent/ though all 5
  23 ;;   notifications are handled on receipt.
  24
  25 (require 'cl-lib)
  26
  27 (defgroup jabber-chatstates nil
  28   "Chat state notifications."
  29   :group 'jabber)
  30
  31 (defconst jabber-chatstates-xmlns "http://jabber.org/protocol/chatstates"
  32   "XML namespace for the chatstates feature.")
  33
  34 (defcustom jabber-chatstates-confirm t
  35   "Send notifications about chat states?"
  36   :group 'jabber-chatstates
  37   :type 'boolean)
  38
  39 (defvar jabber-chatstates-requested 'first-time
  40   "Whether or not chat states notification was requested.
  41 This is one of the following:
  42 first-time - send state in first stanza, then switch to nil
  43 t - send states
  44 nil - don't send states")
  45 (make-variable-buffer-local 'jabber-chatstates-requested)
  46
  47 (defvar jabber-chatstates-last-state nil
  48   "The last seen chat state.")
  49 (make-variable-buffer-local 'jabber-chatstates-last-state)
  50
  51 (defvar jabber-chatstates-message ""
  52   "Human-readable presentation of chat state information.")
  53 (make-variable-buffer-local 'jabber-chatstates-message)
  54
  55 ;;; INCOMING
  56 ;;; Code for requesting chat state notifications from others and handling
  57 ;;; them.
  58
  59 (defun jabber-chatstates-update-message ()
  60   (setq jabber-chatstates-message
  61         (if (and jabber-chatstates-last-state
  62                  (not (eq 'active jabber-chatstates-last-state)))
  63             (format " (%s)" (symbol-name jabber-chatstates-last-state))
  64           "")))
  65
  66 (add-hook 'jabber-chat-send-hooks 'jabber-chatstates-when-sending)
  67 (defun jabber-chatstates-when-sending (text id)
  68   (jabber-chatstates-update-message)
  69   (jabber-chatstates-stop-timer)
  70   (when (and jabber-chatstates-confirm jabber-chatstates-requested)
  71     (when (eq jabber-chatstates-requested 'first-time)
  72       ;; don't send more notifications until we know that the other
  73       ;; side wants them.
  74       (setq jabber-chatstates-requested nil))
  75     (setq jabber-chatstates-composing-sent nil)
  76     `((active ((xmlns . ,jabber-chatstates-xmlns))))))
  77
  78 ;;; OUTGOING
  79 ;;; Code for handling requests for chat state notifications and providing
  80 ;;; them, modulo user preferences.
  81
  82 (defvar jabber-chatstates-composing-sent nil
  83   "Has composing notification been sent?
  84 It can be sent and cancelled several times.")
  85 (make-variable-buffer-local 'jabber-chatstates-composing-sent)
  86
  87 (defvar jabber-chatstates-paused-timer nil
  88   "Timer that counts down from 'composing state to 'paused.")
  89 (make-variable-buffer-local 'jabber-chatstates-paused-timer)
  90
  91 (defun jabber-chatstates-stop-timer ()
  92   "Stop the 'paused timer."
  93   (when jabber-chatstates-paused-timer
  94     (cancel-timer jabber-chatstates-paused-timer)))
  95
  96 (defun jabber-chatstates-kick-timer ()
  97   "Start (or restart) the 'paused timer as approriate."
  98   (jabber-chatstates-stop-timer)
  99   (setq jabber-chatstates-paused-timer
 100         (run-with-timer 5 nil 'jabber-chatstates-send-paused)))
 101
 102 (defun jabber-chatstates-send-paused ()
 103   "Send an 'paused state notification."
 104   (when (and jabber-chatstates-requested jabber-chatting-with)
 105     (setq jabber-chatstates-composing-sent nil)
 106     (jabber-send-sexp-if-connected
 107      jabber-buffer-connection
 108      `(message
 109        ((to . ,jabber-chatting-with)
 110         (type . "chat"))
 111        (paused ((xmlns . ,jabber-chatstates-xmlns)))))))
 112
 113 (defun jabber-chatstates-after-change ()
 114   (let* ((composing-now (not (= (point-max) jabber-point-insert)))
 115          (state (if composing-now 'composing 'active)))
 116     (when (and jabber-chatstates-confirm
 117                jabber-chatting-with
 118                jabber-chatstates-requested
 119                (not (eq composing-now jabber-chatstates-composing-sent)))
 120       (jabber-send-sexp-if-connected
 121        jabber-buffer-connection
 122        `(message
 123          ((to . ,jabber-chatting-with)
 124           (type . "chat"))
 125          (,state ((xmlns . ,jabber-chatstates-xmlns)))))
 126       (when (setq jabber-chatstates-composing-sent composing-now)
 127         (jabber-chatstates-kick-timer)))))
 128
 129 ;;; COMMON
 130
 131 (defun jabber-handle-incoming-message-chatstates (jc xml-data)
 132   (when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))
 133     (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))
 134       (cond
 135        ;; If we get an error message, we shouldn't report any
 136        ;; events, as the requests are mirrored from us.
 137        ((string= (jabber-xml-get-attribute xml-data 'type) "error")
 138         (remove-hook 'post-command-hook 'jabber-chatstates-after-change t)
 139         (setq jabber-chatstates-requested nil))
 140
 141        (t
 142         (let ((state
 143                (or
 144                 (let ((node
 145                        (cl-find jabber-chatstates-xmlns
 146                              (jabber-xml-node-children xml-data)
 147                              :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns))
 148                              :test #'string=)))
 149                   (jabber-xml-node-name node))
 150                 (let ((node
 151                        ;; XXX: this is how we interoperate with
 152                        ;; Google Talk.  We should really use a
 153                        ;; namespace-aware XML parser.
 154                        (cl-find jabber-chatstates-xmlns
 155                              (jabber-xml-node-children xml-data)
 156                              :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns:cha))
 157                              :test #'string=)))
 158                   (when node
 159                     ;; Strip the "cha:" prefix
 160                     (let ((name (symbol-name (jabber-xml-node-name node))))
 161                       (when (> (length name) 4)
 162                         (intern (substring name 4)))))))))
 163           ;; Set up hooks for composition notification
 164           (when (and jabber-chatstates-confirm state)
 165             (setq jabber-chatstates-requested t)
 166             (add-hook 'post-command-hook 'jabber-chatstates-after-change nil t))
 167
 168           (setq jabber-chatstates-last-state state)
 169           (jabber-chatstates-update-message)))))))
 170
 171 ;; Add function last in chain, so a chat buffer is already created.
 172 (add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-chatstates t)
 173
 174 (jabber-disco-advertise-feature "http://jabber.org/protocol/chatstates")
 175
 176 (provide 'jabber-chatstates)
 177 ;; arch-tag: d879de90-51e1-11dc-909d-000a95c2fcd0