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.53 1997-07-02 16:28:48 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 'cl)
  29 (require 'emu)
  30
  31 (autoload 'mule-caesar-region "mule-caesar"
  32   "Caesar rotation of current region." t)
  33
  34
  35 ;;; @ variables
  36 ;;;
  37
  38 (defvar mime/use-multi-frame
  39   (and (>= emacs-major-version 19) window-system))
  40
  41 (defvar mime/find-file-function
  42   (if mime/use-multi-frame
  43       (function find-file-other-frame)
  44     (function find-file)
  45     ))
  46
  47
  48 ;;; @ constants
  49 ;;;
  50
  51 (defconst mime-echo-buffer-name "*MIME-echo*"
  52   "Name of buffer to display MIME-playing information.")
  53
  54 (defconst mime-temp-buffer-name " *MIME-temp*")
  55
  56
  57 ;;; @ definitions about MIME
  58 ;;;
  59
  60 (defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=")
  61 (defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
  62 (defconst mime-charset-regexp mime/token-regexp)
  63
  64 (defconst mime/content-type-subtype-regexp
  65   (concat mime/token-regexp "/" mime/token-regexp))
  66
  67 (defconst mime/disposition-type-regexp mime/token-regexp)
  68
  69
  70 ;;; @ button
  71 ;;;
  72
  73 (defvar mime-button-face 'bold
  74   "Face used for content-button or URL-button of MIME-Preview buffer.")
  75
  76 (defvar mime-button-mouse-face 'highlight
  77   "Face used for MIME-preview buffer mouse highlighting.")
  78
  79 (defsubst mime-add-button (from to function &optional data)
  80   "Create a button between FROM and TO with callback FUNCTION and DATA."
  81   (let ((overlay (make-overlay from to)))
  82     (and mime-button-face
  83          (overlay-put overlay 'face mime-button-face))
  84     (and mime-button-mouse-face
  85          (overlay-put overlay 'mouse-face mime-button-mouse-face))
  86     (add-text-properties from to (list 'mime-button-callback function))
  87     (and data
  88          (add-text-properties from to (list 'mime-button-data data)))
  89     ;;(add-text-properties from to (list 'keymap widget-keymap))
  90     ))
  91
  92 (defsubst mime-insert-button (string function &optional data)
  93   "Insert STRING as button with callback FUNCTION and DATA."
  94   (save-restriction
  95     (narrow-to-region (point)(point))
  96     (insert (concat "[" string "]"))
  97     ;; (widget-push-button-value-create
  98     ;;  (widget-convert 'push-button
  99     ;;                  :notify (lambda (&rest ignore)
 100     ;;                            (mime-view-play-current-entity)
 101     ;;                            )
 102     ;;                  string))
 103     (insert "\n")
 104     (mime-add-button (point-min)(point-max) function data)
 105     ))
 106
 107 (defvar mime-button-mother-dispatcher nil)
 108
 109 (defun mime-button-dispatcher (event)
 110   "Select the button under point."
 111   (interactive "e")
 112   (let (buf point func data)
 113     (save-window-excursion
 114       (mouse-set-point event)
 115       (setq buf (current-buffer)
 116             point (point)
 117             func (get-text-property (point) 'mime-button-callback)
 118             data (get-text-property (point) 'mime-button-data)
 119             )
 120       )
 121     (save-excursion
 122       (set-buffer buf)
 123       (goto-char point)
 124       (if func
 125           (apply func data)
 126         (if (fboundp mime-button-mother-dispatcher)
 127             (funcall mime-button-mother-dispatcher event)
 128           )
 129         ))))
 130
 131
 132 ;;; @ PGP
 133 ;;;
 134
 135 (defvar pgp-function-alist
 136   '(
 137     ;; for mime-pgp
 138     (verify             mc-verify                       "mc-toplev")
 139     (decrypt            mc-decrypt                      "mc-toplev")
 140     (fetch-key          mc-pgp-fetch-key                "mc-pgp")
 141     (snarf-keys         mc-snarf-keys                   "mc-toplev")
 142     ;; for mime-edit
 143     (mime-sign          mime-mc-pgp-sign-region         "mime-mc")
 144     (traditional-sign   mc-pgp-sign-region              "mc-pgp")
 145     (encrypt            mime-mc-pgp-encrypt-region      "mime-mc")
 146     (insert-key         mc-insert-public-key            "mc-toplev")
 147     )
 148   "Alist of service names vs. corresponding functions and its filenames.
 149 Each element looks like (SERVICE FUNCTION FILE).
 150
 151 SERVICE is a symbol of PGP processing.  It allows `verify', `decrypt',
 152 `fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt'
 153 or `insert-key'.
 154
 155 Function is a symbol of function to do specified SERVICE.
 156
 157 FILE is string of filename which has definition of corresponding
 158 FUNCTION.")
 159
 160 (defmacro pgp-function (method)
 161   "Return function to do service METHOD."
 162   (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist)))))
 163   )
 164
 165 (mapcar (function
 166          (lambda (method)
 167            (autoload (second method)(third method))
 168            ))
 169         pgp-function-alist)
 170
 171
 172 ;;; @ method selector kernel
 173 ;;;
 174
 175 (require 'atype)
 176
 177 ;;; @@ field unifier
 178 ;;;
 179
 180 (defun field-unifier-for-mode (a b)
 181   (let ((va (cdr a)))
 182     (if (if (consp va)
 183             (member (cdr b) va)
 184           (equal va (cdr b))
 185           )
 186         (list nil b nil)
 187       )))
 188
 189
 190 ;;; @ field
 191 ;;;
 192
 193 (defsubst regexp-or (&rest args)
 194   (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
 195
 196 (defun tm:set-fields (sym field-list &optional regexp-sym)
 197   (or regexp-sym
 198       (setq regexp-sym
 199             (let ((name (symbol-name sym)))
 200               (intern
 201                (concat (if (string-match "\\(.*\\)-list" name)
 202                            (substring name 0 (match-end 1))
 203                          name)
 204                        "-regexp")
 205                )))
 206       )
 207   (set sym field-list)
 208   (set regexp-sym
 209        (concat "^" (apply (function regexp-or) field-list) ":"))
 210   )
 211
 212 (defun tm:add-fields (sym field-list &optional regexp-sym)
 213   (or regexp-sym
 214       (setq regexp-sym
 215             (let ((name (symbol-name sym)))
 216               (intern
 217                (concat (if (string-match "\\(.*\\)-list" name)
 218                            (substring name 0 (match-end 1))
 219                          name)
 220                        "-regexp")
 221                )))
 222       )
 223   (let ((fields (eval sym)))
 224     (mapcar (function
 225              (lambda (field)
 226                (or (member field fields)
 227                    (setq fields (cons field fields))
 228                    )
 229                ))
 230             (reverse field-list)
 231             )
 232     (set regexp-sym
 233          (concat "^" (apply (function regexp-or) fields) ":"))
 234     (set sym fields)
 235     ))
 236
 237 (defun tm:delete-fields (sym field-list &optional regexp-sym)
 238   (or regexp-sym
 239       (setq regexp-sym
 240             (let ((name (symbol-name sym)))
 241               (intern
 242                (concat (if (string-match "\\(.*\\)-list" name)
 243                            (substring name 0 (match-end 1))
 244                          name)
 245                        "-regexp")
 246                )))
 247       )
 248   (let ((fields (eval sym)))
 249     (mapcar (function
 250              (lambda (field)
 251                (setq fields (delete field fields))
 252                ))
 253             field-list)
 254     (set regexp-sym
 255          (concat "^" (apply (function regexp-or) fields) ":"))
 256     (set sym fields)
 257     ))
 258
 259
 260 ;;; @ RCS version
 261 ;;;
 262
 263 (defsubst get-version-string (id)
 264   "Return a version-string from RCS ID."
 265   (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id)
 266        (substring id (match-beginning 1)(match-end 1))
 267        ))
 268
 269
 270 ;;; @ Other Utility
 271 ;;;
 272
 273 (defsubst eliminate-top-spaces (string)
 274   "Eliminate top sequence of space or tab in STRING."
 275   (if (string-match "^[ \t]+" string)
 276       (substring string (match-end 0))
 277     string))
 278
 279 (defun call-after-loaded (module func &optional hook-name)
 280   "If MODULE is provided, then FUNC is called.
 281 Otherwise func is set to MODULE-load-hook.
 282 If optional argument HOOK-NAME is specified,
 283 it is used as hook to set."
 284   (if (featurep module)
 285       (funcall func)
 286     (or hook-name
 287         (setq hook-name (intern (concat (symbol-name module) "-load-hook")))
 288         )
 289     (add-hook hook-name func)
 290     ))
 291
 292
 293 ;;; @ end
 294 ;;;
 295
 296 (provide 'mime-def)
 297
 298 ;;; mime-def.el ends here