emacs-jabber jabber-muc-nick-completion.el, NONE, 1.1 jabber.el, 1.80, 1.81

[Kirill A. K. <ca...@us...>]

Update of /cvsroot/emacs-jabber/emacs-jabber
In directory sc8-pr-cvs17.sourceforge.net:/tmp/cvs-serv479

Modified Files:
	jabber.el 
Added Files:
	jabber-muc-nick-completion.el 
Log Message:
Add jabber-muc-nick-completion.el


Index: jabber.el
===================================================================
RCS file: /cvsroot/emacs-jabber/emacs-jabber/jabber.el,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -d -r1.80 -r1.81
--- jabber.el	17 Sep 2007 12:26:16 -0000	1.80
+++ jabber.el	3 Feb 2008 05:50:32 -0000	1.81
@@ -124,6 +124,7 @@
 (require 'jabber-search)
 (require 'jabber-browse)
 (require 'jabber-muc)
+(require 'jabber-muc-nick-completion)
 (require 'jabber-version)
 (require 'jabber-ahc-presence)
 (require 'jabber-modeline)

--- NEW FILE: jabber-muc-nick-completion.el ---
;;; jabber-muc-nick-completion.el --- Add nick completion abilyty to emacs-jabber

;; Copyright (C) 2008 - Terechkov Evgenii - ev...@al...
;; Copyright (C) 2007, 2008 - Kirill A. Korinskiy - ca...@ca...
;; Copyright (C) 2007 - Serguei Jidkov - js...@e-...

;; 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:
(defvar jabber-muc-looks-personaling-symbols
  '("," ":" ">")
  "Symbols for personaling messages")

(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 'string
  :group 'jabber-chat)

(defcustom jabber-muc-personal-message-bonus (* 60 20)
  "Bonus for personal message, in seconds."
  :type 'integer
  :group 'jabber-chat)

;;; History:
;; 

;;; Code:

(require 'cl)
(require 'jabber)
(require 'jabber-muc)
(require 'hippie-exp)

(defvar *jabber-muc-participant-last-speaking* nil
  "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).")

(defun modify-alist (key val alist)
  "Update of ALIST's element (KEY . VAL), possibly destructive."
  (let ((entry (assoc key alist)))
    (if (not entry)
	(acons key val alist)
      (setf (cdr entry) val)
      alist)))

(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)))
    ))

(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."
  (string-match (concat
		 "^"
		 (jabber-my-nick group)
		 (regexp-opt jabber-muc-looks-personaling-symbols))
		message))

(defun jabber-muc-nicknames ()
  "List of conference participants, excluding self, or nil if we not in conference."
  (delete-if '(lambda (nick)
		 (string= nick (jabber-my-nick)))
	     (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants)))))

;; TODO: optimize this function
(defun jabber-muc-participant-update-activity (group nick time)
  "Updates NICK's time of last speaking in GROUP to TIME."
  (let* ((room-activity (cdr (assoc group *jabber-muc-participant-last-speaking*)))
	 (old-time (or (cdr (assoc nick room-activity)) 0)))
    (when (> time old-time)
      (setq *jabber-muc-participant-last-speaking*
	   (modify-alist group (modify-alist nick time room-activity)
			 *jabber-muc-participant-last-speaking*)))))

(defun jabber-muc-track-message-time (nick group buffer text proposed-alert)
  "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."
  (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*))))
    (flet ((fetch-time (nick) (or (assoc nick times) (cons nick 0)))
	   (cmp (nt1 nt2)
		(let ((t1 (cdr nt1))
		      (t2 (cdr nt2)))
		  (if (and (zerop t1) (zerop t2))
		      (minusp (compare-strings
			       (car nt1) 0 nil
			       (car nt2) 0 nil
			       t))
		    (> t1 t2)))))
      (mapcar 'car (sort (mapcar 'fetch-time nicks)
			  'cmp)))))

(defun jabber-muc-beginning-of-line ()
  "Return position of line begining."
  (save-excursion
    (skip-syntax-backward "^-")
    (unless (looking-at "^") (error "Can't find beginning of line!"))
    (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)
	  (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 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
	(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 (concat (car he-expand-list) jabber-muc-completion-delimiter)))
      (if (not (string= he-search-string ""))
	  (he-substitute-string subst)
	(jabber-muc-completion-delete-last-tried)
	(insert subst)))
    (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)))
(define-key jabber-chat-mode-map (kbd "<tab>") 'jabber-muc-completion)

(provide 'jabber-muc-nick-completion)

;;; jabber-muc-completion.el ends here