mime-def.el

   1 ;;; mime-def.el --- definition module for SEMI
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: mime-def.el,v 0.76 1998-02-12 14:28:20 morioka Exp $
   7 ;; Keywords: definition, MIME, multimedia, mail, news
   8
   9 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'emu)
  29 (require 'custom)
  30
  31 (defgroup mime nil
  32   "Emacs MIME Interfaces"
  33   :group 'news
  34   :group 'mail)
  35
  36 (custom-handle-keyword 'default-mime-charset :group 'mime
  37                        'custom-variable)
  38
  39 (unless (fboundp 'butlast)
  40   (defun butlast (x &optional n)
  41     "Returns a copy of LIST with the last N elements removed."
  42     (if (and n (<= n 0)) x
  43       (nbutlast (copy-sequence x) n)))
  44
  45   (defun nbutlast (x &optional n)
  46     "Modifies LIST to remove the last N elements."
  47     (let ((m (length x)))
  48       (or n (setq n 1))
  49       (and (< n m)
  50            (progn
  51              (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
  52              x))))
  53   )
  54
  55 (defconst semi-version-name "Otomaru"
  56   "Version name of SEMI-kernel package.")
  57
  58 (autoload 'mule-caesar-region "mule-caesar"
  59   "Caesar rotation of current region." t)
  60
  61
  62 ;;; @ variables
  63 ;;;
  64
  65 (defvar mime/use-multi-frame
  66   (and (>= emacs-major-version 19) window-system))
  67
  68 (defvar mime/find-file-function
  69   (if mime/use-multi-frame
  70       (function find-file-other-frame)
  71     (function find-file)
  72     ))
  73
  74
  75 ;;; @ constants
  76 ;;;
  77
  78 (defconst mime-echo-buffer-name "*MIME-echo*"
  79   "Name of buffer to display MIME-playing information.")
  80
  81 (defconst mime-temp-buffer-name " *MIME-temp*")
  82
  83
  84 ;;; @ definitions about MIME
  85 ;;;
  86
  87 (defconst mime-tspecials "][()<>@,\;:\\\"/?=")
  88 (defconst mime-token-regexp (concat "[^" mime-tspecials "\000-\040]+"))
  89 (defconst mime-charset-regexp mime-token-regexp)
  90
  91 (defconst mime-media-type/subtype-regexp
  92   (concat mime-token-regexp "/" mime-token-regexp))
  93
  94
  95 ;;; @ button
  96 ;;;
  97
  98 (defcustom mime-button-face 'bold
  99   "Face used for content-button or URL-button of MIME-Preview buffer."
 100   :group 'mime
 101   :type 'face)
 102
 103 (defcustom mime-button-mouse-face 'highlight
 104   "Face used for MIME-preview buffer mouse highlighting."
 105   :group 'mime
 106   :type 'face)
 107
 108 (defsubst mime-add-button (from to function &optional data)
 109   "Create a button between FROM and TO with callback FUNCTION and DATA."
 110   (let ((overlay (make-overlay from to)))
 111     (and mime-button-face
 112          (overlay-put overlay 'face mime-button-face))
 113     (and mime-button-mouse-face
 114          (overlay-put overlay 'mouse-face mime-button-mouse-face))
 115     (add-text-properties from to (list 'mime-button-callback function))
 116     (and data
 117          (add-text-properties from to (list 'mime-button-data data)))
 118     ;;(add-text-properties from to (list 'keymap widget-keymap))
 119     ))
 120
 121 (defsubst mime-insert-button (string function &optional data)
 122   "Insert STRING as button with callback FUNCTION and DATA."
 123   (save-restriction
 124     (narrow-to-region (point)(point))
 125     (insert (concat "[" string "]"))
 126     ;; (widget-push-button-value-create
 127     ;;  (widget-convert 'push-button
 128     ;;                  :notify (lambda (&rest ignore)
 129     ;;                            (mime-view-play-current-entity)
 130     ;;                            )
 131     ;;                  string))
 132     (insert "\n")
 133     (mime-add-button (point-min)(point-max) function data)
 134     ))
 135
 136 (defvar mime-button-mother-dispatcher nil)
 137
 138 (defun mime-button-dispatcher (event)
 139   "Select the button under point."
 140   (interactive "e")
 141   (let (buf point func data)
 142     (save-window-excursion
 143       (mouse-set-point event)
 144       (setq buf (current-buffer)
 145             point (point)
 146             func (get-text-property (point) 'mime-button-callback)
 147             data (get-text-property (point) 'mime-button-data)
 148             )
 149       )
 150     (save-excursion
 151       (set-buffer buf)
 152       (goto-char point)
 153       (if func
 154           (apply func data)
 155         (if (fboundp mime-button-mother-dispatcher)
 156             (funcall mime-button-mother-dispatcher event)
 157           )
 158         ))))
 159
 160
 161 ;;; @ PGP
 162 ;;;
 163
 164 (defvar pgp-function-alist
 165   '(
 166     ;; for mime-pgp
 167     (verify             mc-verify                       "mc-toplev")
 168     (decrypt            mc-decrypt                      "mc-toplev")
 169     (fetch-key          mc-pgp-fetch-key                "mc-pgp")
 170     (snarf-keys         mc-snarf-keys                   "mc-toplev")
 171     ;; for mime-edit
 172     (mime-sign          mime-mc-pgp-sign-region         "mime-mc")
 173     (traditional-sign   mc-pgp-sign-region              "mc-pgp")
 174     (encrypt            mime-mc-pgp-encrypt-region      "mime-mc")
 175     (insert-key         mc-insert-public-key            "mc-toplev")
 176     )
 177   "Alist of service names vs. corresponding functions and its filenames.
 178 Each element looks like (SERVICE FUNCTION FILE).
 179
 180 SERVICE is a symbol of PGP processing.  It allows `verify', `decrypt',
 181 `fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt'
 182 or `insert-key'.
 183
 184 Function is a symbol of function to do specified SERVICE.
 185
 186 FILE is string of filename which has definition of corresponding
 187 FUNCTION.")
 188
 189 (defmacro pgp-function (method)
 190   "Return function to do service METHOD."
 191   `(cadr (assq ,method (symbol-value 'pgp-function-alist)))
 192   )
 193
 194 (mapcar (function
 195          (lambda (method)
 196            (autoload (cadr method)(nth 2 method))
 197            ))
 198         pgp-function-alist)
 199
 200
 201 ;;; @ method selector kernel
 202 ;;;
 203
 204 (require 'atype)
 205
 206 ;;; @@ field unifier
 207 ;;;
 208
 209 (defun field-unifier-for-mode (a b)
 210   (let ((va (cdr a)))
 211     (if (if (consp va)
 212             (member (cdr b) va)
 213           (equal va (cdr b))
 214           )
 215         (list nil b nil)
 216       )))
 217
 218
 219 ;;; @ field
 220 ;;;
 221
 222 (defsubst regexp-or (&rest args)
 223   (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
 224
 225 (defun tm:set-fields (sym field-list &optional regexp-sym)
 226   (or regexp-sym
 227       (setq regexp-sym
 228             (let ((name (symbol-name sym)))
 229               (intern
 230                (concat (if (string-match "\\(.*\\)-list" name)
 231                            (substring name 0 (match-end 1))
 232                          name)
 233                        "-regexp")
 234                )))
 235       )
 236   (set sym field-list)
 237   (set regexp-sym
 238        (concat "^" (apply (function regexp-or) field-list) ":"))
 239   )
 240
 241 (defun tm:add-fields (sym field-list &optional regexp-sym)
 242   (or regexp-sym
 243       (setq regexp-sym
 244             (let ((name (symbol-name sym)))
 245               (intern
 246                (concat (if (string-match "\\(.*\\)-list" name)
 247                            (substring name 0 (match-end 1))
 248                          name)
 249                        "-regexp")
 250                )))
 251       )
 252   (let ((fields (eval sym)))
 253     (mapcar (function
 254              (lambda (field)
 255                (or (member field fields)
 256                    (setq fields (cons field fields))
 257                    )
 258                ))
 259             (reverse field-list)
 260             )
 261     (set regexp-sym
 262          (concat "^" (apply (function regexp-or) fields) ":"))
 263     (set sym fields)
 264     ))
 265
 266 (defun tm:delete-fields (sym field-list &optional regexp-sym)
 267   (or regexp-sym
 268       (setq regexp-sym
 269             (let ((name (symbol-name sym)))
 270               (intern
 271                (concat (if (string-match "\\(.*\\)-list" name)
 272                            (substring name 0 (match-end 1))
 273                          name)
 274                        "-regexp")
 275                )))
 276       )
 277   (let ((fields (eval sym)))
 278     (mapcar (function
 279              (lambda (field)
 280                (setq fields (delete field fields))
 281                ))
 282             field-list)
 283     (set regexp-sym
 284          (concat "^" (apply (function regexp-or) fields) ":"))
 285     (set sym fields)
 286     ))
 287
 288
 289 ;;; @ RCS version
 290 ;;;
 291
 292 (defsubst get-version-string (id)
 293   "Return a version-string from RCS ID."
 294   (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id)
 295        (substring id (match-beginning 1)(match-end 1))
 296        ))
 297
 298
 299 ;;; @ Other Utility
 300 ;;;
 301
 302 (defsubst eliminate-top-spaces (string)
 303   "Eliminate top sequence of space or tab in STRING."
 304   (if (string-match "^[ \t]+" string)
 305       (substring string (match-end 0))
 306     string))
 307
 308 (defun call-after-loaded (module func &optional hook-name)
 309   "If MODULE is provided, then FUNC is called.
 310 Otherwise func is set to MODULE-load-hook.
 311 If optional argument HOOK-NAME is specified,
 312 it is used as hook to set."
 313   (if (featurep module)
 314       (funcall func)
 315     (or hook-name
 316         (setq hook-name (intern (concat (symbol-name module) "-load-hook")))
 317         )
 318     (add-hook hook-name func)
 319     ))
 320
 321
 322 ;;; @ end
 323 ;;;
 324
 325 (provide 'mime-def)
 326
 327 ;;; mime-def.el ends here