;;; @ 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.
(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)))
;;; @ 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
(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
projects / elisp / semi.git / commitdiff