eword-encode.el

   1 ;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Revision: 0.11 $
   7 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
   8
   9 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'mel)
  29 (require 'std11)
  30 (require 'mime-def)
  31 (require 'cl)
  32
  33 (defsubst find-non-ascii-charset-string (string)
  34   "Return a list of charsets in the STRING except ascii."
  35   (delq 'ascii (find-charset-string string))
  36   )
  37
  38 (defsubst find-non-ascii-charset-region (start end)
  39   "Return a list of charsets except ascii in the region between START and END."
  40   (delq 'ascii (find-charset-string (buffer-substring start end)))
  41   )
  42
  43
  44 ;;; @ version
  45 ;;;
  46
  47 (defconst eword-encode-RCS-ID
  48   "$Id: eword-encode.el,v 0.11 1997-03-01 02:07:00 tmorioka Exp $")
  49 (defconst eword-encode-version (get-version-string eword-encode-RCS-ID))
  50
  51
  52 ;;; @ variables
  53 ;;;
  54
  55 (defvar eword-field-encoding-method-alist
  56   '(("X-Nsubject" . iso-2022-jp-2)
  57     ("Newsgroups" . nil)
  58     (t            . mime)
  59     )
  60   "*Alist to specify field encoding method.
  61 Its key is field-name, value is encoding method.
  62
  63 If method is `mime', this field will be encoded into MIME format.
  64
  65 If method is a MIME-charset, this field will be encoded as the charset
  66 when it must be convert into network-code.
  67
  68 If method is `default-mime-charset', this field will be encoded as
  69 variable `default-mime-charset' when it must be convert into
  70 network-code.
  71
  72 If method is nil, this field will not be encoded.")
  73
  74 (defvar eword-generate-X-Nsubject nil
  75   "*If it is not nil, X-Nsubject field is generated
  76 when Subject field is encoded by `eword-encode-header'.")
  77
  78 (defvar eword-charset-encoding-alist
  79   '((us-ascii           . nil)
  80     (iso-8859-1         . "Q")
  81     (iso-8859-2         . "Q")
  82     (iso-8859-3         . "Q")
  83     (iso-8859-4         . "Q")
  84     (iso-8859-5         . "Q")
  85     (koi8-r             . "Q")
  86     (iso-8859-7         . "Q")
  87     (iso-8859-8         . "Q")
  88     (iso-8859-9         . "Q")
  89     (iso-2022-jp        . "B")
  90     (iso-2022-kr        . "B")
  91     (gb2312             . "B")
  92     (cn-gb              . "B")
  93     (cn-gb-2312         . "B")
  94     (euc-kr             . "B")
  95     (iso-2022-jp-2      . "B")
  96     (iso-2022-int-1     . "B")
  97     ))
  98
  99
 100 ;;; @ encoded-text encoder
 101 ;;;
 102
 103 (defun tm-eword::encode-encoded-text (charset encoding string &optional mode)
 104   (let ((text
 105          (cond ((string= encoding "B")
 106                 (base64-encode-string string))
 107                ((string= encoding "Q")
 108                 (q-encoding-encode-string string mode))
 109                )
 110          ))
 111     (if text
 112         (concat "=?" (upcase (symbol-name charset)) "?"
 113                 encoding "?" text "?=")
 114       )))
 115
 116
 117 ;;; @ leading char
 118 ;;;
 119
 120 (defun tm-eword::char-type (chr)
 121   (if (or (= chr 32)(= chr ?\t))
 122       nil
 123     (char-charset chr)
 124     ))
 125
 126 (defun tm-eword::parse-lc-word (str)
 127   (let* ((chr (sref str 0))
 128          (lc (tm-eword::char-type chr))
 129          (i (char-length chr))
 130          (len (length str))
 131          )
 132     (while (and (< i len)
 133                 (setq chr (sref str i))
 134                 (eq lc (tm-eword::char-type chr))
 135                 )
 136       (setq i (+ i (char-length chr)))
 137       )
 138     (cons (cons lc (substring str 0 i)) (substring str i))
 139     ))
 140
 141 (defun tm-eword::split-to-lc-words (str)
 142   (let (ret dest)
 143     (while (and (not (string= str ""))
 144                 (setq ret (tm-eword::parse-lc-word str))
 145                 )
 146       (setq dest (cons (car ret) dest))
 147       (setq str (cdr ret))
 148       )
 149     (reverse dest)
 150     ))
 151
 152
 153 ;;; @ word
 154 ;;;
 155
 156 (defun tm-eword::parse-word (lcwl)
 157   (let* ((lcw (car lcwl))
 158          (lc (car lcw))
 159          )
 160     (if (null lc)
 161         lcwl
 162       (let ((lcl (list lc))
 163             (str (cdr lcw))
 164             )
 165         (catch 'tag
 166           (while (setq lcwl (cdr lcwl))
 167             (setq lcw (car lcwl))
 168             (setq lc (car lcw))
 169             (if (null lc)
 170                 (throw 'tag nil)
 171               )
 172             (if (not (memq lc lcl))
 173                 (setq lcl (cons lc lcl))
 174               )
 175             (setq str (concat str (cdr lcw)))
 176             ))
 177         (cons (cons lcl str) lcwl)
 178         ))))
 179
 180 (defun tm-eword::lc-words-to-words (lcwl)
 181   (let (ret dest)
 182     (while (setq ret (tm-eword::parse-word lcwl))
 183       (setq dest (cons (car ret) dest))
 184       (setq lcwl (cdr ret))
 185       )
 186     (reverse dest)
 187     ))
 188
 189
 190 ;;; @ rule
 191 ;;;
 192
 193 (defmacro tm-eword::make-rword (text charset encoding type)
 194   (` (list (, text)(, charset)(, encoding)(, type))))
 195 (defmacro tm-eword::rword-text (rword)
 196   (` (car (, rword))))
 197 (defmacro tm-eword::rword-charset (rword)
 198   (` (car (cdr (, rword)))))
 199 (defmacro tm-eword::rword-encoding (rword)
 200   (` (car (cdr (cdr (, rword))))))
 201 (defmacro tm-eword::rword-type (rword)
 202   (` (car (cdr (cdr (cdr (, rword)))))))
 203
 204 (defun tm-eword::find-charset-rule (charsets)
 205   (if charsets
 206       (let* ((charset (charsets-to-mime-charset charsets))
 207              (encoding (cdr (assq charset eword-charset-encoding-alist)))
 208              )
 209         (list charset encoding)
 210         )))
 211
 212 (defun tm-eword::words-to-ruled-words (wl &optional mode)
 213   (mapcar (function
 214            (lambda (word)
 215              (let ((ret (tm-eword::find-charset-rule (car word))))
 216                (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode)
 217                )))
 218           wl))
 219
 220 (defun tm-eword::space-process (seq)
 221   (let (prev a ac b c cc)
 222     (while seq
 223       (setq b (car seq))
 224       (setq seq (cdr seq))
 225       (setq c (car seq))
 226       (setq cc (tm-eword::rword-charset c))
 227       (if (null (tm-eword::rword-charset b))
 228           (progn
 229             (setq a (car prev))
 230             (setq ac (tm-eword::rword-charset a))
 231             (if (and (tm-eword::rword-encoding a)
 232                      (tm-eword::rword-encoding c))
 233                 (cond ((eq ac cc)
 234                        (setq prev (cons
 235                                    (cons (concat (car a)(car b)(car c))
 236                                          (cdr a))
 237                                    (cdr prev)
 238                                    ))
 239                        (setq seq (cdr seq))
 240                        )
 241                       (t
 242                        (setq prev (cons
 243                                    (cons (concat (car a)(car b))
 244                                          (cdr a))
 245                                    (cdr prev)
 246                                    ))
 247                        ))
 248               (setq prev (cons b prev))
 249               ))
 250         (setq prev (cons b prev))
 251         ))
 252     (reverse prev)
 253     ))
 254
 255 (defun tm-eword::split-string (str &optional mode)
 256   (tm-eword::space-process
 257    (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words
 258                                     (tm-eword::split-to-lc-words str))
 259                                    mode)))
 260
 261
 262 ;;; @ length
 263 ;;;
 264
 265 (defun tm-eword::encoded-word-length (rword)
 266   (let ((string   (tm-eword::rword-text     rword))
 267         (charset  (tm-eword::rword-charset  rword))
 268         (encoding (tm-eword::rword-encoding rword))
 269         ret)
 270     (setq ret
 271           (cond ((string-equal encoding "B")
 272                  (setq string (encode-mime-charset-string string charset))
 273                  (base64-encoded-length string)
 274                  )
 275                 ((string-equal encoding "Q")
 276                  (setq string (encode-mime-charset-string string charset))
 277                  (q-encoding-encoded-length string
 278                                             (tm-eword::rword-type rword))
 279                  )))
 280     (if ret
 281         (cons (+ 7 (length (symbol-name charset)) ret) string)
 282       )))
 283
 284
 285 ;;; @ encode-string
 286 ;;;
 287
 288 (defun tm-eword::encode-string-1 (column rwl)
 289   (let* ((rword (car rwl))
 290          (ret (tm-eword::encoded-word-length rword))
 291          string len)
 292     (if (null ret)
 293         (cond ((and (setq string (car rword))
 294                     (<= (setq len (+ (length string) column)) 76)
 295                     )
 296                (setq rwl (cdr rwl))
 297                )
 298               (t
 299                (setq string "\n ")
 300                (setq len 1)
 301                ))
 302       (cond ((and (setq len (car ret))
 303                   (<= (+ column len) 76)
 304                   )
 305              (setq string
 306                    (tm-eword::encode-encoded-text
 307                     (tm-eword::rword-charset rword)
 308                     (tm-eword::rword-encoding rword)
 309                     (cdr ret)
 310                     (tm-eword::rword-type rword)
 311                     ))
 312              (setq len (+ (length string) column))
 313              (setq rwl (cdr rwl))
 314              )
 315             (t
 316              (setq string (car rword))
 317              (let* ((p 0) np
 318                     (str "") nstr)
 319                (while (and (< p len)
 320                            (progn
 321                              (setq np (+ p (char-length (sref string p))))
 322                              (setq nstr (substring string 0 np))
 323                              (setq ret (tm-eword::encoded-word-length
 324                                         (cons nstr (cdr rword))
 325                                         ))
 326                              (setq nstr (cdr ret))
 327                              (setq len (+ (car ret) column))
 328                              (<= len 76)
 329                              ))
 330                  (setq str nstr
 331                        p np))
 332                (if (string-equal str "")
 333                    (setq string "\n "
 334                          len 1)
 335                  (setq rwl (cons (cons (substring string p) (cdr rword))
 336                                  (cdr rwl)))
 337                  (setq string
 338                        (tm-eword::encode-encoded-text
 339                         (tm-eword::rword-charset rword)
 340                         (tm-eword::rword-encoding rword)
 341                         str
 342                         (tm-eword::rword-type rword)))
 343                  (setq len (+ (length string) column))
 344                  )
 345                )))
 346       )
 347     (list string len rwl)
 348     ))
 349
 350 (defun tm-eword::encode-rwl (column rwl)
 351   (let (ret dest ps special str ew-f pew-f)
 352     (while rwl
 353       (setq ew-f (nth 2 (car rwl)))
 354       (if (and pew-f ew-f)
 355           (setq rwl (cons '(" ") rwl)
 356                 pew-f nil)
 357         (setq pew-f ew-f)
 358         )
 359       (setq ret (tm-eword::encode-string-1 column rwl))
 360       (setq str (car ret))
 361       (if (eq (elt str 0) ?\n)
 362           (if (eq special ?\()
 363               (progn
 364                 (setq dest (concat dest "\n ("))
 365                 (setq ret (tm-eword::encode-string-1 2 rwl))
 366                 (setq str (car ret))
 367                 ))
 368         (cond ((eq special 32)
 369                (if (string= str "(")
 370                    (setq ps t)
 371                  (setq dest (concat dest " "))
 372                  (setq ps nil)
 373                  ))
 374               ((eq special ?\()
 375                (if ps
 376                    (progn
 377                      (setq dest (concat dest " ("))
 378                      (setq ps nil)
 379                      )
 380                  (setq dest (concat dest "("))
 381                  )
 382                )))
 383       (cond ((string= str " ")
 384              (setq special 32)
 385              )
 386             ((string= str "(")
 387              (setq special ?\()
 388              )
 389             (t
 390              (setq special nil)
 391              (setq dest (concat dest str))
 392              ))
 393       (setq column (nth 1 ret)
 394             rwl (nth 2 ret))
 395       )
 396     (list dest column)
 397     ))
 398
 399 (defun tm-eword::encode-string (column str &optional mode)
 400   (tm-eword::encode-rwl column (tm-eword::split-string str mode))
 401   )
 402
 403
 404 ;;; @ converter
 405 ;;;
 406
 407 (defun tm-eword::phrase-to-rwl (phrase)
 408   (let (token type dest str)
 409     (while phrase
 410       (setq token (car phrase))
 411       (setq type (car token))
 412       (cond ((eq type 'quoted-string)
 413              (setq str (concat "\"" (cdr token) "\""))
 414              (setq dest
 415                    (append dest
 416                            (list
 417                             (let ((ret (tm-eword::find-charset-rule
 418                                         (find-non-ascii-charset-string str))))
 419                               (tm-eword::make-rword
 420                                str (car ret)(nth 1 ret) 'phrase)
 421                               )
 422                             )))
 423              )
 424             ((eq type 'comment)
 425              (setq dest
 426                    (append dest
 427                            '(("(" nil nil))
 428                            (tm-eword::words-to-ruled-words
 429                             (tm-eword::lc-words-to-words
 430                              (tm-eword::split-to-lc-words (cdr token)))
 431                             'comment)
 432                            '((")" nil nil))
 433                            ))
 434              )
 435             (t
 436              (setq dest (append dest
 437                                 (tm-eword::words-to-ruled-words
 438                                  (tm-eword::lc-words-to-words
 439                                   (tm-eword::split-to-lc-words (cdr token))
 440                                   ) 'phrase)))
 441              ))
 442       (setq phrase (cdr phrase))
 443       )
 444     (tm-eword::space-process dest)
 445     ))
 446
 447 (defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr)
 448   (if (eq (car phrase-route-addr) 'phrase-route-addr)
 449       (let ((phrase (nth 1 phrase-route-addr))
 450             (route (nth 2 phrase-route-addr))
 451             dest)
 452         (if (eq (car (car phrase)) 'spaces)
 453             (setq phrase (cdr phrase))
 454           )
 455         (setq dest (tm-eword::phrase-to-rwl phrase))
 456         (if dest
 457             (setq dest (append dest '((" " nil nil))))
 458           )
 459         (append
 460          dest
 461          (list (list (concat "<" (std11-addr-to-string route) ">") nil nil))
 462          ))))
 463
 464 (defun tm-eword::addr-spec-to-rwl (addr-spec)
 465   (if (eq (car addr-spec) 'addr-spec)
 466       (list (list (std11-addr-to-string (cdr addr-spec)) nil nil))
 467     ))
 468
 469 (defun tm-eword::mailbox-to-rwl (mbox)
 470   (let ((addr (nth 1 mbox))
 471         (comment (nth 2 mbox))
 472         dest)
 473     (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr)
 474                    (tm-eword::addr-spec-to-rwl addr)
 475                    ))
 476     (if comment
 477         (setq dest
 478               (append dest
 479                       '((" " nil nil)
 480                         ("(" nil nil))
 481                       (tm-eword::split-string comment 'comment)
 482                       '((")" nil nil))
 483                       )))
 484     dest))
 485
 486 (defun tm-eword::addresses-to-rwl (addresses)
 487   (let ((dest (tm-eword::mailbox-to-rwl (car addresses))))
 488     (if dest
 489         (while (setq addresses (cdr addresses))
 490           (setq dest (append dest
 491                              '(("," nil nil))
 492                              '((" " nil nil))
 493                              (tm-eword::mailbox-to-rwl (car addresses))
 494                              ))
 495           ))
 496     dest))
 497
 498 (defun tm-eword::encode-address-list (column str)
 499   (tm-eword::encode-rwl
 500    column
 501    (tm-eword::addresses-to-rwl (std11-parse-addresses-string str))
 502    ))
 503
 504
 505 ;;; @ application interfaces
 506 ;;;
 507
 508 (defun eword-encode-field (str)
 509   (setq str (std11-unfold-string str))
 510   (let ((ret (string-match std11-field-head-regexp str)))
 511     (or (if ret
 512             (let ((field-name (substring str 0 (1- (match-end 0))))
 513                   (field-body (eliminate-top-spaces
 514                                (substring str (match-end 0))))
 515                   fname)
 516               (if (setq ret
 517                         (cond ((string-equal field-body "") "")
 518                               ((member (setq fname (downcase field-name))
 519                                        '("reply-to" "from" "sender"
 520                                          "resent-reply-to" "resent-from"
 521                                          "resent-sender" "to" "resent-to"
 522                                          "cc" "resent-cc"
 523                                          "bcc" "resent-bcc" "dcc")
 524                                        )
 525                                (car (tm-eword::encode-address-list
 526                                      (+ (length field-name) 2) field-body))
 527                                )
 528                               (t
 529                                (car (tm-eword::encode-string
 530                                      (+ (length field-name) 1)
 531                                      field-body 'text))
 532                                ))
 533                         )
 534                   (concat field-name ": " ret)
 535                 )))
 536         (car (tm-eword::encode-string 0 str))
 537         )))
 538
 539 (defun eword-in-subject-p ()
 540   (let ((str (std11-field-body "Subject")))
 541     (if (and str (string-match eword-encoded-word-regexp str))
 542         str)))
 543
 544 (defun eword-encode-header (&optional code-conversion)
 545   "Encode header fields to network representation, such as MIME encoded-word.
 546
 547 It refer variable `eword-field-encoding-method-alist'."
 548   (interactive "*")
 549   (save-excursion
 550     (save-restriction
 551       (std11-narrow-to-header mail-header-separator)
 552       (goto-char (point-min))
 553       (let ((default-cs (mime-charset-to-coding-system default-mime-charset))
 554             beg end field-name)
 555         (while (re-search-forward std11-field-head-regexp nil t)
 556           (setq beg (match-beginning 0))
 557           (setq field-name (buffer-substring beg (1- (match-end 0))))
 558           (setq end (std11-field-end))
 559           (and (find-non-ascii-charset-region beg end)
 560                (let ((ret (or (let ((fname  (downcase field-name)))
 561                                 (assoc-if
 562                                  (function
 563                                   (lambda (str)
 564                                     (and (stringp str)
 565                                          (string= fname (downcase str))
 566                                          )))
 567                                  eword-field-encoding-method-alist))
 568                               (assq t eword-field-encoding-method-alist)
 569                               )))
 570                  (if ret
 571                      (let ((method (cdr ret)))
 572                        (cond ((eq method 'mime)
 573                               (let ((field
 574                                      (buffer-substring-no-properties beg end)
 575                                      ))
 576                                 (delete-region beg end)
 577                                 (insert (eword-encode-field field))
 578                                 ))
 579                              (code-conversion
 580                               (let ((cs
 581                                      (or (mime-charset-to-coding-system
 582                                           method)
 583                                          default-cs)))
 584                                 (encode-coding-region beg end cs)
 585                                 )))
 586                        ))
 587                  ))
 588           ))
 589       (and eword-generate-X-Nsubject
 590            (or (std11-field-body "X-Nsubject")
 591                (let ((str (eword-in-subject-p)))
 592                  (if str
 593                      (progn
 594                        (setq str
 595                              (eword-decode-string
 596                               (std11-unfold-string str)))
 597                        (if code-conversion
 598                            (setq str
 599                                  (encode-mime-charset-string
 600                                   str
 601                                   (or (cdr (assoc-if
 602                                             (function
 603                                              (lambda (str)
 604                                                (and (stringp str)
 605                                                     (string= "x-nsubject"
 606                                                              (downcase str2))
 607                                                     )))
 608                                             eword-field-encoding-method-alist))
 609                                       'iso-2022-jp-2)))
 610                          )
 611                        (insert (concat "\nX-Nsubject: " str))
 612                        )))))
 613       )))
 614
 615 (defun eword-encode-string (str &optional column mode)
 616   (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode)))
 617   )
 618
 619
 620 ;;; @ end
 621 ;;;
 622
 623 (provide 'eword-encode)
 624
 625 ;;; eword-encode.el ends here