semi-def.el

   1 ;;; semi-def.el --- definition module for WEMI
   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 WEMI (Widget based 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
  29 (eval-when-compile (require 'cl))
  30
  31
  32 (defconst mime-module-version '("WEMI" "Totsuka" 1 3 0)
  33   "Implementation name, version name and numbers of MIME-kernel package.")
  34
  35 (autoload 'mule-caesar-region "mule-caesar"
  36   "Caesar rotation of current region." t)
  37
  38
  39 ;;; @ variables
  40 ;;;
  41
  42 (defvar mime/use-multi-frame
  43   (and (>= emacs-major-version 19) window-system))
  44
  45 (defvar mime/find-file-function
  46   (if mime/use-multi-frame
  47       (function find-file-other-frame)
  48     (function find-file)
  49     ))
  50
  51
  52 ;;; @ constants
  53 ;;;
  54
  55 (defconst mime-echo-buffer-name "*MIME-echo*"
  56   "Name of buffer to display MIME-playing information.")
  57
  58 (defconst mime-temp-buffer-name " *MIME-temp*")
  59
  60
  61 ;;; @ button
  62 ;;;
  63
  64 (defcustom mime-button-face 'bold
  65   "Face used for content-button or URL-button of MIME-Preview buffer."
  66   :group 'mime
  67   :type 'face)
  68
  69 (defcustom mime-button-mouse-face 'highlight
  70   "Face used for MIME-preview buffer mouse highlighting."
  71   :group 'mime
  72   :type 'face)
  73
  74 (defsubst mime-insert-button (string function &optional data)
  75   "Insert STRING as button with callback FUNCTION and DATA."
  76   (save-restriction
  77     (narrow-to-region (point)(point))
  78     (widget-create 'push-button
  79                    :action `(lambda (widget &optional event)
  80                               (,function)
  81                               )
  82                    :mouse-down-action `(lambda (widget event)
  83                                          (let (buf point)
  84                                            (save-window-excursion
  85                                              (mouse-set-point event)
  86                                              (setq buf (current-buffer)
  87                                                    point (point)))
  88                                            (save-excursion
  89                                              (set-buffer buf)
  90                                              (goto-char point)
  91                                              (,function)
  92                                              )))
  93                    string)
  94     (insert "\n")
  95     ;;(mime-add-button (point-min)(point-max) function data)
  96     ))
  97
  98 (defvar mime-button-mother-dispatcher nil)
  99
 100 (defun mime-button-dispatcher (event)
 101   "Select the button under point."
 102   (interactive "e")
 103   (let (buf point func data)
 104     (save-window-excursion
 105       (mouse-set-point event)
 106       (setq buf (current-buffer)
 107             point (point)
 108             func (get-text-property (point) 'mime-button-callback)
 109             data (get-text-property (point) 'mime-button-data)
 110             )
 111       )
 112     (save-excursion
 113       (set-buffer buf)
 114       (goto-char point)
 115       (if func
 116           (apply func data)
 117         (if (fboundp mime-button-mother-dispatcher)
 118             (funcall mime-button-mother-dispatcher event)
 119           )
 120         ))))
 121
 122
 123 ;;; @ menu
 124 ;;;
 125
 126 (if window-system
 127     (if (featurep 'xemacs)
 128         (defun select-menu-alist (title menu-alist)
 129           (let (ret)
 130             (popup-menu
 131              (list* title
 132                     "---"
 133                     (mapcar (function
 134                              (lambda (cell)
 135                                (vector (car cell)
 136                                        `(progn
 137                                           (setq ret ',(cdr cell))
 138                                           (throw 'exit nil)
 139                                           )
 140                                        t)
 141                                ))
 142                             menu-alist)
 143                     ))
 144             (recursive-edit)
 145             ret))
 146       (defun select-menu-alist (title menu-alist)
 147         (x-popup-menu
 148          (list '(1 1) (selected-window))
 149          (list title (cons title menu-alist))
 150          ))
 151       )
 152   (defun select-menu-alist (title menu-alist)
 153     (cdr
 154      (assoc (completing-read (concat title " : ") menu-alist)
 155             menu-alist)
 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 ;;; @ field
 201 ;;;
 202
 203 (defun tm:set-fields (sym field-list &optional regexp-sym)
 204   (or regexp-sym
 205       (setq regexp-sym
 206             (let ((name (symbol-name sym)))
 207               (intern
 208                (concat (if (string-match "\\(.*\\)-list" name)
 209                            (substring name 0 (match-end 1))
 210                          name)
 211                        "-regexp")
 212                )))
 213       )
 214   (set sym field-list)
 215   (set regexp-sym
 216        (concat "^" (apply (function regexp-or) field-list) ":"))
 217   )
 218
 219 (defun tm:add-fields (sym field-list &optional regexp-sym)
 220   (or regexp-sym
 221       (setq regexp-sym
 222             (let ((name (symbol-name sym)))
 223               (intern
 224                (concat (if (string-match "\\(.*\\)-list" name)
 225                            (substring name 0 (match-end 1))
 226                          name)
 227                        "-regexp")
 228                )))
 229       )
 230   (let ((fields (eval sym)))
 231     (mapcar (function
 232              (lambda (field)
 233                (or (member field fields)
 234                    (setq fields (cons field fields))
 235                    )
 236                ))
 237             (reverse field-list)
 238             )
 239     (set regexp-sym
 240          (concat "^" (apply (function regexp-or) fields) ":"))
 241     (set sym fields)
 242     ))
 243
 244 (defun tm:delete-fields (sym field-list &optional regexp-sym)
 245   (or regexp-sym
 246       (setq regexp-sym
 247             (let ((name (symbol-name sym)))
 248               (intern
 249                (concat (if (string-match "\\(.*\\)-list" name)
 250                            (substring name 0 (match-end 1))
 251                          name)
 252                        "-regexp")
 253                )))
 254       )
 255   (let ((fields (eval sym)))
 256     (mapcar (function
 257              (lambda (field)
 258                (setq fields (delete field fields))
 259                ))
 260             field-list)
 261     (set regexp-sym
 262          (concat "^" (apply (function regexp-or) fields) ":"))
 263     (set sym fields)
 264     ))
 265
 266
 267 ;;; @ RCS version
 268 ;;;
 269
 270 (defsubst get-version-string (id)
 271   "Return a version-string from RCS ID."
 272   (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id)
 273        (substring id (match-beginning 1)(match-end 1))
 274        ))
 275
 276
 277 ;;; @ Other Utility
 278 ;;;
 279
 280 (defun call-after-loaded (module func &optional hook-name)
 281   "If MODULE is provided, then FUNC is called.
 282 Otherwise func is set to MODULE-load-hook.
 283 If optional argument HOOK-NAME is specified,
 284 it is used as hook to set."
 285   (if (featurep module)
 286       (funcall func)
 287     (or hook-name
 288         (setq hook-name (intern (concat (symbol-name module) "-load-hook")))
 289         )
 290     (add-hook hook-name func)
 291     ))
 292
 293
 294 ;;; @ end
 295 ;;;
 296
 297 (provide 'semi-def)
 298
 299 ;;; semi-def.el ends here