384d1aa7785f1995201c1a953fa6757401f95f9f
[riece] / lisp / riece-button.el
1 ;;; riece-button.el --- adding buttons in channel 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 ;; To use, add the following line to your ~/.riece/init.el:
28 ;; (add-to-list 'riece-addons 'riece-button)
29
30 ;;; Code:
31
32 (require 'riece-commands)
33 (require 'riece-identity)
34 (require 'riece-misc)
35 (require 'wid-edit)
36
37 (defconst riece-channel-button-popup-menu
38   '("Channel"
39     ["Switch To Channel" riece-channel-button-switch-to-channel]
40     ["Part Channel" riece-channel-button-part]
41     ["List Channel" riece-channel-button-list])
42   "Menu for channel buttons.")
43
44 (defconst riece-user-button-popup-menu
45   '("User"
46     ["Finger (WHOIS)" riece-user-button-finger]
47     ["Start Private Conversation" riece-user-button-join-partner]
48     ["Give Channel Operator Privileges" riece-user-button-set-operators]
49     ["Allow To Speak" riece-user-button-set-speakers])
50   "Menu for user buttons.")
51
52 (defvar help-echo-owns-message)
53 (define-widget 'riece-identity-button 'push-button
54   "A channel button."
55   :action 'riece-button-switch-to-identity
56   :help-echo
57   (lambda (widget/window &optional overlay pos)
58     ;; Needed to properly clear the message due to a bug in
59     ;; wid-edit (XEmacs only).
60     (if (boundp 'help-echo-owns-message)
61         (setq help-echo-owns-message t))
62     (format "%S: switch to %s; down-mouse-3: more options"
63             (aref riece-mouse-2 0)
64             ;; XEmacs will get a single widget arg; Emacs 21 will get
65             ;; window, overlay, position.
66             (riece-format-identity
67              (if overlay
68                  (with-current-buffer (riece-overlay-buffer overlay)
69                    (widget-value (widget-at (riece-overlay-start overlay))))
70                (widget-value widget/window))))))
71
72 (defun riece-button-switch-to-identity (widget &optional event)
73   "Switch to identity stored in WIDGET.
74 This function is used as a callback for a channel button."
75   (let ((channel (widget-value widget)))
76     (if (riece-identity-member channel riece-current-channels)
77         (riece-command-switch-to-channel channel)
78       (message "%s" (substitute-command-keys
79                      "Type \\[riece-command-join] to join the channel")))))
80
81 (defun riece-identity-button-popup-menu (event)
82   "Popup the menu for identity buttons."
83   (interactive "@e")
84   (save-excursion
85     (set-buffer (riece-event-buffer event))
86     (goto-char (riece-event-point event))
87     (riece-popup-menu-popup
88      (if (riece-channel-p (riece-identity-prefix
89                            (get-text-property (point) 'riece-identity)))
90          riece-channel-button-popup-menu
91        riece-user-button-popup-menu)
92      event)))
93
94 (defun riece-channel-button-switch-to-channel ()
95   (interactive)
96   (riece-command-switch-to-channel
97    (get-text-property (point) 'riece-identity)))
98
99 (defun riece-channel-button-part ()
100   (interactive)
101   (riece-command-part
102    (get-text-property (point) 'riece-identity)))
103
104 (defun riece-channel-button-list ()
105   (interactive)
106   (riece-command-list
107    (riece-identity-prefix (get-text-property (point) 'riece-identity))))
108
109 (defun riece-user-button-join-partner ()
110   (interactive)
111   (riece-command-join-partner
112    (get-text-property (point) 'riece-identity)))
113
114 (defun riece-user-button-set-operators ()
115   (interactive)
116   (let (group users)
117     (if (riece-region-active-p)
118         (save-excursion
119           (riece-scan-property-region
120            'riece-identity
121            (region-beginning) (region-end)
122            (lambda (start end)
123              (setq group (cons (get-text-property start 'riece-identity)
124                                group)))))
125       (setq group (list (get-text-property (point) 'riece-identity))))
126     (setq users (riece-with-server-buffer
127                     (riece-identity-server riece-current-channel)
128                   (riece-channel-get-users (riece-identity-prefix
129                                             riece-current-channel))))
130     (if (setq group
131               (delq nil
132                     (mapcar
133                      (lambda (identity)
134                        (unless (memq ?o (cdr (riece-identity-assoc
135                                               (riece-identity-prefix identity)
136                                               users
137                                               t)))
138                          identity))
139                      group)))
140         (riece-command-set-operators (mapcar #'riece-identity-prefix group)))))
141
142 (defun riece-user-button-set-speakers ()
143   (interactive)
144   (let (group users)
145     (if (riece-region-active-p)
146         (save-excursion
147           (riece-scan-property-region
148            'riece-identity
149            (region-beginning) (region-end)
150            (lambda (start end)
151              (setq group (cons (get-text-property start 'riece-identity)
152                                group)))))
153       (setq group (list (get-text-property (point) 'riece-identity))))
154     (setq users (riece-with-server-buffer
155                     (riece-identity-server riece-current-channel)
156                   (riece-channel-get-users (riece-identity-prefix
157                                             riece-current-channel))))
158     (if (setq group
159               (delq nil
160                     (mapcar
161                      (lambda (identity)
162                        (unless (memq ?v (cdr (riece-identity-assoc
163                                               (riece-identity-prefix identity)
164                                               users
165                                               t)))
166                          identity))
167                      group)))
168         (riece-command-set-speakers (mapcar #'riece-identity-prefix group)))))
169
170 (defun riece-user-button-finger ()
171   (interactive)
172   (riece-command-finger (get-text-property (point) 'riece-identity)))
173
174 (defun riece-make-identity-button-map ()
175   (let ((map (make-sparse-keymap)))
176     (set-keymap-parent map (current-local-map))
177     (define-key map [down-mouse-3] 'riece-identity-button-popup-menu)
178     map))
179
180 (defvar riece-identity-button-map)
181 (defun riece-button-add-identity-button (start end)
182   (riece-scan-property-region
183    'riece-identity
184    start end
185    (lambda (start end)
186      (let ((inhibit-read-only t)
187            buffer-read-only)
188        (widget-convert-button 'riece-identity-button start end
189                               (get-text-property start 'riece-identity))
190        (add-text-properties start end
191                             (list 'local-map riece-identity-button-map
192                                   'keymap riece-identity-button-map))))))
193
194 (defun riece-button-update-buffer ()
195   (riece-button-add-identity-button (point-min) (point-max)))
196
197 (defun riece-button-requires ()
198   '(riece-highlight))
199
200 (defvar riece-channel-list-mode-map)
201 (defvar riece-user-list-mode-map)
202 (defvar riece-dialogue-mode-map)
203 (defun riece-button-insinuate ()
204   (add-hook 'riece-channel-list-mode-hook
205             (lambda ()
206               (set-keymap-parent riece-channel-list-mode-map widget-keymap)
207               (set (make-local-variable 'riece-identity-button-map)
208                    (riece-make-identity-button-map))
209               (add-hook 'riece-update-buffer-functions
210                         'riece-button-update-buffer t t)))
211   (add-hook 'riece-user-list-mode-hook
212             (lambda ()
213               (set-keymap-parent riece-user-list-mode-map widget-keymap)
214               (set (make-local-variable 'riece-identity-button-map)
215                    (riece-make-identity-button-map))
216               (add-hook 'riece-update-buffer-functions
217                         'riece-button-update-buffer t t)))
218   (add-hook 'riece-dialogue-mode-hook
219             (lambda ()
220               (set-keymap-parent riece-dialogue-mode-map widget-keymap)
221               (set (make-local-variable 'riece-identity-button-map)
222                    (riece-make-identity-button-map))))
223   (add-hook 'riece-after-insert-functions 'riece-button-add-identity-button))
224
225 (provide 'riece-button)
226
227 ;;; riece-button.el ends here