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