ew-dec.el

   1 (require 'emu)
   2 (require 'ew-var)
   3 (require 'ew-unit)
   4 (require 'ew-scan-s)
   5 (require 'ew-scan-m)
   6 (require 'ew-scan-u)
   7 (require 'ew-parse)
   8 (provide 'ew-dec)
   9
  10 (defvar ew-decode-field-cache-buf '())
  11 (defvar ew-decode-field-cache-num 300)
  12
  13 (defun ew-decode-field (field-name field-body)
  14   "Decode MIME RFC2047 encoded-words in a field.
  15 FIELD-NAME is a name of the field such as \"To\", \"Subject\" etc. and
  16 used to selecting syntax of body of the field and deciding first
  17 column of body of the field.
  18 FIELD-BODY is a body of the field.
  19
  20 If FIELD-BODY has multiple lines, each line is separated by CRLF as
  21 pure network representation. Also if the result has multiple lines,
  22 each line is separated by CRLF."
  23   (let* ((key (ew-cons* field-name field-body
  24                         (ew-dynamic-options)))
  25          (tmp (assoc key ew-decode-field-cache-buf)))
  26     (if tmp
  27         (cdr tmp)
  28       (progn
  29         (setq tmp (nthcdr ew-decode-field-cache-num
  30                           ew-decode-field-cache-buf))
  31         (if (cdr tmp)
  32             (progn
  33               (setcdr (cdr tmp) ew-decode-field-cache-buf)
  34               (setq ew-decode-field-cache-buf (cdr tmp))
  35               (setcdr tmp nil))
  36           (setq ew-decode-field-cache-buf
  37                 (cons (cons nil nil)
  38                       ew-decode-field-cache-buf)))
  39         (setcar (car ew-decode-field-cache-buf) key)
  40         (setcdr (car ew-decode-field-cache-buf)
  41                 (ew-decode-field-no-cache
  42                  field-name field-body))
  43         (cdar ew-decode-field-cache-buf)))))
  44
  45 (defun ew-analyze-field-to-decode (field-name field-body)
  46   "Analyze FIELD-BODY to decode."
  47   (let ((tmp (assq (intern (downcase field-name)) ew-decode-field-syntax-alist))
  48         anchor)
  49     (if tmp
  50         (setq tmp (cdr tmp))
  51       (setq tmp ew-decode-field-default-syntax))
  52     (setq anchor (funcall (car tmp) (1+ (length field-name)) field-body))
  53     (put anchor 'field-name field-name)
  54     (put anchor 'scanner (car tmp))
  55     (put anchor 'marker (cdr tmp))
  56     anchor))
  57
  58 (defun ew-decode-analyzed-field (anchor)
  59   "Decode analyzed field."
  60   (or (get anchor 'decoded)
  61       (let (tmp frag1 frag2 decode)
  62         (when ew-decode-sticked-encoded-word
  63           (ew-separate-eword
  64            (get anchor 'next-frag)
  65            anchor
  66            (if (eq (get anchor 'scanner) 'ew-scan-unibyte-unstructured)
  67                '(ew:us-texts)
  68              '(ew:cm-texts))))
  69         (when (get anchor 'marker)
  70           (ew-mark (get anchor 'marker) anchor))
  71         (setq frag1 (get anchor 'next-frag))
  72         (while (not (eq frag1 anchor))
  73           (setq decode (get frag1 'decode))
  74           (setq frag2 (get frag1 'next-frag))
  75           (while (and (not (eq frag2 anchor))
  76                       (eq decode (get frag2 'decode)))
  77             (setq frag2 (get frag2 'next-frag)))
  78           (funcall decode anchor frag1 frag2)
  79           (setq frag1 frag2))
  80         (setq frag1 (get anchor 'prev-frag)
  81               tmp ())
  82         (while (not (eq frag1 anchor))
  83           (setq tmp (cons (or (get frag1 'decoded) (symbol-name frag1)) tmp)
  84                 frag1 (get frag1 'prev-frag)))
  85         (put anchor 'decoded (apply 'concat tmp)))))
  86
  87 (defun ew-decode-field-no-cache (field-name field-body)
  88   "No caching version of ew-decode-field."
  89   (ew-decode-analyzed-field
  90    (ew-analyze-field-to-decode field-name field-body)))
  91
  92 (defun ew-mark (tag anchor)
  93   (let ((tlist (cons (list (symbol-value tag)) (ew-pair-list anchor))))
  94     ;;(insert (format "%s" tlist))
  95     (ew-parse
  96      (lambda ()
  97        (if (null tlist)
  98            (cons 0 anchor)
  99          (prog1 (car tlist) (setq tlist (cdr tlist)))))
 100      (lambda (msg tok)
 101        (message "%s%s : %s" msg tok anchor)
 102        (when (< 0 ew-parse-error-sit-for-seconds)
 103          (sit-for ew-parse-error-sit-for-seconds))))))
 104
 105 (defsubst ew-decode-us-ascii (str)
 106   (decode-mime-charset-string str ew-default-mime-charset 'LF))
 107
 108 (defun ew-decode-none (anchor frag end)
 109   (while (not (eq frag end))
 110     (put frag 'decoded (ew-decode-us-ascii (symbol-name frag)))
 111     (setq frag (get frag 'next-frag))))
 112
 113 (defsubst ew-proper-eword-p (frag)
 114   (and
 115    (or ew-ignore-75bytes-limit
 116        (<= (length (symbol-name frag)) 75))
 117    (or ew-ignore-76bytes-limit
 118        (<= (get frag 'line-length) 76))
 119    (cond
 120     ((eq (get frag 'type) 'ew:cm-texts)
 121      (ew-eword-p (symbol-name frag)))
 122     ((eq (get frag 'type) 'ew:qs-texts)
 123      (ew-eword-p (symbol-name frag)))
 124     ((eq (get frag 'type) 'ew:atom)
 125      (and
 126       (or ew-permit-sticked-comment
 127           (and
 128            (not (ew-comment-frag-p (get frag 'prev-frag)))
 129            (not (ew-comment-frag-p (get frag 'next-frag)))))
 130       (or ew-permit-sticked-special
 131           (and
 132            (or (ew-comment-frag-p (get frag 'prev-frag))
 133                (not (ew-special-frag-p (get frag 'prev-frag))))
 134            (or (ew-comment-frag-p (get frag 'next-frag))
 135                (not (ew-special-frag-p (get frag 'next-frag))))))
 136       (ew-eword-p (symbol-name frag))))
 137     ((eq (get frag 'type) 'ew:us-texts)
 138      (and
 139       (or ew-permit-sticked-special
 140           (not (ew-special-frag-p (get frag 'prev-frag))))
 141       (ew-eword-p (symbol-name frag))))
 142     (t
 143      nil))))
 144
 145 (defun ew-decode-generic (anchor start end
 146                           decode-ewords
 147                           decode-others
 148                           eword gap all)
 149   (let ((frag start) (start-others start) type f)
 150     (while (not (eq frag end))
 151       (setq type (get frag 'type))
 152       (cond
 153        ((and (memq type eword)
 154              (ew-proper-eword-p frag))
 155         (when (not (eq start-others frag))
 156           (funcall decode-others start-others frag))
 157         (let ((first frag) (ewords (list frag)))
 158           (while (progn
 159                    (setq f (get frag 'next-frag))
 160                    (while (and (not (eq f end))
 161                                (memq (get f 'type) gap))
 162                      (setq f (get f 'next-frag)))
 163                    (and (not (eq f end))
 164                         (ew-proper-eword-p f)))
 165             (setq frag (get frag 'next-frag))
 166             (while (not (eq frag f))
 167               (put frag 'decoded "")
 168               (setq frag (get frag 'next-frag)))
 169             (setq ewords (ew-rcons* ewords f)
 170                   frag f))
 171           (funcall decode-ewords
 172                    (nreverse ewords)))
 173         (setq start-others (get frag 'next-frag)))
 174        ((memq type all)
 175         nil)
 176        (t
 177         (error "unexpected token: %s (%s)" frag type)))
 178       (setq frag (get frag 'next-frag)))
 179     (when (not (eq start-others end))
 180       (funcall decode-others start-others end))))
 181
 182 (defun ew-decode-generic-others (start end puncts quotes targets)
 183   (let ((frag start) (start-nonpunct start) type buff tmp)
 184     (while (not (eq frag end))
 185       (setq type (get frag 'type))
 186       (cond
 187        ((memq type puncts)
 188         (when buff
 189           (setq buff (apply 'concat (nreverse buff))
 190                 tmp (ew-decode-us-ascii buff))
 191           (if (equal buff tmp)
 192               (while (not (eq start-nonpunct frag))
 193                 (put start-nonpunct 'decoded (symbol-name start-nonpunct))
 194                 (setq start-nonpunct (get start-nonpunct 'next-frag)))
 195             (progn
 196               (put start-nonpunct 'decoded tmp)
 197               (setq start-nonpunct (get start-nonpunct 'next-frag))
 198               (while (not (eq start-nonpunct frag))
 199                 (put start-nonpunct 'decoded "")
 200                 (setq start-nonpunct (get start-nonpunct 'next-frag)))))
 201           (setq buff ()))
 202         (put frag 'decoded (symbol-name frag))
 203         (setq start-nonpunct (get frag 'next-frag)))
 204        ((memq type quotes)
 205         (setq buff (ew-rcons* buff
 206                               (substring (symbol-name frag) 1))))
 207        ((memq type targets)
 208         (setq buff (ew-rcons* buff
 209                               (symbol-name frag))))
 210        (t (error "something wrong: unexpected token: %s (%s)" frag type)))
 211       (setq frag (get frag 'next-frag)))
 212     (when buff
 213       (setq buff (apply 'concat (nreverse buff))
 214             tmp (ew-decode-us-ascii buff))
 215       (if (equal buff tmp)
 216           (while (not (eq start-nonpunct frag))
 217             (put start-nonpunct 'decoded (symbol-name start-nonpunct))
 218             (setq start-nonpunct (get start-nonpunct 'next-frag)))
 219         (progn
 220           (put start-nonpunct 'decoded tmp)
 221           (setq start-nonpunct (get start-nonpunct 'next-frag))
 222           (while (not (eq start-nonpunct frag))
 223             (put start-nonpunct 'decoded "")
 224             (setq start-nonpunct (get start-nonpunct 'next-frag))))))))
 225
 226 (defun ew-decode-unstructured-ewords (ewords)
 227   (while ewords
 228     (put (car ewords)
 229          'decoded
 230          (list (ew-decode-eword (symbol-name (car ewords)))))
 231     (setq ewords (cdr ewords))))
 232
 233 (defun ew-decode-unstructured-others (start end)
 234   (let (strs)
 235     (while (not (eq start end))
 236       (put start 'decoded "")
 237       (setq strs (ew-rcons* strs
 238                             (symbol-name start))
 239             start (get start 'next-frag)))
 240     (put (get end 'prev-frag)
 241          'decoded
 242          (ew-decode-us-ascii
 243           (apply 'concat (nreverse strs))))))
 244
 245 (defun ew-decode-unstructured (anchor start end)
 246   (ew-decode-generic
 247    anchor start end
 248    'ew-decode-unstructured-ewords
 249    'ew-decode-unstructured-others
 250    '(ew:us-texts)
 251    '(ew:us-wsp
 252      ew:us-fold)
 253    '(ew:us-texts
 254      ew:us-wsp
 255      ew:us-fold))
 256   (let ((frag end) tmp)
 257     (while (not (eq frag start))
 258       (setq frag (get frag 'prev-frag)
 259             tmp (cons (get frag 'decoded) tmp))
 260       (put frag 'decoded ""))
 261     (put start 'decoded (ew-encode-crlf (apply 'ew-quote-concat tmp)))))
 262
 263 (defun ew-decode-phrase-ewords (ewords)
 264   (let* ((qs (eq (get (car ewords) 'type) 'ew:qs-texts))
 265          (regexp (if qs "[\\\\\\\"]" "[][()<>@,;:\\\\\\\".\000-\037]"))
 266          has-dangerous-char
 267          tmp decoded)
 268     (setq tmp ewords)
 269     (while tmp
 270       (put (car tmp)
 271            'decoded
 272            (list (setq decoded (ew-decode-eword (symbol-name (car tmp))))))
 273       (setq tmp (cdr tmp)
 274             has-dangerous-char (or has-dangerous-char
 275                                    (string-match regexp decoded))))
 276     (when has-dangerous-char
 277       (setq tmp ewords)
 278       (while tmp
 279         (setq decoded (get (car tmp) 'decoded))
 280         (setcar decoded (ew-embed-in-quoted-string (car decoded)))
 281         (setq tmp (cdr tmp)))
 282       (when (not qs)
 283         (setq decoded (get (car ewords) 'decoded))
 284         (setcar decoded (concat "\"" (car decoded)))
 285         (setq decoded (get (car (last ewords)) 'decoded))
 286         (setcar decoded (concat (car decoded) "\""))))))
 287
 288 (defun ew-decode-phrase-others (start end)
 289   (ew-decode-generic-others
 290    start end
 291    '(ew:qs-begin
 292      ew:qs-end)
 293    '(ew:qs-qfold
 294      ew:qs-qpair)
 295    '(ew:atom
 296      ew:wsp
 297      ew:fold
 298      ew:qs-texts
 299      ew:qs-wsp
 300      ew:qs-fold)))
 301
 302 (defmacro ew-rotate (var val len)
 303   (let ((tmp (make-symbol "tmp")))
 304     `(let ((,tmp (nthcdr ,(- len 2) ,var)))
 305        (if (cdr ,tmp)
 306            (progn
 307              (setcdr (cdr ,tmp) ,var)
 308              (setq ,var (cdr ,tmp))
 309              (setcdr ,tmp nil))
 310          (setq ,var (cons nil ,var)))
 311        (setcar ,var ,val))))
 312
 313 (defun ew-decode-phrase (anchor start end)
 314   (ew-decode-generic
 315    anchor start end
 316    'ew-decode-phrase-ewords
 317    'ew-decode-phrase-others
 318    (if ew-decode-quoted-encoded-word
 319        '(ew:atom ew:qs-texts)
 320      '(ew:atom))
 321    '(ew:wsp
 322      ew:fold
 323      ew:qs-wsp
 324      ew:qs-fold)
 325    '(ew:atom
 326      ew:wsp
 327      ew:fold
 328      ew:qs-begin
 329      ew:qs-end
 330      ew:qs-texts
 331      ew:qs-wsp
 332      ew:qs-fold
 333      ew:qs-qfold
 334      ew:qs-qpair))
 335   (let ((frag start) decoded str len idx char
 336         chars frags
 337         tmp)
 338     (while (not (eq frag end))
 339       (setq decoded (get frag 'decoded)
 340             str (or (car-safe decoded) decoded)
 341             len (length str)
 342             idx 0)
 343       (while (< idx len)
 344         (setq char (sref str idx))
 345         (ew-rotate chars char 3)
 346         (ew-rotate frags frag 3)
 347         (when (and (not (memq char '(?\t ?\ )))
 348                    (equal (cdr chars) '(?\n ?\r))
 349                    (eq (get (setq tmp (nth 2 frags)) 'type) 'ew:qs-qpair)
 350                    (eq (symbol-name tmp) (get tmp 'decoded)))
 351           (put tmp 'decoded "\r"))
 352         (setq idx (char-next-index char idx)))
 353       (setq frag (get frag 'next-frag)))
 354     (setq frag end
 355           tmp ())
 356     (while (not (eq frag start))
 357       (setq frag (get frag 'prev-frag)
 358             tmp (cons (get frag 'decoded) tmp))
 359       (put frag 'decoded ""))
 360     (put start 'decoded (ew-encode-crlf (apply 'ew-quote-concat tmp)))))
 361
 362 (defun ew-decode-comment-ewords (ewords)
 363   (let* ((regexp "[()\\\\]")
 364          has-dangerous-char
 365          tmp decoded)
 366     (setq tmp ewords)
 367     (while tmp
 368       (put (car tmp)
 369            'decoded
 370            (list (setq decoded (ew-decode-eword (symbol-name (car tmp))))))
 371       (setq tmp (cdr tmp)
 372             has-dangerous-char (or has-dangerous-char
 373                                    (string-match regexp decoded))))
 374     (when has-dangerous-char
 375       (setq tmp ewords)
 376       (while tmp
 377         (setq decoded (get (car tmp) 'decoded))
 378         (setcar decoded (ew-embed-in-comment (car decoded)))
 379         (setq tmp (cdr tmp))))))
 380
 381 (defun ew-decode-comment-others (start end)
 382   (ew-decode-generic-others
 383    start end
 384    '()
 385    '(ew:cm-qfold
 386      ew:cm-qpair)
 387    '(ew:cm-texts
 388      ew:cm-wsp
 389      ew:cm-fold)))
 390
 391 (defun ew-decode-comment (anchor start end)
 392   (ew-decode-generic
 393    anchor start end
 394    'ew-decode-comment-ewords
 395    'ew-decode-comment-others
 396    '(ew:cm-texts)
 397    '(ew:cm-wsp
 398      ew:cm-fold)
 399    '(ew:cm-texts
 400      ew:cm-wsp
 401      ew:cm-fold
 402      ew:cm-qfold
 403      ew:cm-qpair))
 404   (let ((frag start) decoded str len idx char
 405         chars frags tmp)
 406     (while (not (eq frag end))
 407       (setq decoded (get frag 'decoded)
 408             str (or (car-safe decoded) decoded)
 409             len (length str)
 410             idx 0)
 411       (while (< idx len)
 412         (setq char (sref str idx))
 413         (ew-rotate chars char 3)
 414         (ew-rotate frags frag 3)
 415         (when (and (not (memq char '(?\t ?\ )))
 416                    (equal (cdr chars) '(?\n ?\r))
 417                    (eq (get (setq tmp (nth 2 frags)) 'type) 'ew:cm-qpair)
 418                    (eq (symbol-name tmp) (get tmp 'decoded)))
 419           (put tmp 'decoded "\r"))
 420         (setq idx (char-next-index char idx)))
 421       (setq frag (get frag 'next-frag)))
 422     (setq frag end
 423           tmp ())
 424     (while (not (eq frag start))
 425       (setq frag (get frag 'prev-frag)
 426             tmp (cons (get frag 'decoded) tmp))
 427       (put frag 'decoded ""))
 428     (put start 'decoded (ew-encode-crlf (apply 'ew-quote-concat tmp)))))
 429
 430 ;;;
 431
 432 (defun ew-embed-in-phrase (str)
 433   (concat "\"" (ew-embed-in-quoted-string str) "\""))
 434
 435 (defun ew-embed-in-quoted-string (str)
 436   (ew-quote-as-quoted-pair str '(?\\ ?\")))
 437
 438 (defun ew-embed-in-comment (str)
 439   (ew-quote-as-quoted-pair str '(?\\ ?\( ?\))))
 440
 441 (defun ew-quote-as-quoted-pair (str specials)
 442   (let ((i 0) (j 0) (l (length str)) result)
 443     (while (< j l)
 444       (when (member (aref str j) specials)
 445         (setq result (ew-rcons*
 446                       result
 447                       (substring str i j)
 448                       "\\")
 449               i j))
 450       (setq j (1+ j)))
 451     (when (< i l)
 452       (setq result (ew-rcons*
 453                     result
 454                     (substring str i))))
 455     (apply 'concat (nreverse result))))
 456
 457 ;;;
 458
 459 (defun ew-contain-non-ascii-p (str)
 460   (not (eq (charsets-to-mime-charset (find-charset-string str)) 'us-ascii)))
 461
 462 '(
 463
 464 (ew-decode-field "To" " =?US-ASCII?Q?phrase?= <akr@jaist.ac.jp>")
 465 (ew-decode-field "To" " =?US-ASCII?Q?phrase?= < =?US-ASCII?Q?akr?= @jaist.ac.jp>")
 466 (ew-decode-field "To" " =?US-ASCII?Q?akr?= @jaist.ac.jp")
 467 (ew-decode-field "Subject" " =?ISO-2022-JP?B?GyRCJCIbKEI=?=")
 468 (ew-decode-field "Content-Type" " text/vnd.latex-z(=?US-ASCII?Q?What=3F?=);charset=ISO-2022-JP")
 469
 470 (ew-decode-field "To" " =?US-ASCII?Q?A=22B=5CC?= <akr@jaist.ac.jp>")
 471 (let ((ew-decode-quoted-encoded-word t))
 472   (ew-decode-field "To" " \"=?US-ASCII?Q?A=22B=5CC?=\" <akr@jaist.ac.jp>"))
 473
 474 (ew-decode-field "To" " akr@jaist.ac.jp (=?US-ASCII?Q?=28A=29B=5C?=)")
 475
 476 (ew-decode-field "To" "\"A\\BC\e$B\\\"\\\\\e(B\" <foo@bar>")
 477 (ew-decode-field "To" "\"A\\BC\" <foo@bar>")
 478 (ew-decode-field "To" "\"\e\\$\\B\\$\\\"\e\\(\\B\" <foo@bar>")
 479
 480 )