tm-ew-e.el

   1 ;;;
   2 ;;; tm-ew-d.el --- RFC 1522 based multilingual MIME message header
   3 ;;;                encoder for GNU Emacs
   4 ;;;
   5 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   6 ;;; Copyright (C) 1993,1994,1995 MORIOKA Tomohiko
   7 ;;;
   8 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Version:
  10 ;;;     $Id: tm-ew-e.el,v 7.0 1995/10/03 04:35:11 morioka Exp $
  11 ;;; Keywords: mail, news, MIME, RFC 1522, multilingual, encoded-word
  12 ;;;
  13
  14 (require 'mel)
  15 (require 'tl-822)
  16 (require 'tm-def)
  17
  18
  19 ;;; @ encoded-text encoder
  20 ;;;
  21
  22 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
  23   (let ((text
  24          (cond ((string= encoding "B")
  25                 (base64-encode-string string))
  26                ((string= encoding "Q")
  27                 (q-encoding-encode-string string mode))
  28                )
  29          ))
  30     (if text
  31         (concat "=?" charset "?" encoding "?" text "?=")
  32       )))
  33
  34
  35 ;;; @ leading char
  36 ;;;
  37
  38 (defun tm-eword::char-type (chr)
  39   (if (or (= chr 32)(= chr ?\t))
  40       nil
  41     (char-leading-char chr)
  42     ))
  43
  44 (defun tm-eword::parse-lc-word (str)
  45   (let* ((rest (string-to-char-list str))
  46          (chr (car rest))
  47          (lc (tm-eword::char-type chr))
  48          (p (char-bytes chr))
  49          )
  50     (catch 'tag
  51       (while (setq rest (cdr rest))
  52         (setq chr (car rest))
  53         (if (not (eq lc (tm-eword::char-type chr)))
  54             (throw 'tag nil)
  55           )
  56         (setq p (+ p (char-bytes chr)))
  57         ))
  58     (cons (cons lc (substring str 0 p)) (substring str p))
  59     ))
  60
  61 (defun tm-eword::split-to-lc-words (str)
  62   (let (ret dest)
  63     (while (and (not (string= str ""))
  64                 (setq ret (tm-eword::parse-lc-word str))
  65                 )
  66       (setq dest (cons (car ret) dest))
  67       (setq str (cdr ret))
  68       )
  69     (reverse dest)
  70     ))
  71
  72
  73 ;;; @ word
  74 ;;;
  75
  76 (defun tm-eword::parse-word (lcwl)
  77   (let* ((lcw (car lcwl))
  78          (lc (car lcw))
  79          )
  80     (if (null lc)
  81         lcwl
  82       (let ((lcl (list lc))
  83             (str (cdr lcw))
  84             )
  85         (catch 'tag
  86           (while (setq lcwl (cdr lcwl))
  87             (setq lcw (car lcwl))
  88             (setq lc (car lcw))
  89             (if (null lc)
  90                 (throw 'tag nil)
  91               )
  92             (if (not (memq lc lcl))
  93                 (setq lcl (cons lc lcl))
  94               )
  95             (setq str (concat str (cdr lcw)))
  96             ))
  97         (cons (cons lcl str) lcwl)
  98         ))))
  99
 100 (defun tm-eword::lc-words-to-words (lcwl)
 101   (let (ret dest)
 102     (while (setq ret (tm-eword::parse-word lcwl))
 103       (setq dest (cons (car ret) dest))
 104       (setq lcwl (cdr ret))
 105       )
 106     (reverse dest)
 107     ))
 108
 109
 110 ;;; @ rule
 111 ;;;
 112
 113 (defun mime/find-charset-rule (lcl)
 114   (if lcl
 115       (let ((ret (some-element
 116                   (function
 117                    (lambda (elt)
 118                      (subsetp lcl (car elt))
 119                      ))
 120                   mime/lc-charset-rule-list)
 121                  ))
 122         (if ret
 123             (cdr ret)
 124           mime/unknown-charset-rule)
 125         )
 126     '(nil nil)
 127     ))
 128
 129 (defun tm-eword::words-to-ruled-words (wl)
 130   (mapcar (function
 131            (lambda (word)
 132              (cons (cdr word) (mime/find-charset-rule (car word)))
 133              ))
 134           wl))
 135
 136 (defun tm-eword::space-process (seq)
 137   (let (prev a ac b c cc)
 138     (while seq
 139       (setq b (car seq))
 140       (setq seq (cdr seq))
 141       (setq c (car seq))
 142       (setq cc (nth 1 c))
 143       (if (null (nth 1 b))
 144           (progn
 145             (setq a (car prev))
 146             (setq ac (nth 1 a))
 147             (if (and (nth 2 a)(nth 2 c))
 148                 (cond ((equal ac cc)
 149                        (setq prev (cons
 150                                    (cons (concat (car a)(car b)(car c))
 151                                          (cdr a))
 152                                    (cdr prev)
 153                                    ))
 154                        (setq seq (cdr seq))
 155                        )
 156                       (t
 157                        (setq prev (cons
 158                                    (cons (concat (car a)(car b))
 159                                          (cdr a))
 160                                    (cdr prev)
 161                                    ))
 162                        ))
 163               (setq prev (cons b prev))
 164               ))
 165         (setq prev (cons b prev))
 166         ))
 167     (reverse prev)
 168     ))
 169
 170 (defun tm-eword::split-string (str)
 171   (tm-eword::space-process
 172    (tm-eword::words-to-ruled-words
 173     (tm-eword::lc-words-to-words
 174      (tm-eword::split-to-lc-words str)
 175      ))))
 176
 177
 178 ;;; @ length
 179 ;;;
 180
 181 (defun base64-length (string)
 182   (let ((l (length string)))
 183     (* (+ (/ l 3)
 184           (if (= (mod l 3) 0) 0 1)
 185           ) 4)
 186     ))
 187
 188 (defun q-encoding-length (string)
 189   (let ((l 0)(i 0)(len (length string)) chr)
 190     (while (< i len)
 191       (setq chr (elt string i))
 192       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 193           (setq l (+ l 1))
 194         (setq l (+ l 3))
 195         )
 196       (setq i (+ i 1)) )
 197     l))
 198
 199 (defun tm-eword::encoded-word-length (rword)
 200   (let ((charset  (nth 1 rword))
 201         (encoding (nth 2 rword))
 202         (string   (car rword))
 203         ret)
 204     (setq ret
 205           (cond ((equal encoding "B")
 206                  (setq string
 207                        (mime/convert-string-from-emacs string charset))
 208                  (base64-length string)
 209                  )
 210                 ((equal encoding "Q")
 211                  (setq string
 212                        (mime/convert-string-from-emacs string charset))
 213                  (q-encoding-length string)
 214                  )))
 215     (if ret
 216         (cons (+ 7 (length charset) ret) string)
 217       )))
 218
 219
 220 ;;; @ encode-string
 221 ;;;
 222
 223 (defun tm-eword::encode-string-1 (column rwl &optional mode)
 224   (let* ((rword (car rwl))
 225          (ret (tm-eword::encoded-word-length rword))
 226          string len)
 227     (if (null ret)
 228         (cond ((and (setq string (car rword))
 229                     (<= (setq len (+ (length string) column)) 76)
 230                     )
 231                (setq rwl (cdr rwl))
 232                )
 233               (t
 234                (setq string "\n ")
 235                (setq len 1)
 236                ))
 237       (cond ((and (setq len (car ret))
 238                   (<= (+ column len) 76)
 239                   )
 240              (setq string
 241                    (tm-eword::encode-encoded-text
 242                     (nth 1 rword) (nth 2 rword) (cdr ret)
 243                     ))
 244              (setq len (+ (length string) column))
 245              (setq rwl (cdr rwl))
 246              )
 247             (t
 248              (setq string (car rword))
 249              (let* ((ls (reverse (string-to-char-list string)))
 250                     (sl (length string))
 251                     (p sl) str)
 252                (while (and ls
 253                            (progn
 254                              (setq p (- p (char-bytes (car ls))))
 255                              (setq str (substring string 0 p))
 256                              (setq ret (tm-eword::encoded-word-length
 257                                         (cons str (cdr rword))
 258                                         ))
 259                              (setq str (cdr ret))
 260                              (setq len (+ (car ret) column))
 261                              (> len 76)
 262                              ))
 263                  (setq ls (cdr ls))
 264                  )
 265                (if ls
 266                    (progn
 267                      (setq rwl (cons (cons (substring string p) (cdr rword))
 268                                      (cdr rwl)))
 269                      (setq string
 270                            (tm-eword::encode-encoded-text
 271                             (nth 1 rword) (nth 2 rword) str))
 272                      (setq len (+ (length string) column))
 273                      )
 274                  (setq string "\n ")
 275                  (setq len 1)
 276                  )
 277                )))
 278       )
 279     (list string len rwl)
 280     ))
 281
 282 (defun tm-eword::encode-rwl (column rwl &optional mode)
 283   (let (ret dest)
 284     (while rwl
 285       (setq ret (tm-eword::encode-string-1 column rwl mode))
 286       (setq dest (concat dest (car ret))
 287             column (nth 1 ret)
 288             rwl (nth 2 ret))
 289       )
 290     (list dest column)
 291     ))
 292
 293 (defun tm-eword::encode-string (column str &optional mode)
 294   (tm-eword::encode-rwl column (tm-eword::split-string str) mode)
 295   )
 296
 297
 298 ;;; @ converter
 299 ;;;
 300
 301 (defun tm-eword::phrase-to-rwl (phrase)
 302   (let (token type dest)
 303     (while phrase
 304       (setq token (car phrase))
 305       (setq type (car token))
 306       (cond ((eq type 'quoted-string)
 307              (setq dest
 308                    (append dest
 309                            '(("\"" nil nil))
 310                            (tm-eword::words-to-ruled-words
 311                             (tm-eword::lc-words-to-words
 312                              (tm-eword::split-to-lc-words (cdr token))))
 313                            '(("\"" nil nil))
 314                            ))
 315              )
 316             ((eq type 'comment)
 317              (setq dest
 318                    (append dest
 319                            '(("(" nil nil))
 320                            (tm-eword::words-to-ruled-words
 321                             (tm-eword::lc-words-to-words
 322                              (tm-eword::split-to-lc-words (cdr token))))
 323                            '((")" nil nil))
 324                            ))
 325              )
 326             (t
 327              (setq dest (append dest
 328                                 (tm-eword::words-to-ruled-words
 329                                  (tm-eword::lc-words-to-words
 330                                   (tm-eword::split-to-lc-words (cdr token))
 331                                   ))))
 332              ))
 333       (setq phrase (cdr phrase))
 334       )
 335     (tm-eword::space-process dest)
 336     ))
 337
 338 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 339   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 340       (let ((phrase (nth 1 phrase-route-addr))
 341             (route (nth 2 phrase-route-addr))
 342             dest)
 343         (setq dest (tm-eword::phrase-to-rwl phrase))
 344         (if dest
 345             (setq dest (append dest '((" " nil nil))))
 346           )
 347         (append
 348          dest
 349          (list (list (concat "<" (rfc822/addr-to-string route) ">") nil nil))
 350          ))))
 351
 352 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 353   (if (eq (car addr-spec) 'addr-spec)
 354       (list (list (rfc822/addr-to-string (cdr addr-spec)) nil nil))
 355     ))
 356
 357 (defun tm-eword::mailbox-to-rwl (mbox)
 358   (let ((addr (nth 1 mbox))
 359         (comment (nth 2 mbox))
 360         dest)
 361     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 362                    (tm-eword::addr-spec-to-rwl addr)
 363                    ))
 364     (if comment
 365         (setq dest
 366               (append dest
 367                       '((" " nil nil)
 368                         ("(" nil nil))
 369                       (tm-eword::split-string comment)
 370                       '((")" nil nil))
 371                       )))
 372     dest))
 373
 374 (defun tm-eword::addresses-to-rwl (addresses)
 375   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 376     (if dest
 377         (while (setq addresses (cdr addresses))
 378           (setq dest (append dest
 379                              '(("," nil nil))
 380                              '((" " nil nil))
 381                              (tm-eword::mailbox-to-rwl (car addresses))
 382                              ))
 383           ))
 384     dest))
 385
 386 (defun tm-eword::encode-address-list (column str)
 387   (tm-eword::encode-rwl
 388    column
 389    (tm-eword::addresses-to-rwl
 390     (rfc822/parse-addresses
 391      (rfc822/lexical-analyze str)))))
 392
 393
 394 ;;; @ end
 395 ;;;
 396
 397 (provide 'tm-ew-e)