jabber-muc-nick-completion.el

   1 ;;; jabber-muc-nick-completion.el --- Add nick completion abilyty to emacs-jabber
   2
   3 ;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org
   4 ;; Copyright (C) 2007, 2008 - 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). Note that \":\" or alike not needed (it appended in other string)"
  41   :type 'string
  42   :group 'jabber-chat)
  43
  44 ;;; History:
  45 ;;
  46
  47 ;;; Code:
  48
  49 (require 'cl)
  50 (require 'jabber-muc)
  51 (require 'hippie-exp)
  52
  53 (defvar *jabber-muc-participant-last-speaking* nil
  54   "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).")
  55
  56 (defun modify-alist (key val alist)
  57   "Update of ALIST's element (KEY . VAL), possibly destructive."
  58   (let ((entry (assoc key alist)))
  59     (if (not entry)
  60         (acons key val alist)
  61       (setf (cdr entry) val)
  62       alist)))
  63
  64 (defun jabber-my-nick (&optional group)
  65   "Return my jabber nick in GROUP."
  66   (let ((room (or group jabber-group)))
  67     (cdr (or (assoc room *jabber-active-groupchats*)
  68              (assoc room jabber-muc-default-nicknames)))
  69     ))
  70
  71 ;;;###autoload
  72 (defun jabber-muc-looks-like-personal-p (message &optional group)
  73   "Return non-nil if jabber MESSAGE is addresed to me.
  74 Optional argument GROUP to look."
  75   (if message (string-match (concat
  76                  "^"
  77                  (jabber-my-nick group)
  78                  (regexp-opt jabber-muc-looks-personaling-symbols))
  79                 message)
  80     nil))
  81
  82 (defun jabber-muc-nicknames ()
  83   "List of conference participants, excluding self, or nil if we not in conference."
  84   (delete-if '(lambda (nick)
  85                  (string= nick (jabber-my-nick)))
  86              (append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string))))
  87
  88 ;; TODO: optimize this function
  89 (defun jabber-muc-participant-update-activity (group nick time)
  90   "Updates NICK's time of last speaking in GROUP to TIME."
  91   (let* ((room-activity (cdr (assoc group *jabber-muc-participant-last-speaking*)))
  92          (old-time (or (cdr (assoc nick room-activity)) 0)))
  93     (when (> time old-time)
  94       (setq *jabber-muc-participant-last-speaking*
  95            (modify-alist group (modify-alist nick time room-activity)
  96                          *jabber-muc-participant-last-speaking*)))))
  97
  98 (defun jabber-muc-track-message-time (nick group buffer text proposed-alert)
  99   "Tracks time of NICK's last speaking in GROUP."
 100   (when nick
 101     (let ((time (float-time)))
 102       (jabber-muc-participant-update-activity
 103        group
 104        nick
 105        (if (jabber-muc-looks-like-personal-p text group)
 106            (+ time jabber-muc-personal-message-bonus)
 107          time)))))
 108
 109 (defun jabber-sort-nicks (nicks group)
 110   "Return list of NICKS in GROUP, sorted."
 111   (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*))))
 112     (flet ((fetch-time (nick) (or (assoc nick times) (cons nick 0)))
 113            (cmp (nt1 nt2)
 114                 (let ((t1 (cdr nt1))
 115                       (t2 (cdr nt2)))
 116                   (if (and (zerop t1) (zerop t2))
 117                       (string<
 118                        (car nt1)
 119                        (car nt2))
 120                     (> t1 t2)))))
 121       (mapcar 'car (sort (mapcar 'fetch-time nicks)
 122                           '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)
 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
 142 (defun try-expand-jabber-muc (old)
 143   "Try to expand target nick in MUC according to last speaking time.
 144 OLD is last tried nickname."
 145   (unless jabber-chatting-with
 146     (unless old
 147     (let ((nicknames (jabber-muc-nicknames)))
 148       (he-init-string (jabber-muc-beginning-of-line) (point))
 149       (setq he-expand-list (jabber-sort-nicks (all-completions he-search-string (mapcar 'list nicknames)) jabber-group))))
 150
 151   (setq he-expand-list
 152         (delete-if '(lambda (x)
 153                        (he-string-member x he-tried-table))
 154                    he-expand-list))
 155   (if (null he-expand-list)
 156       (progn
 157         (when old
 158           ;; here and later : its hack to workaround
 159           ;; he-substitute-string work which cant substitute empty
 160           ;; lines
 161           (if (string= he-search-string "")
 162               (jabber-muc-completion-delete-last-tried)
 163             (he-reset-string)))
 164         ())
 165     (let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line))
 166                      (concat (car he-expand-list) jabber-muc-completion-delimiter)
 167                    (car he-expand-list))))
 168       (if (not (string= he-search-string ""))
 169           (he-substitute-string subst)
 170         (jabber-muc-completion-delete-last-tried)
 171         (progn
 172           (insert subst)
 173           (if (looking-back (concat "^" (regexp-quote (car he-expand-list))))
 174               (unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter))
 175                 (insert jabber-muc-completion-delimiter)))
 176           )
 177         ))
 178     (setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table)))
 179     (setq he-expand-list (cdr he-expand-list))
 180     t)))
 181
 182 (add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time)
 183 (fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc)))
 184 (define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion)
 185
 186 (provide 'jabber-muc-nick-completion)
 187
 188 ;; arch-tag: 2a81ac72-d261-11dc-be91-000a95c2fcd0
 189 ;;; jabber-muc-completion.el ends here