X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=semi-def.el;h=d4b13e7329b0b64fca2254e8023fb751df140c23;hb=refs%2Fheads%2Femiko-1_14-epg;hp=fe52207e175c93fb5fc73440d3b3076a11c196b0;hpb=1c8085610e26371c80a2a266c7d18d167ae2e8a7;p=elisp%2Fsemi.git diff --git a/semi-def.el b/semi-def.el index fe52207..d4b13e7 100644 --- a/semi-def.el +++ b/semi-def.el @@ -1,8 +1,8 @@ -;;; semi-def.el --- definition module for REMI +;;; semi-def.el --- definition module for SEMI -*- coding: iso-8859-4; -*- -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Keywords: definition, MIME, multimedia, mail, news ;; This file is part of SEMI (Sample of Emacs MIME Implementation). @@ -19,22 +19,22 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Code: -(require 'emu) - (eval-when-compile (require 'cl)) +(require 'custom) -(defconst mime-module-version '("SEMI" "Namerikawa" 1 5 5) - "Implementation name, version name and numbers of MIME-kernel package.") +(defconst mime-user-interface-product ["EMIKO" (1 14 1) "Choanoflagellata"] + "Product name, version number and code name of MIME-kernel package.") (autoload 'mule-caesar-region "mule-caesar" "Caesar rotation of current region." t) +(autoload 'widget-convert-button "wid-edit") ;;; @ constants ;;; @@ -48,220 +48,112 @@ ;;; @ button ;;; -(defcustom mime-button-face 'bold - "Face used for content-button or URL-button of MIME-Preview buffer." - :group 'mime - :type 'face) - -(defcustom mime-button-mouse-face 'highlight - "Face used for MIME-preview buffer mouse highlighting." - :group 'mime - :type 'face) - -(defsubst mime-add-button (from to function &optional data) - "Create a button between FROM and TO with callback FUNCTION and DATA." - (let ((overlay (make-overlay from to))) - (and mime-button-face - (overlay-put overlay 'face mime-button-face)) - (and mime-button-mouse-face - (overlay-put overlay 'mouse-face mime-button-mouse-face)) - (add-text-properties from to (list 'mime-button-callback function)) - (and data - (add-text-properties from to (list 'mime-button-data data))) - )) +(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-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." (save-restriction (narrow-to-region (point)(point)) - (insert (concat "[" string "]\n")) - (mime-add-button (point-min)(point-max) function data) - )) - -(defvar mime-button-mother-dispatcher nil) - -(defun mime-button-dispatcher (event) - "Select the button under point." - (interactive "e") - (let (buf point func data) - (save-window-excursion - (mouse-set-point event) - (setq buf (current-buffer) - point (point) - func (get-text-property (point) 'mime-button-callback) - data (get-text-property (point) 'mime-button-data) - )) - (save-excursion - (set-buffer buf) - (goto-char point) - (if func - (apply func data) - (if (fboundp mime-button-mother-dispatcher) - (funcall mime-button-mother-dispatcher event) - ) - )))) + ;; 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 +;;; +(defcustom mime-browse-url-regexp + (concat "\\(https?\\|ftps?\\|file\\|gopher\\|news\\|nntps?\\|telnets?\\|wais\\|mailto\\):" + "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?" + "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,;]*[-a-zA-Z0-9_=#$@~`%&*+|\\/;]") + "Regexp to match URL in text body." + :group 'mime + :type 'regexp) -;;; @ menu -;;; +(defcustom mime-browse-url-function (function 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 'mime-url-link (match-beginning 0)(match-end 0) + (match-string-no-properties 0)))) -(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) - )) - ) - - -;;; @ PGP -;;; -(defvar pgp-function-alist - '( - ;; for mime-pgp - (verify mc-verify "mc-toplev") - (decrypt mc-decrypt "mc-toplev") - (fetch-key mc-pgp-fetch-key "mc-pgp") - (snarf-keys mc-snarf-keys "mc-toplev") - ;; for mime-edit - (mime-sign mime-mc-pgp-sign-region "mime-mc") - (traditional-sign mc-pgp-sign-region "mc-pgp") - (encrypt mime-mc-pgp-encrypt-region "mime-mc") - (insert-key mc-insert-public-key "mc-toplev") - ) - "Alist of service names vs. corresponding functions and its filenames. -Each element looks like (SERVICE FUNCTION FILE). - -SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' -or `insert-key'. - -Function is a symbol of function to do specified SERVICE. - -FILE is string of filename which has definition of corresponding -FUNCTION.") - -(defmacro pgp-function (method) - "Return function to do service METHOD." - `(cadr (assq ,method (symbol-value 'pgp-function-alist)))) - -(mapcar (function - (lambda (method) - (autoload (cadr method)(nth 2 method)) - )) - pgp-function-alist) - - -;;; @ field +;;; @ menu ;;; -(defun tm:set-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (set sym field-list) - (set regexp-sym - (concat "^" (apply (function regexp-or) field-list) ":")) - ) - -(defun tm:add-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (let ((fields (eval sym))) - (mapcar (function - (lambda (field) - (or (member field fields) - (setq fields (cons field fields)) - ) - )) - (reverse field-list) - ) - (set regexp-sym - (concat "^" (apply (function regexp-or) fields) ":")) - (set sym fields) - )) - -(defun tm:delete-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (let ((fields (eval sym))) - (mapcar (function - (lambda (field) - (setq fields (delete field fields)) - )) - field-list) - (set regexp-sym - (concat "^" (apply (function regexp-or) fields) ":")) - (set sym fields) - )) +(defmacro mime-popup-menu-bogus-filter-constructor (menu) + ;; #### Kludge for FSF Emacs-style menu. + (let ((bogus-menu (make-symbol "bogus-menu"))) + `(let (,bogus-menu selection function) + (easy-menu-define ,bogus-menu nil nil ,menu) + (setq selection (x-popup-menu t ,bogus-menu)) + (when selection + (setq function (lookup-key ,bogus-menu (apply #'vector selection))) + ;; If a callback entry has no name, easy-menu wraps its value. + ;; See `easy-menu-make-symbol'. + (if (eq t (compare-strings "menu-function-" 0 nil + (symbol-name function) 0 14)) + (car (last (symbol-function function))) + function))))) + +;;; While XEmacs can have both X and tty frames at the same time with +;;; gnuclient, we shouldn't emulate in text-mode here. + +(static-if (featurep 'xemacs) + (defalias 'mime-popup-menu-popup 'popup-menu) + (defun mime-popup-menu-popup (menu &optional event) + (let ((function (mime-popup-menu-bogus-filter-constructor menu))) + (when (symbolp function) + (funcall function))))) + +(static-if (featurep 'xemacs) + (defun mime-popup-menu-select (menu &optional event) + (let ((selection (get-popup-menu-response menu event))) + (event-object selection))) + (defun mime-popup-menu-select (menu &optional event) + (mime-popup-menu-bogus-filter-constructor menu))) + +(static-if (featurep 'xemacs) + (defun mime-should-use-popup-menu () + (mouse-event-p last-command-event)) + (defun mime-should-use-popup-menu () + (memq (event-basic-type last-command-event) '(mouse-1 mouse-2 mouse-3)))) + +(defun mime-menu-select (prompt menu &optional event) + (if (mime-should-use-popup-menu) + (mime-popup-menu-select menu event) + (let ((rest (cdr menu))) + (while rest + (setcar rest (append (car rest) nil)) + (setq rest (cdr rest))) + (nth 1 (assoc (completing-read prompt (cdr menu)) (cdr menu)))))) ;;; @ Other Utility ;;; -(defun call-after-loaded (module func &optional hook-name) - "If MODULE is provided, then FUNC is called. -Otherwise func is set to MODULE-load-hook. -If optional argument HOOK-NAME is specified, -it is used as hook to set." - (if (featurep module) - (funcall func) - (or hook-name - (setq hook-name (intern (concat (symbol-name module) "-load-hook"))) - ) - (add-hook hook-name func) - )) - - (defvar mime-condition-type-alist '((preview . mime-preview-condition) (action . mime-acting-condition))) @@ -288,13 +180,9 @@ activate." (funcall func sym condition) (if file (let ((method (cdr (assq 'method condition)))) - (autoload method file) - )) - ) - (error "Function for mode `%s' is not found." mode) - )) - (error "Variable for target-type `%s' is not found." target-type) - ))) + (autoload method file)))) + (error "Function for mode `%s' is not found." mode))) + (error "Variable for target-type `%s' is not found." target-type)))) ;;; @ end