xyzzy and kamail

This is for Japanese readers, I think,since there is a very good
Emacs-like text editor, xyzzy, created by a Japanese.
And based on this editor, another Japanese wrote a mailer called KaMail.
This mail soft is not so completed and I made some improvements.

我想本篇只是面向日本的读者。因为一个日本人制作了一个非常好的
文本编辑器，xyzzy。在此基础上另外一个人写了一个邮件软件，Kamail。
但是此软件还不是很完善，我觉得别扭的地方改写了一下。

日本にはファンが多いと思いますが、亀井さん作のテキストエディターｘｙｚｚyに、
KaMail（服部さん作）というメールソフトが組み込まれています。
ただし、不完全なところがあり、私なりに修正を入れて使っています。

以下は、あくまでもメモになります。
(defun kamail-cite-body (&optional prefix buffer)
  "本文を挿入する"
  (interactive "p")
  (setq buffer (or buffer (kamail-draft-old-buffer)))
  (unless (find-buffer buffer)
    (return-from kamail-cite-body))
  (save-excursion
    (with-input-from-buffer (buffer)
      (let (line)
     (while (setq line (read-line nil nil))
       (when (string= line "")
         (return)))
     (while (setq line (read-line nil nil))
       ;;;added by chen
       (unless (string-matchp "^\[[0-9-]+: \\(.+ \\)*<.+/.+> *\\(\[.+\]\\|\(.+\)\\|.+\\)* *\]$" line)
       ;;;chen
         (insert (format nil "~@[~A~]~A~%"
      prefix
      line))))
     )))
  (when (interactive-p)
    (kamail-color-mail))
)
(defun kamail-prepare-forward-with-attachment ()
  (interactive)
  (let ((buffer (selected-buffer))
     (hash (header-to-alist))
     (boundary (kamail-boundary-string))
     (number kamail-number)
     start
     ref id to to-name osubject subject date from ng group cc oto occ)
    (and (kamail-mail-status-forwarded)
      (kamail-summary-status-forwarded))
    (kamail-create-draft-buffer)
    (switch-to-buffer *kamail-buffer-draft*)
    (setq kamail-draft-reply-header hash)
    (multiple-value-setq (osubject id from oto occ date ref ng)
      (kamail-draft-header-values hash))
    (setq to (kamail-draft-ask-to))
    (setq to-name (get-header-value to *kamail-address-alist*))
    (when to-name
      (setq to (format nil "~A <~A>" to-name to))
    )
    (setq subject (concat "Fw: " osubject))
    (kamail-draft-format-header (kamail-draft-select-from)
      to cc subject ng nil ref)
    (insert (or *kamail-draft-new-string* "\n"))
    (when *kamail-signature-auto-insert*
      (kamail-insert-signature))
; (kamail-change-header-multipart boundary)
; (kamail-change-body-multipart boundary)
    (kamail-cite-body nil
      (buffer-name buffer))

    (kamail-forward-attachments)
    ; 最初のパートを探す
    (goto-char (point-min))
    (when (scan-buffer (format nil "^--~A$" boundary)
      :regexp t :tail t)
      (if (scan-buffer (format nil "^--~A$" boundary)
      :regexp t :tail nil)
       (forward-line -2)
     (while (forward-line 1)
       (and (eolp) (return)))))
    (kamail-draft-refresh)
    (run-hooks '*kamail-prepare-draft-hook*)
  ))

(defun kamail-forward-attachments ()
#|
    (let ((end-reg (format nil "^--~A--$" boundary)))
    (save-excursion
      (goto-char (point-min))
      (unless (scan-buffer end-reg :regexp t :tail nil)
     (error "Multipartの終わりがないっす: ~A" end-reg))
      (insert (format nil "--~A~%" boundary))
      (insert (format nil "Content-Type: message/rfc822~%"))
      (insert (format nil "~%"))
     ; 再度メッセージを取得
     (kamail-account-select-folder *kamail-folder-current*)
     (kamail-get-message number))
|#
      (save-excursion
     (set-buffer *kamail-buffer-multipart*)
     (kamail-save-attach-all)))

(defun kamail-attach-files (files)
  (progn
    ;(delete-buffer *kamail-buffer-multipart*)
    (switch-to-buffer *kamail-buffer-draft*)
    (setq files (mapcar #'(lambda (x)
      (list x)) files))

    (kamail-add-attachments files)
    (while (not (endp files))
      (delete-file (car (pop files))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-decode-mime-header ()
  (save-excursion
    (while (or (looking-for ">From ")
            (looking-for *kamail-status-header-field*))
      (or (forward-line 1) (return)))
    ;;;;added by chen to decode Chinese characters
    (let ((beg (point)))
      (save-excursion
     (when
         (scan-buffer "\\(^[sS]ubject: \\|^[tT]o: \\|^[cC]c: \\|^[bB]cc: \\)\\(=\\?\\)[gG][bB][^\\?]*\\(\\?\\)"
      :regexp t :case-fold t
      :tail t)
       (replace-match "\\1\\2gb2312\\3"))))

    (let ((beg (point-min)))
      (save-excursion
     ;;(goto-char beg)
     (when
         (scan-buffer "\\(^content-type: .+\\)\\(\n[ \t]+\\)*\\(.*charset.*=.*\\)[gG][bB]\\w*"
      :regexp t :case-fold t
      :tail t)
       (replace-match "\\1\\3gb2312"))))

    ;;;end
    (let ((beg (point)))
      (save-excursion
     (when (scan-buffer "^X-Mailer :"
      :regexp t
      :tail t)
       (delete-region (- (point) 2) (- (point) 1)))))
    (decode-mime-header)))

;;;added by chen;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-save-attach-all ()
; (interactive)
  (progn ;;;;;save-excursion
    (setq attachments nil)
    (goto-char (point-min))
    (while (kamail-multipart-next-part nil)
      (refresh-screen)
      (kamail-save-attach-this-part))
    (kamail-attach-files attachments)))

(defun kamail-save-attach-this-part ()
    (let ((part (kamail-multipart-this)))
      (when part
     (let ((header (kamail-multipart-header part))
           (start (kamail-multipart-start part))
           (stop (kamail-multipart-stop part))
           type
           enc
           charset
           disp
           file
           savename
           ;;;attach
           )
       (multiple-value-setq (type enc charset disp file)
         (kamail-get-part-header header))
       (when file
         ;(return nil))
       (setq savename (concat *kamail-attach-save-directory* file))
       (when savename
         (setq *kamail-attach-save-directory*
      (directory-namestring savename))
         (setq enc (or enc ""))
         (save-excursion
           (set-buffer *kamail-buffer-view*)
           (cond ((string-matchp "base64" enc)
      (and
      (base64-decode-region-to-file savename start stop)
      (message "Saved: ~A" savename)
      )
      )
      ((string-matchp "uuencode" enc)
      (let (begin endin)
      (goto-char start)
      (when (scan-buffer "^begin" :regexp t :tail nil)
      (forward-line 1)
      (setq begin (point))
      (when (and (scan-buffer "^end" :regexp t :tail nil)
      (<= (point) stop))
      (setq endin (point)))
      )
      (if (and begin endin)
      (and
      (uudecode-region-to-file savename begin endin)
      (message "Saved: ~A" savename)
      )
      (message-box "Could not find \"begin\" or \"end\" for uudecode")
      )
      ))
      ((string-matchp "quoted-printable" enc)
      (and
      (quoted-printable-decode-region-to-file savename start stop)
      (message "Saved: ~A" savename)
      )
      )
      ((or (string-matchp "binhex" type)
      (string-matchp "binhex" enc))
      (let (begin)
      (goto-char start)
      (when (scan-buffer "^:" :regexp t :tail nil)
      (setq begin (point))
      (when (scan-buffer ":$" :regexp t :tail t)
      (binhex-decode-region-to-file savename begin (point))
      (message "Saved: ~A" savename))
      )))
      (t
      (and
      (kamail-write-selected-buffer savename start stop)
      (message "Saved: ~A" savename)
      )
      )
      );cond
           )
         )
         (push savename attachments))))))
     ; (kamail-attach-file savename)
      ; ))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun kamail-create-send-buffer ()
  (interactive)
  (goto-char (point-min))
  ; from den8view.l
  (when (re-search-forward "[\xa0-\xdf\X8540-\X889e\Xeb40-\Xffff]+" t)
    (ed::show-match)
    (msgbox "送信しちゃまずい文字発見")) ;;changed by chen according to info on the net (error "送信しちゃまずい文字発見"))
  (let ((attach kamail-draft-attach-alist))
    (kamail-send-buffer-create)
    (kamail-send-mode)
    (insert-buffer *kamail-buffer-draft*)
    (goto-char (point-min))
    (kamail-header-date-update)
    (kamail-encode-message)
    (when attach
      (kamail-change-to-multipart attach))
    (set-buffer-modified-p nil)
    (run-hooks '*kamail-create-send-buffer-hook*)))

(defun kamail-list-mail ()
  (interactive)
  (when (and (stringp kamail-summary-folder)
          (string= kamail-summary-folder *kamail-folder-current*))
    (return-from kamail-list-mail nil)
  )
  (kamail-summary-mode)
  (let (headers
     (buffer-read-only nil)
     (type (kamail-folder-type)))
    (declare (special buffer-read-only))
    (erase-buffer (selected-buffer))
    (when *kamail-close-other-connection*
      (kamail-close-other t))
    (cond ((not (characterp type))
        (error "できまへん: ~S" *kamail-folder-current*))
       ((char= type *kamail-folder-imap-char*);IMAP
        (setq headers (kamail-imap-mail-list)))
       ((char= type *kamail-folder-news-char*);NEWS
        (setq headers (kamail-news-list)))
       ((char= type *kamail-folder-pop3-char*);POP3
        (setq headers (kamail-pop3-list)))
       ((char= type *kamail-folder-local-char*);LOCAL
        (setq headers (kamail-local-list *kamail-folder-current*)))
       ((char= type *kamail-folder-spool-char*);SPOOL
        (setq headers (kamail-spool-list *kamail-folder-current*)))
       ((char= type *kamail-folder-archive-char*);ARCHIVE
        (setq headers (kamail-archive-list *kamail-folder-current*)))
       (t
        (error "まだできません: ~S" *kamail-folder-current*))
    )
    (setq kamail-headers (kamail-summary-parse-headers-date headers))
    ;(setq kamail-headers headers)
    ;;;modified by chen
    ;(kamail-list-refresh t)
    (kamail-list-refresh t 'kamail-sortfunc-by-date-reverse)
    ;;;chen
    (setq kamail-summary-folder *kamail-folder-current*)
    (set-buffer-modified-p nil)
    (when *kamail-summary-open-unread*
      (kamail-next-new))
    (run-hooks '*kamail-list-mail-hook*)
  ))

  (define-key *kamail-view-map* '(#\C-c #\f) 'kamail-prepare-forward-with-attachment)