ew-dec.el

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