crepu.dev Git - config.git/blob - djavu-asus/emacs/elpa/jabber-20230715.456/jabber-muc-nick-completion.el

1 ;;; jabber-muc-nick-completion.el --- MUC nick completion -*- lexical-binding: t; -*-

7 ;; This file is a part of jabber.el.

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.

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.

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

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)

29 (defcustom jabber-muc-looks-personaling-symbols '("," ":" ">")

30 "Symbols for personaling messages."

31 :type '(repeat string)

32 :group 'jabber-chat)

34 (defcustom jabber-muc-personal-message-bonus (* 60 20)

35 "Bonus for personal message, in seconds."

36 :type 'integer

37 :group 'jabber-chat)

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)

46 ;;; Commentary:

47 ;;

49 ;;; History:

50 ;;

52 ;;; Code:

54 (require 'hippie-exp)

56 (defvar *jabber-muc-participant-last-speaking* nil

57 "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).")

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

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

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

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

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