djavu-asus/elpa/jabber-20230715.456/jabber-muc-nick-completion.el

   1 ;;; jabber-muc-nick-completion.el --- MUC nick completion  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org
   4 ;; Copyright (C) 2007, 2008, 2010 - Kirill A. Korinskiy - catap@catap.ru
   5 ;; Copyright (C) 2007 - Serguei Jidkov - jsv@e-mail.ru
   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 ;;; User customizations here:
  24 (defcustom jabber-muc-completion-delimiter ": "
  25   "String to add to end of completion line."
  26   :type 'string
  27   :group 'jabber-chat)
  28
  29 (defcustom jabber-muc-looks-personaling-symbols '("," ":" ">")
  30   "Symbols for personaling messages."
  31   :type '(repeat string)
  32   :group 'jabber-chat)
  33
  34 (defcustom jabber-muc-personal-message-bonus (* 60 20)
  35   "Bonus for personal message, in seconds."
  36   :type 'integer
  37   :group 'jabber-chat)
  38
  39 (defcustom jabber-muc-all-string "all"
  40   "String meaning all conference members (to insert in completion).
  41 Note that \":\" or alike not needed (it appended in other string)"
  42   :type 'string
  43   :group 'jabber-chat)
  44
  45
  46 ;;; Commentary:
  47 ;;
  48
  49 ;;; History:
  50 ;;
  51
  52 ;;; Code:
  53
  54 (require 'hippie-exp)
  55
  56 (defvar *jabber-muc-participant-last-speaking* nil
  57   "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).")
  58
  59 (defun jabber-my-nick (&optional group)
  60   "Return my jabber nick in GROUP."
  61   (let ((room (or group jabber-group)))
  62     (cdr (or (assoc room *jabber-active-groupchats*)
  63              (assoc room jabber-muc-default-nicknames)))))
  64
  65 ;;;###autoload
  66 (defun jabber-muc-looks-like-personal-p (message &optional group)
  67   "Return non-nil if jabber MESSAGE is addresed to me.
  68 Optional argument GROUP to look."
  69   (if message (string-match (concat
  70                  "^"
  71                  (jabber-my-nick group)
  72                  (regexp-opt jabber-muc-looks-personaling-symbols))
  73                 message)
  74     nil))
  75
  76 (defun jabber-muc-nicknames ()
  77   "List of conference participants, excluding self, or nil if we not in conference."
  78   (cl-delete-if '(lambda (nick)
  79                  (string= nick (jabber-my-nick)))
  80              (append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string))))
  81
  82 (defun jabber-muc-participant-update-activity (group nick time)
  83   "Update NICK's time of last speaking in GROUP to TIME."
  84   (let* ((room (assoc group *jabber-muc-participant-last-speaking*))
  85          (room-activity (cdr room))
  86          (entry (assoc nick room-activity))
  87          (old-time (or (cdr entry) 0)))
  88     (when (> time old-time)
  89       ;; don't use put-alist for speed
  90       (progn
  91         (if entry (setcdr entry time)
  92           (setq room-activity
  93                 (cons (cons nick time) room-activity)))
  94         (if room (setcdr room room-activity)
  95           (setq *jabber-muc-participant-last-speaking*
  96                 (cons (cons group room-activity)
  97                       *jabber-muc-participant-last-speaking*)))))))
  98
  99 (defun jabber-muc-track-message-time (nick group buffer text &optional title)
 100   "Tracks time of NICK's last speaking in GROUP."
 101   (when nick
 102     (let ((time (float-time)))
 103       (jabber-muc-participant-update-activity
 104        group
 105        nick
 106        (if (jabber-muc-looks-like-personal-p text group)
 107            (+ time jabber-muc-personal-message-bonus)
 108          time)))))
 109
 110   (defun jabber-sort-nicks (nicks group)
 111     "Return list of NICKS in GROUP, sorted."
 112     (cl-letf* ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))
 113                ((symbol-function 'fetch-time) (lambda (nick) (or (assoc nick times)
 114                                                                  (cons nick 0))))
 115                ((symbol-function 'cmp) (lambda (nt1 nt2)
 116                                          (let ((t1 (cdr nt1))
 117                                                (t2 (cdr nt2)))
 118                                            (if (and (zerop t1) (zerop t2))
 119                                                (string< (car nt1)
 120                                                         (car nt2))
 121                                              (> t1 t2))))))
 122       (mapcar #'car (sort (mapcar #'fetch-time nicks) #'cmp))))
 123
 124 (defun jabber-muc-beginning-of-line ()
 125   "Return position of line begining."
 126   (save-excursion
 127     (if (looking-back jabber-muc-completion-delimiter (line-beginning-position))
 128         (backward-char (+ (length jabber-muc-completion-delimiter) 1)))
 129     (skip-syntax-backward "^-")
 130     (point)))
 131
 132 ;;; One big hack:
 133 (defun jabber-muc-completion-delete-last-tried ()
 134   "Delete last tried competion variand from line."
 135   (let ((last-tried (car he-tried-table)))
 136     (when last-tried
 137       (goto-char he-string-beg)
 138       (delete-char (length last-tried))
 139       (ignore-errors (delete-char (length jabber-muc-completion-delimiter))))))
 140
 141 (defun try-expand-jabber-muc (old)
 142   "Try to expand target nick in MUC according to last speaking time.
 143 OLD is last tried nickname."
 144   (unless jabber-chatting-with
 145     (unless old
 146       (let ((nicknames (jabber-muc-nicknames)))
 147         (he-init-string (jabber-muc-beginning-of-line) (point))
 148         (setq he-expand-list
 149               (jabber-sort-nicks (all-completions he-search-string
 150                                             (mapcar 'list nicknames))
 151                            jabber-group))))
 152
 153     (setq he-expand-list
 154           (cl-delete-if '(lambda (x)
 155                            (he-string-member x he-tried-table))
 156                         he-expand-list))
 157     (if (null he-expand-list)
 158         (progn
 159           (when old
 160             ;; here and later : its hack to workaround
 161             ;; he-substitute-string work which cant substitute empty
 162             ;; lines
 163             (if (string= he-search-string "")
 164                 (jabber-muc-completion-delete-last-tried)
 165               (he-reset-string)))
 166           ())
 167       (let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line))
 168                        (concat (car he-expand-list) jabber-muc-completion-delimiter)
 169                      (car he-expand-list))))
 170         (if (not (string= he-search-string ""))
 171             (he-substitute-string subst)
 172           (jabber-muc-completion-delete-last-tried)
 173           (progn
 174             (insert subst)
 175             (if (looking-back (concat "^" (regexp-quote (car he-expand-list))) nil)
 176                 (unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter)
 177                                       nil)
 178                   (insert jabber-muc-completion-delimiter))))))
 179       (setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table)))
 180       (setq he-expand-list (cdr he-expand-list))
 181       t)))
 182
 183 (add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time)
 184 (fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc)))
 185 (with-eval-after-load 'jabber-chatbuffer
 186   (define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion))
 187
 188 (provide 'jabber-muc-nick-completion)
 189
 190 ;; arch-tag: 2a81ac72-d261-11dc-be91-000a95c2fcd0
 191 ;;; jabber-muc-nick-completion.el ends here