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