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