Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-ew-e.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs
2
3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Version: $Revision: 1.1.1.1 $
7 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
8
9 ;; This file is part of tm (Tools for MIME).
10
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
15
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Code:
27
28 (require 'mel)
29 (require 'std11)
30 (require 'tm-def)
31 (require 'tl-list)
32
33
34 ;;; @ version
35 ;;;
36
37 (defconst tm-ew-e/RCS-ID
38 "$Id: tm-ew-e.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $")
39 (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID))
40
41
42 ;;; @ variables
43 ;;;
44
45 (defvar mime/field-encoding-method-alist
46 (if (boundp 'mime/no-encoding-header-fields)
47 (nconc
48 (mapcar (function
49 (lambda (field-name)
50 (cons field-name 'default-mime-charset)
51 ))
52 mime/no-encoding-header-fields)
53 '((t . mime))
54 )
55 '(("X-Nsubject" . iso-2022-jp-2)
56 ("Newsgroups" . nil)
57 (t . mime)
58 ))
59 "*Alist to specify field encoding method.
60 Its key is field-name, value is encoding method.
61
62 If method is `mime', this field will be encoded into MIME format.
63
64 If method is a MIME-charset, this field will be encoded as the charset
65 when it must be convert into network-code.
66
67 If method is `default-mime-charset', this field will be encoded as
68 variable `default-mime-charset' when it must be convert into
69 network-code.
70
71 If method is nil, this field will not be encoded. [tm-ew-e.el]")
72
73 (defvar mime/generate-X-Nsubject
74 (and (boundp 'mime/use-X-Nsubject)
75 mime/use-X-Nsubject)
76 "*If it is not nil, X-Nsubject field is generated
77 when Subject field is encoded by `mime/encode-message-header'.
78 \[tm-ew-e.el]")
79
80 (defvar mime-eword/charset-encoding-alist
81 '((us-ascii . nil)
82 (iso-8859-1 . "Q")
83 (iso-8859-2 . "Q")
84 (iso-8859-3 . "Q")
85 (iso-8859-4 . "Q")
86 (iso-8859-5 . "Q")
87 (koi8-r . "Q")
88 (iso-8859-7 . "Q")
89 (iso-8859-8 . "Q")
90 (iso-8859-9 . "Q")
91 (iso-2022-jp . "B")
92 (iso-2022-kr . "B")
93 (euc-kr . "B")
94 (iso-2022-jp-2 . "B")
95 (iso-2022-int-1 . "B")
96 ))
97
98 ;;; @ encoded-text encoder
99 ;;;
100
101 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
102 (let ((text
103 (cond ((string= encoding "B")
104 (base64-encode-string string))
105 ((string= encoding "Q")
106 (q-encoding-encode-string string mode))
107 )
108 ))
109 (if text
110 (concat "=?" (upcase (symbol-name charset)) "?"
111 encoding "?" text "?=")
112 )))
113
114
115 ;;; @ leading char
116 ;;;
117
118 (defun tm-eword::char-type (chr)
119 (if (or (= chr 32)(= chr ?\t))
120 nil
121 (char-charset chr)
122 ))
123
124 (defun tm-eword::parse-lc-word (str)
125 (let* ((chr (sref str 0))
126 (lc (tm-eword::char-type chr))
127 (i (char-length chr))
128 (len (length str))
129 )
130 (while (and (< i len)
131 (setq chr (sref str i))
132 (eq lc (tm-eword::char-type chr))
133 )
134 (setq i (+ i (char-length chr)))
135 )
136 (cons (cons lc (substring str 0 i)) (substring str i))
137 ))
138
139 (defun tm-eword::split-to-lc-words (str)
140 (let (ret dest)
141 (while (and (not (string= str ""))
142 (setq ret (tm-eword::parse-lc-word str))
143 )
144 (setq dest (cons (car ret) dest))
145 (setq str (cdr ret))
146 )
147 (reverse dest)
148 ))
149
150
151 ;;; @ word
152 ;;;
153
154 (defun tm-eword::parse-word (lcwl)
155 (let* ((lcw (car lcwl))
156 (lc (car lcw))
157 )
158 (if (null lc)
159 lcwl
160 (let ((lcl (list lc))
161 (str (cdr lcw))
162 )
163 (catch 'tag
164 (while (setq lcwl (cdr lcwl))
165 (setq lcw (car lcwl))
166 (setq lc (car lcw))
167 (if (null lc)
168 (throw 'tag nil)
169 )
170 (if (not (memq lc lcl))
171 (setq lcl (cons lc lcl))
172 )
173 (setq str (concat str (cdr lcw)))
174 ))
175 (cons (cons lcl str) lcwl)
176 ))))
177
178 (defun tm-eword::lc-words-to-words (lcwl)
179 (let (ret dest)
180 (while (setq ret (tm-eword::parse-word lcwl))
181 (setq dest (cons (car ret) dest))
182 (setq lcwl (cdr ret))
183 )
184 (reverse dest)
185 ))
186
187
188 ;;; @ rule
189 ;;;
190
191 (defmacro tm-eword::make-rword (text charset encoding type)
192 (` (list (, text)(, charset)(, encoding)(, type))))
193 (defmacro tm-eword::rword-text (rword)
194 (` (car (, rword))))
195 (defmacro tm-eword::rword-charset (rword)
196 (` (car (cdr (, rword)))))
197 (defmacro tm-eword::rword-encoding (rword)
198 (` (car (cdr (cdr (, rword))))))
199 (defmacro tm-eword::rword-type (rword)
200 (` (car (cdr (cdr (cdr (, rword)))))))
201
202 (defun tm-eword::find-charset-rule (charsets)
203 (if charsets
204 (let* ((charset (charsets-to-mime-charset charsets))
205 (encoding (cdr (assq charset mime-eword/charset-encoding-alist)))
206 )
207 (list charset encoding)
208 )))
209
210 (defun tm-eword::words-to-ruled-words (wl &optional mode)
211 (mapcar (function
212 (lambda (word)
213 (let ((ret (tm-eword::find-charset-rule (car word))))
214 (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
215 )))
216 wl))
217
218 (defun tm-eword::space-process (seq)
219 (let (prev a ac b c cc)
220 (while seq
221 (setq b (car seq))
222 (setq seq (cdr seq))
223 (setq c (car seq))
224 (setq cc (tm-eword::rword-charset c))
225 (if (null (tm-eword::rword-charset b))
226 (progn
227 (setq a (car prev))
228 (setq ac (tm-eword::rword-charset a))
229 (if (and (tm-eword::rword-encoding a)
230 (tm-eword::rword-encoding c))
231 (cond ((eq ac cc)
232 (setq prev (cons
233 (cons (concat (car a)(car b)(car c))
234 (cdr a))
235 (cdr prev)
236 ))
237 (setq seq (cdr seq))
238 )
239 (t
240 (setq prev (cons
241 (cons (concat (car a)(car b))
242 (cdr a))
243 (cdr prev)
244 ))
245 ))
246 (setq prev (cons b prev))
247 ))
248 (setq prev (cons b prev))
249 ))
250 (reverse prev)
251 ))
252
253 (defun tm-eword::split-string (str &optional mode)
254 (tm-eword::space-process
255 (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words
256 (tm-eword::split-to-lc-words str))
257 mode)))
258
259
260 ;;; @ length
261 ;;;
262
263 (defun tm-eword::encoded-word-length (rword)
264 (let ((string (tm-eword::rword-text rword))
265 (charset (tm-eword::rword-charset rword))
266 (encoding (tm-eword::rword-encoding rword))
267 ret)
268 (setq ret
269 (cond ((string-equal encoding "B")
270 (setq string (encode-mime-charset-string string charset))
271 (base64-encoded-length string)
272 )
273 ((string-equal encoding "Q")
274 (setq string (encode-mime-charset-string string charset))
275 (q-encoding-encoded-length string
276 (tm-eword::rword-type rword))
277 )))
278 (if ret
279 (cons (+ 7 (length (symbol-name charset)) ret) string)
280 )))
281
282
283 ;;; @ encode-string
284 ;;;
285
286 (defun tm-eword::encode-string-1 (column rwl)
287 (let* ((rword (car rwl))
288 (ret (tm-eword::encoded-word-length rword))
289 string len)
290 (if (null ret)
291 (cond ((and (setq string (car rword))
292 (<= (setq len (+ (length string) column)) 76)
293 )
294 (setq rwl (cdr rwl))
295 )
296 (t
297 (setq string "\n ")
298 (setq len 1)
299 ))
300 (cond ((and (setq len (car ret))
301 (<= (+ column len) 76)
302 )
303 (setq string
304 (tm-eword::encode-encoded-text
305 (tm-eword::rword-charset rword)
306 (tm-eword::rword-encoding rword)
307 (cdr ret)
308 (tm-eword::rword-type rword)
309 ))
310 (setq len (+ (length string) column))
311 (setq rwl (cdr rwl))
312 )
313 (t
314 (setq string (car rword))
315 (let* ((sl (length string))
316 (p 0) np
317 (str "") nstr)
318 (while (and (< p len)
319 (progn
320 (setq np (+ p (char-length (sref string p))))
321 (setq nstr (substring string 0 np))
322 (setq ret (tm-eword::encoded-word-length
323 (cons nstr (cdr rword))
324 ))
325 (setq nstr (cdr ret))
326 (setq len (+ (car ret) column))
327 (<= len 76)
328 ))
329 (setq str nstr
330 p np))
331 (if (string-equal str "")
332 (setq string "\n "
333 len 1)
334 (setq rwl (cons (cons (substring string p) (cdr rword))
335 (cdr rwl)))
336 (setq string
337 (tm-eword::encode-encoded-text
338 (tm-eword::rword-charset rword)
339 (tm-eword::rword-encoding rword)
340 str
341 (tm-eword::rword-type rword)))
342 (setq len (+ (length string) column))
343 )
344 )))
345 )
346 (list string len rwl)
347 ))
348
349 (defun tm-eword::encode-rwl (column rwl)
350 (let (ret dest ps special str ew-f pew-f)
351 (while rwl
352 (setq ew-f (nth 2 (car rwl)))
353 (if (and pew-f ew-f)
354 (setq rwl (cons '(" ") rwl)
355 pew-f nil)
356 (setq pew-f ew-f)
357 )
358 (setq ret (tm-eword::encode-string-1 column rwl))
359 (setq str (car ret))
360 (if (eq (elt str 0) ?\n)
361 (if (eq special ?\()
362 (progn
363 (setq dest (concat dest "\n ("))
364 (setq ret (tm-eword::encode-string-1 2 rwl))
365 (setq str (car ret))
366 ))
367 (cond ((eq special 32)
368 (if (string= str "(")
369 (setq ps t)
370 (setq dest (concat dest " "))
371 (setq ps nil)
372 ))
373 ((eq special ?\()
374 (if ps
375 (progn
376 (setq dest (concat dest " ("))
377 (setq ps nil)
378 )
379 (setq dest (concat dest "("))
380 )
381 )))
382 (cond ((string= str " ")
383 (setq special 32)
384 )
385 ((string= str "(")
386 (setq special ?\()
387 )
388 (t
389 (setq special nil)
390 (setq dest (concat dest str))
391 ))
392 (setq column (nth 1 ret)
393 rwl (nth 2 ret))
394 )
395 (list dest column)
396 ))
397
398 (defun tm-eword::encode-string (column str &optional mode)
399 (tm-eword::encode-rwl column (tm-eword::split-string str mode))
400 )
401
402
403 ;;; @ converter
404 ;;;
405
406 (defun tm-eword::phrase-to-rwl (phrase)
407 (let (token type dest str)
408 (while phrase
409 (setq token (car phrase))
410 (setq type (car token))
411 (cond ((eq type 'quoted-string)
412 (setq str (concat "\"" (cdr token) "\""))
413 (setq dest
414 (append dest
415 (list
416 (let ((ret (tm-eword::find-charset-rule
417 (find-non-ascii-charset-string str))))
418 (tm-eword::make-rword
419 str (car ret)(nth 1 ret) 'phrase)
420 )
421 )))
422 )
423 ((eq type 'comment)
424 (setq dest
425 (append dest
426 '(("(" nil nil))
427 (tm-eword::words-to-ruled-words
428 (tm-eword::lc-words-to-words
429 (tm-eword::split-to-lc-words (cdr token)))
430 'comment)
431 '((")" nil nil))
432 ))
433 )
434 (t
435 (setq dest (append dest
436 (tm-eword::words-to-ruled-words
437 (tm-eword::lc-words-to-words
438 (tm-eword::split-to-lc-words (cdr token))
439 ) 'phrase)))
440 ))
441 (setq phrase (cdr phrase))
442 )
443 (tm-eword::space-process dest)
444 ))
445
446 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
447 (if (eq (car phrase-route-addr) 'phrase-route-addr)
448 (let ((phrase (nth 1 phrase-route-addr))
449 (route (nth 2 phrase-route-addr))
450 dest)
451 (if (eq (car (car phrase)) 'spaces)
452 (setq phrase (cdr phrase))
453 )
454 (setq dest (tm-eword::phrase-to-rwl phrase))
455 (if dest
456 (setq dest (append dest '((" " nil nil))))
457 )
458 (append
459 dest
460 (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
461 ))))
462
463 (defun tm-eword::addr-spec-to-rwl (addr-spec)
464 (if (eq (car addr-spec) 'addr-spec)
465 (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
466 ))
467
468 (defun tm-eword::mailbox-to-rwl (mbox)
469 (let ((addr (nth 1 mbox))
470 (comment (nth 2 mbox))
471 dest)
472 (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
473 (tm-eword::addr-spec-to-rwl addr)
474 ))
475 (if comment
476 (setq dest
477 (append dest
478 '((" " nil nil)
479 ("(" nil nil))
480 (tm-eword::split-string comment 'comment)
481 '((")" nil nil))
482 )))
483 dest))
484
485 (defun tm-eword::addresses-to-rwl (addresses)
486 (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
487 (if dest
488 (while (setq addresses (cdr addresses))
489 (setq dest (append dest
490 '(("," nil nil))
491 '((" " nil nil))
492 (tm-eword::mailbox-to-rwl (car addresses))
493 ))
494 ))
495 dest))
496
497 (defun tm-eword::encode-address-list (column str)
498 (tm-eword::encode-rwl
499 column
500 (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
501 ))
502
503
504 ;;; @ application interfaces
505 ;;;
506
507 (defun mime/encode-field (str)
508 (setq str (std11-unfold-string str))
509 (let ((ret (string-match std11-field-head-regexp str)))
510 (or (if ret
511 (let ((field-name (substring str 0 (1- (match-end 0))))
512 (field-body (eliminate-top-spaces
513 (substring str (match-end 0))))
514 fname)
515 (if (setq ret
516 (cond ((string-equal field-body "") "")
517 ((member (setq fname (downcase field-name))
518 '("reply-to" "from" "sender"
519 "resent-reply-to" "resent-from"
520 "resent-sender" "to" "resent-to"
521 "cc" "resent-cc"
522 "bcc" "resent-bcc" "dcc")
523 )
524 (car (tm-eword::encode-address-list
525 (+ (length field-name) 2) field-body))
526 )
527 (t
528 (car (tm-eword::encode-string
529 (+ (length field-name) 1)
530 field-body 'text))
531 ))
532 )
533 (concat field-name ": " ret)
534 )))
535 (car (tm-eword::encode-string 0 str))
536 )))
537
538 (defun mime/exist-encoded-word-in-subject ()
539 (let ((str (std11-field-body "Subject")))
540 (if (and str (string-match mime/encoded-word-regexp str))
541 str)))
542
543 (defun mime/encode-message-header (&optional code-conversion)
544 (interactive "*")
545 (save-excursion
546 (save-restriction
547 (std11-narrow-to-header mail-header-separator)
548 (goto-char (point-min))
549 (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
550 beg end field-name)
551 (while (re-search-forward std11-field-head-regexp nil t)
552 (setq beg (match-beginning 0))
553 (setq field-name (buffer-substring beg (1- (match-end 0))))
554 (setq end (std11-field-end))
555 (and (find-non-ascii-charset-region beg end)
556 (let ((ret (or (ASSOC (downcase field-name)
557 mime/field-encoding-method-alist
558 :test (function
559 (lambda (str1 str2)
560 (and (stringp str2)
561 (string= str1
562 (downcase str2))
563 ))))
564 (assq t mime/field-encoding-method-alist)
565 )))
566 (if ret
567 (let ((method (cdr ret)))
568 (cond ((eq method 'mime)
569 (let ((field
570 (buffer-substring-no-properties beg end)
571 ))
572 (delete-region beg end)
573 (insert (mime/encode-field field))
574 ))
575 (code-conversion
576 (let ((cs
577 (or (mime-charset-to-coding-system
578 method)
579 default-cs)))
580 (encode-coding-region beg end cs)
581 )))
582 ))
583 ))
584 ))
585 (and mime/generate-X-Nsubject
586 (or (std11-field-body "X-Nsubject")
587 (let ((str (mime/exist-encoded-word-in-subject)))
588 (if str
589 (progn
590 (setq str
591 (mime-eword/decode-string
592 (std11-unfold-string str)))
593 (if code-conversion
594 (setq str
595 (encode-mime-charset-string
596 str
597 (or (cdr (ASSOC
598 "x-nsubject"
599 mime/field-encoding-method-alist
600 :test
601 (function
602 (lambda (str1 str2)
603 (and (stringp str2)
604 (string= str1
605 (downcase str2))
606 )))))
607 'iso-2022-jp-2)))
608 )
609 (insert (concat "\nX-Nsubject: " str))
610 )))))
611 )))
612
613 (defun mime-eword/encode-string (str &optional column mode)
614 (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
615 )
616
617
618 ;;; @ end
619 ;;;
620
621 (provide 'tm-ew-e)
622
623 ;;; tm-ew-e.el ends here