X-Git-Url: https://cgit.sxemacs.org/?p=riece;a=blobdiff_plain;f=lisp%2Friece-button.el;h=ff8c0e5c6f8569924806e784c45ed516c0938f0e;hp=f65e7bf0ba55428023313ad63f1114d825ca33e1;hb=0cbbce733a3c11cab8b6869887b79d9013217481;hpb=a86316a5d418673f99e35a21a59356b57a778a3d diff --git a/lisp/riece-button.el b/lisp/riece-button.el index f65e7bf..ff8c0e5 100644 --- a/lisp/riece-button.el +++ b/lisp/riece-button.el @@ -34,68 +34,244 @@ (require 'riece-misc) (require 'wid-edit) +(defconst riece-channel-button-popup-menu + '("Channel" + ["Switch To Channel" riece-channel-button-switch-to-channel] + ["Part Channel" riece-channel-button-part] + ["List Channel" riece-channel-button-list]) + "Menu for channel buttons.") + +(defconst riece-user-button-popup-menu + '("User" + ["Finger (WHOIS)" riece-user-button-finger] + ["Start Private Conversation" riece-user-button-join-partner] + ["Give Channel Operator Privileges" riece-user-button-set-operators] + ["Allow To Speak" riece-user-button-set-speakers]) + "Menu for user buttons.") + +(defvar riece-button-enabled nil) + +(defconst riece-button-description + "Display useful buttons in IRC buffers") + (defvar help-echo-owns-message) -(define-widget 'riece-channel-button 'push-button +(define-widget 'riece-identity-button 'push-button "A channel button." - :action 'riece-channel-button-action + :action 'riece-button-switch-to-identity :help-echo (lambda (widget/window &optional overlay pos) ;; Needed to properly clear the message due to a bug in ;; wid-edit (XEmacs only). (if (boundp 'help-echo-owns-message) (setq help-echo-owns-message t)) - (format "Switch to %s" + (format "%S: switch to %s; down-mouse-3: more options" + (aref riece-mouse-2 0) ;; XEmacs will get a single widget arg; Emacs 21 will get ;; window, overlay, position. (riece-format-identity (if overlay - (with-current-buffer (overlay-buffer overlay) - (widget-value (widget-at (overlay-start overlay)))) + (with-current-buffer (riece-overlay-buffer overlay) + (widget-value (widget-at (riece-overlay-start overlay)))) (widget-value widget/window)))))) -(defun riece-channel-button-action (widget &optional event) +(defun riece-button-switch-to-identity (widget &optional event) + "Switch to identity stored in WIDGET. +This function is used as a callback for a channel button." (let ((channel (widget-value widget))) (if (riece-identity-member channel riece-current-channels) (riece-command-switch-to-channel channel) (message "%s" (substitute-command-keys "Type \\[riece-command-join] to join the channel"))))) -(defun riece-button-add-channel-buttons (start end length) +(defun riece-identity-button-click (event) + "Call widget-button-click and select the last selected window." + (interactive "e") ;widget-button-click has + ;interactive spec "@e" + (let ((buffer (current-buffer)) + (point (point)) + window) + (unwind-protect + (save-excursion + (set-buffer (riece-event-buffer event)) + (goto-char (riece-event-point event)) + (widget-button-click event)) + ;; riece-button-switch-to-identity changes window-configuration + ;; so we must select the last selected window by _buffer_. + (if (setq window (get-buffer-window buffer)) + (progn + (select-window window) + (set-window-point window point)) + (if riece-debug + (message "buffer %s not visible" (buffer-name buffer))))))) + +(defun riece-identity-button-popup-menu (event) + "Popup the menu for identity buttons." + (interactive "e") (save-excursion - (catch 'done - (while t - ;; Search for the beginning of the button region. - (unless (get-text-property start 'riece-identity) - (setq start (next-single-property-change start 'riece-identity - nil end))) - ;; Search for the end of the button region. - (let* ((identity (get-text-property start 'riece-identity)) - (button-end (next-single-property-change start 'riece-identity - nil end))) - (if (= button-end end) - (throw 'done nil) - (if (riece-channel-p (riece-identity-prefix identity)) - (widget-convert-button - 'riece-channel-button start button-end identity)) - (setq start button-end))))))) - -(defun riece-button-update-channel-list-buffer () - (if riece-channel-list-buffer-mode - (save-excursion - (set-buffer riece-channel-list-buffer) - (let ((inhibit-read-only t) - buffer-read-only) - (riece-button-add-channel-buttons (point-min) (point-max) nil))))) - -(defun riece-button-requires () - '(riece-highlight)) + (set-buffer (riece-event-buffer event)) + (goto-char (riece-event-point event)) + (riece-popup-menu-popup + (if (riece-channel-p (riece-identity-prefix + (get-text-property (point) 'riece-identity))) + riece-channel-button-popup-menu + riece-user-button-popup-menu) + event))) + +(defun riece-channel-button-switch-to-channel () + (interactive) + (riece-command-switch-to-channel + (get-text-property (point) 'riece-identity))) + +(defun riece-channel-button-part () + (interactive) + (riece-command-part + (get-text-property (point) 'riece-identity))) + +(defun riece-channel-button-list () + (interactive) + (riece-command-list + (riece-identity-prefix (get-text-property (point) 'riece-identity)))) + +(defun riece-user-button-join-partner () + (interactive) + (riece-command-join-partner + (get-text-property (point) 'riece-identity))) + +(defun riece-user-button-set-operators () + (interactive) + (let (group users) + (if (riece-region-active-p) + (save-excursion + (riece-scan-property-region + 'riece-identity + (region-beginning) (region-end) + (lambda (start end) + (setq group (cons (get-text-property start 'riece-identity) + group))))) + (setq group (list (get-text-property (point) 'riece-identity)))) + (setq users (riece-with-server-buffer + (riece-identity-server riece-current-channel) + (riece-channel-get-users (riece-identity-prefix + riece-current-channel)))) + (if (setq group + (delq nil + (mapcar + (lambda (identity) + (unless (memq ?o (cdr (riece-identity-assoc + (riece-identity-prefix identity) + users + t))) + identity)) + group))) + (riece-command-set-operators (mapcar #'riece-identity-prefix group))))) + +(defun riece-user-button-set-speakers () + (interactive) + (let (group users) + (if (riece-region-active-p) + (save-excursion + (riece-scan-property-region + 'riece-identity + (region-beginning) (region-end) + (lambda (start end) + (setq group (cons (get-text-property start 'riece-identity) + group))))) + (setq group (list (get-text-property (point) 'riece-identity)))) + (setq users (riece-with-server-buffer + (riece-identity-server riece-current-channel) + (riece-channel-get-users (riece-identity-prefix + riece-current-channel)))) + (if (setq group + (delq nil + (mapcar + (lambda (identity) + (unless (memq ?v (cdr (riece-identity-assoc + (riece-identity-prefix identity) + users + t))) + identity)) + group))) + (riece-command-set-speakers (mapcar #'riece-identity-prefix group))))) +(defun riece-user-button-finger () + (interactive) + (riece-command-finger (get-text-property (point) 'riece-identity))) + +(defun riece-make-identity-button-map () + (let ((map (make-sparse-keymap))) + (set-keymap-parent map (current-local-map)) + (define-key map [down-mouse-2] 'riece-identity-button-click) + (define-key map [down-mouse-3] 'riece-identity-button-popup-menu) + map)) + +(defvar riece-identity-button-map) +(defun riece-button-add-identity-button (start end) + (if riece-button-enabled + (riece-scan-property-region + 'riece-identity + start end + (lambda (start end) + (let ((inhibit-read-only t) + buffer-read-only) + (widget-convert-button 'riece-identity-button start end + (get-text-property start 'riece-identity)) + (add-text-properties + start end + (list 'local-map riece-identity-button-map + 'keymap riece-identity-button-map))))))) + +(defun riece-button-update-buffer () + (riece-button-add-identity-button (point-min) (point-max))) + +(defvar riece-channel-list-mode-map) +(defvar riece-user-list-mode-map) +(defvar riece-dialogue-mode-map) (defun riece-button-insinuate () (add-hook 'riece-channel-list-mode-hook (lambda () (set-keymap-parent riece-channel-list-mode-map widget-keymap) + (set (make-local-variable 'riece-identity-button-map) + (riece-make-identity-button-map)) + (add-hook 'riece-update-buffer-functions + 'riece-button-update-buffer t t))) + (add-hook 'riece-user-list-mode-hook + (lambda () + (set-keymap-parent riece-user-list-mode-map widget-keymap) + (set (make-local-variable 'riece-identity-button-map) + (riece-make-identity-button-map)) (add-hook 'riece-update-buffer-functions - 'riece-button-update-channel-list-buffer t)))) + 'riece-button-update-buffer t t))) + (add-hook 'riece-dialogue-mode-hook + (lambda () + (set-keymap-parent riece-dialogue-mode-map widget-keymap) + (set (make-local-variable 'riece-identity-button-map) + (riece-make-identity-button-map)))) + (add-hook 'riece-after-insert-functions 'riece-button-add-identity-button)) + +(defun riece-button-enable () + (setq riece-button-enabled t) + (let ((pointer riece-buffer-list)) + (while pointer + (with-current-buffer (car pointer) + (if (eq (derived-mode-class major-mode) + 'riece-dialogue-mode) + (riece-button-update-buffer))) + (setq pointer (cdr pointer))) + (if riece-current-channel + (riece-emit-signal 'user-list-changed riece-current-channel)) + (riece-emit-signal 'channel-list-changed))) + +(defun riece-button-disable () + (setq riece-button-enabled nil) + (save-excursion + (let ((pointer riece-buffer-list)) + (while pointer + ;; On XEmacs, BUFFER arg of widget-map-buttons is ignored. + (set-buffer (car pointer)) + (widget-map-buttons + (lambda (widget maparg) + (widget-leave-text widget))) + (setq pointer (cdr pointer)))))) (provide 'riece-button)