cgit.sxemacs.org Git - riece/blob - 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 (overlay-buffer overlay)
  69                    (widget-value (widget-at (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)
 117     (if (riece-region-active-p)
 118         (save-excursion
 119           (riece-button-map-identity-region
 120            (region-beginning) (region-end)
 121            (lambda (start end)
 122              (setq group (cons (get-text-property start 'riece-identity)
 123                                group)))))
 124       (setq group (list (get-text-property (point) 'riece-identity))))
 125     (if (setq group
 126               (delq nil
 127                     (mapcar
 128                      (lambda (identity)
 129                        (riece-with-server-buffer (riece-identity-server
 130                                                   riece-current-channel)
 131                          (if (and (member
 132                                    (riece-identity-prefix identity)
 133                                    (riece-channel-get-users
 134                                     (riece-identity-prefix
 135                                      riece-current-channel)))
 136                                   (not (member
 137                                         (riece-identity-prefix identity)
 138                                         (riece-channel-get-operators
 139                                          (riece-identity-prefix
 140                                           riece-current-channel)))))
 141                              identity)))
 142                      group)))
 143         (riece-command-set-operators (mapcar #'riece-identity-prefix group)))))
 144
 145 (defun riece-user-button-set-speakers ()
 146   (interactive)
 147   (let (group)
 148     (if (riece-region-active-p)
 149         (save-excursion
 150           (riece-button-map-identity-region
 151            (region-beginning) (region-end)
 152            (lambda (start end)
 153              (setq group (cons (get-text-property start 'riece-identity)
 154                                group)))))
 155       (setq group (list (get-text-property (point) 'riece-identity))))
 156     (if (setq group
 157               (delq nil
 158                     (mapcar
 159                      (lambda (identity)
 160                        (riece-with-server-buffer (riece-identity-server
 161                                                   riece-current-channel)
 162                          (if (and (member
 163                                    (riece-identity-prefix identity)
 164                                    (riece-channel-get-users
 165                                     (riece-identity-prefix
 166                                      riece-current-channel)))
 167                                   (not (member
 168                                         (riece-identity-prefix identity)
 169                                         (riece-channel-get-operators
 170                                          (riece-identity-prefix
 171                                           riece-current-channel))))
 172                                   (not (member
 173                                         (riece-identity-prefix identity)
 174                                         (riece-channel-get-speakers
 175                                          (riece-identity-prefix
 176                                           riece-current-channel)))))
 177                              identity)))
 178                      group)))
 179         (riece-command-set-speakers (mapcar #'riece-identity-prefix group)))))
 180
 181 (defun riece-user-button-finger ()
 182   (interactive)
 183   (riece-command-finger
 184    (riece-identity-prefix (get-text-property (point) 'riece-identity))))
 185
 186 (defun riece-make-identity-button-map ()
 187   (let ((map (make-sparse-keymap)))
 188     (set-keymap-parent map (current-local-map))
 189     (define-key map [down-mouse-3] 'riece-identity-button-popup-menu)
 190     map))
 191
 192 (defun riece-button-map-identity-region (start end function)
 193   (catch 'done
 194     (while t
 195       ;; Search for the beginning of the button region.
 196       (unless (get-text-property start 'riece-identity)
 197         (setq start (next-single-property-change start 'riece-identity
 198                                                  nil end)))
 199       (if (= start end)
 200           (throw 'done nil))
 201       ;; Search for the end of the button region.
 202       (let ((button-end (next-single-property-change start 'riece-identity
 203                                                      nil end)))
 204         (if (= button-end end)
 205             (throw 'done nil))
 206         (funcall function start button-end)
 207         (setq start button-end)))))
 208
 209 (defvar riece-identity-button-map)
 210 (defun riece-button-add-identity-button (start end)
 211   (riece-button-map-identity-region
 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 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 (defun riece-button-requires ()
 226   '(riece-highlight))
 227
 228 (defvar riece-channel-list-mode-map)
 229 (defvar riece-user-list-mode-map)
 230 (defvar riece-dialogue-mode-map)
 231 (defun riece-button-insinuate ()
 232   (add-hook 'riece-channel-list-mode-hook
 233             (lambda ()
 234               (set-keymap-parent riece-channel-list-mode-map widget-keymap)
 235               (set (make-local-variable 'riece-identity-button-map)
 236                    (riece-make-identity-button-map))
 237               (add-hook 'riece-update-buffer-functions
 238                         'riece-button-update-buffer t t)))
 239   (add-hook 'riece-user-list-mode-hook
 240             (lambda ()
 241               (set-keymap-parent riece-user-list-mode-map widget-keymap)
 242               (set (make-local-variable 'riece-identity-button-map)
 243                    (riece-make-identity-button-map))
 244               (add-hook 'riece-update-buffer-functions
 245                         'riece-button-update-buffer t t)))
 246   (add-hook 'riece-dialogue-mode-hook
 247             (lambda ()
 248               (set-keymap-parent riece-dialogue-mode-map widget-keymap)
 249               (set (make-local-variable 'riece-identity-button-map)
 250                    (riece-make-identity-button-map))))
 251   (add-hook 'riece-after-insert-functions 'riece-button-add-identity-button))
 252
 253 (provide 'riece-button)
 254
 255 ;;; riece-button.el ends here