cgit.sxemacs.org Git - riece/blob - 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   (save-excursion
 257     (when riece-channel-list-buffer
 258       (set-buffer riece-channel-list-buffer)
 259       (riece-button-channel-list-mode-hook))
 260     (when riece-user-list-buffer
 261       (set-buffer riece-user-list-buffer)
 262       (riece-button-user-list-mode-hook))
 263     (let ((buffers riece-buffer-list))
 264       (while buffers
 265         (set-buffer (car buffers))
 266         (if (eq (derived-mode-class major-mode)
 267                 'riece-dialogue-mode)
 268             (riece-button-dialogue-mode-hook))
 269         (setq buffers (cdr buffers)))))
 270   (add-hook 'riece-after-insert-functions 'riece-button-add-identity-button))
 271
 272 (defun riece-button-uninstall ()
 273   (let ((buffers riece-buffer-list))
 274     (save-excursion
 275       (while buffers
 276         (set-buffer (car buffers))
 277         (remove-hook 'riece-update-buffer-functions
 278                      'riece-button-update-buffer)
 279         (if (local-variable-p 'riece-identity-button-map
 280                               (car buffers))
 281             (kill-local-variable 'riece-identity-button-map))
 282         (setq buffers (cdr buffers)))))
 283   (remove-hook 'riece-channel-list-mode-hook
 284                'riece-button-channel-list-mode-hook)
 285   (remove-hook 'riece-user-list-mode-hook
 286                'riece-button-user-list-mode-hook)
 287   (remove-hook 'riece-dialogue-mode-hook
 288                'riece-button-dialogue-mode-hook)
 289   (remove-hook 'riece-after-insert-functions
 290                'riece-button-add-identity-button))
 291
 292 (defun riece-button-enable ()
 293   (setq riece-button-enabled t)
 294   (let ((pointer riece-buffer-list))
 295     (while pointer
 296       (with-current-buffer (car pointer)
 297         (if (eq (derived-mode-class major-mode)
 298                 'riece-dialogue-mode)
 299             (riece-button-update-buffer)))
 300       (setq pointer (cdr pointer)))
 301     (if riece-current-channel
 302         (riece-emit-signal 'user-list-changed riece-current-channel))
 303     (riece-emit-signal 'channel-list-changed)))
 304
 305 (defun riece-button-disable ()
 306   (setq riece-button-enabled nil)
 307   (save-excursion
 308     (let ((pointer riece-buffer-list))
 309       (while pointer
 310         ;; On XEmacs, BUFFER arg of widget-map-buttons is ignored.
 311         (set-buffer (car pointer))
 312         (widget-map-buttons
 313          (lambda (widget maparg)
 314            (widget-leave-text widget)))
 315         (setq pointer (cdr pointer))))))
 316
 317 (provide 'riece-button)
 318
 319 ;;; riece-button.el ends here