semi-def.el

   1 ;;; semi-def.el --- definition module for SEMI
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 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 (require 'poe)
  28 (eval-when-compile (require 'cl))
  29 (require 'custom)
  30
  31 (defconst mime-user-interface-product ["EMY" (1 13 6) "Life is balance"]
  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
  40 ;;; @ constants
  41 ;;;
  42
  43 (defconst mime-echo-buffer-name "*MIME-echo*"
  44   "Name of buffer to display MIME-playing information.")
  45
  46 (defconst mime-temp-buffer-name " *MIME-temp*")
  47
  48
  49 ;;; @ button
  50 ;;;
  51
  52 (defcustom mime-button-face 'bold
  53   "Face used for content-button or URL-button of MIME-Preview buffer."
  54   :group 'mime
  55   :type 'face)
  56
  57 (defcustom mime-button-mouse-face 'highlight
  58   "Face used for MIME-preview buffer mouse highlighting."
  59   :group 'mime
  60   :type 'face)
  61
  62 (defcustom mime-use-widget nil
  63   "If t, use widget to display buttons."
  64   :group 'mime
  65   :type 'boolean)
  66
  67 (defun mime-create-widget-button (string function)
  68   "Display STRING as a widget button with the callback FUNCTION.
  69 Under XEmacs, the function `mime-create-xpm-button' might be identical
  70 to the function `mime-create-widget-button' if the feature `xpm' is not
  71 provided or the TTY frame is used."
  72   (let ((start (point)))
  73     (widget-create
  74      'push-button
  75      :action `(lambda (widget &optional event) (,function))
  76      :mouse-down-action `(lambda (widget event)
  77                            (let (buf point)
  78                              (save-window-excursion
  79                                (mouse-set-point event)
  80                                (setq buf (current-buffer)
  81                                      point (point)))
  82                              (save-excursion
  83                                (set-buffer buf)
  84                                (goto-char point)
  85                                (,function))))
  86      string)
  87     ;; #### ???
  88 ;;    (static-when (featurep 'xemacs)
  89 ;;      (let ((end (point))
  90 ;;          extent)
  91 ;;      (insert "[" string "]")
  92 ;;      (while (setq extent (extent-at start nil nil extent))
  93 ;;        (set-extent-endpoints extent end (point)))
  94 ;;      (delete-region start end))))
  95     (add-text-properties start (point)
  96                          (list 'start-open t
  97                                'mime-button t)))
  98   (insert "\n"))
  99
 100 (static-when (featurep 'xemacs)
 101   (defcustom mime-xpm-button-shadow-thickness 3
 102     "A number of pixels should be used for the shadows on the edges of
 103 the buttons."
 104     :group 'mime
 105     :type 'integer)
 106
 107   (defcustom mime-xpm-button-foreground "Yellow"
 108     "A color used to display the text."
 109     :group 'mime
 110     :type 'string)
 111
 112   (defcustom mime-xpm-button-background "#a0a0d0"
 113     "A background color the text will be displayed upon."
 114     :group 'mime
 115     :type 'string)
 116
 117   (defvar mime-xpm-button-glyph-cache nil)
 118
 119   ;; #### device-on-widow-system-p must be checked at run-time.
 120   (if (and (featurep 'xpm) (device-on-window-system-p))
 121       (defun mime-create-xpm-button (string function)
 122         "Display STRING as a XPM button with the callback FUNCTION.
 123 It might be identical to the function `mime-create-widget-button'
 124 if the feature `xpm' is not provided or the TTY frame is used."
 125         (set-extent-properties (make-extent (point)
 126                                             (progn
 127                                               (insert "[" string "]")
 128                                               (point)))
 129                                '(invisible t intangible t))
 130         (let* ((spec (list string
 131                            mime-xpm-button-shadow-thickness
 132                            mime-xpm-button-foreground
 133                            mime-xpm-button-background))
 134                (button (cdr (assoc spec mime-xpm-button-glyph-cache))))
 135           (or button
 136               (set-alist 'mime-xpm-button-glyph-cache spec
 137                          (setq button (apply (function xpm-button-create)
 138                                              spec))))
 139           (let* ((extent (make-extent (point) (point)))
 140                  (down-glyph (make-glyph (car (cdr button))))
 141                  (up-glyph (make-glyph (car button)))
 142                  (down-func `(lambda (event)
 143                                (interactive "e")
 144                                (set-extent-begin-glyph ,extent ,down-glyph)))
 145                  (up-func `(lambda (event)
 146                              (interactive "e")
 147                              (mouse-set-point event)
 148                              (set-extent-begin-glyph ,extent ,up-glyph)
 149                              (,function)))
 150                  (keymap (make-sparse-keymap)))
 151             (define-key keymap 'button1 down-func)
 152             (define-key keymap 'button2 down-func)
 153             (define-key keymap 'button1up up-func)
 154             (define-key keymap 'button2up up-func)
 155             (set-extent-begin-glyph extent up-glyph)
 156             (set-extent-property extent 'keymap keymap))
 157           (insert "\n")))
 158     (fset 'mime-create-xpm-button 'mime-create-widget-button)))
 159
 160 (defcustom mime-create-button-function 'mime-create-widget-button
 161   "A function called to create the content button."
 162   :group 'mime
 163   :type (list
 164          'cons
 165          :convert-widget
 166          (function
 167           (lambda (widget)
 168             (list
 169              'radio
 170              :args
 171              (append
 172               '((const :tag "Widget button" mime-create-widget-button))
 173               (static-when (featurep 'xemacs)
 174                 '((const :tag "Xpm button" mime-create-xpm-button)))
 175               '((function :tag "Other"))))))))
 176
 177 (defsubst mime-add-button (from to function &optional data)
 178   "Create a button between FROM and TO with callback FUNCTION and DATA."
 179   (and mime-button-face
 180        (put-text-property from to 'face mime-button-face))
 181   (and mime-button-mouse-face
 182        (put-text-property from to 'mouse-face mime-button-mouse-face))
 183   (add-text-properties from to (list 'mime-button-callback function
 184                                      'start-open t
 185                                      'mime-button t))
 186   (and data
 187        (add-text-properties from to (list 'mime-button-data data))))
 188
 189 (defsubst mime-insert-button (string function &optional data)
 190   "Insert STRING as button with callback FUNCTION and DATA."
 191   (unless (bolp)
 192     (insert "\n"))
 193   (save-restriction
 194     (narrow-to-region (point) (point))
 195     (if mime-use-widget
 196         (mapcar (function
 197                  (lambda (line)
 198                    (funcall mime-create-button-function line function)))
 199                 (split-string string "\n"))
 200       (progn
 201         ;; One more newline to avoid concatenation of face property.
 202         (insert (concat "[" string "]\n\n"))
 203         (mime-add-button (point-min) (1- (point-max)) function data)
 204         (delete-char -1)))))
 205
 206 (defvar mime-button-mother-dispatcher nil)
 207
 208 (defun mime-button-dispatcher (event)
 209   "Select the button under point."
 210   (interactive "e")
 211   (let (buf point func data)
 212     (save-window-excursion
 213       (mouse-set-point event)
 214       (setq buf (current-buffer)
 215             point (point)
 216             func (get-text-property (point) 'mime-button-callback)
 217             data (get-text-property (point) 'mime-button-data)))
 218     (save-excursion
 219       (set-buffer buf)
 220       (goto-char point)
 221       (if func
 222           (apply func data)
 223         (if (fboundp mime-button-mother-dispatcher)
 224             (funcall mime-button-mother-dispatcher event))))))
 225
 226
 227 ;;; @ for URL
 228 ;;;
 229
 230 (defcustom mime-browse-url-regexp
 231   (concat "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):"
 232           "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
 233           "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
 234   "*Regexp to match URL in text body."
 235   :group 'mime
 236   :type 'regexp)
 237
 238 (defcustom mime-browse-url-function (function browse-url)
 239   "*Function to browse URL."
 240   :group 'mime
 241   :type 'function)
 242
 243 (defsubst mime-add-url-buttons ()
 244   "Add URL-buttons for text body."
 245   (goto-char (point-min))
 246   (while (re-search-forward mime-browse-url-regexp nil t)
 247     (let ((beg (match-beginning 0))
 248           (end (match-end 0)))
 249       (if mime-use-widget
 250           (progn
 251             (widget-convert-button 'mime-url-link beg end
 252                                    (buffer-substring beg end))
 253             (static-unless (featurep 'xemacs)
 254               (overlay-put (make-overlay beg end) 'local-map widget-keymap)))
 255         (mime-add-button beg end mime-browse-url-function
 256                          (list (buffer-substring beg end)))))))
 257
 258 (define-widget 'mime-url-link 'link
 259   "A link to an www page."
 260   :help-echo 'widget-url-link-help-echo
 261   :action 'widget-mime-url-link-action)
 262
 263 (defun widget-mime-url-link-action (widget &optional event)
 264   "Open the url specified by WIDGET."
 265   (funcall mime-browse-url-function (widget-value widget)))
 266
 267
 268 ;;; @ menu
 269 ;;;
 270
 271 (if window-system
 272     (if (featurep 'xemacs)
 273         (defun select-menu-alist (title menu-alist)
 274           (let (ret)
 275             (popup-menu
 276              (list* title
 277                     "---"
 278                     (mapcar (function
 279                              (lambda (cell)
 280                                (vector (car cell)
 281                                        `(progn
 282                                           (setq ret ',(cdr cell))
 283                                           (throw 'exit nil))
 284                                        t)))
 285                             menu-alist)))
 286             (recursive-edit)
 287             ret))
 288       (defun select-menu-alist (title menu-alist)
 289         (x-popup-menu
 290          (list '(1 1) (selected-window))
 291          (list title (cons title menu-alist)))))
 292   (defun select-menu-alist (title menu-alist)
 293     (cdr
 294      (assoc (completing-read (concat title " : ") menu-alist)
 295             menu-alist))))
 296
 297
 298 ;;; @ Other Utility
 299 ;;;
 300
 301 (defvar mime-condition-type-alist
 302   '((preview . mime-preview-condition)
 303     (action . mime-acting-condition)))
 304
 305 (defvar mime-condition-mode-alist
 306   '((with-default . ctree-set-calist-with-default)
 307     (t . ctree-set-calist-strictly)))
 308
 309 (defun mime-add-condition (target-type condition &optional mode file)
 310   "Add CONDITION to database specified by TARGET-TYPE.
 311 TARGET-TYPE must be 'preview or 'action.
 312 If optional argument MODE is 'strict or nil (omitted), CONDITION is
 313 added strictly.
 314 If optional argument MODE is 'with-default, CONDITION is added with
 315 default rule.
 316 If optional argument FILE is specified, it is loaded when CONDITION is
 317 activate."
 318   (let ((sym (cdr (assq target-type mime-condition-type-alist))))
 319     (if sym
 320         (let ((func (cdr (or (assq mode mime-condition-mode-alist)
 321                              (assq t mime-condition-mode-alist)))))
 322           (if (fboundp func)
 323               (progn
 324                 (funcall func sym condition)
 325                 (if file
 326                     (let ((method (cdr (assq 'method condition))))
 327                       (autoload method file))))
 328             (error "Function for mode `%s' is not found." mode)))
 329       (error "Variable for target-type `%s' is not found." target-type))))
 330
 331
 332 ;;; @ end
 333 ;;;
 334
 335 (provide 'semi-def)
 336
 337 ;;; semi-def.el ends here