From 4dff238f60501b2990725dce9a02ffe394223fd0 Mon Sep 17 00:00:00 2001 From: ueno Date: Wed, 13 Sep 2000 05:10:28 +0000 Subject: [PATCH] * mime-view.el (mime-view-xemacs-popup-menu): Abolish. (mime-view-menu-title): Abolish. (mime-view-menu-list): Rewrite in easymenu-style. (mime-view-popup-menu): New function. (mime-view-define-keymap): Simplify; don't check `emacs-major-version'. * semi-def.el (mime-menu-bogus-filter-constructor): New macro. (mime-menu-popup): New macro. (select-menu-alist): Rewrite with `defun-maybe-cond'. (mime-insert-button): Use `widget-convert-button'. (mime-url-link): New widget. --- mime-view.el | 81 +++++++++++++--------------------------------------- semi-def.el | 89 ++++++++++++++++++++++++++++++++++++---------------------- 2 files changed, 75 insertions(+), 95 deletions(-) diff --git a/mime-view.el b/mime-view.el index 85d0771..270ec9d 100644 --- a/mime-view.el +++ b/mime-view.el @@ -1004,51 +1004,22 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." ;;; @ MIME viewer mode ;;; -(defconst mime-view-menu-title "MIME-View") (defconst mime-view-menu-list - '((up "Move to upper entity" mime-preview-move-to-upper) - (previous "Move to previous entity" mime-preview-move-to-previous) - (next "Move to next entity" mime-preview-move-to-next) - (scroll-down "Scroll-down" mime-preview-scroll-down-entity) - (scroll-up "Scroll-up" mime-preview-scroll-up-entity) - (play "Play current entity" mime-preview-play-current-entity) - (extract "Extract current entity" mime-preview-extract-current-entity) - (print "Print current entity" mime-preview-print-current-entity)) + '("MIME-View" + ["Move to upper entity" mime-preview-move-to-upper] + ["Move to previous entity" mime-preview-move-to-previous] + ["Move to next entity" mime-preview-move-to-next] + ["Scroll-down" mime-preview-scroll-down-entity] + ["Scroll-up" mime-preview-scroll-up-entity] + ["Play current entity" mime-preview-play-current-entity] + ["Extract current entity" mime-preview-extract-current-entity] + ["Print current entity" mime-preview-print-current-entity]) "Menu for MIME Viewer") -(cond ((featurep 'xemacs) - (defvar mime-view-xemacs-popup-menu - (cons mime-view-menu-title - (mapcar (function - (lambda (item) - (vector (nth 1 item)(nth 2 item) t))) - mime-view-menu-list))) - (defun mime-view-xemacs-popup-menu (event) - "Popup the menu in the MIME Viewer buffer" - (interactive "e") - (select-window (event-window event)) - (set-buffer (event-buffer event)) - (popup-menu 'mime-view-xemacs-popup-menu)) - (defvar mouse-button-2 'button2)) - (t - (defvar mime-view-popup-menu - (let ((menu (make-sparse-keymap mime-view-menu-title))) - (nconc menu - (mapcar (function - (lambda (item) - (list (intern (nth 1 item)) 'menu-item - (nth 1 item)(nth 2 item)))) - mime-view-menu-list)))) - (defun mime-view-popup-menu (event) - "Popup the menu in the MIME Viewer buffer" - (interactive "@e") - (let ((menu mime-view-popup-menu) events func) - (setq events (x-popup-menu t menu)) - (and events - (setq func (lookup-key menu (apply #'vector events))) - (commandp func) - (funcall func)))) - (defvar mouse-button-2 [mouse-2]))) +(defun mime-view-popup-menu (event) + "Popup the menu in the MIME Viewer buffer" + (interactive "@e") + (mime-menu-popup event mime-view-menu-list)) ;;; The current local map is taken precendence over `widget-keymap', because GNU Emacs' ;;; widget implementation doesn't set `local-map' property. So we need to specify derivation. @@ -1130,26 +1101,12 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (define-key mime-view-mode-map [backspace] (function mime-preview-scroll-down-entity)) (if (functionp default) - (cond ((featurep 'xemacs) - (set-keymap-default-binding mime-view-mode-map default)) - (t - (setq mime-view-mode-map - (append mime-view-mode-map (list (cons t default))))))) - (cond ((featurep 'xemacs) - (define-key mime-view-mode-map - mouse-button-3 (function mime-view-xemacs-popup-menu))) - ((>= emacs-major-version 19) - (define-key mime-view-mode-map - mouse-button-3 (function mime-view-popup-menu)) - (define-key mime-view-mode-map [menu-bar mime-view] - (cons mime-view-menu-title - (make-sparse-keymap mime-view-menu-title))) - (mapcar (function - (lambda (item) - (define-key mime-view-mode-map - (vector 'menu-bar 'mime-view (car item)) - (cons (nth 1 item)(nth 2 item))))) - (reverse mime-view-menu-list)))) + (static-if (featurep 'xemacs) + (set-keymap-default-binding mime-view-mode-map default) + (setq mime-view-mode-map + (append mime-view-mode-map (list (cons t default)))))) + (define-key mime-view-mode-map + mouse-button-3 (function mime-view-popup-menu)) (use-local-map mime-view-mode-map) (run-hooks 'mime-view-define-keymap-hook))) diff --git a/semi-def.el b/semi-def.el index dbae683..a9a94ba 100644 --- a/semi-def.el +++ b/semi-def.el @@ -50,20 +50,29 @@ ;;; @ button ;;; -(define-widget 'mime-button 'push-button +(define-widget 'mime-button 'link "Widget for MIME button." :action 'mime-button-action) (defun mime-button-action (widget &optional event) - (let ((function (widget-get widget :mime-callback)) - (data (widget-get widget :mime-data))) + (let ((function (widget-get widget :mime-button-callback)) + (data (widget-get widget :mime-button-data))) (when function (funcall function data)))) (defsubst mime-insert-button (string function &optional data) "Insert STRING as button with callback FUNCTION and DATA." - (widget-create 'mime-button :mime-callback function :mime-data data string) - (insert "\n")) + (save-restriction + (narrow-to-region (point)(point)) + ;; Maybe we should introduce button formatter such as + ;; `gnus-mime-button-line-format'. + (insert "[" string "]") + ;; XEmacs -- when `widget-glyph-enable' is non nil, widget values are not + ;; guaranteed to be underlain. + (widget-convert-button 'mime-button (point-min)(point-max) + :mime-button-callback function + :mime-button-data data) + (insert "\n"))) ;;; @ for URL @@ -73,51 +82,65 @@ (concat "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):" "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?" "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]") - "*Regexp to match URL in text body." + "Regexp to match URL in text body." :group 'mime :type 'regexp) (defcustom mime-browse-url-function (function browse-url) - "*Function to browse URL." + "Function to browse URL." :group 'mime :type 'function) +(define-widget 'mime-url-link 'url-link + "A link to an www page.") + (defsubst mime-add-url-buttons () "Add URL-buttons for text body." (goto-char (point-min)) (while (re-search-forward mime-browse-url-regexp nil t) - (widget-convert-button 'url-link (match-beginning 0)(match-end 0) + (widget-convert-button 'mime-url-link (match-beginning 0)(match-end 0) (match-string-no-properties 0)))) ;;; @ menu ;;; -(if window-system - (if (featurep 'xemacs) - (defun select-menu-alist (title menu-alist) - (let (ret) - (popup-menu - (list* title - "---" - (mapcar (function - (lambda (cell) - (vector (car cell) - `(progn - (setq ret ',(cdr cell)) - (throw 'exit nil)) - t))) - menu-alist))) - (recursive-edit) - ret)) - (defun select-menu-alist (title menu-alist) - (x-popup-menu - (list '(1 1) (selected-window)) - (list title (cons title menu-alist))))) - (defun select-menu-alist (title menu-alist) - (cdr - (assoc (completing-read (concat title " : ") menu-alist) - menu-alist)))) +(defun-maybe-cond select-menu-alist (title menu-alist) + ((fboundp 'popup-menu) + ;; While XEmacs can have both X and tty frames at the same time with + ;; gnuclient, we shouldn't emulate in text-mode here. + (let (ret) + (popup-menu + ;; list* is CL function, but CL is a part of XEmacs. + (list* title + "---" + (mapcar + (lambda (cell) + (vector (car cell) + `(progn + (setq ret ',(cdr cell)) + (throw 'exit nil)) + t))) + menu-alist)) + (recursive-edit) + ret)) + (window-system + (x-popup-menu t (list title (cons title menu-alist))))) + +(defmacro mime-menu-bogus-filter-constructor (name menu) + `(let (x y) + (setq x (x-popup-menu t ,menu) + y (and x (lookup-key ,menu (apply #'vector x)))) + (if (and x y) + (funcall y)))) + +(defmacro mime-menu-popup (event menu) + (if (fboundp 'popup-menu) + `(popup-menu ,menu) + ;; #### Kludge for GNU Emacs 20.7 or earlier. + `(let (bogus-menu) + (easy-menu-define bogus-menu nil nil ,menu) + (mime-menu-bogus-filter-constructor "Popup" bogus-menu)))) ;;; @ Other Utility -- 1.7.10.4