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 &optional eword-filter)
  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
  24 If EWORD-FILTER is non-nil, it should be closure. it is called for
  25 each successful decoded encoded-word with decoded string as a
  26 argument. The return value of EWORD-FILTER is used as decoding result
  27 instead of its argument."
  28   (let* ((key (ew-cons* field-name field-body eword-filter
  29                         (ew-dynamic-options)))
  30          (tmp (assoc key ew-decode-field-cache-buf)))
  31     (if tmp
  32         (cdr tmp)
  33       (progn
  34         (setq tmp (nthcdr ew-decode-field-cache-num
  35                           ew-decode-field-cache-buf))
  36         (if (cdr tmp)
  37             (progn
  38               (setcdr (cdr tmp) ew-decode-field-cache-buf)
  39               (setq ew-decode-field-cache-buf (cdr tmp))
  40               (setcdr tmp nil))
  41           (setq ew-decode-field-cache-buf
  42                 (cons (cons nil nil)
  43                       ew-decode-field-cache-buf)))
  44         (setcar (car ew-decode-field-cache-buf) key)
  45         (setcdr (car ew-decode-field-cache-buf)
  46                 (ew-decode-field-no-cache
  47                  field-name field-body eword-filter))
  48         (cdar ew-decode-field-cache-buf)))))
  49
  50 (defun ew-decode-field-no-cache (field-name field-body &optional eword-filter)
  51   "No caching version of ew-decode-field."
  52   (let ((tmp (assq (intern (downcase field-name)) ew-decode-field-syntax-alist))
  53         frag-anchor frag1 frag2 decode)
  54     (if tmp
  55         (setq tmp (cdr tmp))
  56       (setq tmp ew-decode-field-default-syntax))
  57     (setq frag-anchor (funcall (car tmp) (1+ (length field-name)) field-body))
  58     ;;(setq zzz frag-anchor)
  59     (when (and (eq (car tmp) 'ew-scan-unibyte-unstructured)
  60                ew-decode-sticked-encoded-word)
  61       (ew-separate-eword (get frag-anchor 'next-frag)
  62                          frag-anchor
  63                          '(ew:us-texts)))
  64     (when (cdr tmp)
  65       (ew-mark (cdr tmp) frag-anchor))
  66     (setq frag1 (get frag-anchor 'next-frag))
  67     (while (not (eq frag1 frag-anchor))
  68       (setq decode (get frag1 'decode))
  69       (setq frag2 (get frag1 'next-frag))
  70       (while (and (not (eq frag2 frag-anchor))
  71                   (eq decode (get frag2 'decode)))
  72         (setq frag2 (get frag2 'next-frag)))
  73       (funcall decode frag-anchor frag1 frag2 eword-filter)
  74       (setq frag1 frag2))
  75     (setq frag1 (get frag-anchor 'prev-frag)
  76           tmp ())
  77     (while (not (eq frag1 frag-anchor))
  78       (setq tmp (cons (or (get frag1 'decoded) (symbol-name frag1)) tmp)
  79             frag1 (get frag1 'prev-frag)))
  80     (apply 'concat tmp)))
  81
  82 (defun ew-mark (tag anchor)
  83   (let ((tlist (cons (list (symbol-value tag)) (ew-pair-list anchor))))
  84     ;;(insert (format "%s" tlist))
  85     (ew-parse
  86      (lambda ()
  87        (if (null tlist)
  88            (cons 0 anchor)
  89          (prog1 (car tlist) (setq tlist (cdr tlist)))))
  90      (lambda (msg tok)
  91        (message "%s%s : %s" msg tok anchor)
  92        (when (< 0 ew-parse-error-sit-for-seconds)
  93          (sit-for ew-parse-error-sit-for-seconds))))))
  94
  95 (defun ew-decode-none (anchor frag end eword-filter)
  96   (while (not (eq frag end))
  97     (put frag 'decoded (funcall ew-decode-us-ascii (symbol-name frag)))
  98     (setq frag (get frag 'next-frag))))
  99
 100 (defun ew-decode-generic (anchor start end
 101                           decode-ewords
 102                           decode-others
 103                           eword gap all
 104                           eword-filter)
 105   (let ((frag start) result buff type f)
 106     (while (not (eq frag end))
 107       (setq type (get frag 'type))
 108       (cond
 109        ((and (memq type eword)
 110              (ew-proper-eword-p frag))
 111         (when buff
 112           (setq result (ew-rappend result
 113                                    (funcall decode-others
 114                                             (nreverse buff)))
 115                 buff ()))
 116         (let ((first frag) (ewords (list frag)))
 117           (while (progn
 118                    (setq f (get frag 'next-frag))
 119                    (while (and (not (eq f end))
 120                                (memq (get f 'type) gap))
 121                      (setq f (get f 'next-frag)))
 122                    (and (not (eq f end))
 123                         (ew-proper-eword-p f)))
 124             (setq ewords (ew-rcons* ewords f)
 125                   frag f))
 126           (while (not (eq first frag))
 127             (put first 'decoded "")
 128             (setq first (get first 'next-frag)))
 129           (put frag 'decoded "")
 130           (setq result (ew-rappend result
 131                                    (funcall decode-ewords
 132                                             (nreverse ewords)
 133                                             eword-filter)))))
 134        ((memq type all)
 135         (setq buff (cons frag buff))
 136         (put frag 'decoded ""))
 137        (t
 138         (error "unexpected token: %s (%s)" frag type)))
 139       (setq frag (get frag 'next-frag)))
 140     (when buff
 141       (setq result (ew-rappend result (funcall decode-others (nreverse buff)))))
 142     (put start 'decoded
 143          (apply 'ew-quote-concat (nreverse result)))
 144     ))
 145
 146 (defun ew-decode-generic-others (frags puncts quotes targets)
 147   (let (result buff frag type tmp)
 148     (while frags
 149       (setq frag (car frags)
 150             type (get frag 'type)
 151             frags (cdr frags))
 152       (cond
 153        ((memq type puncts)
 154         (when buff
 155           (setq buff (nreverse buff)
 156                 tmp (funcall ew-decode-us-ascii
 157                              (mapconcat 'car buff "")))
 158           (if (ew-contain-non-ascii-p tmp)
 159               (setq result (ew-rcons* result tmp))
 160             (setq result (ew-rcons*
 161                           result
 162                           (funcall ew-decode-us-ascii
 163                                    (mapconcat 'cdr buff "")))))
 164           (setq buff ()))
 165         (setq result (ew-rcons*
 166                       result
 167                       (symbol-name frag))))
 168        ((memq type quotes)
 169         (setq buff (ew-rcons*
 170                     buff
 171                     (cons (substring (symbol-name frag) 1)
 172                           (symbol-name frag)))))
 173        ((memq type targets)
 174         (setq buff (ew-rcons*
 175                     buff
 176                     (cons (symbol-name frag)
 177                           (symbol-name frag)))))
 178        (t
 179         (error "something wrong: unexpected token: %s (%s)" frag type))))
 180     (when buff
 181       (setq buff (nreverse buff)
 182             tmp (funcall ew-decode-us-ascii
 183                          (mapconcat 'car buff "")))
 184       (if (ew-contain-non-ascii-p tmp)
 185           (setq result (ew-rcons* result tmp))
 186         (setq result (ew-rcons*
 187                       result
 188                       (funcall ew-decode-us-ascii
 189                                (mapconcat 'cdr buff "")))))
 190       (setq buff ()))
 191     (nreverse result)))
 192
 193 (defun ew-decode-unstructured-ewords (ewords eword-filter)
 194   (let (result)
 195     (while ewords
 196       (setq result (ew-rcons*
 197                     result
 198                     (list (ew-decode-eword (symbol-name (car ewords))
 199                                            eword-filter
 200                                            'ew-encode-crlf)))
 201             ewords (cdr ewords)))
 202     (nreverse result)))
 203
 204 (defun ew-decode-unstructured-others (frags)
 205   (let (result)
 206     (while frags
 207       (setq result (ew-rcons*
 208                     result
 209                     (symbol-name (car frags)))
 210             frags (cdr frags)))
 211     (list (funcall ew-decode-us-ascii
 212                    (apply 'concat (nreverse result))))))
 213
 214 (defun ew-decode-unstructured (anchor start end eword-filter)
 215   (ew-decode-generic
 216    anchor start end
 217    'ew-decode-unstructured-ewords
 218    'ew-decode-unstructured-others
 219    '(ew:us-texts)
 220    '(ew:us-wsp
 221      ew:us-fold)
 222    '(ew:us-texts
 223      ew:us-wsp
 224      ew:us-fold)
 225    eword-filter))
 226
 227 (defun ew-decode-phrase-ewords (ewords eword-filter)
 228   (let ((qs (eq (get (car ewords) 'type) 'ew:qs-texts))
 229         require-quoting
 230         result)
 231     (while ewords
 232       (setq result (ew-rcons*
 233                     result
 234                     (list (ew-decode-eword (symbol-name (car ewords))
 235                                            eword-filter
 236                                            'ew-encode-crlf)))
 237             require-quoting (or require-quoting
 238                                 (string-match "[][()<>@,;:\\\".\000-\037]"
 239                                               (caar result)))
 240             ewords (cdr ewords)))
 241     (if require-quoting
 242         (list
 243          (funcall (if qs 'ew-embed-in-quoted-string 'ew-embed-in-phrase)
 244                   (apply 'ew-quote-concat
 245                          (nreverse result))))
 246       (nreverse result))))
 247
 248 (defun ew-decode-phrase-others (frags)
 249   (ew-decode-generic-others
 250    frags
 251    '(ew:qs-begin
 252      ew:qs-end)
 253    '(ew:qs-qfold
 254      ew:qs-qpair)
 255    '(ew:atom
 256      ew:wsp
 257      ew:fold
 258      ew:qs-texts
 259      ew:qs-wsp
 260      ew:qs-fold)))
 261
 262 (defun ew-decode-phrase (anchor start end eword-filter)
 263   (ew-decode-generic
 264    anchor start end
 265    'ew-decode-phrase-ewords
 266    'ew-decode-phrase-others
 267    (if ew-decode-quoted-encoded-word
 268        '(ew:atom ew:qs-texts)
 269      '(ew:atom))
 270    '(ew:wsp
 271      ew:fold)
 272    '(ew:atom
 273      ew:wsp
 274      ew:fold
 275      ew:qs-begin
 276      ew:qs-end
 277      ew:qs-texts
 278      ew:qs-wsp
 279      ew:qs-fold
 280      ew:qs-qfold
 281      ew:qs-qpair)
 282    eword-filter))
 283
 284 (defun ew-decode-comment-ewords (ewords eword-filter)
 285   (let (require-quoting
 286         result)
 287     (while ewords
 288       (setq result (ew-rcons*
 289                     result
 290                     (list (ew-decode-eword (symbol-name (car ewords))
 291                                            eword-filter
 292                                            'ew-encode-crlf)))
 293             require-quoting (or require-quoting
 294                                 (string-match "[()\\\\]" (caar result)))
 295             ewords (cdr ewords)))
 296     (if require-quoting
 297         (list
 298          (ew-embed-in-comment
 299           (apply 'ew-quote-concat
 300                  (nreverse result))))
 301       (nreverse result))))
 302
 303 (defun ew-decode-comment-others (frags)
 304   (ew-decode-generic-others
 305    frags
 306    '()
 307    '(ew:cm-qfold
 308      ew:cm-qpair)
 309    '(ew:cm-texts
 310      ew:cm-wsp
 311      ew:cm-fold)))
 312
 313 (defun ew-decode-comment (anchor start end eword-filter)
 314   (ew-decode-generic
 315    anchor start end
 316    'ew-decode-comment-ewords
 317    'ew-decode-comment-others
 318    '(ew:cm-texts)
 319    '(ew:cm-wsp
 320      ew:cm-fold)
 321    '(ew:cm-texts
 322      ew:cm-wsp
 323      ew:cm-fold
 324      ew:cm-qfold
 325      ew:cm-qpair)
 326    eword-filter))
 327
 328 ;;;
 329
 330 (defun ew-embed-in-phrase (str)
 331   (concat "\"" (ew-embed-in-quoted-string str) "\""))
 332
 333 (defun ew-embed-in-quoted-string (str)
 334   (ew-quote-as-quoted-pair str '(?\\ ?\")))
 335
 336 (defun ew-embed-in-comment (str)
 337   (ew-quote-as-quoted-pair str '(?\\ ?\( ?\))))
 338
 339 (defun ew-quote-as-quoted-pair (str specials)
 340   (let ((i 0) (j 0) (l (length str)) result)
 341     (while (< j l)
 342       (when (member (aref str j) specials)
 343         (setq result (ew-rcons*
 344                       result
 345                       (substring str i j)
 346                       "\\")
 347               i j))
 348       (setq j (1+ j)))
 349     (when (< i l)
 350       (setq result (ew-rcons*
 351                     result
 352                     (substring str i))))
 353     (apply 'concat (nreverse result))))
 354
 355 ;;;
 356
 357 (defun ew-proper-eword-p (frag)
 358   (and
 359    (or ew-ignore-75bytes-limit
 360        (<= (length (symbol-name frag)) 75))
 361    (or ew-ignore-76bytes-limit
 362        (<= (get frag 'line-length) 76))
 363    (cond
 364     ((eq (get frag 'type) 'ew:cm-texts)
 365      (ew-eword-p (symbol-name frag)))
 366     ((eq (get frag 'type) 'ew:qs-texts)
 367      (ew-eword-p (symbol-name frag)))
 368     ((eq (get frag 'type) 'ew:atom)
 369      (and
 370       (or ew-permit-sticked-comment
 371           (and
 372            (not (ew-comment-frag-p (get frag 'prev-frag)))
 373            (not (ew-comment-frag-p (get frag 'next-frag)))))
 374       (or ew-permit-sticked-special
 375           (and
 376            (or (ew-comment-frag-p (get frag 'prev-frag))
 377                (not (ew-special-frag-p (get frag 'prev-frag))))
 378            (or (ew-comment-frag-p (get frag 'next-frag))
 379                (not (ew-special-frag-p (get frag 'next-frag))))))
 380       (ew-eword-p (symbol-name frag))))
 381     ((eq (get frag 'type) 'ew:us-texts)
 382      (and
 383       (or ew-permit-sticked-special
 384           (not (ew-special-frag-p (get frag 'prev-frag))))
 385       (ew-eword-p (symbol-name frag))))
 386     (t
 387      nil))))
 388
 389 (defun ew-contain-non-ascii-p (str)
 390   (not (eq (charsets-to-mime-charset (find-charset-string str)) 'us-ascii)))
 391
 392 '(
 393
 394 (ew-decode-field "To" " =?US-ASCII?Q?phrase?= <akr@jaist.ac.jp>")
 395 (ew-decode-field "To" " =?US-ASCII?Q?phrase?= < =?US-ASCII?Q?akr?= @jaist.ac.jp>")
 396 (ew-decode-field "To" " =?US-ASCII?Q?akr?= @jaist.ac.jp")
 397 (ew-decode-field "Subject" " =?ISO-2022-JP?B?GyRCJCIbKEI=?=")
 398 (ew-decode-field "Content-Type" " text/vnd.latex-z(=?US-ASCII?Q?What=3F?=);charset=ISO-2022-JP")
 399
 400 (ew-decode-field "To" " =?US-ASCII?Q?A=22B=5CC?= <akr@jaist.ac.jp>")
 401 (let ((ew-decode-quoted-encoded-word t))
 402   (ew-decode-field "To" " \"=?US-ASCII?Q?A=22B=5CC?=\" <akr@jaist.ac.jp>"))
 403
 404 (ew-decode-field "To" " akr@jaist.ac.jp (=?US-ASCII?Q?=28A=29B=5C?=)")
 405
 406 (ew-decode-field "To" "\"A\\BC\e$B\\\"\\\\\e(B\" <foo@bar>")
 407 (ew-decode-field "To" "\"A\\BC\" <foo@bar>")
 408 (ew-decode-field "To" "\"\e\\$\\B\\$\\\"\e\\(\\B\" <foo@bar>")
 409
 410 )