eword-decode.el

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