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