X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=semi-def.el;h=a88b32d253f85ab2ccbcc2b4c1f6021230c32a97;hb=4bedbfeec63d11acb1d0957225030643cfa5b9a3;hp=bff40af273f7b73987e0b9efe2914e17a4db79da;hpb=0320f2ef5cc0c5b2d1fbec6780676d48eeeea45f;p=elisp%2Fsemi.git diff --git a/semi-def.el b/semi-def.el index bff40af..a88b32d 100644 --- a/semi-def.el +++ b/semi-def.el @@ -1,11 +1,11 @@ -;;; semi-def.el --- definition module for SEMI +;;; 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,01,03 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; Keywords: definition, MIME, multimedia, mail, news -;; This file is part of SEMI (Spadework for Emacs MIME Interfaces). +;; This file is part of SEMI (Sample of Emacs MIME Implementation). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -24,31 +24,17 @@ ;;; Code: -(require 'emu) - (eval-when-compile (require 'cl)) +(require 'custom) -(defconst mime-module-version '("SEMI" "Kajiyashiki" 1 3 4) - "Implementation name, version name and numbers of MIME-kernel package.") +(defconst mime-user-interface-product ["SEMI" (1 14 6) "Maruoka"] + "Product name, version number and code name of MIME-kernel package.") (autoload 'mule-caesar-region "mule-caesar" "Caesar rotation of current region." t) -;;; @ variables -;;; - -(defvar mime/use-multi-frame - (and (>= emacs-major-version 19) window-system)) - -(defvar mime/find-file-function - (if mime/use-multi-frame - (function find-file-other-frame) - (function find-file) - )) - - ;;; @ constants ;;; @@ -73,29 +59,20 @@ (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))) - ;;(add-text-properties from to (list 'keymap widget-keymap)) - )) + (and mime-button-face + (put-text-property from to 'face mime-button-face)) + (and mime-button-mouse-face + (put-text-property from to 'mouse-face mime-button-mouse-face)) + (put-text-property from to 'mime-button-callback function) + (and data + (put-text-property from to 'mime-button-data 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 "]")) - ;; (widget-push-button-value-create - ;; (widget-convert 'push-button - ;; :notify (lambda (&rest ignore) - ;; (mime-preview-play-current-entity) - ;; ) - ;; string)) - (insert "\n") + (insert (concat "[" string "]\n")) (mime-add-button (point-min)(point-max) function data) )) @@ -111,8 +88,7 @@ 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) @@ -120,179 +96,111 @@ (apply func data) (if (fboundp mime-button-mother-dispatcher) (funcall mime-button-mother-dispatcher event) - ) - )))) - - -;;; @ 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) - )) - ) + ))))) -;;; @ PGP +;;; @ for URL ;;; -(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 -;;; - -(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) ":")) - ) +(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) -(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) - )) +(defcustom mime-browse-url-function (function browse-url) + "*Function to browse URL." + :group 'mime + :type 'function) -(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) - )) +(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) + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (mime-add-button beg end mime-browse-url-function + (list (buffer-substring beg end)))))) -;;; @ RCS version +;;; @ menu ;;; -(defsubst get-version-string (id) - "Return a version-string from RCS ID." - (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id) - (substring id (match-beginning 1)(match-end 1)) - )) - +(static-cond ((featurep 'xemacs) + (defun mime-should-use-popup-menu () + (and window-system + (mouse-event-p last-command-event))) + (defun mime-select-menu-alist (title menu-alist) + (if (mime-should-use-popup-menu) + (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) + (cdr + (assoc (completing-read (concat title " : ") menu-alist) + menu-alist))))) + (t + (defun mime-should-use-popup-menu () + (and window-system + (memq (event-basic-type last-command-event) + '(mouse-1 mouse-2 mouse-3)))) + (defun mime-select-menu-alist (title menu-alist) + (if (mime-should-use-popup-menu) + (x-popup-menu + (list '(1 1) (selected-window)) + (list title (cons title menu-alist))) + (cdr + (assoc (completing-read (concat title " : ") menu-alist) + menu-alist)))))) ;;; @ 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))) + +(defvar mime-condition-mode-alist + '((with-default . ctree-set-calist-with-default) + (t . ctree-set-calist-strictly))) + +(defun mime-add-condition (target-type condition &optional mode file) + "Add CONDITION to database specified by TARGET-TYPE. +TARGET-TYPE must be 'preview or 'action. +If optional argument MODE is 'strict or nil (omitted), CONDITION is +added strictly. +If optional argument MODE is 'with-default, CONDITION is added with +default rule. +If optional argument FILE is specified, it is loaded when CONDITION is +activate." + (let ((sym (cdr (assq target-type mime-condition-type-alist)))) + (if sym + (let ((func (cdr (or (assq mode mime-condition-mode-alist) + (assq t mime-condition-mode-alist))))) + (if (fboundp func) + (progn + (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) + ))) ;;; @ end