05dff6b678fffa454ec350fe883f22a4a55097e6
[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., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, 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 (defvar riece-button-enabled nil)
52
53 (defconst riece-button-description
54   "Display useful buttons in IRC buffers.")
55
56 (defvar help-echo-owns-message)
57 (define-widget 'riece-identity-button 'push-button
58   "A channel button."
59   :action 'riece-button-switch-to-identity
60   :help-echo
61   (lambda (widget/window &optional overlay pos)
62     ;; Needed to properly clear the message due to a bug in
63     ;; wid-edit (XEmacs only).
64     (if (boundp 'help-echo-owns-message)
65         (setq help-echo-owns-message t))
66     (format "%S: switch to %s; down-mouse-3: more options"
67             (aref riece-mouse-2 0)
68             ;; XEmacs will get a single widget arg; Emacs 21 will get
69             ;; window, overlay, position.
70             (riece-format-identity
71              (if overlay
72                  (with-current-buffer (riece-overlay-buffer overlay)
73                    (widget-value (widget-at (riece-overlay-start overlay))))
74                (widget-value widget/window))))))
75
76 (defun riece-button-switch-to-identity (widget &optional event)
77   "Switch to identity stored in WIDGET.
78 This function is used as a callback for a channel button."
79   (let ((channel (widget-value widget)))
80     (if (riece-identity-member channel riece-current-channels)
81         (riece-command-switch-to-channel channel)
82       (message "%s" (substitute-command-keys
83                      "Type \\[riece-command-join] to join the channel")))))
84
85 (defun riece-identity-button-click (event)
86   "Call widget-button-click and select the last selected window."
87   (interactive "e")                     ;widget-button-click has
88                                         ;interactive spec "@e"
89   (let ((buffer (current-buffer))
90         (point (point))
91         window)
92     (unwind-protect
93         (save-excursion
94           (set-buffer (riece-event-buffer event))
95           (goto-char (riece-event-point event))
96           (widget-button-click event))
97       ;; riece-button-switch-to-identity changes window-configuration
98       ;; so we must select the last selected window by _buffer_.
99       (if (setq window (get-buffer-window buffer))
100           (progn
101             (select-window window)
102             (set-window-point window point))
103         (if riece-debug
104             (riece-debug (format "buffer %s not visible"
105                                  (buffer-name buffer))))))))
106
107 (defun riece-identity-button-popup-menu (event)
108   "Popup the menu for identity buttons."
109   (interactive "e")
110   (save-excursion
111     (set-buffer (riece-event-buffer event))
112     (goto-char (riece-event-point event))
113     (riece-popup-menu-popup
114      (if (riece-channel-p (riece-identity-prefix
115                            (get-text-property (point) 'riece-identity)))
116          riece-channel-button-popup-menu
117        riece-user-button-popup-menu)
118      event)))
119
120 (defun riece-channel-button-switch-to-channel ()
121   (interactive)
122   (riece-command-switch-to-channel
123    (get-text-property (point) 'riece-identity)))
124
125 (defun riece-channel-button-part ()
126   (interactive)
127   (riece-command-part
128    (get-text-property (point) 'riece-identity)))
129
130 (defun riece-channel-button-list ()
131   (interactive)
132   (riece-command-list
133    (riece-identity-prefix (get-text-property (point) 'riece-identity))))
134
135 (defun riece-user-button-join-partner ()
136   (interactive)
137   (riece-command-join-partner
138    (get-text-property (point) 'riece-identity)))
139
140 (defun riece-user-button-set-operators ()
141   (interactive)
142   (let (group users)
143     (if (riece-region-active-p)
144         (save-excursion
145           (riece-scan-property-region
146            'riece-identity
147            (region-beginning) (region-end)
148            (lambda (start end)
149              (setq group (cons (get-text-property start 'riece-identity)
150                                group)))))
151       (setq group (list (get-text-property (point) 'riece-identity))))
152     (setq users (riece-with-server-buffer
153                     (riece-identity-server riece-current-channel)
154                   (riece-channel-get-users (riece-identity-prefix
155                                             riece-current-channel))))
156     (if (setq group
157               (delq nil
158                     (mapcar
159                      (lambda (identity)
160                        (unless (memq ?o (cdr (riece-identity-assoc
161                                               (riece-identity-prefix identity)
162                                               users
163                                               t)))
164                          identity))
165                      group)))
166         (riece-command-set-operators (mapcar #'riece-identity-prefix group)))))
167
168 (defun riece-user-button-set-speakers ()
169   (interactive)
170   (let (group users)
171     (if (riece-region-active-p)
172         (save-excursion
173           (riece-scan-property-region
174            'riece-identity
175            (region-beginning) (region-end)
176            (lambda (start end)
177              (setq group (cons (get-text-property start 'riece-identity)
178                                group)))))
179       (setq group (list (get-text-property (point) 'riece-identity))))
180     (setq users (riece-with-server-buffer
181                     (riece-identity-server riece-current-channel)
182                   (riece-channel-get-users (riece-identity-prefix
183                                             riece-current-channel))))
184     (if (setq group
185               (delq nil
186                     (mapcar
187                      (lambda (identity)
188                        (unless (memq ?v (cdr (riece-identity-assoc
189                                               (riece-identity-prefix identity)
190                                               users
191                                               t)))
192                          identity))
193                      group)))
194         (riece-command-set-speakers (mapcar #'riece-identity-prefix group)))))
195
196 (defun riece-user-button-finger ()
197   (interactive)
198   (riece-command-finger (get-text-property (point) 'riece-identity)))
199
200 (defun riece-make-identity-button-map ()
201   (let ((map (make-sparse-keymap)))
202     (set-keymap-parent map (current-local-map))
203     (define-key map [down-mouse-2] 'riece-identity-button-click)
204     (define-key map [down-mouse-3] 'riece-identity-button-popup-menu)
205     map))
206
207 (defvar riece-identity-button-map)
208 (defun riece-button-add-identity-button (start end)
209   (if riece-button-enabled
210       (riece-scan-property-region
211        'riece-identity
212        start end
213        (lambda (start end)
214          (let ((inhibit-read-only t)
215                buffer-read-only)
216            (widget-convert-button 'riece-identity-button start end
217                                   (get-text-property start 'riece-identity))
218            (add-text-properties
219             start end
220             (list 'local-map riece-identity-button-map
221                   'keymap riece-identity-button-map)))))))
222
223 (defun riece-button-update-buffer ()
224   (riece-button-add-identity-button (point-min) (point-max)))
225
226 (defvar riece-channel-list-mode-map)
227 (defvar riece-user-list-mode-map)
228 (defvar riece-dialogue-mode-map)
229
230 (defun riece-button-channel-list-mode-hook ()
231   (set-keymap-parent riece-channel-list-mode-map widget-keymap)
232   (set (make-local-variable 'riece-identity-button-map)
233        (riece-make-identity-button-map))
234   (add-hook 'riece-update-buffer-functions
235             'riece-button-update-buffer t t))
236
237 (defun riece-button-user-list-mode-hook ()
238   (set-keymap-parent riece-user-list-mode-map widget-keymap)
239   (set (make-local-variable 'riece-identity-button-map)
240        (riece-make-identity-button-map))
241   (add-hook 'riece-update-buffer-functions
242             'riece-button-update-buffer t t))
243
244 (defun riece-button-dialogue-mode-hook ()
245   (set-keymap-parent riece-dialogue-mode-map widget-keymap)
246   (set (make-local-variable 'riece-identity-button-map)
247        (riece-make-identity-button-map)))
248
249 (defun riece-button-insinuate ()
250   (add-hook 'riece-channel-list-mode-hook
251             'riece-button-channel-list-mode-hook)
252   (add-hook 'riece-user-list-mode-hook
253             'riece-button-user-list-mode-hook)
254   (add-hook 'riece-dialogue-mode-hook
255             'riece-button-dialogue-mode-hook)
256   (add-hook 'riece-after-insert-functions 'riece-button-add-identity-button))
257
258 (defun riece-button-uninstall ()
259   (let ((buffers riece-buffer-list))
260     (save-excursion
261       (while buffers
262         (set-buffer (car buffers))
263         (remove-hook 'riece-update-buffer-functions
264                      'riece-button-update-buffer)
265         (setq buffers (cdr buffers)))))
266   (remove-hook 'riece-channel-list-mode-hook
267                'riece-button-channel-list-mode-hook)
268   (remove-hook 'riece-user-list-mode-hook
269                'riece-button-user-list-mode-hook)
270   (remove-hook 'riece-dialogue-mode-hook
271                'riece-button-dialogue-mode-hook)
272   (remove-hook 'riece-after-insert-functions
273                'riece-button-add-identity-button)))
274
275 (defun riece-button-enable ()
276   (setq riece-button-enabled t)
277   (let ((pointer riece-buffer-list))
278     (while pointer
279       (with-current-buffer (car pointer)
280         (if (eq (derived-mode-class major-mode)
281                 'riece-dialogue-mode)
282             (riece-button-update-buffer)))
283       (setq pointer (cdr pointer)))
284     (if riece-current-channel
285         (riece-emit-signal 'user-list-changed riece-current-channel))
286     (riece-emit-signal 'channel-list-changed)))
287
288 (defun riece-button-disable ()
289   (setq riece-button-enabled nil)
290   (save-excursion
291     (let ((pointer riece-buffer-list))
292       (while pointer
293         ;; On XEmacs, BUFFER arg of widget-map-buttons is ignored.
294         (set-buffer (car pointer))
295         (widget-map-buttons
296          (lambda (widget maparg)
297            (widget-leave-text widget)))
298         (setq pointer (cdr pointer))))))
299
300 (provide 'riece-button)
301
302 ;;; riece-button.el ends here