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, 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). 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 jabber-my-nick (&optional group)
  57   "Return my jabber nick in GROUP."
  58   (let ((room (or group jabber-group)))
  59     (cdr (or (assoc room *jabber-active-groupchats*)
  60              (assoc room jabber-muc-default-nicknames)))
  61     ))
  62
  63 ;;;###autoload
  64 (defun jabber-muc-looks-like-personal-p (message &optional group)
  65   "Return non-nil if jabber MESSAGE is addresed to me.
  66 Optional argument GROUP to look."
  67   (if message (string-match (concat
  68                  "^"
  69                  (jabber-my-nick group)
  70                  (regexp-opt jabber-muc-looks-personaling-symbols))
  71                 message)
  72     nil))
  73
  74 (defun jabber-muc-nicknames ()
  75   "List of conference participants, excluding self, or nil if we not in conference."
  76   (delete-if '(lambda (nick)
  77                  (string= nick (jabber-my-nick)))
  78              (append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string))))
  79
  80 (defun jabber-muc-participant-update-activity (group nick time)
  81   "Updates NICK's time of last speaking in GROUP to TIME."
  82   (let* ((room (assoc group *jabber-muc-participant-last-speaking*))
  83          (room-activity (cdr room))
  84          (entry (assoc nick room-activity))
  85          (old-time (or (cdr entry) 0)))
  86     (when (> time old-time)
  87       ;; don't use put-alist for speed
  88       (progn
  89         (if entry (setcdr entry time)
  90           (setq room-activity
  91                 (cons (cons nick time) room-activity)))
  92         (if room (setcdr room room-activity)
  93           (setq *jabber-muc-participant-last-speaking*
  94                 (cons (cons group room-activity)
  95                       *jabber-muc-participant-last-speaking*)))))))
  96
  97 (defun jabber-muc-track-message-time (nick group buffer text &optional title)
  98   "Tracks time of NICK's last speaking in GROUP."
  99   (when nick
 100     (let ((time (float-time)))
 101       (jabber-muc-participant-update-activity
 102        group
 103        nick
 104        (if (jabber-muc-looks-like-personal-p text group)
 105            (+ time jabber-muc-personal-message-bonus)
 106          time)))))
 107
 108 (defun jabber-sort-nicks (nicks group)
 109   "Return list of NICKS in GROUP, sorted."
 110   (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*))))
 111     (flet ((fetch-time (nick) (or (assoc nick times) (cons nick 0)))
 112            (cmp (nt1 nt2)
 113                 (let ((t1 (cdr nt1))
 114                       (t2 (cdr nt2)))
 115                   (if (and (zerop t1) (zerop t2))
 116                       (string<
 117                        (car nt1)
 118                        (car nt2))
 119                     (> t1 t2)))))
 120       (mapcar 'car (sort (mapcar 'fetch-time nicks)
 121                           'cmp)))))
 122
 123 (defun jabber-muc-beginning-of-line ()
 124   "Return position of line begining."
 125   (save-excursion
 126     (if (looking-back jabber-muc-completion-delimiter)
 127         (backward-char (+ (length jabber-muc-completion-delimiter) 1)))
 128     (skip-syntax-backward "^-")
 129     (point)))
 130
 131 ;;; One big hack:
 132 (defun jabber-muc-completion-delete-last-tried ()
 133   "Delete last tried competion variand from line."
 134   (let ((last-tried (car he-tried-table)))
 135     (when last-tried
 136       (goto-char he-string-beg)
 137       (delete-char (length last-tried))
 138       (ignore-errors (delete-char (length jabber-muc-completion-delimiter)))
 139       )))
 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 (jabber-sort-nicks (all-completions he-search-string (mapcar 'list nicknames)) jabber-group))))
 149
 150   (setq he-expand-list
 151         (delete-if '(lambda (x)
 152                        (he-string-member x he-tried-table))
 153                    he-expand-list))
 154   (if (null he-expand-list)
 155       (progn
 156         (when old
 157           ;; here and later : its hack to workaround
 158           ;; he-substitute-string work which cant substitute empty
 159           ;; lines
 160           (if (string= he-search-string "")
 161               (jabber-muc-completion-delete-last-tried)
 162             (he-reset-string)))
 163         ())
 164     (let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line))
 165                      (concat (car he-expand-list) jabber-muc-completion-delimiter)
 166                    (car he-expand-list))))
 167       (if (not (string= he-search-string ""))
 168           (he-substitute-string subst)
 169         (jabber-muc-completion-delete-last-tried)
 170         (progn
 171           (insert subst)
 172           (if (looking-back (concat "^" (regexp-quote (car he-expand-list))))
 173               (unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter))
 174                 (insert jabber-muc-completion-delimiter)))
 175           )
 176         ))
 177     (setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table)))
 178     (setq he-expand-list (cdr he-expand-list))
 179     t)))
 180
 181 (add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time)
 182 (fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc)))
 183 (define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion)
 184
 185 (provide 'jabber-muc-nick-completion)
 186
 187 ;; arch-tag: 2a81ac72-d261-11dc-be91-000a95c2fcd0
 188 ;;; jabber-muc-completion.el ends here