Synch with the flim-1_14 branch.
[elisp/flim.git] / eword-decode.el
1 ;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
2
3 ;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
4
5 ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
6 ;;         MORIOKA Tomohiko <tomo@m17n.org>
7 ;;         TANAKA Akira <akr@m17n.org>
8 ;; Created: 1995/10/03
9 ;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
10 ;;      Renamed: 1993/06/03 to tiny-mime.el by MORIOKA Tomohiko
11 ;;      Renamed: 1995/10/03 to tm-ew-d.el (split off encoder)
12 ;;               by MORIOKA Tomohiko
13 ;;      Renamed: 1997/02/22 from tm-ew-d.el by MORIOKA Tomohiko
14 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
15
16 ;; This file is part of FLIM (Faithful Library about Internet Message).
17
18 ;; This program is free software; you can redistribute it and/or
19 ;; modify it under the terms of the GNU General Public License as
20 ;; published by the Free Software Foundation; either version 2, or (at
21 ;; your option) any later version.
22
23 ;; This program is distributed in the hope that it will be useful, but
24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
26 ;; General Public License for more details.
27
28 ;; You should have received a copy of the GNU General Public License
29 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
31 ;; Boston, MA 02111-1307, USA.
32
33 ;;; Code:
34
35 (require 'mime-def)
36 (require 'mel)
37 (require 'std11)
38
39 (eval-when-compile (require 'cl))       ; list*, pop
40
41
42 ;;; @ Variables
43 ;;;
44
45 ;; User options are defined in mime-def.el.
46
47
48 ;;; @ MIME encoded-word definition
49 ;;;
50
51 (eval-and-compile
52   (defconst eword-encoded-text-regexp "[!->@-~]+")
53
54   (defconst eword-encoded-word-regexp
55     (eval-when-compile
56       (concat (regexp-quote "=?")
57               "\\("
58               mime-charset-regexp
59               "\\)"
60               (regexp-quote "?")
61               "\\([BbQq]\\)"
62               (regexp-quote "?")
63               "\\("
64               eword-encoded-text-regexp
65               "\\)"
66               (regexp-quote "?="))))
67   )
68
69
70 ;;; @ for string
71 ;;;
72
73 (defun eword-decode-string (string &optional must-unfold)
74   "Decode MIME encoded-words in STRING.
75
76 STRING is unfolded before decoding.
77
78 If an encoded-word is broken or your emacs implementation can not
79 decode the charset included in it, it is not decoded.
80
81 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
82 if there are in decoded encoded-words (generated by bad manner MUA
83 such as a version of Net$cape)."
84   (setq string (std11-unfold-string string))
85   (let ((dest "")(ew nil)
86         beg end)
87     (while (and (string-match eword-encoded-word-regexp string)
88                 (setq beg (match-beginning 0)
89                       end (match-end 0))
90                 )
91       (if (> beg 0)
92           (if (not
93                (and (eq ew t)
94                     (string-match "^[ \t]+$" (substring string 0 beg))
95                     ))
96               (setq dest (concat dest (substring string 0 beg)))
97             )
98         )
99       (setq dest
100             (concat dest
101                     (eword-decode-encoded-word
102                      (substring string beg end) must-unfold)
103                     ))
104       (setq string (substring string end))
105       (setq ew t)
106       )
107     (concat dest string)
108     ))
109
110 (defun eword-decode-structured-field-body (string
111                                            &optional start-column max-column
112                                            start)
113   (let ((tokens (eword-lexical-analyze string start 'must-unfold))
114         (result "")
115         token)
116     (while tokens
117       (setq token (car tokens))
118       (setq result (concat result (eword-decode-token token)))
119       (setq tokens (cdr tokens)))
120     result))
121
122 (defun eword-decode-and-unfold-structured-field-body (string
123                                                       &optional
124                                                       start-column
125                                                       max-column
126                                                       start)
127   "Decode and unfold STRING as structured field body.
128 It decodes non us-ascii characters in FULL-NAME encoded as
129 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
130 characters are regarded as variable `default-mime-charset'.
131
132 If an encoded-word is broken or your emacs implementation can not
133 decode the charset included in it, it is not decoded."
134   (let ((tokens (eword-lexical-analyze string start 'must-unfold))
135         (result ""))
136     (while tokens
137       (let* ((token (car tokens))
138              (type (car token)))
139         (setq tokens (cdr tokens))
140         (setq result
141               (if (eq type 'spaces)
142                   (concat result " ")
143                 (concat result (eword-decode-token token))
144                 ))))
145     result))
146
147 (defun eword-decode-and-fold-structured-field-body (string
148                                                     start-column
149                                                     &optional max-column
150                                                     start)
151   (if (and mime-field-decoding-max-size
152            (> (length string) mime-field-decoding-max-size))
153       string
154     (or max-column
155         (setq max-column fill-column))
156     (let ((c start-column)
157           (tokens (eword-lexical-analyze string start 'must-unfold))
158           (result "")
159           token)
160       (while (and (setq token (car tokens))
161                   (setq tokens (cdr tokens)))
162         (let* ((type (car token)))
163           (if (eq type 'spaces)
164               (let* ((next-token (car tokens))
165                      (next-str (eword-decode-token next-token))
166                      (next-len (string-width next-str))
167                      (next-c (+ c next-len 1)))
168                 (if (< next-c max-column)
169                     (setq result (concat result " " next-str)
170                           c next-c)
171                   (setq result (concat result "\n " next-str)
172                         c (1+ next-len)))
173                 (setq tokens (cdr tokens))
174                 )
175             (let* ((str (eword-decode-token token)))
176               (setq result (concat result str)
177                     c (+ c (string-width str)))
178               ))))
179       (if token
180           (concat result (eword-decode-token token))
181         result))))
182
183 ;; unlimited patch by simm-emacs@fan.gr.jp
184 ;;   Tue, 01 Feb 2000 13:43:09 +0900
185 (defun eword-decode-unstructured-field-body (string &optional start-column
186                                                     max-column)
187   (eword-decode-string
188    (decode-mime-charset-string-unlimited
189     string
190     (or default-mime-charset-unlimited default-mime-charset))))
191
192 (defun eword-decode-and-unfold-unstructured-field-body (string
193                                                         &optional start-column
194                                                         max-column)
195   (eword-decode-string
196    (decode-mime-charset-string-unlimited
197     (std11-unfold-string string)
198     (or default-mime-charset-unlimited default-mime-charset))
199    'must-unfold))
200
201 (defun eword-decode-unfolded-unstructured-field-body (string
202                                                       &optional start-column
203                                                       max-column)
204   (eword-decode-string
205    (decode-mime-charset-string-unlimited
206     string
207     (or default-mime-charset-unlimited default-mime-charset))
208    'must-unfold))
209
210
211 ;;; @ for region
212 ;;;
213
214 (defun eword-decode-region (start end &optional unfolding must-unfold)
215   "Decode MIME encoded-words in region between START and END.
216
217 If UNFOLDING is not nil, it unfolds before decoding.
218
219 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
220 if there are in decoded encoded-words (generated by bad manner MUA
221 such as a version of Net$cape)."
222   (interactive "*r")
223   (save-excursion
224     (save-restriction
225       (narrow-to-region start end)
226       (if unfolding
227           (eword-decode-unfold)
228         )
229       (goto-char (point-min))
230       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
231                                         "\\(\n?[ \t]\\)+"
232                                         "\\(" eword-encoded-word-regexp "\\)")
233                                 nil t)
234         (replace-match "\\1\\6")
235         (goto-char (point-min))
236         )
237       (while (re-search-forward eword-encoded-word-regexp nil t)
238         (insert (eword-decode-encoded-word
239                  (prog1
240                      (buffer-substring (match-beginning 0) (match-end 0))
241                    (delete-region (match-beginning 0) (match-end 0))
242                    ) must-unfold))
243         )
244       )))
245
246 (defun eword-decode-unfold ()
247   (goto-char (point-min))
248   (let (field beg end)
249     (while (re-search-forward std11-field-head-regexp nil t)
250       (setq beg (match-beginning 0)
251             end (std11-field-end))
252       (setq field (buffer-substring beg end))
253       (if (string-match eword-encoded-word-regexp field)
254           (save-restriction
255             (narrow-to-region (goto-char beg) end)
256             (while (re-search-forward "\n\\([ \t]\\)" nil t)
257               (replace-match (match-string 1))
258               )
259             (goto-char (point-max))
260             ))
261       )))
262
263
264 ;;; @ for message header
265 ;;;
266
267 (defvar mime-field-decoder-alist nil)
268
269 (defvar mime-field-decoder-cache nil)
270
271 (defvar mime-update-field-decoder-cache 'mime-update-field-decoder-cache
272   "*Field decoder cache update function.")
273
274 ;;;###autoload
275 (defun mime-set-field-decoder (field &rest specs)
276   "Set decoder of FIELD.
277 SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'.
278 Each mode must be `nil', `plain', `wide', `summary' or `nov'.
279 If mode is `nil', corresponding decoder is set up for every modes."
280   (when specs
281     (let ((mode (pop specs))
282           (function (pop specs)))
283       (if mode
284           (progn
285             (let ((cell (assq mode mime-field-decoder-alist)))
286               (if cell
287                   (setcdr cell (put-alist field function (cdr cell)))
288                 (setq mime-field-decoder-alist
289                       (cons (cons mode (list (cons field function)))
290                             mime-field-decoder-alist))
291                 ))
292             (apply (function mime-set-field-decoder) field specs)
293             )
294         (mime-set-field-decoder field
295                                 'plain function
296                                 'wide function
297                                 'summary function
298                                 'nov function)
299         ))))
300
301 ;;;###autoload
302 (defmacro mime-find-field-presentation-method (name)
303   "Return field-presentation-method from NAME.
304 NAME must be `plain', `wide', `summary' or `nov'."
305   (cond ((eq name nil)
306          `(or (assq 'summary mime-field-decoder-cache)
307               '(summary))
308          )
309         ((and (consp name)
310               (car name)
311               (consp (cdr name))
312               (symbolp (car (cdr name)))
313               (null (cdr (cdr name))))
314          `(or (assq ,name mime-field-decoder-cache)
315               (cons ,name nil))
316          )
317         (t
318          `(or (assq (or ,name 'summary) mime-field-decoder-cache)
319               (cons (or ,name 'summary) nil))
320          )))
321
322 (defun mime-find-field-decoder-internal (field &optional mode)
323   "Return function to decode field-body of FIELD in MODE.
324 Optional argument MODE must be object of field-presentation-method."
325   (cdr (or (assq field (cdr mode))
326            (prog1
327                (funcall mime-update-field-decoder-cache
328                         field (car mode))
329              (setcdr mode
330                      (cdr (assq (car mode) mime-field-decoder-cache)))
331              ))))
332
333 ;;;###autoload
334 (defun mime-find-field-decoder (field &optional mode)
335   "Return function to decode field-body of FIELD in MODE.
336 Optional argument MODE must be object or name of
337 field-presentation-method.  Name of field-presentation-method must be
338 `plain', `wide', `summary' or `nov'.
339 Default value of MODE is `summary'."
340   (if (symbolp mode)
341       (let ((p (cdr (mime-find-field-presentation-method mode))))
342         (if (and p (setq p (assq field p)))
343             (cdr p)
344           (cdr (funcall mime-update-field-decoder-cache
345                         field (or mode 'summary)))))
346     (inline (mime-find-field-decoder-internal field mode))
347     ))
348
349 ;;;###autoload
350 (defun mime-update-field-decoder-cache (field mode &optional function)
351   "Update field decoder cache `mime-field-decoder-cache'."
352   (cond ((eq function 'identity)
353          (setq function nil)
354          )
355         ((null function)
356          (let ((decoder-alist
357                 (cdr (assq (or mode 'summary) mime-field-decoder-alist))))
358            (setq function (cdr (or (assq field decoder-alist)
359                                    (assq t decoder-alist)))))
360          ))
361   (let ((cell (assq mode mime-field-decoder-cache))
362         ret)
363     (if cell
364         (if (setq ret (assq field (cdr cell)))
365             (setcdr ret function)
366           (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
367       (setq mime-field-decoder-cache
368             (cons (cons mode (list (setq ret (cons field function))))
369                   mime-field-decoder-cache)))
370     ret))
371
372 ;; ignored fields
373 (mime-set-field-decoder 'Archive                nil nil)
374 (mime-set-field-decoder 'Content-Md5            nil nil)
375 (mime-set-field-decoder 'Control                nil nil)
376 (mime-set-field-decoder 'Date                   nil nil)
377 (mime-set-field-decoder 'Distribution           nil nil)
378 (mime-set-field-decoder 'Followup-Host          nil nil)
379 (mime-set-field-decoder 'Followup-To            nil nil)
380 (mime-set-field-decoder 'Lines                  nil nil)
381 (mime-set-field-decoder 'Message-Id             nil nil)
382 (mime-set-field-decoder 'Newsgroups             nil nil)
383 (mime-set-field-decoder 'Nntp-Posting-Host      nil nil)
384 (mime-set-field-decoder 'Path                   nil nil)
385 (mime-set-field-decoder 'Posted-And-Mailed      nil nil)
386 (mime-set-field-decoder 'Received               nil nil)
387 (mime-set-field-decoder 'Status                 nil nil)
388 (mime-set-field-decoder 'X-Face                 nil nil)
389 (mime-set-field-decoder 'X-Face-Version         nil nil)
390 (mime-set-field-decoder 'X-Info                 nil nil)
391 (mime-set-field-decoder 'X-Pgp-Key-Info         nil nil)
392 (mime-set-field-decoder 'X-Pgp-Sig              nil nil)
393 (mime-set-field-decoder 'X-Pgp-Sig-Version      nil nil)
394 (mime-set-field-decoder 'Xref                   nil nil)
395
396 ;; structured fields
397 (let ((fields
398        '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
399          To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
400          Mail-Followup-To
401          Mime-Version Content-Type Content-Transfer-Encoding
402          Content-Disposition User-Agent))
403       field)
404   (while fields
405     (setq field (pop fields))
406     (mime-set-field-decoder
407      field
408      'plain     #'eword-decode-structured-field-body
409      'wide      #'eword-decode-and-fold-structured-field-body
410      'summary   #'eword-decode-and-unfold-structured-field-body
411      'nov       #'eword-decode-and-unfold-structured-field-body)
412     ))
413
414 ;; unstructured fields (default)
415 (mime-set-field-decoder
416  t
417  'plain #'eword-decode-unstructured-field-body
418  'wide  #'eword-decode-unstructured-field-body
419  'summary #'eword-decode-and-unfold-unstructured-field-body
420  'nov   #'eword-decode-unfolded-unstructured-field-body)
421
422 ;;;###autoload
423 (defun mime-decode-field-body (field-body field-name
424                                           &optional mode max-column)
425   "Decode FIELD-BODY as FIELD-NAME in MODE, and return the result.
426 Optional argument MODE must be `plain', `wide', `summary' or `nov'.
427 Default mode is `summary'.
428
429 If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with
430 MAX-COLUMN.
431
432 Non MIME encoded-word part in FILED-BODY is decoded with
433 `default-mime-charset'."
434   (let (field-name-symbol len decoder)
435     (if (symbolp field-name)
436         (setq field-name-symbol field-name
437               len (1+ (string-width (symbol-name field-name))))
438       (setq field-name-symbol (intern (capitalize field-name))
439             len (1+ (string-width field-name))))
440     (setq decoder (mime-find-field-decoder field-name-symbol mode))
441     (if decoder
442         (funcall decoder field-body len max-column)
443       ;; Don't decode
444       (if (eq mode 'summary)
445           (std11-unfold-string field-body)
446         field-body)
447       )))
448
449 ;;;###autoload
450 (defun mime-decode-header-in-region (start end
451                                            &optional code-conversion)
452   "Decode MIME encoded-words in region between START and END.
453 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
454 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
455 Otherwise it decodes non-ASCII bit patterns as the
456 default-mime-charset."
457   (interactive "*r")
458   (save-excursion
459     (save-restriction
460       (narrow-to-region start end)
461       (let ((default-charset
462               (if code-conversion
463                   (if (mime-charset-to-coding-system code-conversion)
464                       code-conversion
465                     default-mime-charset))))
466         (if default-charset
467             (let ((mode-obj (mime-find-field-presentation-method 'wide))
468                   beg p end field-name len field-decoder)
469               (goto-char (point-min))
470               (while (re-search-forward std11-field-head-regexp nil t)
471                 (setq beg (match-beginning 0)
472                       p (match-end 0)
473                       field-name (buffer-substring beg (1- p))
474                       len (string-width field-name)
475                       field-name (intern (capitalize field-name))
476                       field-decoder (inline
477                                       (mime-find-field-decoder-internal
478                                        field-name mode-obj)))
479                 (when field-decoder
480                   (setq end (std11-field-end))
481                   (let ((body (buffer-substring p end))
482                         (default-mime-charset default-charset))
483                     (delete-region p end)
484                     (insert (funcall field-decoder body (1+ len)))
485                     ))
486                 ))
487           (eword-decode-region (point-min) (point-max) t)
488           )))))
489
490 ;;;###autoload
491 (defun mime-decode-header-in-buffer (&optional code-conversion separator)
492   "Decode MIME encoded-words in header fields.
493 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
494 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
495 Otherwise it decodes non-ASCII bit patterns as the
496 default-mime-charset.
497 If SEPARATOR is not nil, it is used as header separator."
498   (interactive "*")
499   (mime-decode-header-in-region
500    (point-min)
501    (save-excursion
502      (goto-char (point-min))
503      (if (re-search-forward
504           (concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
505           nil t)
506          (match-beginning 0)
507        (point-max)
508        ))
509    code-conversion))
510
511 (defalias 'eword-decode-header 'mime-decode-header-in-buffer)
512 (make-obsolete 'eword-decode-header 'mime-decode-header-in-buffer)
513
514
515 ;;; @ encoded-word decoder
516 ;;;
517
518 (defvar eword-decode-encoded-word-error-handler
519   'eword-decode-encoded-word-default-error-handler)
520
521 (defvar eword-warning-face nil
522   "Face used for invalid encoded-word.")
523
524 (defun eword-decode-encoded-word-default-error-handler (word signal)
525   (and (add-text-properties 0 (length word)
526                             (and eword-warning-face
527                                  (list 'face eword-warning-face))
528                             word)
529        word))
530
531 (defun eword-decode-encoded-word (word &optional must-unfold)
532   "Decode WORD if it is an encoded-word.
533
534 If your emacs implementation can not decode the charset of WORD, it
535 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
536
537 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
538 if there are in decoded encoded-word (generated by bad manner MUA such
539 as a version of Net$cape)."
540   (or (if (string-match eword-encoded-word-regexp word)
541           (let ((charset
542                  (substring word (match-beginning 1) (match-end 1))
543                  )
544                 (encoding
545                  (upcase
546                   (substring word (match-beginning 2) (match-end 2))
547                   ))
548                 (text
549                  (substring word (match-beginning 3) (match-end 3))
550                  ))
551             (condition-case err
552                 (eword-decode-encoded-text charset encoding text must-unfold)
553               (error
554                (funcall eword-decode-encoded-word-error-handler word err)
555                ))
556             ))
557       word))
558
559
560 ;;; @ encoded-text decoder
561 ;;;
562
563 (defun eword-decode-encoded-text (charset encoding string
564                                           &optional must-unfold)
565   "Decode STRING as an encoded-text.
566
567 If your emacs implementation can not decode CHARSET, it returns nil.
568
569 If ENCODING is not \"B\" or \"Q\", it occurs error.
570 So you should write error-handling code if you don't want break by errors.
571
572 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
573 if there are in decoded encoded-text (generated by bad manner MUA such
574 as a version of Net$cape)."
575   (let ((cs (mime-charset-to-coding-system charset)))
576     (if cs
577         (let ((dest (encoded-text-decode-string string encoding)))
578           (when dest
579             (setq dest (decode-mime-charset-string dest charset))
580             (if must-unfold
581                 (mapconcat (function
582                             (lambda (chr)
583                               (cond ((eq chr ?\n) "")
584                                     ((eq chr ?\t) " ")
585                                     (t (char-to-string chr)))
586                               ))
587                            (std11-unfold-string dest)
588                            "")
589               dest))))))
590
591
592 ;;; @ lexical analyze
593 ;;;
594
595 (defvar eword-lexical-analyze-cache nil)
596 (defvar eword-lexical-analyze-cache-max 299
597   "*Max position of eword-lexical-analyze-cache.
598 It is max size of eword-lexical-analyze-cache - 1.")
599
600 (defvar mime-header-lexical-analyzer
601   '(eword-analyze-quoted-string
602     eword-analyze-domain-literal
603     eword-analyze-comment
604     eword-analyze-spaces
605     eword-analyze-special
606     eword-analyze-encoded-word
607     eword-analyze-atom)
608   "*List of functions to return result of lexical analyze.
609 Each function must have three arguments: STRING, START and MUST-UNFOLD.
610 STRING is the target string to be analyzed.
611 START is start position of STRING to analyze.
612 If MUST-UNFOLD is not nil, each function must unfold and eliminate
613 bare-CR and bare-LF from the result even if they are included in
614 content of the encoded-word.
615 Each function must return nil if it can not analyze STRING as its
616 format.
617
618 Previous function is preferred to next function.  If a function
619 returns nil, next function is used.  Otherwise the return value will
620 be the result.")
621
622 (defun eword-analyze-quoted-string (string start &optional must-unfold)
623   (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
624     (if p
625         (cons (cons 'quoted-string
626                     (decode-mime-charset-string
627                      (std11-strip-quoted-pair
628                       (substring string (1+ start) (1- p)))
629                      default-mime-charset))
630               ;;(substring string p))
631               p)
632       )))
633
634 (defun eword-analyze-domain-literal (string start &optional must-unfold)
635   (std11-analyze-domain-literal string start))
636
637 (defun eword-analyze-comment (string from &optional must-unfold)
638   (let ((len (length string))
639         (i (or from 0))
640         dest last-str
641         chr ret)
642     (when (and (> len i)
643                (eq (aref string i) ?\())
644       (setq i (1+ i)
645             from i)
646       (catch 'tag
647         (while (< i len)
648           (setq chr (aref string i))
649           (cond ((eq chr ?\\)
650                  (setq i (1+ i))
651                  (if (>= i len)
652                      (throw 'tag nil)
653                    )
654                  (setq last-str (concat last-str
655                                         (substring string from (1- i))
656                                         (char-to-string (aref string i)))
657                        i (1+ i)
658                        from i)
659                  )
660                 ((eq chr ?\))
661                  (setq ret (concat last-str
662                                    (substring string from i)))
663                  (throw 'tag (cons
664                               (cons 'comment
665                                     (nreverse
666                                      (if (string= ret "")
667                                          dest
668                                        (cons
669                                         (eword-decode-string
670                                          (decode-mime-charset-string
671                                           ret default-mime-charset)
672                                          must-unfold)
673                                         dest)
674                                        )))
675                               (1+ i)))
676                  )
677                 ((eq chr ?\()
678                  (if (setq ret (eword-analyze-comment string i must-unfold))
679                      (setq last-str
680                            (concat last-str
681                                    (substring string from i))
682                            dest
683                            (if (string= last-str "")
684                                (cons (car ret) dest)
685                              (list* (car ret)
686                                     (eword-decode-string
687                                      (decode-mime-charset-string
688                                       last-str default-mime-charset)
689                                      must-unfold)
690                                     dest)
691                              )
692                            i (cdr ret)
693                            from i
694                            last-str "")
695                    (throw 'tag nil)
696                    ))
697                 (t
698                  (setq i (1+ i))
699                  ))
700           )))))
701
702 (defun eword-analyze-spaces (string start &optional must-unfold)
703   (std11-analyze-spaces string start))
704
705 (defun eword-analyze-special (string start &optional must-unfold)
706   (std11-analyze-special string start))
707
708 (defun eword-analyze-encoded-word (string start &optional must-unfold)
709   (if (and (string-match eword-encoded-word-regexp string start)
710            (= (match-beginning 0) start))
711       (let ((end (match-end 0))
712             (dest (eword-decode-encoded-word (match-string 0 string)
713                                              must-unfold))
714             )
715         ;;(setq string (substring string end))
716         (setq start end)
717         (while (and (string-match (eval-when-compile
718                                     (concat "[ \t\n]*\\("
719                                             eword-encoded-word-regexp
720                                             "\\)"))
721                                   string start)
722                     (= (match-beginning 0) start))
723           (setq end (match-end 0))
724           (setq dest
725                 (concat dest
726                         (eword-decode-encoded-word (match-string 1 string)
727                                                    must-unfold))
728                 ;;string (substring string end))
729                 start end)
730           )
731         (cons (cons 'atom dest) ;;string)
732               end)
733         )))
734
735 (defun eword-analyze-atom (string start &optional must-unfold)
736   (if (and (string-match std11-atom-regexp string start)
737            (= (match-beginning 0) start))
738       (let ((end (match-end 0)))
739         (cons (cons 'atom (decode-mime-charset-string
740                            (substring string start end)
741                            default-mime-charset))
742               ;;(substring string end)
743               end)
744         )))
745
746 (defun eword-lexical-analyze-internal (string start must-unfold)
747   (let ((len (length string))
748         dest ret)
749     (while (< start len)
750       (setq ret
751             (let ((rest mime-header-lexical-analyzer)
752                   func r)
753               ;; unlimited patch by simm-emacs@fan.gr.jp,
754               ;;   Mon, 10 Jan 2000 12:52:39 +0900
755               (while (and (setq func (car rest))
756                           (or (and mime-decode-unlimited
757                                    (eq func 'eword-analyze-quoted-string))
758                               (null
759                                (setq r (funcall func string start must-unfold)))))
760                 (setq rest (cdr rest)))
761               (or r
762                   (cons (cons 'error (substring string start)) (1+ len)))
763               ))
764       (setq dest (cons (car ret) dest)
765             start (cdr ret))
766       )
767     (nreverse dest)
768     ))
769
770 (defun eword-lexical-analyze (string &optional start must-unfold)
771   "Return lexical analyzed list corresponding STRING.
772 It is like std11-lexical-analyze, but it decodes non us-ascii
773 characters encoded as encoded-words or invalid \"raw\" format.
774 \"Raw\" non us-ascii characters are regarded as variable
775 `default-mime-charset'."
776   (let ((key (substring string (or start 0)))
777         ret cell)
778     (set-text-properties 0 (length key) nil key)
779     (if (setq ret (assoc key eword-lexical-analyze-cache))
780         (cdr ret)
781       (setq ret (eword-lexical-analyze-internal key 0 must-unfold))
782       (setq eword-lexical-analyze-cache
783             (cons (cons key ret)
784                   eword-lexical-analyze-cache))
785       (if (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max
786                                   eword-lexical-analyze-cache)))
787           (setcdr cell nil))
788       ret)))
789
790 (defun eword-decode-token (token)
791   (let ((type (car token))
792         (value (cdr token)))
793     (cond ((eq type 'quoted-string)
794            (std11-wrap-as-quoted-string value))
795           ((eq type 'comment)
796            (let ((dest ""))
797              (while value
798                (setq dest (concat dest
799                                   (if (stringp (car value))
800                                       ;; unlimited patch by simm-emacs@fan.gr.jp
801                                       ;;   Mon, 10 Jan 2000 12:53:46 +0900
802                                       (if mime-decode-unlimited
803                                           (eword-decode-string
804                                            (std11-wrap-as-quoted-pairs
805                                             (car value) '(?( ?))))
806                                         (std11-wrap-as-quoted-pairs
807                                          (car value) '(?( ?))))
808                                     (eword-decode-token (car value))
809                                     ))
810                      value (cdr value))
811                )
812              (concat "(" dest ")")
813              ))
814           (t value))))
815
816 (defun eword-extract-address-components (string &optional start)
817   "Extract full name and canonical address from STRING.
818 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
819 If no name can be extracted, FULL-NAME will be nil.
820 It decodes non us-ascii characters in FULL-NAME encoded as
821 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
822 characters are regarded as variable `default-mime-charset'."
823   (let* ((structure (car (std11-parse-address
824                           (eword-lexical-analyze
825                            (std11-unfold-string string) start
826                            'must-unfold))))
827          (phrase  (std11-full-name-string structure))
828          (address (std11-address-string structure))
829          )
830     (list phrase address)
831     ))
832
833
834 ;;; @ end
835 ;;;
836
837 (provide 'eword-decode)
838
839 ;;; eword-decode.el ends here