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