1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
;;; semi-def.el --- definition module for SEMI -*- coding: iso-8859-4; -*-
;; Copyright (C) 1995,96,97,98,99,2000,01,03 Free Software Foundation, Inc.
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Keywords: definition, MIME, multimedia, mail, news
;; This file is part of SEMI (Sample of Emacs MIME Implementation).
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Code:
(eval-when-compile (require 'cl))
(require 'custom)
(defconst mime-user-interface-product ["SEMI" (1 14 6) "Maruoka"]
"Product name, version number and code name of MIME-kernel package.")
(autoload 'mule-caesar-region "mule-caesar"
"Caesar rotation of current region." t)
;;; @ constants
;;;
(defconst mime-echo-buffer-name "*MIME-echo*"
"Name of buffer to display MIME-playing information.")
(defconst mime-temp-buffer-name " *MIME-temp*")
;;; @ button
;;;
(defcustom mime-button-face 'bold
"Face used for content-button or URL-button of MIME-Preview buffer."
:group 'mime
:type 'face)
(defcustom mime-button-mouse-face 'highlight
"Face used for MIME-preview buffer mouse highlighting."
:group 'mime
:type 'face)
(defsubst mime-add-button (from to function &optional data)
"Create a button between FROM and TO with callback FUNCTION and DATA."
(and mime-button-face
(put-text-property from to 'face mime-button-face))
(and mime-button-mouse-face
(put-text-property from to 'mouse-face mime-button-mouse-face))
(put-text-property from to 'mime-button-callback function)
(and data
(put-text-property from to 'mime-button-data data))
)
(defsubst mime-insert-button (string function &optional data)
"Insert STRING as button with callback FUNCTION and DATA."
(save-restriction
(narrow-to-region (point)(point))
(insert (concat "[" string "]\n"))
(mime-add-button (point-min)(point-max) function data)
))
(defvar mime-button-mother-dispatcher nil)
(defun mime-button-dispatcher (event)
"Select the button under point."
(interactive "e")
(let (buf point func data)
(save-window-excursion
(mouse-set-point event)
(setq buf (current-buffer)
point (point)
func (get-text-property (point) 'mime-button-callback)
data (get-text-property (point) 'mime-button-data)
))
(save-excursion
(set-buffer buf)
(goto-char point)
(if func
(apply func data)
(if (fboundp mime-button-mother-dispatcher)
(funcall mime-button-mother-dispatcher event)
)))))
;;; @ for URL
;;;
(defcustom mime-browse-url-regexp
(concat "\\(https?\\|ftps?\\|file\\|gopher\\|news\\|nntps?\\|telnets?\\|wais\\|mailto\\):"
"\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
"[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
"*Regexp to match URL in text body."
:group 'mime
:type 'regexp)
(defcustom mime-browse-url-function (function browse-url)
"*Function to browse URL."
:group 'mime
:type 'function)
(defsubst mime-add-url-buttons ()
"Add URL-buttons for text body."
(goto-char (point-min))
(while (re-search-forward mime-browse-url-regexp nil t)
(let ((beg (match-beginning 0))
(end (match-end 0)))
(mime-add-button beg end mime-browse-url-function
(list (buffer-substring beg end))))))
;;; @ menu
;;;
(static-cond ((featurep 'xemacs)
(defun mime-should-use-popup-menu ()
(and window-system
(mouse-event-p last-command-event)))
(defun mime-select-menu-alist (title menu-alist)
(if (mime-should-use-popup-menu)
(let (ret)
(popup-menu
(list* title
"---"
(mapcar (function
(lambda (cell)
(vector (car cell)
`(progn
(setq ret ',(cdr cell))
(throw 'exit nil))
t)))
menu-alist)))
(recursive-edit)
ret)
(cdr
(assoc (completing-read (concat title " : ") menu-alist)
menu-alist)))))
(t
(defun mime-should-use-popup-menu ()
(and window-system
(memq (event-basic-type last-command-event)
'(mouse-1 mouse-2 mouse-3))))
(defun mime-select-menu-alist (title menu-alist)
(if (mime-should-use-popup-menu)
(x-popup-menu
(list '(1 1) (selected-window))
(list title (cons title menu-alist)))
(cdr
(assoc (completing-read (concat title " : ") menu-alist)
menu-alist))))))
;;; @ Other Utility
;;;
(defvar mime-condition-type-alist
'((preview . mime-preview-condition)
(action . mime-acting-condition)))
(defvar mime-condition-mode-alist
'((with-default . ctree-set-calist-with-default)
(t . ctree-set-calist-strictly)))
(defun mime-add-condition (target-type condition &optional mode file)
"Add CONDITION to database specified by TARGET-TYPE.
TARGET-TYPE must be 'preview or 'action.
If optional argument MODE is 'strict or nil (omitted), CONDITION is
added strictly.
If optional argument MODE is 'with-default, CONDITION is added with
default rule.
If optional argument FILE is specified, it is loaded when CONDITION is
activate."
(let ((sym (cdr (assq target-type mime-condition-type-alist))))
(if sym
(let ((func (cdr (or (assq mode mime-condition-mode-alist)
(assq t mime-condition-mode-alist)))))
(if (fboundp func)
(progn
(funcall func sym condition)
(if file
(let ((method (cdr (assq 'method condition))))
(autoload method file)
))
)
(error "Function for mode `%s' is not found." mode)
))
(error "Variable for target-type `%s' is not found." target-type)
)))
;;; @ end
;;;
(provide 'semi-def)
;;; semi-def.el ends here
|
