New branch "et-gnus-6_11" for experimental T-gnus.
[elisp/gnus.git-] / lisp / gnus-art.el
index 865fa38..4e00ea7 100644 (file)
@@ -619,6 +619,14 @@ on parts -- for instance, adding Vcard info to a database."
 (defcustom gnus-mime-multipart-functions nil
   "An alist of MIME types to functions to display them.")
 
+(defcustom gnus-article-date-lapsed-new-header nil
+  "Whether the X-Sent and Date headers can coexist.
+When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
+either replace the old \"Date:\" header (if this variable is nil), or
+be added below it (otherwise)."
+  :group 'gnus-article-headers
+  :type 'boolean)
+
 ;;;
 ;;; The treatment variables
 ;;;
@@ -884,12 +892,22 @@ See the manual for details."
   :type gnus-article-treat-custom)
 
 (defcustom gnus-treat-play-sounds nil
-  "Fill long lines.
+  "Play sounds.
 Valid values are nil, t, `head', `last', an integer or a predicate.
 See the manual for details."
   :group 'gnus-article-treat
   :type gnus-article-treat-custom)
 
+(defcustom gnus-treat-decode-article-as-default-mime-charset nil
+  "Decode an article as `default-mime-charset'.  For instance, if you want to
+attempt to decode an article even if the value of `gnus-show-mime' is nil,
+you could set this variable to something like: nil for don't decode, t for
+decode the body, '(or header t) for the whole article, etc."
+  :group 'gnus-article-treat
+  :type '(radio (const :tag "Off" nil)
+               (const :tag "Decode body" t)
+               (const :tag "Decode all" (or head t))))
+
 ;;; Internal variables
 
 (defvar article-goto-body-goes-to-point-min-p nil)
@@ -899,7 +917,6 @@ See the manual for details."
 (defvar gnus-treatment-function-alist
   '((gnus-treat-strip-banner gnus-article-strip-banner)
     (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
-    (gnus-treat-highlight-signature gnus-article-highlight-signature)
     (gnus-treat-buttonize gnus-article-add-buttons)
     (gnus-treat-fill-article gnus-article-fill-cited-article)
     (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
@@ -932,7 +949,9 @@ See the manual for details."
     (gnus-treat-display-xface gnus-article-display-x-face)
     (gnus-treat-display-smileys gnus-smiley-display)
     (gnus-treat-display-picons gnus-article-display-picons)
-    (gnus-treat-play-sounds gnus-earcon-display)))
+    (gnus-treat-play-sounds gnus-earcon-display)
+    (gnus-treat-decode-article-as-default-mime-charset
+     gnus-article-decode-article-as-default-mime-charset)))
 
 (defvar gnus-article-mime-handle-alist nil)
 (defvar article-lapsed-timer nil)
@@ -1030,81 +1049,75 @@ Initialized from `text-mode-syntax-table.")
     i))
 
 (defun article-hide-headers (&optional arg delete)
-  "Toggle whether to hide unwanted headers and possibly sort them as well.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
+  "Hide unwanted headers and possibly sort them as well."
   (interactive (gnus-article-hidden-arg))
-  (current-buffer)
+  ;; Lars said that this function might be inhibited.
   (if (gnus-article-check-hidden-text 'headers arg)
-      ;; Show boring headers as well.
       (progn
+       ;; Show boring headers as well.
        (gnus-article-show-hidden-text 'boring-headers)
        (when (eq 1 (point-min))
          (set-window-start (get-buffer-window (current-buffer)) 1)))
-    ;; This function might be inhibited.
-    (unless gnus-inhibit-hiding
-      (save-excursion
-       (save-restriction
-         (let ((buffer-read-only nil)
-               (case-fold-search t)
-               (props (nconc (list 'article-type 'headers)
-                             gnus-hidden-properties))
-               (max (1+ (length gnus-sorted-header-list)))
-               (ignored (when (not gnus-visible-headers)
-                          (cond ((stringp gnus-ignored-headers)
-                                 gnus-ignored-headers)
-                                ((listp gnus-ignored-headers)
-                                 (mapconcat 'identity gnus-ignored-headers
-                                            "\\|")))))
-               (visible
-                (cond ((stringp gnus-visible-headers)
-                       gnus-visible-headers)
-                      ((and gnus-visible-headers
-                            (listp gnus-visible-headers))
-                       (mapconcat 'identity gnus-visible-headers "\\|"))))
-               (inhibit-point-motion-hooks t)
-               beg)
-           ;; First we narrow to just the headers.
-           (goto-char (point-min))
-           ;; Hide any "From " lines at the beginning of (mail) articles.
-           (while (looking-at "From ")
-             (forward-line 1))
-           (unless (bobp)
-             (if delete
-                 (delete-region (point-min) (point))
-               (gnus-article-hide-text (point-min) (point) props)))
-           ;; Then treat the rest of the header lines.
-           (narrow-to-region
-            (point)
-            (if (search-forward "\n\n" nil t) ; if there's a body
-                (progn (forward-line -1) (point))
-              (point-max)))
-           ;; Then we use the two regular expressions
-           ;; `gnus-ignored-headers' and `gnus-visible-headers' to
-           ;; select which header lines is to remain visible in the
-           ;; article buffer.
-           (goto-char (point-min))
-           (while (re-search-forward "^[^ \t]*:" nil t)
-             (beginning-of-line)
-             ;; Mark the rank of the header.
-             (put-text-property
-              (point) (1+ (point)) 'message-rank
-              (if (or (and visible (looking-at visible))
-                      (and ignored
-                           (not (looking-at ignored))))
-                  (gnus-article-header-rank)
-                (+ 2 max)))
-             (forward-line 1))
-           (message-sort-headers-1)
-           (when (setq beg (text-property-any
-                            (point-min) (point-max) 'message-rank (+ 2 max)))
-             ;; We make the unwanted headers invisible.
-             (if delete
-                 (delete-region beg (point-max))
-               ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
-               (gnus-article-hide-text-type beg (point-max) 'headers))
-             ;; Work around XEmacs lossage.
-             (put-text-property (point-min) beg 'invisible nil))))))))
+  (unless gnus-inhibit-hiding
+    (save-excursion
+      (save-restriction
+       (let ((buffer-read-only nil)
+             (inhibit-read-only t)
+             (case-fold-search t)
+             (max (1+ (length gnus-sorted-header-list)))
+             (ignored (when (not gnus-visible-headers)
+                        (cond ((stringp gnus-ignored-headers)
+                               gnus-ignored-headers)
+                              ((listp gnus-ignored-headers)
+                               (mapconcat 'identity gnus-ignored-headers
+                                          "\\|")))))
+             (visible
+              (cond ((stringp gnus-visible-headers)
+                     gnus-visible-headers)
+                    ((and gnus-visible-headers
+                          (listp gnus-visible-headers))
+                     (mapconcat 'identity gnus-visible-headers "\\|"))))
+             (inhibit-point-motion-hooks t)
+             beg)
+         ;; First we narrow to just the headers.
+         (article-narrow-to-head)
+         ;; Hide any "From " lines at the beginning of (mail) articles.
+         (while (looking-at "From ")
+           (forward-line 1))
+         (unless (bobp)
+           (if delete
+               (delete-region (point-min) (point))
+             (gnus-article-hide-text (point-min) (point)
+                                     (nconc (list 'article-type 'headers)
+                                            gnus-hidden-properties))))
+         ;; Then treat the rest of the header lines.
+         ;; Then we use the two regular expressions
+         ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+         ;; select which header lines is to remain visible in the
+         ;; article buffer.
+         (while (re-search-forward "^[^ \t]*:" nil t)
+           (beginning-of-line)
+           ;; Mark the rank of the header.
+           (put-text-property
+            (point) (1+ (point)) 'message-rank
+            (if (or (and visible (looking-at visible))
+                    (and ignored
+                         (not (looking-at ignored))))
+                (gnus-article-header-rank)
+              (+ 2 max)))
+           (forward-line 1))
+         (message-sort-headers-1)
+         (when (setq beg (text-property-any
+                          (point-min) (point-max) 'message-rank (+ 2 max)))
+           ;; We delete or make invisible the unwanted headers.
+           (if delete
+               (progn
+                 (add-text-properties
+                  (point-min) (+ 5 (point-min))
+                  '(article-type headers dummy-invisible t))
+                 (delete-region beg (point-max)))
+             (gnus-article-hide-text-type beg (point-max) 'headers))))))))
+  )
 
 (defun article-hide-boring-headers (&optional arg)
   "Toggle hiding of headers that aren't very interesting.
@@ -1196,6 +1209,86 @@ always hide."
           (point-max)))
        'boring-headers))))
 
+(defun article-toggle-headers (&optional arg)
+  "Toggle hiding of headers.  If given a negative prefix, always show;
+if given a positive prefix, always hide."
+  (interactive (gnus-article-hidden-arg))
+  (let ((force (when (numberp arg)
+                (cond ((> arg 0) 'always-hide)
+                      ((< arg 0) 'always-show))))
+       (window (get-buffer-window gnus-article-buffer))
+       (header-end (point-min))
+       header-start field-end field-start
+       (inhibit-point-motion-hooks t)
+       (inhibit-read-only t)
+       buffer-read-only)
+    (save-restriction
+      (widen)
+      (while (and (setq header-start
+                       (text-property-any header-end (point-max)
+                                          'article-treated-header t))
+                 (setq header-end
+                       (text-property-not-all header-start (point-max)
+                                              'article-treated-header t)))
+       (setq field-end header-start)
+       (cond
+        (;; Hide exposed invisible fields.
+         (and (not (eq 'always-show force))
+              (setq field-start
+                    (text-property-any field-end header-end
+                                       'exposed-invisible-field t)))
+         (while (and field-start
+                     (setq field-end (text-property-not-all
+                                      field-start header-end
+                                      'exposed-invisible-field t)))
+           (add-text-properties field-start field-end gnus-hidden-properties)
+           (setq field-start (text-property-any field-end header-end
+                                                'exposed-invisible-field t)))
+         (put-text-property header-start header-end
+                            'exposed-invisible-field nil))
+        (;; Expose invisible fields.
+         (and (not (eq 'always-hide force))
+              (setq field-start
+                    (text-property-any field-end header-end 'invisible t)))
+         (while (and field-start
+                     (setq field-end (text-property-not-all
+                                      field-start header-end
+                                      'invisible t)))
+           ;; If the invisible text is not terminated with newline, we
+           ;; won't expose it.  Because it may be created by x-face-mule.
+           ;; BTW, XEmacs sometimes fail in putting a invisible text
+           ;; property with `gnus-article-hide-text' (really?).  In that
+           ;; case, the invisible text might be started from the middle of
+           ;; a line so we will expose the sort of thing.
+           (when (or (not (or (eq header-start field-start)
+                              (eq ?\n (char-before field-start))))
+                     (eq ?\n (char-before field-end)))
+             (remove-text-properties field-start field-end
+                                     gnus-hidden-properties)
+             (put-text-property field-start field-end
+                                'exposed-invisible-field t))
+           (setq field-start (text-property-any field-end header-end
+                                                'invisible t))))
+        (;; Hide fields.
+         (not (eq 'always-show force))
+         (narrow-to-region header-start header-end)
+         (article-hide-headers)
+         ;; Re-display X-Face image under XEmacs.
+         (when (and (featurep 'xemacs)
+                    (gnus-functionp gnus-article-x-face-command))
+           (let ((func (cadr (assq 'gnus-treat-display-xface
+                                   gnus-treatment-function-alist)))
+                 (condition 'head))
+             (when (and func
+                        (gnus-treat-predicate gnus-treat-display-xface))
+               (funcall func)
+               (put-text-property header-start header-end 'read-only nil))))
+         (widen))
+        ))
+      (goto-char (point-min))
+      (when window
+       (set-window-start window (point-min))))))
+
 (defvar gnus-article-normalized-header-length 40
   "Length of normalized headers.")
 
@@ -1736,7 +1829,8 @@ means show, 0 means toggle."
   "Say whether the current buffer contains hidden text of type TYPE."
   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
     (while (and pos
-               (not (get-text-property pos 'invisible)))
+               (not (get-text-property pos 'invisible))
+               (not (get-text-property pos 'dummy-invisible)))
       (setq pos
            (text-property-any (1+ pos) (point-max) 'article-type type)))
     (if pos
@@ -1774,46 +1868,75 @@ If HIDE, hide the text instead."
 (defun article-date-ut (&optional type highlight header)
   "Convert DATE date to universal time in the current article.
 If TYPE is `local', convert to local time; if it is `lapsed', output
-how much time has lapsed since DATE."
+how much time has lapsed since DATE. For `lapsed', the value of
+`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
+should replace the \"Date:\" one, or should be added below it."
   (interactive (list 'ut t))
   (let* ((header (or header
-                    (mail-header-date (save-excursion
-                                        (set-buffer gnus-summary-buffer)
-                                        gnus-current-headers))
+                    (and (eq 1 (point-min))
+                         (mail-header-date (save-excursion
+                                             (set-buffer gnus-summary-buffer)
+                                             gnus-current-headers)))
                     (message-fetch-field "date")
                     ""))
         (date (if (vectorp header) (mail-header-date header)
                 header))
-        (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
         (inhibit-point-motion-hooks t)
-        bface eface newline)
+        bface eface date-pos)
     (when (and date (not (string= date "")))
       (save-excursion
        (save-restriction
          (article-narrow-to-head)
+         (when (or (and (eq type 'lapsed)
+                        gnus-article-date-lapsed-new-header
+                        ;; Attempt to get the face of X-Sent first.
+                        (re-search-forward "^X-Sent:[ \t]" nil t))
+                   (re-search-forward "^Date:[ \t]" nil t)
+                   ;; If Date is missing, try again for X-Sent.
+                   (re-search-forward "^X-Sent:[ \t]" nil t))
+           (setq bface (get-text-property (gnus-point-at-bol) 'face)
+                 eface (get-text-property (1- (gnus-point-at-eol))
+                                          'face)))
          (let ((buffer-read-only nil))
+           ;; Delete any old X-Sent headers.
+           (when (setq date-pos
+                       (text-property-any (point-min) (point-max)
+                                          'article-date-lapsed t))
+             (goto-char (setq date-pos (set-marker (make-marker) date-pos)))
+             (delete-region (match-beginning 0)
+                            (progn (forward-line 1) (point))))
+           (goto-char (point-min))
            ;; Delete any old Date headers.
-           (if (re-search-forward date-regexp nil t)
+           (while (re-search-forward "^Date:[ \t]" nil t)
+             (unless date-pos
+               (setq date-pos (match-beginning 0)))
+             (unless (and (eq type 'lapsed)
+                          gnus-article-date-lapsed-new-header)
+               (delete-region (match-beginning 0)
+                              (progn (message-next-header) (point)))))
+           (if date-pos
                (progn
-                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
-                       eface (get-text-property (1- (gnus-point-at-eol))
-                                                'face))
-                 (delete-region (progn (beginning-of-line) (point))
-                                (progn (end-of-line) (point)))
-                 (beginning-of-line))
-             (goto-char (point-max))
-             (setq newline t))
+                 (goto-char date-pos)
+                 (unless (bolp)
+                   ;; Possibly, Date has been deleted.
+                   (insert "\n"))
+                 (when (and (eq type 'lapsed)
+                            gnus-article-date-lapsed-new-header
+                            (looking-at "Date:"))
+                   (forward-line 1)))
+             (goto-char (point-min)))
            (insert (article-make-date-line date type))
+           (when (eq type 'lapsed)
+             (put-text-property (gnus-point-at-bol) (point)
+                                'article-date-lapsed t))
+           (insert "\n")
+           (forward-line -1)
            ;; Do highlighting.
-           (beginning-of-line)
            (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
              (put-text-property (match-beginning 1) (1+ (match-end 1))
                                 'face bface)
              (put-text-property (match-beginning 2) (match-end 2)
-                                'face eface))
-           (when newline
-             (end-of-line)
-             (insert "\n"))))))))
+                                'face eface))))))))
 
 (defun article-make-date-line (date type)
   "Return a DATE line of TYPE."
@@ -2309,6 +2432,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
                      (apply ',afunc args))))))))
    '(article-hide-headers
      article-hide-boring-headers
+     article-toggle-headers
      article-treat-overstrike
      article-fill-long-lines
      article-capitalize-sentences
@@ -2412,7 +2536,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
     (easy-menu-define
      gnus-article-treatment-menu gnus-article-mode-map ""
      '("Treatment"
-       ["Hide headers" gnus-article-hide-headers t]
+       ["Hide headers" gnus-article-toggle-headers t]
        ["Hide signature" gnus-article-hide-signature t]
        ["Hide citation" gnus-article-hide-citation t]
        ["Treat overstrike" gnus-article-treat-overstrike t]
@@ -2692,23 +2816,129 @@ If ALL-HEADERS is non-nil, no headers are hidden."
            (gnus-configure-windows 'article)
            t))))))
 
+(defun gnus-article-prepare-mime-display (&optional number)
+  (goto-char (point-min))
+  (when (re-search-forward "^[^\t ]+:" nil t)
+    (goto-char (match-beginning 0)))
+  (let* ((entity (if (eq 1 (point-min))
+                    (get-text-property 1 'mime-view-entity)
+                  (get-text-property (point) 'mime-view-entity)))
+        (number (or number 0))
+        next type ids)
+    (save-restriction
+      (narrow-to-region (point)
+                       (if (search-forward "\n\n" nil t)
+                           (point)
+                         (point-max)))
+      (gnus-treat-article 'head)
+      (put-text-property (point-min) (point-max) 'article-treated-header t)
+      (goto-char (point-max)))
+    (while (and (not (eobp))
+               entity
+               (setq next (next-single-property-change (point)
+                                                       'mime-view-entity)))
+      (setq type (mime-entity-content-type entity)
+           type (format "%s/%s"
+                        (mime-content-type-primary-type type)
+                        (mime-content-type-subtype type)))
+      (if (string-equal type "message/rfc822")
+         (save-restriction
+           (narrow-to-region (point) (point-max))
+           (gnus-article-prepare-mime-display number)
+           (goto-char (point-max)))
+       (setq ids (length (mime-entity-node-id entity))
+             entity (get-text-property next 'mime-view-entity)
+             number (1+ number))
+       (save-restriction
+         (narrow-to-region (point) next)
+         (if (or (null entity)
+                 (< (length (mime-entity-node-id entity)) ids))
+             (gnus-treat-article 'last number number type)
+           (gnus-treat-article t number nil type))
+         (goto-char (point-max)))))
+    (unless (eobp)
+      (save-restriction
+       (narrow-to-region (point) (point-max))
+       (if entity
+           (progn
+             (setq type (mime-entity-content-type entity)
+                   type (format "%s/%s"
+                                (mime-content-type-primary-type type)
+                                (mime-content-type-subtype type)))
+             (if (string-equal type "message/rfc822")
+                 (gnus-article-prepare-mime-display number)
+               (incf number)
+               (gnus-treat-article 'last number number type)))
+         (gnus-treat-article t))))))
+
 ;;;###autoload
 (defun gnus-article-prepare-display ()
   "Make the current buffer look like a nice article."
-  (let ((method
-        (if gnus-show-mime
-            (progn
-              (setq mime-message-structure gnus-current-headers)
-              gnus-article-display-method-for-mime)
-          gnus-article-display-method-for-traditional)))
-    (gnus-run-hooks 'gnus-tmp-internal-hook)
-    (gnus-run-hooks 'gnus-article-prepare-hook)
-    ;; Display message.
-    (funcall method)
-    ;; Associate this article with the current summary buffer.
-    (setq gnus-article-current-summary gnus-summary-buffer)
-    ;; Perform the article display hooks.
-    (gnus-run-hooks 'gnus-article-display-hook)))
+  (gnus-run-hooks 'gnus-tmp-internal-hook)
+  (gnus-run-hooks 'gnus-article-prepare-hook)
+  ;; Display message.
+  (let (mime-display-header-hook)
+    (funcall (if gnus-show-mime
+                (progn
+                  (setq mime-message-structure gnus-current-headers)
+                  (mime-buffer-entity-set-buffer-internal
+                   mime-message-structure
+                   gnus-original-article-buffer)
+                  (mime-entity-set-representation-type-internal
+                   mime-message-structure 'mime-buffer-entity)
+                  (luna-send mime-message-structure
+                             'initialize-instance
+                             mime-message-structure)
+                  gnus-article-display-method-for-mime)
+              gnus-article-display-method-for-traditional)))
+  ;; Associate this article with the current summary buffer.
+  (setq gnus-article-current-summary gnus-summary-buffer)
+  ;; Call the treatment functions.
+  (let ((inhibit-read-only t)
+       buffer-read-only)
+    (save-restriction
+      (widen)
+      (if gnus-show-mime
+         (gnus-article-prepare-mime-display)
+       (narrow-to-region (goto-char (point-min))
+                         (if (search-forward "\n\n" nil t)
+                             (point)
+                           (point-max)))
+       (gnus-treat-article 'head)
+       (put-text-property (point-min) (point-max) 'article-treated-header t)
+       (goto-char (point-max))
+       (widen)
+       (narrow-to-region (point) (point-max))
+       (gnus-treat-article t))
+      (put-text-property (point-min) (point-max) 'read-only nil)))
+  ;; Perform the article display hooks.  Incidentally, this hook is
+  ;; an obsolete variable by now.
+  (gnus-run-hooks 'gnus-article-display-hook))
+
+(defun gnus-article-decode-article-as-default-mime-charset ()
+  "Decode an article as `default-mime-charset'.  It won't work if the
+value of the variable `gnus-show-mime' is non-nil."
+  (unless gnus-show-mime
+    (decode-mime-charset-region (point-min) (point-max)
+                               (with-current-buffer gnus-summary-buffer
+                                 default-mime-charset))))
+
+(autoload 'x-face-mule-x-face-decode-message-header "x-face-mule")
+
+(defun gnus-article-display-x-face-with-x-face-mule (&rest args)
+  "Decode and show X-Face with the function
+`x-face-mule-x-face-decode-message-header'.  The buffer is expected to be
+narrowed to just the headers of the article."
+  (when (featurep 'xemacs)
+    (error "`%s' won't work under XEmacs."
+          'gnus-article-display-x-face-with-x-face-mule))
+  (when window-system
+    (condition-case err
+       (x-face-mule-x-face-decode-message-header)
+      (error (error "%s"
+                   (if (featurep 'x-face-mule)
+                       "Please install x-face-mule 0.24 or later."
+                     err))))))
 
 ;;;
 ;;; Gnus MIME viewing functions
@@ -4575,31 +4805,33 @@ For example:
 (defvar length)
 (defun gnus-treat-predicate (val)
   (cond
-   (condition
-    (eq condition val))
+   ((eq val 'mime)
+    (not (not gnus-show-mime)))
    ((null val)
     nil)
-   ((eq val t)
-    t)
-   ((eq val 'head)
-    nil)
-   ((eq val 'last)
-    (eq part-number total-parts))
-   ((numberp val)
-    (< length val))
    ((listp val)
     (let ((pred (pop val)))
       (cond
        ((eq pred 'or)
        (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
        ((eq pred 'and)
-       (apply 'gnus-and (mapcar 'gnus-tread-predicate val)))
+       (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
        ((eq pred 'not)
        (not (gnus-treat-predicate val)))
        ((eq pred 'typep)
        (equal (cadr val) type))
        (t
-       (error "%S is not a valid predicate" pred)))))
+       (gnus-treat-predicate pred)))))
+   (condition
+    (eq condition val))
+   ((eq val t)
+    t)
+   ((eq val 'head)
+    nil)
+   ((eq val 'last)
+    (eq part-number total-parts))
+   ((numberp val)
+    (< length val))
    (t
     (error "%S is not a valid value" val))))