fd6f24e8b59fbca445062e2b344c507d54651459
[riece] / lisp / riece-button.el
1 ;;; riece-button.el --- display useful buttons in IRC buffers
2 ;; Copyright (C) 1998-2003 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1998-09-28
6 ;; Keywords: IRC, riece
7
8 ;; This file is part of Riece.
9
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
24
25 ;;; Commentary:
26
27 ;; NOTE: This is an add-on module for Riece.
28
29 ;;; Code:
30
31 (require 'riece-commands)
32 (require 'riece-identity)
33 (require 'riece-misc)
34 (require 'wid-edit)
35
36 (defconst riece-channel-button-popup-menu
37   '("Channel"
38     ["Switch To Channel" riece-channel-button-switch-to-channel]
39     ["Part Channel" riece-channel-button-part]
40     ["List Channel" riece-channel-button-list])
41   "Menu for channel buttons.")
42
43 (defconst riece-user-button-popup-menu
44   '("User"
45     ["Finger (WHOIS)" riece-user-button-finger]
46     ["Start Private Conversation" riece-user-button-join-partner]
47     ["Set +o" riece-user-button-set-operators]
48     ["Set +v" riece-user-button-set-speakers])
49   "Menu for user buttons.")
50
51 (defconst riece-button-description
52   "Display useful buttons in IRC buffers.")
53
54 (defvar help-echo-owns-message)
55 (define-widget 'riece-identity-button 'push-button
56   "A channel button."
57   :action 'riece-button-switch-to-identity
58   :help-echo
59   (lambda (widget/window &optional overlay pos)
60     ;; Needed to properly clear the message due to a bug in
61     ;; wid-edit (XEmacs only).
62     (if (boundp 'help-echo-owns-message)
63         (setq help-echo-owns-message t))
64     (format (riece-mcat "%S: switch to %s; down-mouse-3: more options")
65             (aref riece-mouse-2 0)
66             ;; XEmacs will get a single widget arg; Emacs 21 will get
67             ;; window, overlay, position.
68             (riece-format-identity
69              (if overlay
70                  (with-current-buffer (riece-overlay-buffer overlay)
71                    (widget-value (widget-at (riece-overlay-start overlay))))
72                (widget-value widget/window))))))
73
74 (defun riece-button-switch-to-identity (widget &optional event)
75   "Switch to identity stored in WIDGET.
76 This function is used as a callback for a channel button."
77   (let ((channel (widget-value widget)))
78     (if (riece-identity-member channel riece-current-channels)
79         (riece-command-switch-to-channel channel)
80       (message "%s" (substitute-command-keys
81                      (riece-mcat
82                       "Type \\[riece-command-join] to join the channel"))))))
83
84 (defun riece-identity-button-click (event)
85   "Call widget-button-click and select the last selected window."
86   (interactive "e")                     ;widget-button-click has
87                                         ;interactive spec "@e"
88   (let ((buffer (current-buffer))
89         (point (point))
90         window)
91     (unwind-protect
92         (save-excursion
93           (set-buffer (riece-event-buffer event))
94           (goto-char (riece-event-point event))
95           (widget-button-click event))
96       ;; riece-button-switch-to-identity changes window-configuration
97       ;; so we must select the last selected window by _buffer_.
98       (if (setq window (get-buffer-window buffer))
99           (progn
100             (select-window window)
101             (set-window-point window point))
102         (if riece-debug
103             (riece-debug (format "buffer %s not visible"
104                                  (buffer-name buffer))))))))
105
106 (defun riece-identity-button-popup-menu (event)
107   "Popup the menu for identity buttons."
108   (interactive "e")
109   (save-excursion
110     (set-buffer (riece-event-buffer event))
111     (goto-char (riece-event-point event))
112     (riece-popup-menu-popup
113      (if (riece-channel-p (riece-identity-prefix
114                            (get-text-property (point) 'riece-identity)))
115          riece-channel-button-popup-menu
116        riece-user-button-popup-menu)
117      event)))
118
119 (defun riece-channel-button-switch-to-channel ()
120   (interactive)
121   (riece-command-switch-to-channel
122    (get-text-property (point) 'riece-identity)))
123
124 (defun riece-channel-button-part ()
125   (interactive)
126   (riece-command-part
127    (get-text-property (point) 'riece-identity)))
128
129 (defun riece-channel-button-list ()
130   (interactive)
131   (riece-command-list
132    (riece-identity-prefix (get-text-property (point) 'riece-identity))))
133
134 (defun riece-user-button-join-partner ()
135   (interactive)
136   (riece-command-join-partner
137    (get-text-property (point) 'riece-identity)))
138
139 (defun riece-user-button-set-operators ()
140   (interactive)
141   (let (group users)
142     (if (riece-region-active-p)
143         (save-excursion
144           (riece-scan-property-region
145            'riece-identity
146            (region-beginning) (region-end)
147            (lambda (start end)
148              (setq group (cons (get-text-property start 'riece-identity)
149                                group)))))
150       (setq group (list (get-text-property (point) 'riece-identity))))
151     (setq users (riece-with-server-buffer
152                     (riece-identity-server riece-current-channel)
153                   (riece-channel-get-users (riece-identity-prefix
154                                             riece-current-channel))))
155     (if (setq group
156               (delq nil
157                     (mapcar
158                      (lambda (identity)
159                        (unless (memq ?o (cdr (riece-identity-assoc
160                                               (riece-identity-prefix identity)
161                                               users
162                                               t)))
163                          identity))
164                      group)))
165         (riece-command-set-operators (mapcar #'riece-identity-prefix group)))))
166
167 (defun riece-user-button-set-speakers ()
168   (interactive)
169   (let (group users)
170     (if (riece-region-active-p)
171         (save-excursion
172           (riece-scan-property-region
173            'riece-identity
174            (region-beginning) (region-end)
175            (lambda (start end)
176              (setq group (cons (get-text-property start 'riece-identity)
177                                group)))))
178       (setq group (list (get-text-property (point) 'riece-identity))))
179     (setq users (riece-with-server-buffer
180                     (riece-identity-server riece-current-channel)
181                   (riece-channel-get-users (riece-identity-prefix
182                                             riece-current-channel))))
183     (if (setq group
184               (delq nil
185                     (mapcar
186                      (lambda (identity)
187                        (unless (memq ?v (cdr (riece-identity-assoc
188                                               (riece-identity-prefix identity)
189                                               users
190                                               t)))
191                          identity))
192                      group)))
193         (riece-command-set-speakers (mapcar #'riece-identity-prefix group)))))
194
195 (defun riece-user-button-finger ()
196   (interactive)
197   (riece-command-finger (get-text-property (point) 'riece-identity)))
198
199 (defun riece-make-identity-button-map ()
200   (let ((map (make-sparse-keymap)))
201     (set-keymap-parent map (current-local-map))
202     (define-key map [down-mouse-2] 'riece-identity-button-click)
203     (define-key map [down-mouse-3] 'riece-identity-button-popup-menu)
204     map))
205
206 (defvar riece-identity-button-map)
207 (defun riece-button-add-identity-button (start end)
208   (if (get 'riece-button 'riece-addon-enabled)
209       (riece-scan-property-region
210        'riece-identity
211        start end
212        (lambda (start end)
213          (let ((inhibit-read-only t)
214                buffer-read-only)
215            (widget-convert-button 'riece-identity-button start end
216                                   (get-text-property start 'riece-identity))
217            (add-text-properties
218             start end
219             (list 'local-map riece-identity-button-map
220                   'keymap riece-identity-button-map)))))))
221
222 (defun riece-button-update-buffer ()
223   (riece-button-add-identity-button (point-min) (point-max)))
224
225 (defvar riece-channel-list-mode-map)
226 (defvar riece-user-list-mode-map)
227 (defvar riece-dialogue-mode-map)
228
229 (defun riece-button-channel-list-mode-hook ()
230   (set-keymap-parent riece-channel-list-mode-map widget-keymap)
231   (set (make-local-variable 'riece-identity-button-map)
232        (riece-make-identity-button-map))
233   (add-hook 'riece-update-buffer-functions
234             'riece-button-update-buffer t t))
235
236 (defun riece-button-user-list-mode-hook ()
237   (set-keymap-parent riece-user-list-mode-map widget-keymap)
238   (set (make-local-variable 'riece-identity-button-map)
239        (riece-make-identity-button-map))
240   (add-hook 'riece-update-buffer-functions
241             'riece-button-update-buffer t t))
242
243 (defun riece-button-dialogue-mode-hook ()
244   (set-keymap-parent riece-dialogue-mode-map widget-keymap)
245   (set (make-local-variable 'riece-identity-button-map)
246        (riece-make-identity-button-map)))
247
248 (defun riece-button-insinuate ()
249   (save-excursion
250     (when riece-channel-list-buffer
251       (set-buffer riece-channel-list-buffer)
252       (riece-button-channel-list-mode-hook))
253     (when riece-user-list-buffer
254       (set-buffer riece-user-list-buffer)
255       (riece-button-user-list-mode-hook))
256     (let ((buffers riece-buffer-list))
257       (while buffers
258         (set-buffer (car buffers))
259         (if (riece-derived-mode-p 'riece-dialogue-mode)
260             (riece-button-dialogue-mode-hook))
261         (setq buffers (cdr buffers)))))
262   (add-hook 'riece-channel-list-mode-hook
263             'riece-button-channel-list-mode-hook)
264   (add-hook 'riece-user-list-mode-hook
265             'riece-button-user-list-mode-hook)
266   (add-hook 'riece-dialogue-mode-hook
267             'riece-button-dialogue-mode-hook)
268   (add-hook 'riece-after-insert-functions 'riece-button-add-identity-button))
269
270 (defun riece-button-uninstall ()
271   (let ((buffers riece-buffer-list))
272     (save-excursion
273       (while buffers
274         (set-buffer (car buffers))
275         (remove-hook 'riece-update-buffer-functions
276                      'riece-button-update-buffer t)
277         (if (local-variable-p 'riece-identity-button-map
278                               (car buffers))
279             (kill-local-variable 'riece-identity-button-map))
280         (setq buffers (cdr buffers)))))
281   (remove-hook 'riece-channel-list-mode-hook
282                'riece-button-channel-list-mode-hook)
283   (remove-hook 'riece-user-list-mode-hook
284                'riece-button-user-list-mode-hook)
285   (remove-hook 'riece-dialogue-mode-hook
286                'riece-button-dialogue-mode-hook)
287   (remove-hook 'riece-after-insert-functions
288                'riece-button-add-identity-button))
289
290 (defun riece-button-enable ()
291   (let ((pointer riece-buffer-list))
292     (while pointer
293       (with-current-buffer (car pointer)
294         (if (riece-derived-mode-p 'riece-dialogue-mode)
295             (riece-button-update-buffer)))
296       (setq pointer (cdr pointer)))
297     (if riece-current-channel
298         (riece-emit-signal 'user-list-changed riece-current-channel))
299     (riece-emit-signal 'channel-list-changed)))
300
301 (defun riece-button-disable ()
302   (save-excursion
303     (let ((pointer riece-buffer-list))
304       (while pointer
305         ;; On XEmacs, BUFFER arg of widget-map-buttons is ignored.
306         (set-buffer (car pointer))
307         (widget-map-buttons
308          (lambda (widget maparg)
309            (widget-leave-text widget)))
310         (setq pointer (cdr pointer))))))
311
312 (provide 'riece-button)
313
314 ;;; riece-button.el ends here