;;; jabber-muc-nick-completion.el --- MUC nick completion -*- lexical-binding: t; -*- ;; Copyright (C) 2008 - Terechkov Evgenii - evg@altlinux.org ;; Copyright (C) 2007, 2008, 2010 - Kirill A. Korinskiy - catap@catap.ru ;; Copyright (C) 2007 - Serguei Jidkov - jsv@e-mail.ru ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; User customizations here: (defcustom jabber-muc-completion-delimiter ": " "String to add to end of completion line." :type 'string :group 'jabber-chat) (defcustom jabber-muc-looks-personaling-symbols '("," ":" ">") "Symbols for personaling messages." :type '(repeat string) :group 'jabber-chat) (defcustom jabber-muc-personal-message-bonus (* 60 20) "Bonus for personal message, in seconds." :type 'integer :group 'jabber-chat) (defcustom jabber-muc-all-string "all" "String meaning all conference members (to insert in completion). Note that \":\" or alike not needed (it appended in other string)" :type 'string :group 'jabber-chat) ;;; Commentary: ;; ;;; History: ;; ;;; Code: (require 'hippie-exp) (defvar *jabber-muc-participant-last-speaking* nil "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).") (defun jabber-my-nick (&optional group) "Return my jabber nick in GROUP." (let ((room (or group jabber-group))) (cdr (or (assoc room *jabber-active-groupchats*) (assoc room jabber-muc-default-nicknames))))) ;;;###autoload (defun jabber-muc-looks-like-personal-p (message &optional group) "Return non-nil if jabber MESSAGE is addresed to me. Optional argument GROUP to look." (if message (string-match (concat "^" (jabber-my-nick group) (regexp-opt jabber-muc-looks-personaling-symbols)) message) nil)) (defun jabber-muc-nicknames () "List of conference participants, excluding self, or nil if we not in conference." (cl-delete-if '(lambda (nick) (string= nick (jabber-my-nick))) (append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string)))) (defun jabber-muc-participant-update-activity (group nick time) "Update NICK's time of last speaking in GROUP to TIME." (let* ((room (assoc group *jabber-muc-participant-last-speaking*)) (room-activity (cdr room)) (entry (assoc nick room-activity)) (old-time (or (cdr entry) 0))) (when (> time old-time) ;; don't use put-alist for speed (progn (if entry (setcdr entry time) (setq room-activity (cons (cons nick time) room-activity))) (if room (setcdr room room-activity) (setq *jabber-muc-participant-last-speaking* (cons (cons group room-activity) *jabber-muc-participant-last-speaking*))))))) (defun jabber-muc-track-message-time (nick group buffer text &optional title) "Tracks time of NICK's last speaking in GROUP." (when nick (let ((time (float-time))) (jabber-muc-participant-update-activity group nick (if (jabber-muc-looks-like-personal-p text group) (+ time jabber-muc-personal-message-bonus) time))))) (defun jabber-sort-nicks (nicks group) "Return list of NICKS in GROUP, sorted." (cl-letf* ((times (cdr (assoc group *jabber-muc-participant-last-speaking*))) ((symbol-function 'fetch-time) (lambda (nick) (or (assoc nick times) (cons nick 0)))) ((symbol-function 'cmp) (lambda (nt1 nt2) (let ((t1 (cdr nt1)) (t2 (cdr nt2))) (if (and (zerop t1) (zerop t2)) (string< (car nt1) (car nt2)) (> t1 t2)))))) (mapcar #'car (sort (mapcar #'fetch-time nicks) #'cmp)))) (defun jabber-muc-beginning-of-line () "Return position of line begining." (save-excursion (if (looking-back jabber-muc-completion-delimiter (line-beginning-position)) (backward-char (+ (length jabber-muc-completion-delimiter) 1))) (skip-syntax-backward "^-") (point))) ;;; One big hack: (defun jabber-muc-completion-delete-last-tried () "Delete last tried competion variand from line." (let ((last-tried (car he-tried-table))) (when last-tried (goto-char he-string-beg) (delete-char (length last-tried)) (ignore-errors (delete-char (length jabber-muc-completion-delimiter)))))) (defun try-expand-jabber-muc (old) "Try to expand target nick in MUC according to last speaking time. OLD is last tried nickname." (unless jabber-chatting-with (unless old (let ((nicknames (jabber-muc-nicknames))) (he-init-string (jabber-muc-beginning-of-line) (point)) (setq he-expand-list (jabber-sort-nicks (all-completions he-search-string (mapcar 'list nicknames)) jabber-group)))) (setq he-expand-list (cl-delete-if '(lambda (x) (he-string-member x he-tried-table)) he-expand-list)) (if (null he-expand-list) (progn (when old ;; here and later : its hack to workaround ;; he-substitute-string work which cant substitute empty ;; lines (if (string= he-search-string "") (jabber-muc-completion-delete-last-tried) (he-reset-string))) ()) (let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line)) (concat (car he-expand-list) jabber-muc-completion-delimiter) (car he-expand-list)))) (if (not (string= he-search-string "")) (he-substitute-string subst) (jabber-muc-completion-delete-last-tried) (progn (insert subst) (if (looking-back (concat "^" (regexp-quote (car he-expand-list))) nil) (unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter) nil) (insert jabber-muc-completion-delimiter)))))) (setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table))) (setq he-expand-list (cdr he-expand-list)) t))) (add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time) (fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc))) (with-eval-after-load 'jabber-chatbuffer (define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion)) (provide 'jabber-muc-nick-completion) ;; arch-tag: 2a81ac72-d261-11dc-be91-000a95c2fcd0 ;;; jabber-muc-nick-completion.el ends here