cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-bq.el

   1 ;;; mew-bq.el --- Base64 and Quoted-Printable encoding for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Aug 20, 1997
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-bq-version "mew-bq.el version 0.04")
  10
  11 (require 'mew)
  12
  13 (defvar mew-header-encode-switch
  14   (if (fboundp 'base64-encode-string)
  15       '(("B" . base64-encode-string)
  16         ("Q" . mew-header-encode-qp))
  17     '(("B" . mew-header-encode-base64)
  18       ("Q" . mew-header-encode-qp))))
  19
  20 (defvar mew-header-decode-switch
  21   (if (fboundp 'base64-decode-string)
  22       '(("B" . base64-decode-string)
  23         ("Q" . mew-header-decode-qp))
  24     '(("B" . mew-header-decode-base64)
  25       ("Q" . mew-header-decode-qp))))
  26
  27 (defconst mew-base64-char64
  28   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  29
  30 (defconst mew-base64-char256
  31   (let ((i 0) (len (length mew-base64-char64)) (s (make-string 256 0)))
  32     (while (< i len)
  33       (aset s (aref mew-base64-char64 i) i)
  34       (setq i (1+ i)))
  35     s))
  36
  37 (defconst mew-header-decode-regex
  38   "=\\?\\([^? \t]+\\)\\?\\(.\\)\\?\\([^? \t]+\\)\\?=")
  39
  40 ;;;
  41 ;;;
  42 ;;;
  43
  44 (defun mew-header-sanity-check-string (str)
  45   (if (null str)
  46       str
  47     (while (string-match "[\000-\010\012-\037\177]+" str)
  48       (setq str (concat (substring str 0 (match-beginning 0))
  49                         (substring str (match-end 0)))))
  50     str))
  51
  52 (defun mew-header-sanity-check-region (beg end)
  53   (save-restriction
  54     (narrow-to-region beg end)
  55     (goto-char (point-min))
  56     (while (re-search-forward "[\000-\010\013-\037\177]+" nil t) ;; allow \n
  57       (replace-match "" nil t))))
  58
  59 (defun mew-header-encode (str)
  60   ;; sanity check should be done
  61   (let* ((charset (mew-charset-guess-string str))
  62          (data (mew-charset-to-data charset))
  63          (b-or-q (nth 5 data))
  64          (cs (nth 4 data))
  65          (fun (cdr (mew-assoc-case-equal b-or-q mew-header-encode-switch 0)))
  66          (estr (mew-cs-encode-string str cs)))
  67     (concat "=?" charset "?" b-or-q "?" (funcall fun estr) "?=")))
  68
  69 (defun mew-header-decode (charset b-or-q estr)
  70   (let* ((fun (cdr (mew-assoc-case-equal b-or-q mew-header-decode-switch 0)))
  71          (cs (mew-charset-to-cs charset))
  72          ret)
  73     (cond
  74      ((and (null cs) (not (mew-case-equal charset mew-us-ascii)))
  75       mew-error-unknown-charset)
  76      (fun ;; cs may be nil
  77       (setq ret (mew-cs-decode-string
  78                  (or (funcall fun estr) mew-error-illegal-base64)
  79                  cs))
  80       (mew-header-sanity-check-string ret))
  81      (t
  82       estr))))
  83
  84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85 ;;;
  86 ;;; Base64 encoding
  87 ;;;
  88
  89 (defun mew-header-encode-base64 (str256)
  90   (let* ((len (length str256))
  91          (ret (make-string (* (/ (+ len 2) 3) 4) ?=))
  92          (pad (% len 3))
  93          (lim (- len pad))
  94          (i -1) (j -1) c)
  95     (while (< (setq i (1+ i)) lim)
  96       (setq c (logior (lsh (aref str256 i) 16)
  97                       (lsh (aref str256 (setq i (1+ i))) 8)
  98                       (aref str256 (setq i (1+ i)))))
  99       (aset ret (setq j (1+ j))
 100             (aref mew-base64-char64 (lsh c -18)))
 101       (aset ret (setq j (1+ j))
 102             (aref mew-base64-char64 (logand (lsh c -12) 63)))
 103       (aset ret (setq j (1+ j))
 104             (aref mew-base64-char64 (logand (lsh c -6) 63)))
 105       (aset ret (setq j (1+ j))
 106             (aref mew-base64-char64 (logand c 63))))
 107     (cond
 108      ((= pad 1)
 109       (setq c (aref str256 i))
 110       (aset ret (setq j (1+ j))
 111             (aref mew-base64-char64 (lsh c -2)))
 112       (aset ret (1+ j)
 113             (aref mew-base64-char64 (lsh (logand c 3) 4))))
 114      ((= pad 2)
 115       (setq c (logior (lsh (aref str256 i) 8)
 116                       (aref str256 (1+ i))))
 117       (aset ret (setq j (1+ j))
 118             (aref mew-base64-char64 (lsh c -10)))
 119       (aset ret (setq j (1+ j))
 120             (aref mew-base64-char64 (logand (lsh c -4) 63)))
 121       (aset ret (1+ j)
 122             (aref mew-base64-char64 (logand (lsh c 2) 63)))))
 123     ret))
 124
 125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 126 ;;;
 127 ;;; Base64 decoding
 128 ;;;
 129
 130 (defun mew-header-decode-base64 (str64)
 131   (let* ((len (length str64))
 132          ret
 133          (i 0) (j -1) (padlen 0) c)
 134     (if (string-match "=+$" str64)
 135         (setq padlen (- (match-end 0) (match-beginning 0))))
 136     (cond
 137      ((or (string-match "[^a-zA-Z0-9+/=]" str64)
 138           (not (zerop (logand len 3)))
 139           (< padlen 0)
 140           (> padlen 2))
 141       nil)  ;; return value
 142      ((zerop (setq len (- len padlen))) "")
 143      (t
 144       (setq ret (make-string (/ (* len 3) 4) ?a))
 145       (while
 146           (progn
 147             (setq
 148              c (logior
 149                 (lsh (aref mew-base64-char256 (aref str64 i)) 18)
 150                 (lsh (aref mew-base64-char256 (aref str64 (setq i (1+ i)))) 12)
 151                 (lsh (aref mew-base64-char256 (aref str64 (setq i (1+ i)))) 6)
 152                 (aref mew-base64-char256 (aref str64 (setq i (1+ i))))))
 153             (aset ret (setq j (1+ j)) (lsh c -16))
 154             (< (setq i (1+ i)) len))
 155         (aset ret (setq j (1+ j)) (logand (lsh c -8) 255))
 156         (aset ret (setq j (1+ j)) (logand c 255)))
 157       (if (< padlen 2)
 158           (aset ret (1+ j) (logand (lsh c -8) 255)))
 159       (if (zerop padlen)
 160           (aset ret (1+ (1+ j)) (logand c 255)))
 161       ret))))
 162
 163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 164 ;;;
 165 ;;; Quoted-printable encoding
 166 ;;;
 167
 168 (defun mew-header-encode-qp (str)
 169   (let* ((len (length str))
 170          (ret (make-string (* len 3) ?a))
 171          (i 0) (j 0) char)
 172     (while (< i len)
 173       (setq char (aref str i))
 174       (cond
 175        ((char-equal char 32)
 176         (aset ret j ?_))
 177        ((and (> char 32)
 178              (< char 126)
 179              (not (char-equal char ?=))
 180              (not (char-equal char ??))
 181              (not (char-equal char ?_))) ;; space
 182         (aset ret j char))
 183        (t
 184         (aset ret j ?=)
 185         (setq j (1+ j))
 186         (aset ret j (aref "0123456789ABCDEF" (lsh char -4)))
 187         (setq j (1+ j))
 188         (aset ret j (aref "0123456789ABCDEF" (logand char 15)))))
 189       (setq i (1+ i) j (1+ j)))
 190     (substring ret 0 j)))
 191
 192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 193 ;;;
 194 ;;; Quoted-printable decoding
 195 ;;;
 196
 197 (defmacro mew-hexchar-to-int (hex)
 198   (` (cond
 199       ((and (<= ?0 (, hex)) (<= (, hex) ?9))
 200        (- (, hex) ?0))
 201       ((and (<= ?A (, hex)) (<= (, hex) ?F))
 202        (+ (- (, hex) ?A) 10))
 203       ((and (<= ?a (, hex)) (<= (, hex) ?f))
 204        (+ (- (, hex) ?a) 10)))))
 205
 206 (defun mew-header-decode-qp (qpstr &optional key)
 207   (let* ((len (length qpstr))
 208          (ret (make-string len ?a))
 209          (i 0) (j 0) char)
 210     (setq key (or key ?=))
 211     (while (< i len)
 212       (setq char (aref qpstr i))
 213       (cond
 214        ((char-equal char ?_)
 215         (aset ret j 32))
 216        ((char-equal char key)
 217         (aset ret j (+ (* (mew-hexchar-to-int (aref qpstr (1+ i))) 16)
 218                        (mew-hexchar-to-int (aref qpstr (+ i 2)))))
 219         (setq i (+ i 2)))
 220        (t
 221         (aset ret j char)))
 222       (setq i (1+ i) j (1+ j)))
 223     (substring ret 0 j)))
 224
 225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 226 ;;
 227 ;; RFC 2047 encoding
 228 ;;
 229
 230 ;; DRUMS says that each line should be less than or equal to 78
 231 ;; excluding CRLF.
 232 ;; RFC2047 says that encoded-word must be less than or equal to 75.
 233 ;; RFC2047 says that each line which includes one or more encoded-words
 234 ;; must be less than or equal to 76.
 235
 236 (defvar mew-encode-word-max-length 75)
 237 (defvar mew-field-max-length 76)
 238
 239 ;; If possible, mew-header-encode-string should expect the length of
 240 ;; results and split 'str' before encoding so that every 'encoded-word'
 241 ;; fits in 75 length. However, it is very difficult first because
 242 ;; it is very difficult to know actual length of 'str' after convention
 243 ;; from the internal representation to charset encoding. Second because
 244 ;; ISO-2022-JP can't be simply split. If split, extra escape sequences
 245 ;; appear. Moreover, it is not effective to expect the length of results
 246 ;; because 'str' is short enough in most cases. So, we measure the length
 247 ;; of results. If it is longer than 75, 'str' is split and 'substr1' and
 248 ;; 'substr2' are encoded.... Repeat this recursively but not so deeply.
 249
 250 (defun mew-header-encode-string (str &optional key-len)
 251   (let* ((max mew-encode-word-max-length)
 252          (encoded-word (mew-header-encode str)))
 253     (if key-len
 254         (setq max (- max key-len)))
 255     (if (> (length encoded-word) max)
 256         (let ((med (/ (length str) 2))
 257               (i 0))
 258           (while (< i med)
 259             (setq i (+ i (mew-charlen (mew-aref str i)))))
 260           (append
 261            (mew-header-encode-string (substring str 0 i) key-len)
 262            (mew-header-encode-string (substring str i nil))))
 263       (list encoded-word))))
 264
 265 (defun mew-header-encode-split-string (str)
 266   "Split STR to need-to-encode string and non-encode-string."
 267   (let ((start 0) beg end ret)
 268     (while (string-match "\\(^\\|[ \t]+\\)[\t -~]+\\($\\|[ \t]+\\)" str start)
 269       (setq beg (match-beginning 0))
 270       (setq end (match-end 0))
 271       (if (equal start beg)
 272           (setq ret (cons (substring str beg end) ret))
 273         (setq ret (cons (substring str beg end)
 274                         (cons (substring str start beg) ret))))
 275       (setq start end))
 276     (if (/= start (length str))
 277         (setq ret (cons (substring str start nil) ret)))
 278     (nreverse ret)))
 279
 280 (defun mew-header-encode-comma-text (str)
 281   (let ((str-list (mapcar (function mew-chop) (mew-split str ?,))))
 282     (mew-header-encode-text (car str-list))
 283     (setq str-list (cdr str-list))
 284     (while str-list
 285       (insert ", ") ;; must be fold here
 286       (mew-header-encode-text (car str-list))
 287       (setq str-list (cdr str-list)))))
 288
 289 (defmacro mew-header-encode-cond (c)
 290   (` (cond
 291       ((> (, c) 127) ;; non-ascii
 292        (if (equal status 'space)
 293            (progn
 294              (insert (substring str bound i))
 295              (setq bound i)))
 296        (setq status 'non-ascii))
 297       ;; end of non-ascii
 298       (t ;; ascii
 299        (cond
 300         ((equal status 'space)
 301          (insert (substring str bound i)) ;; spaces
 302          (setq bound i)
 303          (setq status 'ascii))
 304         ((equal status 'ascii)
 305          (setq status 'ascii))
 306         ((equal status 'non-ascii)
 307          (setq status 'non-ascii))
 308         ((equal status 'non-ascii-space)
 309          (mew-header-encode-text (substring str bound SBOUND))
 310          ;; non-ascii
 311          (insert (substring str SBOUND i)) ;; spaces
 312          (setq bound i)
 313          (setq status 'ascii))))
 314       ;; end of ascii
 315       )))
 316
 317 (defmacro mew-header-encode-cond2 (opt)
 318   (` (cond
 319       ((equal status 'ascii)
 320        (insert (substring str bound i)))
 321       ((equal status 'space)
 322        (insert (substring str bound i)))
 323       ((equal status 'non-ascii)
 324        (mew-header-encode-text (substring str bound i)) (, opt))
 325       ((equal status 'non-ascii-space)
 326        (mew-header-encode-text (substring str bound SBOUND) (, opt))
 327        (insert (substring str SBOUND i))))))
 328
 329 (defun mew-header-encode-addr (str)
 330   (let* ((len (length str))
 331          (i 0) (bound 0) (status 'space)
 332          SBOUND open c I)
 333     ;; status space, ascii, non-ascii, non-ascii-space
 334     ;; assumptions:
 335     ;;  <> doesn't contain non-ascii characters.
 336     ;;  () doesn't recurse.
 337     ;; if " " contains non-ascii, cause an error.
 338     (while (< i len)
 339       (setq c (mew-aref str i))
 340       (cond
 341        ;; quote
 342        ((char-equal c ?\")
 343         (setq I (1+ i))
 344         (setq open t)
 345         (catch 'quote
 346           (while (< I len)
 347             (setq c (mew-aref str I))
 348             (cond
 349              ((char-equal c ?\")
 350               (setq open nil)
 351               (throw 'quote nil))
 352              ((> c 127)
 353               (mew-draft-undo)
 354               (error "Only ASCII is allowed in quoted-string in the header. ")))
 355             (setq I (+ I (mew-charlen c)))))
 356         (if open
 357             (progn
 358               (mew-draft-undo)
 359               (error "Quote string must be closed in the header. ")))
 360         (mew-header-encode-cond ?a)
 361         (setq i I))
 362        ;; end of quote
 363        ;; comment
 364        ((char-equal c ?\()
 365         (mew-header-encode-cond2 nil)
 366         (insert "(")
 367         (setq i (1+ i))
 368         (setq bound i)
 369         (setq status 'ascii)
 370         (setq open t)
 371         (let (qp)
 372           (catch 'comment
 373             (while (< i len)
 374               (setq c (mew-aref str i))
 375               (cond
 376                ((char-equal c ?\))
 377                 (setq open nil)
 378                 (throw 'comment nil))
 379                ((char-equal c ?\")
 380                 (setq qp t))
 381                ((> c 127)
 382                 (setq status 'non-ascii)))
 383               (setq i (+ i (mew-charlen c)))))
 384           (if (and qp (equal status 'non-ascii))
 385               (progn
 386                 (mew-draft-undo)
 387                 (error "Only ASCII is allowed in quoted-string in the header. "))))
 388         (if open
 389             (progn
 390               (mew-draft-undo)
 391               (error "Comment must be closed in the header. ")))
 392         (mew-header-encode-cond2 'comment)
 393         (if (equal i len)
 394             ()
 395           (insert ")")
 396           (setq bound (1+ i)))
 397         (setq status 'space))
 398        ;; end of ()
 399        ;; route
 400        ((char-equal c ?<)
 401         (mew-header-encode-cond2 nil)
 402         (if (or (char-equal (char-before (point)) 32)
 403                 (char-equal (char-before (point)) ?\t))
 404             (insert "<")
 405           (insert " <"))
 406         (setq i (1+ i))
 407         (setq bound i)
 408         (setq status 'ascii)
 409         (setq open t)
 410         (catch 'route
 411           (while (< i len)
 412             (setq c (mew-aref str i))
 413             (cond
 414              ((char-equal c ?>)
 415               (setq open nil)
 416               (throw 'route nil))
 417              ((> c 127)
 418               (mew-draft-undo)
 419               (error "<> must contain ASCII only. "))
 420              (t
 421               (insert c)))
 422             (setq i (+ i (mew-charlen c)))))
 423         (if open
 424             (progn
 425               (mew-draft-undo)
 426               (error "<> must be closed in the header. ")))
 427         (if (equal i len)
 428             ()
 429           (insert ">")
 430           (setq bound (1+ i)))
 431         (setq status 'space))
 432        ;; end of <>
 433        ;; space
 434        ((or (char-equal c 32) (char-equal c ?\t))
 435         (cond
 436          ((or (equal status 'ascii) (equal status 'space))
 437           (insert (substring str bound i)) ;; 'ascii
 438           (setq bound i)
 439           (setq status 'space))
 440          ((equal status 'non-ascii)
 441           (setq status 'non-ascii-space)
 442           (setq SBOUND i))))
 443        ;; end of white space
 444        ;; comma
 445        ((char-equal c ?,)
 446         (mew-header-encode-cond2 nil)
 447         (insert ", ")
 448         (setq i (1+ i))
 449         (catch 'comma
 450           (while (< i len)
 451             (setq c (mew-aref str i))
 452             (if (or (char-equal c 32) (char-equal c ?\t) (char-equal c ?\n))
 453                 () ;; loop
 454               (throw 'comma nil))
 455             (setq i (1+ i))))
 456         ;; get back to the end of white spaces
 457         (setq bound i)
 458         (setq c 32)
 459         (setq i (1- i))
 460         (setq status 'space))
 461        ;; end of comma
 462        ;; the others
 463        (t (mew-header-encode-cond c)))
 464       ;; end of outside cond
 465       (setq i (+ i (mew-charlen c))))
 466     ;; end of while
 467     (mew-header-encode-cond2 nil)))
 468
 469 (defun mew-header-encode-text (str &optional comment key-len)
 470   ;; 'comment' means that we are in RFC822 comment "(...)".
 471   (let ((str-list (mew-header-encode-split-string str))
 472         head-is-e e-list)
 473     (if (string-match "^[\t -~]+$" (car str-list))
 474         (progn
 475           ;; ascii
 476           (insert (car str-list))
 477           (setq str-list (cdr str-list)))
 478       (setq head-is-e t))
 479     (while str-list
 480       ;; encoded-words
 481       (if (and key-len head-is-e)
 482           (progn
 483             (setq e-list (mew-header-encode-string (car str-list) key-len))
 484             (setq head-is-e nil))
 485         (setq e-list (mew-header-encode-string (car str-list))))
 486       (insert (mapconcat (function identity) e-list " "))
 487       ;; ascii
 488       (setq str-list (cdr str-list))
 489       (if (car str-list)
 490           (progn
 491             (insert (car str-list))
 492             (setq str-list (cdr str-list)))))))
 493
 494 (defun mew-header-fold-region (beg end med &optional use-tab)
 495   (let ((limit1 med) limit2)
 496     (save-restriction
 497       (narrow-to-region beg end)
 498       (goto-char beg)
 499       (while (not (eobp))
 500         (while (> (- (setq limit2 (save-excursion (end-of-line) (point)))
 501                      (point))
 502                   mew-field-max-length)
 503           (forward-char mew-field-max-length)
 504           (if (re-search-backward "[ \t]" limit1 t)
 505               (progn
 506                 (insert "\n")
 507                 (if use-tab
 508                     (progn
 509                       (delete-char 1)
 510                       (insert "\t"))))
 511             ;; Ugh!
 512             (if (re-search-forward "[ \t]" limit2 t) ;; hold on ayway
 513                 (progn
 514                   (backward-char)
 515                   (insert "\n")
 516                   (if use-tab
 517                       (progn
 518                         (delete-char 1)
 519                         (insert "\t"))))
 520               (forward-line))) ;; give up this line
 521           (setq limit1 (1+ (point))))
 522         (forward-line)
 523         (setq limit1 (1+ (point)))))))
 524
 525 (defun mew-header-encode-region (beg end)
 526   (save-restriction
 527     (narrow-to-region beg end)
 528     (mew-header-sanity-check-region (point-min) (point-max))
 529     (mew-charset-sanity-check (point-min) (point-max))
 530     (goto-char (point-min))
 531     (let (key med type str start last)
 532       (while (not (eobp))
 533         (setq start (point))
 534         (if (not (looking-at mew-keyval))
 535             (forward-line)
 536           (setq key (mew-match 1))
 537           (setq med (match-end 0))
 538           (forward-line)
 539           (mew-header-goto-next)
 540           (setq last (1- (point)))
 541           (if (= last med)
 542               ()
 543             (if (equal (list mew-lc-ascii) (mew-find-cs-region med last))
 544                 () ;; no encoding
 545               (setq str (buffer-substring med (1- (point)))) ;; excluding \n
 546               (delete-region med (point))
 547               (setq type (mew-field-type-for-encoding key))
 548               (cond
 549                ((equal type 'mailbox)
 550                 (mew-header-encode-addr str))
 551                ((equal type 'mime)
 552                 (mew-header-encode-addr str))
 553                ((equal type 'comma-text)
 554                 (mew-header-encode-comma-text str))
 555                ((equal type 'text)
 556                 (mew-header-encode-text str nil (length key)))
 557                ((equal type 'unstruct)
 558                 (mew-header-encode-text str nil (length key))))
 559               (insert "\n")) ;; previously deleted, so insert here
 560             (mew-header-fold-region start (point) med)))))))
 561
 562 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 563 ;;
 564 ;; RFC 2047 decoding
 565 ;;
 566
 567 (defun mew-header-unfold-region (type)
 568   (goto-char (point-min))
 569   (cond
 570    ((equal type 'struct)
 571     ;; If each line doesn't end with ",", unfold it.
 572     ;; In Page 5 of RFC822 says, "Unfolding is accomplished by
 573     ;; regarding CRLF immediately followed by a LWSP-char as
 574     ;; equivalent to the LWSP-char". However, it also says,
 575     ;; "In structured field bodies, multiple linear space ASCII
 576     ;; characters (namely HTABs and SPACEs) are treated as single
 577     ;; spaces and may freely surround any symbol." So, remove
 578     ;; continuous white spaces.
 579     (while (re-search-forward ",[ \t]+\n" nil t)
 580       (replace-match ",\n" nil t))
 581     (goto-char (point-min))
 582     (while (re-search-forward "\\([^,]\\)[ \t]*\n[ \t]+" nil t)
 583       (replace-match (concat (mew-match 1) " ") nil t)))
 584    ((equal type 'text)
 585     ;; In Page 5 of RFC822 says, "Unfolding is accomplished by
 586     ;; regarding CRLF immediately followed by a LWSP-char as
 587     ;; equivalent to the LWSP-char".
 588     (while (re-search-forward "\n\\([ \t]\\)" nil t)
 589       (replace-match (mew-match 1) nil t)))
 590    (t ;; unstruct
 591     )))
 592
 593 (defun mew-header-decode-region (type rbeg rend &optional unfold)
 594   "RFC 2047 decoding. This is liberal on the one point from RFC 2047.
 595 That is, each line may be more than 75. "
 596   (save-restriction
 597     (narrow-to-region rbeg rend)
 598     (goto-char (point-min))
 599     (if (and (not unfold)
 600              (not (re-search-forward mew-header-decode-regex nil t)))
 601         (mew-header-unfold-region type)
 602       (let ((endq-regex "\\(\\\\*\\)\"")
 603             (next-regex (concat "[ \t]*" mew-header-decode-regex))
 604             regex beg end cs-str esc )
 605         (if (or mew-decode-quoted (memq type '(text comma-text)))
 606             ;; unstructured or allow decoding in quoted-string
 607             (setq regex mew-header-decode-regex)
 608           ;; structured or deny decoding in quoted-string
 609           (setq regex (concat endq-regex "\\|" mew-header-decode-regex)))
 610         (mew-header-unfold-region type)
 611         ;; In Page 10 of RFC 2047 says, "When displaying a particular
 612         ;; header field that contains multiple 'encoded-word's, any
 613         ;; 'linear-white-space' that separates a pair of adjacent
 614         ;; 'encoded-word's is ignored".
 615         (goto-char (point-min))
 616         (while (re-search-forward regex nil t)
 617           ;; encoded-word in quoted-string should not be decoded
 618           ;; according to RFC 2047. However, if users wish
 619           ;; (ie mew-decode-quoted is *non-nil*), decode it.
 620           (goto-char (match-beginning 0))
 621           ;; count escapes leads to double quote char
 622           (if (not (eq (following-char) ?\\))
 623               (setq esc 0)
 624             (setq esc (- (match-end 1) (match-beginning 1))))
 625           (forward-char esc)
 626           ;; Now pointer is skipped leading escapes
 627           (if (not (eq (following-char) ?\"))
 628             (while (looking-at next-regex)
 629               (setq beg (match-beginning 0)
 630                     end (match-end 0)
 631                     cs-str (mew-header-decode (mew-match 1)
 632                                               (mew-match 2)
 633                                               (mew-match 3)))
 634               (delete-region beg end)
 635               (insert cs-str))
 636             ;; beginning of quoted string
 637             (goto-char (match-end 0))
 638             (if (= 0 (% esc 2))
 639               ;; skip to end of quoted-string
 640                 (while (and (re-search-forward endq-regex nil t)
 641                             (setq esc (- (match-end 1) (match-beginning 1)))
 642                             (= 1 (% esc 2)))
 643                   (goto-char (match-end 0))))
 644             ))))
 645     (goto-char (point-max))))
 646
 647 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 648 ;;
 649 ;; RFC 2231
 650 ;;
 651
 652 (defun mew-param-encode (str)
 653   (let* ((charset (mew-charset-guess-string str))
 654          (data (mew-charset-to-data charset))
 655          (cs (nth 4 data))
 656          (estr (mew-cs-encode-string str cs))
 657          (len (length estr))
 658          (ret (make-string (* len 3) ?a))
 659          (i 0) (j 0) char)
 660     (while (< i len)
 661       (setq char (aref estr i))
 662       (if (or (and (<= ?0 char) (<= char ?9))
 663               (and (<= ?a char) (<= char ?z))
 664               (and (<= ?A char) (<= char ?Z)))
 665           (aset ret j char)
 666         (aset ret j ?%)
 667         (setq j (1+ j))
 668         (aset ret j (aref "0123456789ABCDEF" (lsh char -4)))
 669         (setq j (1+ j))
 670         (aset ret j (aref "0123456789ABCDEF" (logand char 15))))
 671       (setq i (1+ i) j (1+ j)))
 672     (concat charset "''" (substring ret 0 j))))
 673
 674 (defun mew-param-decode (whole-value)
 675   (let* ((value-params (mew-addrstr-parse-value-list whole-value))
 676          (value (car value-params))
 677          (params (cdr value-params))
 678          (max 0) num
 679          ret ext ea ext-sort entry charset cs
 680          paramname-value paramname paramvalue)
 681     (while params
 682       (setq paramname-value (mew-param-analyze (car params)))
 683       (setcar paramname-value (downcase (nth 0 paramname-value)))
 684       (if (equal (length paramname-value) 2)
 685           (setq ret (cons paramname-value ret))
 686         (setq ext (cons paramname-value ext))
 687         (setq num (nth 2 paramname-value))
 688         (if (> num max) (setq max num)))
 689       (setq params (cdr params)))
 690     (if (null ext)
 691         (cons value (nreverse ret)) ;; fast return
 692       (setq max (1+ max))
 693       (while ext
 694         (setq ea (car ext))
 695         (setq paramname (nth 0 ea))
 696         (setq paramvalue (nth 1 ea))
 697         (setq num (nth 2 ea))
 698         (if (setq entry (assoc paramname ext-sort))
 699             (progn
 700               (aset (nth 1 entry) num paramvalue)
 701               (if (not (equal num 0))
 702                   ()
 703                 (setcar (nthcdr 2 entry) (nth 3 ea)) ;; charset
 704                 (setcar (nthcdr 3 entry) (nth 4 ea)))) ;; lang
 705           (setq entry (make-vector max nil))
 706           (aset entry num paramvalue)
 707           (setq ext-sort
 708                 (cons (list paramname entry (nth 3 ea) (nth 4 ea))
 709                       ext-sort)))
 710         (setq ext (cdr ext)))
 711       (while ext-sort
 712         (setq ea (car ext-sort))
 713         (setq paramvalue nil)
 714         (setq paramname (nth 0 ea))
 715         (setq entry (nth 1 ea))
 716         (setq charset (nth 2 ea))
 717         (setq num 0)
 718         (catch 'concat-loop
 719           (while (< num max)
 720             (if (aref entry num)
 721                 (setq paramvalue (concat paramvalue (aref entry num))) ;; xxx
 722               (throw 'concat-loop nil))
 723             (setq num (1+ num))))
 724         (if charset
 725             (progn
 726               (setq cs (mew-charset-to-cs charset))
 727               (if (and (null cs) (not (mew-case-equal charset mew-us-ascii)))
 728                   (setq paramvalue mew-error-unknown-charset)
 729                 (setq paramvalue (mew-cs-decode-string paramvalue cs)))))
 730         (setq ret (cons (list paramname paramvalue) ret))
 731         (setq ext-sort (cdr ext-sort)))
 732       (cons value (nreverse ret))))) ;; late return
 733
 734 (defun mew-param-analyze (param)
 735   "Return (paramname paramvalue) or (paramname paramvalue section charset lang)."
 736   (let* (name section asterisk value charset lang)
 737     (if (not (string-match
 738               "^\\([^=*]+\\)\\(\\|\\*[0-9]+\\)\\(\\*?\\)=\\(.*\\)$" param))
 739         ()
 740       (setq name (mew-match 1 param))
 741       (setq section (mew-match 2 param)) ;; *21
 742       (setq asterisk (string= (mew-match 3 param) "*"))
 743       (setq value (mew-match 4 param))
 744       (if (string= section "")
 745           (if asterisk
 746               (setq section 0)
 747             (setq section nil))
 748         (setq section (string-to-int (substring section 1 nil))))
 749       (if (null asterisk)
 750           ;; delete quote
 751           (if (and (< 1 (length value))
 752                    (char-equal (aref value 0) 34)
 753                    (char-equal (aref value (1- (length value))) 34))
 754               (setq value (substring value 1 -1)))
 755         (if (and (equal section 0)
 756                  (string-match "^\\([^']*\\)'\\([^']*\\)'\\(.*\\)$" value))
 757             (progn
 758               (setq charset (mew-match 1 value))
 759               (setq lang (mew-match 2 value))
 760               (if (string= lang "") (setq lang nil))
 761               (setq value (mew-match 3 value))
 762               (if (string= value "") (setq value nil))))
 763         (setq value (mew-header-decode-qp value ?%)))
 764       (if section
 765           (list name value section charset lang)
 766         (list name value)))))
 767
 768 (provide 'mew-bq)
 769
 770 ;;; Copyright Notice:
 771
 772 ;; Copyright (C) 1997, 1998, 1999 Mew developing team.
 773 ;; All rights reserved.
 774
 775 ;; Redistribution and use in source and binary forms, with or without
 776 ;; modification, are permitted provided that the following conditions
 777 ;; are met:
 778 ;;
 779 ;; 1. Redistributions of source code must retain the above copyright
 780 ;;    notice, this list of conditions and the following disclaimer.
 781 ;; 2. Redistributions in binary form must reproduce the above copyright
 782 ;;    notice, this list of conditions and the following disclaimer in the
 783 ;;    documentation and/or other materials provided with the distribution.
 784 ;; 3. Neither the name of the team nor the names of its contributors
 785 ;;    may be used to endorse or promote products derived from this software
 786 ;;    without specific prior written permission.
 787 ;;
 788 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 789 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 790 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 791 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 792 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 793 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 794 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 795 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 796 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 797 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 798 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 799
 800 ;;; mew-bq.el ends here