Synch to No Gnus 200501120840.
[elisp/gnus.git-] / lisp / gnus-art.el
index 174c983..8d2cbbd 100644 (file)
@@ -353,27 +353,56 @@ advertisements.  For example:
                   (symbol :tag "Item in `gnus-article-banner-alist'" none)
                   regexp
                   (const :tag "None" nil))))
+  :version "21.4"
   :group 'gnus-article-washing)
 
+(defmacro gnus-emphasis-custom-with-format (&rest body)
+  `(let ((format "\
+\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
+\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
+     ,@body))
+
+(defun gnus-emphasis-custom-value-to-external (value)
+  (gnus-emphasis-custom-with-format
+   (if (consp (car value))
+       (list (format format (car (car value)) (cdr (car value)))
+            2
+            (if (nth 1 value) 2 3)
+            (nth 2 value))
+     value)))
+
+(defun gnus-emphasis-custom-value-to-internal (value)
+  (gnus-emphasis-custom-with-format
+   (let ((regexp (concat "\\`"
+                        (format (regexp-quote format)
+                                "\\([^()]+\\)" "\\([^()]+\\)")
+                        "\\'"))
+        pattern)
+     (if (string-match regexp (setq pattern (car value)))
+        (list (cons (match-string 1 pattern) (match-string 2 pattern))
+              (= (nth 2 value) 2)
+              (nth 3 value))
+       value))))
+
 (defcustom gnus-emphasis-alist
-  (let ((format
-        "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
-       (types
-        '(("\\*" "\\*" bold)
+  (let ((types
+        '(("\\*" "\\*" bold nil 2)
           ("_" "_" underline)
           ("/" "/" italic)
           ("_/" "/_" underline-italic)
           ("_\\*" "\\*_" underline-bold)
           ("\\*/" "/\\*" bold-italic)
           ("_\\*/" "/\\*_" underline-bold-italic))))
-    `(,@(mapcar
-        (lambda (spec)
-          (list
-           (format format (car spec) (car (cdr spec)))
-           2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
-        types)
-       ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
-        2 3 gnus-emphasis-underline)))
+    (nconc
+     (gnus-emphasis-custom-with-format
+      (mapcar (lambda (spec)
+               (list (format format (car spec) (cadr spec))
+                     (or (nth 3 spec) 2)
+                     (or (nth 4 spec) 3)
+                     (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
+             types))
+     '(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+       2 3 gnus-emphasis-underline))))
   "*Alist that says how to fontify certain phrases.
 Each item looks like this:
 
@@ -384,11 +413,43 @@ is a number that says what regular expression grouping used to find
 the entire emphasized word.  The third is a number that says what
 regexp grouping should be displayed and highlighted.  The fourth
 is the face used for highlighting."
-  :type '(repeat (list :value ("" 0 0 default)
-                      regexp
-                      (integer :tag "Match group")
-                      (integer :tag "Emphasize group")
-                      face))
+  :type
+  '(repeat
+    (menu-choice
+     :format "%[Customizing Style%]\n%v"
+     :indent 2
+     (group :tag "Default"
+           :value ("" 0 0 default)
+           :value-create
+           (lambda (widget)
+             (let ((value (widget-get
+                           (cadr (widget-get (widget-get widget :parent)
+                                             :args))
+                           :value)))
+               (if (not (eq (nth 2 value) 'default))
+                   (widget-put
+                    widget
+                    :value
+                    (gnus-emphasis-custom-value-to-external value))))
+             (widget-group-value-create widget))
+           regexp
+           (integer :format "Match group: %v")
+           (integer :format "Emphasize group: %v")
+           face)
+     (group :tag "Simple"
+           :value (("_" . "_") nil default)
+           (cons :format "%v"
+                 (regexp :format "Start regexp: %v")
+                 (regexp :format "End regexp: %v"))
+           (boolean :format "Show start and end patterns: %[%v%]\n"
+                    :on " On " :off " Off ")
+           face)))
+  :get (lambda (symbol)
+        (mapcar 'gnus-emphasis-custom-value-to-internal
+                (default-value symbol)))
+  :set (lambda (symbol value)
+        (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external
+                                    value)))
   :group 'gnus-article-emphasis)
 
 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
@@ -540,17 +601,19 @@ you could set this variable to something like:
  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
 
-This variable is an alist where the where the key is the match and the
-value is a list of possible files to save in if the match is non-nil.
+This variable is an alist where the key is the match and the
+value is a list of possible files to save in if the match is
+non-nil.
 
 If the match is a string, it is used as a regexp match on the
 article.  If the match is a symbol, that symbol will be funcalled
-from the buffer of the article to be saved with the newsgroup as the
-parameter.  If it is a list, it will be evaled in the same buffer.
+from the buffer of the article to be saved with the newsgroup as
+the parameter.  If it is a list, it will be evaled in the same
+buffer.
 
-If this form or function returns a string, this string will be used as
-a possible file name; and if it returns a non-nil list, that list will
-be used as possible file names."
+If this form or function returns a string, this string will be
+used as a possible file name; and if it returns a non-nil list,
+that list will be used as possible file names."
   :group 'gnus-article-saving
   :type '(repeat (choice (list :value (fun) function)
                         (cons :value ("" "") regexp (repeat string))
@@ -610,6 +673,13 @@ The following additional specs are available:
   :type 'hook
   :group 'gnus-article-various)
 
+(defcustom gnus-copy-article-ignored-headers nil
+  "List of headers to be removed when copying an article.
+Each element is a regular expression."
+  :version "22.0" ;; No Gnus
+  :type '(repeat regexp)
+  :group 'gnus-article-various)
+
 (make-obsolete-variable 'gnus-article-hide-pgp-hook
                        "This variable is obsolete in Gnus 5.10.")
 
@@ -969,6 +1039,7 @@ See Info node `(gnus)Customizing Articles' for details."
   "Remove newlines from within URLs.
 Valid values are nil, t, `head', `last', an integer or a predicate.
 See Info node `(gnus)Customizing Articles' for details."
+  :version "21.4"
   :group 'gnus-article-treat
   :link '(custom-manual "(gnus)Customizing Articles")
   :type gnus-article-treat-custom)
@@ -1173,6 +1244,7 @@ See Info node `(gnus)Customizing Articles' for details."
   "Unfold folded header lines.
 Valid values are nil, t, `head', `last', an integer or a predicate.
 See Info node `(gnus)Customizing Articles' for details."
+  :version "21.4"
   :group 'gnus-article-treat
   :link '(custom-manual "(gnus)Customizing Articles")
   :type gnus-article-treat-custom)
@@ -1328,6 +1400,7 @@ See Info node `(gnus)Customizing Articles' and Info node
 Valid values are nil, t, `head', `last', an integer or a predicate.
 See Info node `(gnus)Customizing Articles' and Info node
 `(gnus)Picons' for details."
+  :version "21.4"
   :group 'gnus-article-treat
   :group 'gnus-picon
   :link '(custom-manual "(gnus)Customizing Articles")
@@ -1343,6 +1416,7 @@ See Info node `(gnus)Customizing Articles' and Info node
 Valid values are nil, t, `head', `last', an integer or a predicate.
 See Info node `(gnus)Customizing Articles' and Info node
 `(gnus)Picons' for details."
+  :version "21.4"
   :group 'gnus-article-treat
   :group 'gnus-picon
   :link '(custom-manual "(gnus)Customizing Articles")
@@ -1367,9 +1441,10 @@ See Info node `(gnus)Customizing Articles' and Info node
 (put 'gnus-treat-newsgroups-picon 'highlight t)
 
 (defcustom gnus-treat-body-boundary
-  (if (or gnus-treat-newsgroups-picon
-         gnus-treat-mail-picon
-         gnus-treat-from-picon)
+  (if (and (eq window-system 'x)
+          (or gnus-treat-newsgroups-picon
+              gnus-treat-mail-picon
+              gnus-treat-from-picon))
       'head nil)
   "Draw a boundary at the end of the headers.
 Valid values are nil and `head'.
@@ -1438,6 +1513,7 @@ See Info node `(gnus)Customizing Articles' for details."
 To automatically treat X-PGP-Sig, set it to head.
 Valid values are nil, t, `head', `last', an integer or a predicate.
 See Info node `(gnus)Customizing Articles' for details."
+  :version "21.4"
   :group 'gnus-article-treat
   :group 'mime-security
   :type gnus-article-treat-custom)
@@ -1775,12 +1851,9 @@ always hide."
     (save-excursion
       (save-restriction
        (let ((inhibit-read-only t)
-             (list gnus-boring-article-headers)
-             (inhibit-point-motion-hooks t)
-             elem)
+             (inhibit-point-motion-hooks t))
          (article-narrow-to-head)
-         (while list
-           (setq elem (pop list))
+         (dolist (elem gnus-boring-article-headers)
            (goto-char (point-min))
            (cond
             ;; Hide empty headers.
@@ -1988,9 +2061,8 @@ characters to translate to."
 MAP is an alist where the elements are on the form (\"from\" \"to\")."
   (save-excursion
     (when (article-goto-body)
-      (let ((inhibit-read-only t)
-           elem)
-       (while (setq elem (pop map))
+      (let ((inhibit-read-only t))
+       (dolist (elem map)
          (save-excursion
            (while (search-forward (car elem) nil t)
              (replace-match (cadr elem)))))))))
@@ -2214,7 +2286,7 @@ unfolded."
              (mail-narrow-to-head)
              (while (gnus-article-goto-header "Face")
                (setq faces (nconc faces (list (mail-header-field-value)))))))
-         (while (setq face (pop faces))
+         (dolist (face faces)
            (let ((png (gnus-convert-face-to-png face))
                  image)
              (when png
@@ -2502,7 +2574,7 @@ If READ-CHARSET, ask for a coding system."
     (let ((inhibit-read-only t))
       (goto-char (point-min))
       (while (re-search-forward
-             "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
+             "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
        (replace-match "\\1\\3" t)))
     (when (interactive-p)
       (gnus-treat-article nil))))
@@ -4743,8 +4815,8 @@ N is the numerical prefix."
 
 (defun gnus-article-mime-match-handle-first (condition)
   (if condition
-      (let ((alist gnus-article-mime-handle-alist) ihandle n)
-       (while (setq ihandle (pop alist))
+      (let (n)
+       (dolist (ihandle gnus-article-mime-handle-alist)
          (if (and (cond
                    ((functionp condition)
                     (funcall condition (cdr ihandle)))
@@ -4911,11 +4983,15 @@ N is the numerical prefix."
          ;; We have to do this since selecting the window
          ;; may change the point.  So we set the window point.
          (set-window-point window point)))
-      (let* ((handles (or ihandles
-                         (mm-dissect-buffer nil gnus-article-loose-mime)
-                         (and gnus-article-emulate-mime
-                              (mm-uu-dissect))))
-            (inhibit-read-only t) handle name type b e display)
+      (let ((handles ihandles)
+           (inhibit-read-only t)
+           handle name type b e display)
+       (cond (handles)
+             ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
+              (when gnus-article-emulate-mime
+                (mm-uu-dissect-text-parts handles)))
+             (gnus-article-emulate-mime
+              (setq handles (mm-uu-dissect))))
        (when (and (not ihandles)
                   (not gnus-displaying-mime))
          ;; Top-level call; we clean up.
@@ -5076,7 +5152,7 @@ If displaying \"text/html\" is discouraged \(see
              (forward-line -1)
              (setq beg (point)))
            (gnus-article-insert-newline)
-           (mm-insert-inline handle (mm-get-part handle))
+           (mm-display-inline handle)
            (goto-char (point-max))))
          ;; Do highlighting.
          (save-excursion
@@ -5340,7 +5416,7 @@ If given a numerical ARG, move forward ARG pages."
          (goto-char (point-min))
          (gnus-insert-prev-page-button)))
       (when (and (gnus-visual-p 'page-marker)
-                (< (+ (point-max) 2) (buffer-size)))
+                (< (point-max) (save-restriction (widen) (point-max))))
        (save-excursion
          (goto-char (point-max))
          (gnus-insert-next-page-button))))))
@@ -5986,7 +6062,10 @@ groups."
   "Start editing the contents of the current article buffer."
   (let ((winconf (current-window-configuration)))
     (set-buffer gnus-article-buffer)
-    (gnus-article-edit-mode)
+    (let ((message-auto-save-directory
+          ;; Don't associate the article buffer with a draft file.
+          nil))
+      (gnus-article-edit-mode))
     (funcall start-func)
     (set-buffer-modified-p nil)
     (gnus-configure-windows 'edit-article)
@@ -6717,6 +6796,8 @@ variable it the real callback function."
      0 (>= gnus-button-browse-level 0) browse-url 0)
     ("^[^:]+:" gnus-button-url-regexp
      0 (>= gnus-button-browse-level 0) browse-url 0)
+    ("^OpenPGP:.*url=" gnus-button-url-regexp
+     0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0)
     ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
     ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
@@ -6827,9 +6908,8 @@ do the highlighting.  See the documentation for those functions."
   "Highlight article headers as specified by `gnus-header-face-alist'."
   (interactive)
   (gnus-with-article-headers
-    (let ((alist gnus-header-face-alist)
-         entry regexp header-face field-face from hpoints fpoints)
-      (while (setq entry (pop alist))
+    (let (regexp header-face field-face from hpoints fpoints)
+      (dolist (entry gnus-header-face-alist)
        (goto-char (point-min))
        (setq regexp (concat "^\\("
                             (if (string-equal "" (nth 0 entry))
@@ -6934,11 +7014,9 @@ specified by `gnus-button-alist'."
   "Add buttons to the head of the article."
   (interactive)
   (gnus-with-article-headers
-    (let ((alist gnus-header-button-alist)
-         entry beg end)
-      (while alist
+    (let (beg end)
+      (dolist (entry gnus-header-button-alist)
        ;; Each alist entry.
-       (setq entry (pop alist))
        (goto-char (point-min))
        (while (re-search-forward (car entry) nil t)
          ;; Each header matching the entry.
@@ -7125,6 +7203,13 @@ specified by `gnus-button-alist'."
   (Info-directory)
   (Info-menu url))
 
+(defun gnus-button-openpgp (url)
+  "Retrieve and add an OpenPGP key given URL from an OpenPGP header."
+  (with-temp-buffer
+    (mm-url-insert-file-contents-external url)
+    (pgg-snarf-keys-region (point-min) (point-max))
+    (pgg-display-output-buffer nil nil nil)))
+
 (defun gnus-button-message-id (message-id)
   "Fetch MESSAGE-ID."
   (with-current-buffer gnus-summary-buffer