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-us-ascii (str)
  96   (decode-mime-charset-string str ew-default-mime-charset 'LF))
  97
  98 (defun ew-decode-none (anchor frag end eword-filter)
  99   (while (not (eq frag end))
 100     (put frag 'decoded (ew-decode-us-ascii (symbol-name frag)))
 101     (setq frag (get frag 'next-frag))))
 102
 103 (defun ew-decode-generic (anchor start end
 104                           decode-ewords
 105                           decode-others
 106                           eword gap all
 107                           eword-filter)
 108   (let ((frag start) result buff type f)
 109     (while (not (eq frag end))
 110       (setq type (get frag 'type))
 111       (cond
 112        ((and (memq type eword)
 113              (ew-proper-eword-p frag))
 114         (when buff
 115           (setq result (ew-rappend result
 116                                    (funcall decode-others
 117                                             (nreverse buff)))
 118                 buff ()))
 119         (let ((first frag) (ewords (list frag)))
 120           (while (progn
 121                    (setq f (get frag 'next-frag))
 122                    (while (and (not (eq f end))
 123                                (memq (get f 'type) gap))
 124                      (setq f (get f 'next-frag)))
 125                    (and (not (eq f end))
 126                         (ew-proper-eword-p f)))
 127             (setq ewords (ew-rcons* ewords f)
 128                   frag f))
 129           (while (not (eq first frag))
 130             (put first 'decoded "")
 131             (setq first (get first 'next-frag)))
 132           (put frag 'decoded "")
 133           (setq result (ew-rappend result
 134                                    (funcall decode-ewords
 135                                             (nreverse ewords)
 136                                             eword-filter)))))
 137        ((memq type all)
 138         (setq buff (cons frag buff))
 139         (put frag 'decoded ""))
 140        (t
 141         (error "unexpected token: %s (%s)" frag type)))
 142       (setq frag (get frag 'next-frag)))
 143     (when buff
 144       (setq result (ew-rappend result (funcall decode-others (nreverse buff)))))
 145     (put start 'decoded
 146          (apply 'ew-quote-concat (nreverse result)))
 147     ))
 148
 149 (defun ew-decode-generic-others (frags puncts quotes targets)
 150   (let (result buff frag type tmp)
 151     (while frags
 152       (setq frag (car frags)
 153             type (get frag 'type)
 154             frags (cdr frags))
 155       (cond
 156        ((memq type puncts)
 157         (when buff
 158           (setq buff (nreverse buff)
 159                 tmp (ew-decode-us-ascii
 160                      (mapconcat 'car buff "")))
 161           (if (ew-contain-non-ascii-p tmp)
 162               (setq result (ew-rcons* result tmp))
 163             (setq result (ew-rcons*
 164                           result
 165                           (ew-decode-us-ascii
 166                            (mapconcat 'cdr buff "")))))
 167           (setq buff ()))
 168         (setq result (ew-rcons*
 169                       result
 170                       (symbol-name frag))))
 171        ((memq type quotes)
 172         (setq buff (ew-rcons*
 173                     buff
 174                     (cons (substring (symbol-name frag) 1)
 175                           (symbol-name frag)))))
 176        ((memq type targets)
 177         (setq buff (ew-rcons*
 178                     buff
 179                     (cons (symbol-name frag)
 180                           (symbol-name frag)))))
 181        (t
 182         (error "something wrong: unexpected token: %s (%s)" frag type))))
 183     (when buff
 184       (setq buff (nreverse buff)
 185             tmp (ew-decode-us-ascii
 186                  (mapconcat 'car buff "")))
 187       (if (ew-contain-non-ascii-p tmp)
 188           (setq result (ew-rcons* result tmp))
 189         (setq result (ew-rcons*
 190                       result
 191                       (ew-decode-us-ascii
 192                        (mapconcat 'cdr buff "")))))
 193       (setq buff ()))
 194     (nreverse result)))
 195
 196 (defun ew-decode-unstructured-ewords (ewords eword-filter)
 197   (let (result)
 198     (while ewords
 199       (setq result (ew-rcons*
 200                     result
 201                     (list (ew-decode-eword (symbol-name (car ewords))
 202                                            eword-filter
 203                                            'ew-encode-crlf)))
 204             ewords (cdr ewords)))
 205     (nreverse result)))
 206
 207 (defun ew-decode-unstructured-others (frags)
 208   (let (result)
 209     (while frags
 210       (setq result (ew-rcons*
 211                     result
 212                     (symbol-name (car frags)))
 213             frags (cdr frags)))
 214     (list (ew-decode-us-ascii
 215            (apply 'concat (nreverse result))))))
 216
 217 (defun ew-decode-unstructured (anchor start end eword-filter)
 218   (ew-decode-generic
 219    anchor start end
 220    'ew-decode-unstructured-ewords
 221    'ew-decode-unstructured-others
 222    '(ew:us-texts)
 223    '(ew:us-wsp
 224      ew:us-fold)
 225    '(ew:us-texts
 226      ew:us-wsp
 227      ew:us-fold)
 228    eword-filter))
 229
 230 (defun ew-decode-phrase-ewords (ewords eword-filter)
 231   (let ((qs (eq (get (car ewords) 'type) 'ew:qs-texts))
 232         require-quoting
 233         result)
 234     (while ewords
 235       (setq result (ew-rcons*
 236                     result
 237                     (list (ew-decode-eword (symbol-name (car ewords))
 238                                            eword-filter
 239                                            'ew-encode-crlf)))
 240             require-quoting (or require-quoting
 241                                 (string-match "[][()<>@,;:\\\".\000-\037]"
 242                                               (caar result)))
 243             ewords (cdr ewords)))
 244     (if require-quoting
 245         (list
 246          (funcall (if qs 'ew-embed-in-quoted-string 'ew-embed-in-phrase)
 247                   (apply 'ew-quote-concat
 248                          (nreverse result))))
 249       (nreverse result))))
 250
 251 (defun ew-decode-phrase-others (frags)
 252   (ew-decode-generic-others
 253    frags
 254    '(ew:qs-begin
 255      ew:qs-end)
 256    '(ew:qs-qfold
 257      ew:qs-qpair)
 258    '(ew:atom
 259      ew:wsp
 260      ew:fold
 261      ew:qs-texts
 262      ew:qs-wsp
 263      ew:qs-fold)))
 264
 265 (defun ew-decode-phrase (anchor start end eword-filter)
 266   (ew-decode-generic
 267    anchor start end
 268    'ew-decode-phrase-ewords
 269    'ew-decode-phrase-others
 270    (if ew-decode-quoted-encoded-word
 271        '(ew:atom ew:qs-texts)
 272      '(ew:atom))
 273    '(ew:wsp
 274      ew:fold)
 275    '(ew:atom
 276      ew:wsp
 277      ew:fold
 278      ew:qs-begin
 279      ew:qs-end
 280      ew:qs-texts
 281      ew:qs-wsp
 282      ew:qs-fold
 283      ew:qs-qfold
 284      ew:qs-qpair)
 285    eword-filter))
 286
 287 (defun ew-decode-comment-ewords (ewords eword-filter)
 288   (let (require-quoting
 289         result)
 290     (while ewords
 291       (setq result (ew-rcons*
 292                     result
 293                     (list (ew-decode-eword (symbol-name (car ewords))
 294                                            eword-filter
 295                                            'ew-encode-crlf)))
 296             require-quoting (or require-quoting
 297                                 (string-match "[()\\\\]" (caar result)))
 298             ewords (cdr ewords)))
 299     (if require-quoting
 300         (list
 301          (ew-embed-in-comment
 302           (apply 'ew-quote-concat
 303                  (nreverse result))))
 304       (nreverse result))))
 305
 306 (defun ew-decode-comment-others (frags)
 307   (ew-decode-generic-others
 308    frags
 309    '()
 310    '(ew:cm-qfold
 311      ew:cm-qpair)
 312    '(ew:cm-texts
 313      ew:cm-wsp
 314      ew:cm-fold)))
 315
 316 (defun ew-decode-comment (anchor start end eword-filter)
 317   (ew-decode-generic
 318    anchor start end
 319    'ew-decode-comment-ewords
 320    'ew-decode-comment-others
 321    '(ew:cm-texts)
 322    '(ew:cm-wsp
 323      ew:cm-fold)
 324    '(ew:cm-texts
 325      ew:cm-wsp
 326      ew:cm-fold
 327      ew:cm-qfold
 328      ew:cm-qpair)
 329    eword-filter))
 330
 331 ;;;
 332
 333 (defun ew-embed-in-phrase (str)
 334   (concat "\"" (ew-embed-in-quoted-string str) "\""))
 335
 336 (defun ew-embed-in-quoted-string (str)
 337   (ew-quote-as-quoted-pair str '(?\\ ?\")))
 338
 339 (defun ew-embed-in-comment (str)
 340   (ew-quote-as-quoted-pair str '(?\\ ?\( ?\))))
 341
 342 (defun ew-quote-as-quoted-pair (str specials)
 343   (let ((i 0) (j 0) (l (length str)) result)
 344     (while (< j l)
 345       (when (member (aref str j) specials)
 346         (setq result (ew-rcons*
 347                       result
 348                       (substring str i j)
 349                       "\\")
 350               i j))
 351       (setq j (1+ j)))
 352     (when (< i l)
 353       (setq result (ew-rcons*
 354                     result
 355                     (substring str i))))
 356     (apply 'concat (nreverse result))))
 357
 358 ;;;
 359
 360 (defun ew-proper-eword-p (frag)
 361   (and
 362    (or ew-ignore-75bytes-limit
 363        (<= (length (symbol-name frag)) 75))
 364    (or ew-ignore-76bytes-limit
 365        (<= (get frag 'line-length) 76))
 366    (cond
 367     ((eq (get frag 'type) 'ew:cm-texts)
 368      (ew-eword-p (symbol-name frag)))
 369     ((eq (get frag 'type) 'ew:qs-texts)
 370      (ew-eword-p (symbol-name frag)))
 371     ((eq (get frag 'type) 'ew:atom)
 372      (and
 373       (or ew-permit-sticked-comment
 374           (and
 375            (not (ew-comment-frag-p (get frag 'prev-frag)))
 376            (not (ew-comment-frag-p (get frag 'next-frag)))))
 377       (or ew-permit-sticked-special
 378           (and
 379            (or (ew-comment-frag-p (get frag 'prev-frag))
 380                (not (ew-special-frag-p (get frag 'prev-frag))))
 381            (or (ew-comment-frag-p (get frag 'next-frag))
 382                (not (ew-special-frag-p (get frag 'next-frag))))))
 383       (ew-eword-p (symbol-name frag))))
 384     ((eq (get frag 'type) 'ew:us-texts)
 385      (and
 386       (or ew-permit-sticked-special
 387           (not (ew-special-frag-p (get frag 'prev-frag))))
 388       (ew-eword-p (symbol-name frag))))
 389     (t
 390      nil))))
 391
 392 (defun ew-contain-non-ascii-p (str)
 393   (not (eq (charsets-to-mime-charset (find-charset-string str)) 'us-ascii)))
 394
 395 '(
 396
 397 (ew-decode-field "To" " =?US-ASCII?Q?phrase?= <akr@jaist.ac.jp>")
 398 (ew-decode-field "To" " =?US-ASCII?Q?phrase?= < =?US-ASCII?Q?akr?= @jaist.ac.jp>")
 399 (ew-decode-field "To" " =?US-ASCII?Q?akr?= @jaist.ac.jp")
 400 (ew-decode-field "Subject" " =?ISO-2022-JP?B?GyRCJCIbKEI=?=")
 401 (ew-decode-field "Content-Type" " text/vnd.latex-z(=?US-ASCII?Q?What=3F?=);charset=ISO-2022-JP")
 402
 403 (ew-decode-field "To" " =?US-ASCII?Q?A=22B=5CC?= <akr@jaist.ac.jp>")
 404 (let ((ew-decode-quoted-encoded-word t))
 405   (ew-decode-field "To" " \"=?US-ASCII?Q?A=22B=5CC?=\" <akr@jaist.ac.jp>"))
 406
 407 (ew-decode-field "To" " akr@jaist.ac.jp (=?US-ASCII?Q?=28A=29B=5C?=)")
 408
 409 (ew-decode-field "To" "\"A\\BC\e$B\\\"\\\\\e(B\" <foo@bar>")
 410 (ew-decode-field "To" "\"A\\BC\" <foo@bar>")
 411 (ew-decode-field "To" "\"\e\\$\\B\\$\\\"\e\\(\\B\" <foo@bar>")
 412
 413 )