semi-def.el

   1 ;;; semi-def.el --- definition module for SEMI -*- coding: iso-8859-4; -*-
   2
   3 ;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;; Keywords: definition, MIME, multimedia, mail, news
   7
   8 ;; This file is part of SEMI (Sample of Emacs MIME Implementation).
   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 (eval-when-compile (require 'cl))
  28
  29 (require 'custom)
  30
  31 (defconst mime-user-interface-product ["EMIKO" (1 14 1) "Choanoflagellata"]
  32   "Product name, version number and code name of MIME-kernel package.")
  33
  34 (autoload 'mule-caesar-region "mule-caesar"
  35   "Caesar rotation of current region." t)
  36
  37 (autoload 'widget-convert-button "wid-edit")
  38
  39 ;;; @ constants
  40 ;;;
  41
  42 (defconst mime-echo-buffer-name "*MIME-echo*"
  43   "Name of buffer to display MIME-playing information.")
  44
  45 (defconst mime-temp-buffer-name " *MIME-temp*")
  46
  47
  48 ;;; @ button
  49 ;;;
  50
  51 (define-widget 'mime-button 'link
  52   "Widget for MIME button."
  53   :action 'mime-button-action)
  54
  55 (defun mime-button-action (widget &optional event)
  56   (let ((function (widget-get widget :mime-button-callback))
  57         (data (widget-get widget :mime-button-data)))
  58     (when function
  59       (funcall function data))))
  60
  61 (defsubst mime-insert-button (string function &optional data)
  62   "Insert STRING as button with callback FUNCTION and DATA."
  63   (save-restriction
  64     (narrow-to-region (point)(point))
  65     ;; Maybe we should introduce button formatter such as
  66     ;; `gnus-mime-button-line-format'.
  67     (insert "[" string "]")
  68     ;; XEmacs -- when `widget-glyph-enable' is non nil, widget values are not
  69     ;; guaranteed to be underlain.
  70     (widget-convert-button 'mime-button (point-min)(point-max)
  71                            :mime-button-callback function
  72                            :mime-button-data data)
  73     (insert "\n")))
  74
  75
  76 ;;; @ for URL
  77 ;;;
  78
  79 (defcustom mime-browse-url-regexp
  80   (concat "\\(https?\\|ftps?\\|file\\|gopher\\|news\\|nntps?\\|telnets?\\|wais\\|mailto\\):"
  81           "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
  82           "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,;]*[-a-zA-Z0-9_=#$@~`%&*+|\\/;]")
  83   "Regexp to match URL in text body."
  84   :group 'mime
  85   :type 'regexp)
  86
  87 (defcustom mime-browse-url-function (function browse-url)
  88   "Function to browse URL."
  89   :group 'mime
  90   :type 'function)
  91
  92 (define-widget 'mime-url-link 'url-link
  93   "A link to an www page.")
  94
  95 (defsubst mime-add-url-buttons ()
  96   "Add URL-buttons for text body."
  97   (goto-char (point-min))
  98   (while (re-search-forward mime-browse-url-regexp nil t)
  99     (widget-convert-button 'mime-url-link (match-beginning 0)(match-end 0)
 100                            (match-string-no-properties 0))))
 101
 102
 103 ;;; @ menu
 104 ;;;
 105
 106 (defmacro mime-popup-menu-bogus-filter-constructor (menu)
 107   ;; #### Kludge for FSF Emacs-style menu.
 108   (let ((bogus-menu (make-symbol "bogus-menu")))
 109     `(let (,bogus-menu selection function)
 110        (easy-menu-define ,bogus-menu nil nil ,menu)
 111        (setq selection (x-popup-menu t ,bogus-menu))
 112        (when selection
 113          (setq function (lookup-key ,bogus-menu (apply #'vector selection)))
 114          ;; If a callback entry has no name, easy-menu wraps its value.
 115          ;; See `easy-menu-make-symbol'.
 116          (if (eq t (compare-strings "menu-function-" 0 nil
 117                                     (symbol-name function) 0 14))
 118              (car (last (symbol-function function)))
 119            function)))))
 120
 121 ;;; While XEmacs can have both X and tty frames at the same time with
 122 ;;; gnuclient, we shouldn't emulate in text-mode here.
 123
 124 (static-if (featurep 'xemacs)
 125     (defalias 'mime-popup-menu-popup 'popup-menu)
 126   (defun mime-popup-menu-popup (menu &optional event)
 127     (let ((function (mime-popup-menu-bogus-filter-constructor menu)))
 128       (when (symbolp function)
 129         (funcall function)))))
 130
 131 (static-if (featurep 'xemacs)
 132     (defun mime-popup-menu-select (menu &optional event)
 133       (let ((selection (get-popup-menu-response menu event)))
 134         (event-object selection)))
 135   (defun mime-popup-menu-select (menu &optional event)
 136     (mime-popup-menu-bogus-filter-constructor menu)))
 137
 138 (static-if (featurep 'xemacs)
 139     (defun mime-should-use-popup-menu ()
 140       (mouse-event-p last-command-event))
 141   (defun mime-should-use-popup-menu ()
 142     (memq 'click (event-modifiers last-command-event))))
 143
 144 (defun mime-menu-select (prompt menu &optional event)
 145   (if (mime-should-use-popup-menu)
 146       (mime-popup-menu-select menu event)
 147     (let ((rest (cdr menu)))
 148       (while rest
 149         (setcar rest (append (car rest) nil))
 150         (setq rest (cdr rest)))
 151       (nth 1 (assoc (completing-read prompt (cdr menu)) (cdr menu))))))
 152
 153
 154 ;;; @ Other Utility
 155 ;;;
 156
 157 (defvar mime-condition-type-alist
 158   '((preview . mime-preview-condition)
 159     (action . mime-acting-condition)))
 160
 161 (defvar mime-condition-mode-alist
 162   '((with-default . ctree-set-calist-with-default)
 163     (t . ctree-set-calist-strictly)))
 164
 165 (defun mime-add-condition (target-type condition &optional mode file)
 166   "Add CONDITION to database specified by TARGET-TYPE.
 167 TARGET-TYPE must be 'preview or 'action.
 168 If optional argument MODE is 'strict or nil (omitted), CONDITION is
 169 added strictly.
 170 If optional argument MODE is 'with-default, CONDITION is added with
 171 default rule.
 172 If optional argument FILE is specified, it is loaded when CONDITION is
 173 activate."
 174   (let ((sym (cdr (assq target-type mime-condition-type-alist))))
 175     (if sym
 176         (let ((func (cdr (or (assq mode mime-condition-mode-alist)
 177                              (assq t mime-condition-mode-alist)))))
 178           (if (fboundp func)
 179               (progn
 180                 (funcall func sym condition)
 181                 (if file
 182                     (let ((method (cdr (assq 'method condition))))
 183                       (autoload method file))))
 184             (error "Function for mode `%s' is not found." mode)))
 185       (error "Variable for target-type `%s' is not found." target-type))))
 186
 187
 188 ;;; @ end
 189 ;;;
 190
 191 (provide 'semi-def)
 192
 193 ;;; semi-def.el ends here