mime-def.el

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