cgit.sxemacs.org Git - riece/blob - lisp/riece-button.el

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