2001-06-30 YAGI Tatsuya <yagi@is.titech.ac.jp>

[gnus] / lisp / mml.el

diff --git a/lisp/mml.el b/lisp/mml.el
index 1a1cbd7..ad1c450 100644 (file)
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -1,5 +1,5 @@
 ;;; mml.el --- A package for parsing and validating MML documents
 ;;; mml.el --- A package for parsing and validating MML documents

-;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.


@@ -33,13 +33,14 @@
 (eval-and-compile
   (autoload 'message-make-message-id "message")
   (autoload 'gnus-setup-posting-charset "gnus-msg")
 (eval-and-compile
   (autoload 'message-make-message-id "message")
   (autoload 'gnus-setup-posting-charset "gnus-msg")

+  (autoload 'gnus-add-minor-mode "gnus-ems")

   (autoload 'message-fetch-field "message")
   (autoload 'message-posting-charset "message"))
 
 (defvar mml-generate-multipart-alist nil
   "*Alist of multipart generation functions.
 Each entry has the form (NAME . FUNCTION), where
   (autoload 'message-fetch-field "message")
   (autoload 'message-posting-charset "message"))
 
 (defvar mml-generate-multipart-alist nil
   "*Alist of multipart generation functions.
 Each entry has the form (NAME . FUNCTION), where

-NAME is a string containing the name of the part (without the 
+NAME is a string containing the name of the part (without the

 leading \"/multipart/\"),
 FUNCTION is a Lisp function which is called to generate the part.
 
 leading \"/multipart/\"),
 FUNCTION is a Lisp function which is called to generate the part.
 


@@ -77,7 +78,7 @@ one charsets.")
 
 (defvar mml-buffer-list nil)
 
 
 (defvar mml-buffer-list nil)
 

-(defun mml-generate-new-buffer (name) 
+(defun mml-generate-new-buffer (name)

   (let ((buf (generate-new-buffer name)))
     (push buf mml-buffer-list)
     buf))
   (let ((buf (generate-new-buffer name)))
     (push buf mml-buffer-list)
     buf))


@@ -89,13 +90,14 @@ one charsets.")
 
 (defun mml-parse ()
   "Parse the current buffer as an MML document."
 
 (defun mml-parse ()
   "Parse the current buffer as an MML document."

-  (goto-char (point-min))
-  (let ((table (syntax-table)))
-    (unwind-protect
-       (progn
-         (set-syntax-table mml-syntax-table)
-         (mml-parse-1))
-      (set-syntax-table table))))
+  (save-excursion
+    (goto-char (point-min))
+    (let ((table (syntax-table)))
+      (unwind-protect
+         (progn
+           (set-syntax-table mml-syntax-table)
+           (mml-parse-1))
+       (set-syntax-table table)))))

 
 (defun mml-parse-1 ()
   "Parse the current buffer as an MML document."
 
 (defun mml-parse-1 ()
   "Parse the current buffer as an MML document."


@@ -119,15 +121,19 @@ one charsets.")
        (setq raw (cdr (assq 'raw tag))
              point (point)
              contents (mml-read-part (eq 'mml (car tag)))
        (setq raw (cdr (assq 'raw tag))
              point (point)
              contents (mml-read-part (eq 'mml (car tag)))

-             charsets (if raw nil 
+             charsets (if raw nil

                         (mm-find-mime-charset-region point (point))))
        (when (and (not raw) (memq nil charsets))
          (if (or (memq 'unknown-encoding mml-confirmation-set)
                         (mm-find-mime-charset-region point (point))))
        (when (and (not raw) (memq nil charsets))
          (if (or (memq 'unknown-encoding mml-confirmation-set)

-                 (y-or-n-p
-                  "Message contains characters with unknown encoding.  Really send?"))
-             (if (setq use-ascii 
+                  (message-options-get 'unknown-encoding)
+                 (and (y-or-n-p "\
+Message contains characters with unknown encoding.  Really send?")
+                       (message-options-set 'unknown-encoding t)))
+             (if (setq use-ascii

                        (or (memq 'use-ascii mml-confirmation-set)
                        (or (memq 'use-ascii mml-confirmation-set)

-                           (y-or-n-p "Use ASCII as charset?")))
+                            (message-options-get 'use-ascii)
+                           (and (y-or-n-p "Use ASCII as charset?")
+                                 (message-options-set 'use-ascii t))))

                  (setq charsets (delq nil charsets))
                (setq warn nil))
            (error "Edit your message to remove those characters")))
                  (setq charsets (delq nil charsets))
                (setq warn nil))
            (error "Edit your message to remove those characters")))


@@ -143,18 +149,18 @@ one charsets.")
                          tag point (point) use-ascii)))
            (when (and warn
                       (not (memq 'multipart mml-confirmation-set))
                          tag point (point) use-ascii)))
            (when (and warn
                       (not (memq 'multipart mml-confirmation-set))

-                      (not
-                       (y-or-n-p
-                        (format
-                         "Warning: Your message contains more than %d parts.  Really send? "
-                         (length nstruct)))))
+                       (not (message-options-get 'multipart))
+                      (not (and (y-or-n-p (format "\
+A message part needs to be split into %d charset parts.  Really send? "
+                                                   (length nstruct)))
+                                 (message-options-set 'multipart t))))

              (error "Edit your message to use only one charset"))
            (setq struct (nconc nstruct struct)))))))
     (unless (eobp)
       (forward-line 1))
     (nreverse struct)))
 
              (error "Edit your message to use only one charset"))
            (setq struct (nconc nstruct struct)))))))
     (unless (eobp)
       (forward-line 1))
     (nreverse struct)))
 

-(defun mml-parse-singlepart-with-multiple-charsets 
+(defun mml-parse-singlepart-with-multiple-charsets

   (orig-tag beg end &optional use-ascii)
   (save-excursion
     (save-restriction
   (orig-tag beg end &optional use-ascii)
   (save-excursion
     (save-restriction


@@ -214,7 +220,8 @@ one charsets.")
 
 (defun mml-read-tag ()
   "Read a tag and return the contents."
 
 (defun mml-read-tag ()
   "Read a tag and return the contents."

-  (let (contents name elem val)
+  (let ((orig-point (point))
+       contents name elem val)

     (forward-char 2)
     (setq name (buffer-substring-no-properties
                (point) (progn (forward-sexp 1) (point))))
     (forward-char 2)
     (setq name (buffer-substring-no-properties
                (point) (progn (forward-sexp 1) (point))))


@@ -232,6 +239,8 @@ one charsets.")
     (goto-char (match-end 0))
     ;; Don't skip the leading space.
     ;;(skip-chars-forward " \t\n")
     (goto-char (match-end 0))
     ;; Don't skip the leading space.
     ;;(skip-chars-forward " \t\n")

+    ;; Put the tag location into the returned contents
+    (setq contents (append (list (cons 'tag-location orig-point)) contents))

     (cons (intern name) (nreverse contents))))
 
 (defun mml-read-part (&optional mml)
     (cons (intern name) (nreverse contents))))
 
 (defun mml-read-part (&optional mml)


@@ -247,7 +256,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
            (if (re-search-forward "<#\\(/\\)?mml." nil t)
                (setq count (+ count (if (match-beginning 1) -1 1)))
              (goto-char (point-max))))
            (if (re-search-forward "<#\\(/\\)?mml." nil t)
                (setq count (+ count (if (match-beginning 1) -1 1)))
              (goto-char (point-max))))

-         (buffer-substring-no-properties beg (if (> count 0) 
+         (buffer-substring-no-properties beg (if (> count 0)

                                                  (point)
                                                (match-beginning 0))))
       (if (re-search-forward
                                                  (point)
                                                (match-beginning 0))))
       (if (re-search-forward


@@ -280,7 +289,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
        (buffer-string)))))
 
 (defun mml-generate-mime-1 (cont)
        (buffer-string)))))
 
 (defun mml-generate-mime-1 (cont)

-  (let ((mm-use-ultra-safe-encoding 
+  (let ((mm-use-ultra-safe-encoding

         (or mm-use-ultra-safe-encoding (assq 'sign cont))))
     (save-restriction
       (narrow-to-region (point) (point))
         (or mm-use-ultra-safe-encoding (assq 'sign cont))))
     (save-restriction
       (narrow-to-region (point) (point))


@@ -292,9 +301,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
          (if (and (not raw)
                   (member (car (split-string type "/")) '("text" "message")))
              (with-temp-buffer
          (if (and (not raw)
                   (member (car (split-string type "/")) '("text" "message")))
              (with-temp-buffer

-               (setq charset (mm-charset-to-coding-system 
+               (setq charset (mm-charset-to-coding-system

                               (cdr (assq 'charset cont))))
                               (cdr (assq 'charset cont))))

-               (if (eq charset 'ascii) (setq charset nil))
+               (when (eq charset 'ascii)
+                 (setq charset nil))

                (cond
                 ((cdr (assq 'buffer cont))
                  (insert-buffer-substring (cdr (assq 'buffer cont))))
                (cond
                 ((cdr (assq 'buffer cont))
                  (insert-buffer-substring (cdr (assq 'buffer cont))))


@@ -311,10 +321,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                    ;; Remove quotes from quoted tags.
                    (goto-char (point-min))
                    (while (re-search-forward
                    ;; Remove quotes from quoted tags.
                    (goto-char (point-min))
                    (while (re-search-forward

-                           "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t)
+                           "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
+                           nil t)

                      (delete-region (+ (match-beginning 0) 2)
                                     (+ (match-beginning 0) 3))))))
                      (delete-region (+ (match-beginning 0) 2)
                                     (+ (match-beginning 0) 3))))))

-               (cond 
+               (cond

                 ((eq (car cont) 'mml)
                  (let ((mml-boundary (funcall mml-boundary-function
                                               (incf mml-multipart-number)))
                 ((eq (car cont) 'mml)
                  (let ((mml-boundary (funcall mml-boundary-function
                                               (incf mml-multipart-number)))


@@ -327,7 +338,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                  (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
                    ;; ignore 0x1b, it is part of iso-2022-jp
                    (setq encoding (mm-body-7-or-8))))
                  (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
                    ;; ignore 0x1b, it is part of iso-2022-jp
                    (setq encoding (mm-body-7-or-8))))

-                (t 
+                (t

                  (setq charset (mm-encode-body charset))
                  (setq encoding (mm-body-encoding
                                  charset (cdr (assq 'encoding cont))))))
                  (setq charset (mm-encode-body charset))
                  (setq encoding (mm-body-encoding
                                  charset (cdr (assq 'encoding cont))))))


@@ -369,7 +380,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
               (concat "access-type="
                       (if (member (nth 0 name) '("ftp@" "anonymous@"))
                           "anon-ftp"
               (concat "access-type="
                       (if (member (nth 0 name) '("ftp@" "anonymous@"))
                           "anon-ftp"

-                        "ftp")))))      
+                        "ftp")))))

          (when url
            (mml-insert-parameter
             (mail-header-encode-parameter "url" url)
          (when url
            (mml-insert-parameter
             (mail-header-encode-parameter "url" url)


@@ -523,8 +534,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
         (mail-header-encode-parameter
          (symbol-name type) value))))))
 
         (mail-header-encode-parameter
          (symbol-name type) value))))))
 

-(defvar ange-ftp-name-format)
-(defvar efs-path-regexp)
+(eval-when-compile
+  (defvar ange-ftp-name-format)
+  (defvar efs-path-regexp))

 (defun mml-parse-file-name (path)
   (if (if (boundp 'efs-path-regexp)
          (string-match efs-path-regexp path)
 (defun mml-parse-file-name (path)
   (if (if (boundp 'efs-path-regexp)
          (string-match efs-path-regexp path)


@@ -585,7 +597,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
        (save-excursion
          (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
          (mm-insert-part handle)
        (save-excursion
          (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
          (mm-insert-part handle)

-         (if (setq mmlp (equal (mm-handle-media-type handle) 
+         (if (setq mmlp (equal (mm-handle-media-type handle)

                                "message/rfc822"))
              (mime-to-mml)))))
     (if mmlp
                                "message/rfc822"))
              (mime-to-mml)))))
     (if mmlp


@@ -594,7 +606,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
                   (equal (mm-handle-media-type handle) "text/plain"))
        (mml-insert-mml-markup handle buffer textp)))
     (cond
                   (equal (mm-handle-media-type handle) "text/plain"))
        (mml-insert-mml-markup handle buffer textp)))
     (cond

-     (mmlp 
+     (mmlp

       (insert-buffer buffer)
       (goto-char (point-max))
       (insert "<#/mml>\n"))
       (insert-buffer buffer)
       (goto-char (point-max))
       (insert "<#/mml>\n"))


@@ -849,7 +861,7 @@ If RAW, don't highlight the article."
   (interactive "P")
   (let ((buf (current-buffer))
        (message-options message-options)
   (interactive "P")
   (let ((buf (current-buffer))
        (message-options message-options)

-       (message-posting-charset (or (gnus-setup-posting-charset 
+       (message-posting-charset (or (gnus-setup-posting-charset

                                      (save-restriction
                                        (message-narrow-to-headers-or-head)
                                        (message-fetch-field "Newsgroups")))
                                      (save-restriction
                                        (message-narrow-to-headers-or-head)
                                        (message-fetch-field "Newsgroups")))


@@ -875,8 +887,10 @@ If RAW, don't highlight the article."
        (run-hooks 'gnus-article-decode-hook)
        (let ((gnus-newsgroup-name "dummy"))
          (gnus-article-prepare-display))))
        (run-hooks 'gnus-article-decode-hook)
        (let ((gnus-newsgroup-name "dummy"))
          (gnus-article-prepare-display))))

-    (fundamental-mode)
+    ;; Disable article-mode-map. 
+    (use-local-map nil)

     (setq buffer-read-only t)
     (setq buffer-read-only t)

+    (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))

     (goto-char (point-min))))
 
 (defun mml-validate ()
     (goto-char (point-min))))
 
 (defun mml-validate ()