*** empty log message ***
[gnus] / lisp / article.el
index ec64511..f4b9196 100644 (file)
 (require 'nnheader)
 (require 'gnus-util)
 (require 'message)
-
-(defvar article-ignored-headers
-   "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:\\|^Received:\\|^Mail-from:"
-  "*All headers that match this regexp will be hidden.
+(require 'custom)
+
+(defgroup article nil
+  "Article display."
+  :group 'gnus)
+
+(defcustom gnus-ignored-headers
+  '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:"
+    "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:"
+    "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:"
+    "^Approved:" "^Sender:" "^Received:" "^Mail-from:") 
+  "All headers that match this regexp will be hidden.
 This variable can also be a list of regexps of headers to be ignored.
-If `article-visible-headers' is non-nil, this variable will be ignored.")
-
-(defvar article-visible-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-"
-  "*All headers that do not match this regexp will be hidden.
+If `article-visible-headers' is non-nil, this variable will be ignored."
+  :type '(choice :custom-show nil
+                regexp
+                (repeat regexp))
+  :group 'article)
+
+(defcustom gnus-visible-headers 
+  '("^From:" "^Newsgroups:" "^Subject:" "^Date:" "^Followup-To:"
+    "^Reply-To:" "^Organization:" "^Summary:" "^Keywords:" "^To:"
+    "^Cc:" "^Posted-To:" "^Mail-Copies-To:" "^Apparently-To:"
+    "^Gnus-Warning:" "^Resent-")
+  "All headers that do not match this regexp will be hidden.
 This variable can also be a list of regexp of headers to remain visible.
-If this variable is non-nil, `article-ignored-headers' will be ignored.")
+If this variable is non-nil, `gnus-article-ignored-headers' will be ignored."
+  :type '(choice :custom-show nil
+                (repeat regexp)
+                regexp)
+  :group 'article)
 
-(defvar article-sorted-header-list
+(defcustom gnus-sorted-header-list
   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:"
     "^Cc:" "^Date:" "^Organization:")
-  "*This variable is a list of regular expressions.
+  "This variable is a list of regular expressions.
 If it is non-nil, headers that match the regular expressions will
 be placed first in the article buffer in the sequence specified by
-this list.")
+this list."
+  :type '(repeat regexp)
+  :group 'article)
 
-(defvar article-boring-article-headers
-  '(empty followup-to reply-to)
-  "*Headers that are only to be displayed if they have interesting data.
+(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
+  "Headers that are only to be displayed if they have interesting data.
 Possible values in this list are `empty', `newsgroups', `followup-to',
-`reply-to', and `date'.")
-
-(defvar article-signature-separator "^-- *$"
-  "Regexp matching signature separator.")
-
-(defvar gnus-signature-separator "^-- *$"
-  "Regexp matching signature separator.")
-
-(defvar article-signature-limit nil
-  "Provide a limit to what is considered a signature.
+`reply-to', and `date'."
+  :type '(set (const :tag "Headers with no content." empty)
+             (const :tag "Newsgroups with only one group." newsgroups)
+             (const :tag "Followup-to identical to newsgroups." followup-to)
+             (const :tag "Reply-to identical to from." reply-to)
+             (const :tag "Date less than four days old." date))
+  :group 'article)
+
+(defcustom gnus-signature-separator '("^-- $" "^-- *$")
+  "Regexp matching signature separator.
+This can also be a list of regexps.  In that case, it will be checked
+from head to tail looking for a separator.  Searches will be done from
+the end of the buffer."
+  :type '(repeat string)
+  :group 'article)
+
+(defcustom gnus-signature-limit nil
+   "Provide a limit to what is considered a signature.
 If it is a number, no signature may not be longer (in characters) than
-that number.  If it is a function, the function will be called without
-any parameters, and if it returns nil, there is no signature in the
-buffer.  If it is a string, it will be used as a regexp.  If it
-matches, the text in question is not a signature.")
-
-(defvar article-hidden-properties '(invisible t intangible t)
-  "Property list to use for hiding text.")
-
-(defvar article-x-face-command
+that number.  If it is a floating point number, no signature may be
+longer (in lines) than that number.  If it is a function, the function
+will be called without any parameters, and if it returns nil, there is
+no signature in the buffer.  If it is a string, it will be used as a
+regexp.  If it matches, the text in question is not a signature."
+  :type '(choice integer number function regexp)
+  :group 'article)
+
+(defcustom gnus-hidden-properties '(invisible t intangible t)
+  "Property list to use for hiding text."
+  :type 'sexp 
+  :group 'article)
+
+(defcustom gnus-article-x-face-command
   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
   "String or function to be executed to display an X-Face header.
 If it is a string, the command will be executed in a sub-shell
-asynchronously.         The compressed face will be piped to this command.")
-
-(defvar article-x-face-too-ugly nil
-  "Regexp matching posters whose face shouldn't be shown automatically.")
-
-(defvar article-emphasis-alist
-  '(("_\\(\\w+\\)_" 0 1 'underline)
-    ("\\W\\(/\\(\\w+\\)/\\)\\W" 1 2 'italic)
-    ("\\(_\\*\\|\\*_\\)\\(\\w+\\)\\(_\\*\\|\\*_\\)" 0 2 'bold-underline)
-    ("\\*\\(\\w+\\)\\*" 0 1 'bold))
+asynchronously.         The compressed face will be piped to this command."
+  :type 'string                                ;Leave function case to Lisp.
+  :group 'article)
+
+(defcustom gnus-article-x-face-too-ugly nil
+  "Regexp matching posters whose face shouldn't be shown automatically."
+  :type 'regexp
+  :group 'article)
+
+(defcustom gnus-emphasis-alist
+  '(("_\\(\\w+\\)_" 0 1 underline)
+    ("\\W\\(/\\(\\w+\\)/\\)\\W" 1 2 italic)
+    ("\\(_\\*\\|\\*_\\)\\(\\w+\\)\\(_\\*\\|\\*_\\)" 0 2 bold-underline)
+    ("\\*\\(\\w+\\)\\*" 0 1 bold))
   "Alist that says how to fontify certain phrases.
 Each item looks like this:
 
@@ -94,7 +132,13 @@ The first element is a regular expression to be matched.  The second
 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.")
+is the face used for highlighting."
+  :type '(repeat (list :value ("" 0 0 default)
+                      regexp
+                      (integer :tag "Match group")
+                      (integer :tag "Emphasize group")
+                      face))
+  :group 'article)
 
 (eval-and-compile
   (autoload 'hexl-hex-string-to-integer "hexl")
@@ -103,7 +147,7 @@ is the face used for highlighting.")
 
 ;;; Internal variables.
 
-(defvar article-inhibit-hiding nil)
+(defvar gnus-inhibit-hiding nil)
 (defvar gnus-newsgroup-name)
 
 (defsubst article-hide-text (b e props)
@@ -116,27 +160,47 @@ is the face used for highlighting.")
 
 (defsubst article-unhide-text (b e)
   "Remove hidden text properties from region between B and E."
-  (remove-text-properties b e article-hidden-properties)
-  (when (memq 'intangible article-hidden-properties)
+  (remove-text-properties b e gnus-hidden-properties)
+  (when (memq 'intangible gnus-hidden-properties)
     (put-text-property (max (1- b) (point-min))
-                           b 'intangible nil)))
+                      b 'intangible nil)))
 
 (defun article-hide-text-type (b e type)
   "Hide text of TYPE between B and E."
   (article-hide-text
-   b e (cons 'article-type (cons type article-hidden-properties))))
+   b e (cons 'article-type (cons type gnus-hidden-properties))))
 
 (defun article-unhide-text-type (b e type)
   "Hide text of TYPE between B and E."
   (remove-text-properties
-   b e (cons 'article-type (cons type article-hidden-properties)))
-  (when (memq 'intangible article-hidden-properties)
+   b e (cons 'article-type (cons type gnus-hidden-properties)))
+  (when (memq 'intangible gnus-hidden-properties)
     (put-text-property (max (1- b) (point-min))
-                           b 'intangible nil)))
+                      b 'intangible nil)))
+
+(defun article-hide-text-of-type (type)
+  "Hide text of TYPE in the current buffer."
+  (save-excursion
+    (let ((b (point-min))
+         (e (point-max)))
+      (while (setq b (text-property-any b e 'article-type type))
+       (add-text-properties b (incf b) gnus-hidden-properties)))))
+
+(defun article-delete-text-of-type (type)
+  "Delete text of TYPE in the current buffer."
+  (save-excursion
+    (let ((b (point-min))
+         (e (point-max)))
+      (while (setq b (text-property-any b e 'article-type type))
+       (delete-region b (incf b))))))
+
+(defun article-text-type-exists-p (type)
+  "Say whether any text of type TYPE exists in the buffer."
+  (text-property-any (point-min) (point-max) 'article-type type))
 
 (defsubst article-header-rank ()
   "Give the rank of the string HEADER as given by `article-sorted-header-list'."
-  (let ((list article-sorted-header-list)
+  (let ((list gnus-sorted-header-list)
        (i 0))
     (while list
       (when (looking-at (car list))
@@ -154,25 +218,25 @@ always hide."
       ;; Show boring headers as well.
       (article-show-hidden-text 'boring-headers)
     ;; This function might be inhibited.
-    (unless article-inhibit-hiding
+    (unless gnus-inhibit-hiding
       (save-excursion
        (save-restriction
          (let ((buffer-read-only nil)
                (props (nconc (list 'article-type 'headers)
-                             article-hidden-properties))
-               (max (1+ (length article-sorted-header-list)))
-               (ignored (when (not (stringp article-visible-headers))
-                          (cond ((stringp article-ignored-headers)
-                                 article-ignored-headers)
-                                ((listp article-ignored-headers)
-                                 (mapconcat 'identity article-ignored-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 article-visible-headers)
-                       article-visible-headers)
-                      ((and article-visible-headers
-                            (listp article-visible-headers))
-                       (mapconcat 'identity article-visible-headers "\\|"))))
+                (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)
                want-list beg)
            ;; First we narrow to just the headers.
@@ -190,14 +254,13 @@ always hide."
             (point)
             (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
            ;; Then we use the two regular expressions
-           ;; `article-ignored-headers' and `article-visible-headers' to
+           ;; `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)
-             ;; We add the headers we want to keep to a list and delete
-             ;; them from the buffer.
+             ;; Mark the rank of the header.
              (put-text-property 
               (point) (1+ (point)) 'message-rank
               (if (or (and visible (looking-at visible))
@@ -226,7 +289,7 @@ always hide."
     (save-excursion
       (save-restriction
        (let ((buffer-read-only nil)
-             (list article-boring-article-headers)
+             (list gnus-boring-article-headers)
              (inhibit-point-motion-hooks t)
              elem)
          (nnheader-narrow-to-headers)
@@ -236,7 +299,7 @@ always hide."
            (cond
             ;; Hide empty headers.
             ((eq elem 'empty)
-             (while (re-search-forward "^[^:]+:[ \t]\n[^ \t]" nil t)
+             (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
                (forward-line -1)
                (article-hide-text-type
                 (progn (beginning-of-line) (point))
@@ -367,12 +430,12 @@ always hide."
        (nnheader-narrow-to-headers)
        (setq from (message-fetch-field "from"))
        (goto-char (point-min))
-       (when (and article-x-face-command
+       (when (and gnus-article-x-face-command
                   (or force
                       ;; Check whether this face is censored.
-                      (not article-x-face-too-ugly)
-                      (and article-x-face-too-ugly from
-                           (not (string-match article-x-face-too-ugly
+                      (not gnus-article-x-face-too-ugly)
+                      (and gnus-article-x-face-too-ugly from
+                           (not (string-match gnus-article-x-face-too-ugly
                                               from))))
                   ;; Has to be present.
                   (re-search-forward "^X-Face: " nil t))
@@ -380,22 +443,21 @@ always hide."
          (let ((beg (point))
                (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
            ;; We display the face.
-           (if (symbolp article-x-face-command)
+           (if (symbolp gnus-article-x-face-command)
                ;; The command is a lisp function, so we call it.
-               (if (gnus-functionp article-x-face-command)
-                   (funcall article-x-face-command beg end)
-                 (error "%s is not a function" article-x-face-command))
+               (if (gnus-functionp gnus-article-x-face-command)
+                   (funcall gnus-article-x-face-command beg end)
+                 (error "%s is not a function" gnus-article-x-face-command))
              ;; The command is a string, so we interpret the command
              ;; as a, well, command, and fork it off.
              (let ((process-connection-type nil))
                (process-kill-without-query
                 (start-process
                  "article-x-face" nil shell-file-name shell-command-switch
-                 article-x-face-command))
+                 gnus-article-x-face-command))
                (process-send-region "article-x-face" beg end)
                (process-send-eof "article-x-face")))))))))
 
-(defalias 'article-headers-decode-quoted-printable 'article-decode-rfc1522)
 (defun article-decode-rfc1522 ()
   "Hack to remove QP encoding from headers."
   (let ((case-fold-search t)
@@ -406,17 +468,20 @@ always hide."
       (narrow-to-region
        (goto-char (point-min))
        (or (search-forward "\n\n" nil t) (point-max)))
-
       (goto-char (point-min))
       (while (re-search-forward 
              "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
        (setq string (match-string 1))
-       (narrow-to-region (match-beginning 0) (match-end 0))
-       (delete-region (point-min) (point-max))
-       (insert string)
-       (article-mime-decode-quoted-printable (goto-char (point-min)) (point-max))
-       (subst-char-in-region (point-min) (point-max) ?_ ? )
-       (widen)
+       (save-restriction
+         (narrow-to-region (match-beginning 0) (match-end 0))
+         (delete-region (point-min) (point-max))
+         (insert string)
+         (article-mime-decode-quoted-printable (goto-char (point-min))
+                                               (point-max))
+         (subst-char-in-region (point-min) (point-max) ?_ ? )
+         (goto-char (point-max)))
+       (when (looking-at "\\([ \t\n]+\\)=\\?")
+         (replace-match "" t t nil 1))
        (goto-char (point-min))))))
 
 (defun article-de-quoted-unreadable (&optional force)
@@ -438,6 +503,10 @@ or not."
        (search-forward "\n\n" nil 'move)
        (article-mime-decode-quoted-printable (point) (point-max))))))
 
+(defun article-mime-decode-quoted-printable-buffer ()
+  "Decode Quoted-Printable in the current buffer."
+  (article-mime-decode-quoted-printable (point-min) (point-max)))
+  
 (defun article-mime-decode-quoted-printable (from to)
   "Decode Quoted-Printable in the region between FROM and TO."
   (interactive "r")
@@ -539,31 +608,80 @@ always hide."
        (while (looking-at "[ \t]$")
          (gnus-delete-line))))))
 
+(defun article-strip-multiple-blank-lines ()
+  "Replace consecutive blank lines with one empty line."
+  (interactive)
+  (save-excursion
+    (let (buffer-read-only)
+      ;; First make all blank lines empty.
+      (goto-char (point-min))
+      (while (re-search-forward "^[ \t]+$" nil t)
+       (replace-match "" nil t))
+      ;; Then replace multiple empty lines with a single empty line.
+      (goto-char (point-min))
+      (while (re-search-forward "\n\n\n+" nil t)
+       (replace-match "\n\n" t t)))))
+
+(defun article-strip-blank-lines ()
+  "Strip leading, trailing and multiple blank lines."
+  (interactive)
+  (article-strip-leading-blank-lines)
+  (article-remove-trailing-blank-lines)
+  (article-strip-multiple-blank-lines))
+
 (defvar mime::preview/content-list)
 (defvar mime::preview-content-info/point-min)
 (defun article-narrow-to-signature ()
   "Narrow to the signature."
   (widen)
-  (if (and (boundp 'mime::preview/content-list)
-          mime::preview/content-list)
-      (let ((pcinfo (car (last mime::preview/content-list))))
-       (condition-case ()
-           (narrow-to-region
-            (funcall (intern "mime::preview-content-info/point-min") pcinfo)
-            (point-max))
-         (error nil))))
-  (goto-char (point-max))
-  (when (re-search-backward article-signature-separator nil t)
+  (when (and (boundp 'mime::preview/content-list)
+            mime::preview/content-list)
+    ;; We have a MIMEish article, so we use the MIME data to narrow.
+    (let ((pcinfo (car (last mime::preview/content-list))))
+      (condition-case ()
+         (narrow-to-region
+          (funcall (intern "mime::preview-content-info/point-min") pcinfo)
+          (point-max))
+       (error nil))))
+  
+  (when (article-search-signature)
     (forward-line 1)
-    (when (or (null article-signature-limit)
-             (and (numberp article-signature-limit)
-                  (< (- (point-max) (point)) article-signature-limit))
-             (and (gnus-functionp article-signature-limit)
-                  (funcall article-signature-limit))
-             (and (stringp article-signature-limit)
-                  (not (re-search-forward article-signature-limit nil t))))
-      (narrow-to-region (point) (point-max))
-      t)))
+    ;; Check whether we have some limits to what we consider
+    ;; to be a signature.
+    (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
+                   (list gnus-signature-limit)))
+         limit limited)
+      (while (setq limit (pop limits))
+       (if (or (and (integerp limit)
+                    (< (- (point-max) (point)) limit))
+               (and (floatp limit)
+                    (< (count-lines (point) (point-max)) limit))
+               (and (gnus-functionp limit)
+                    (funcall limit))
+               (and (stringp limit)
+                    (not (re-search-forward limit nil t))))
+           ()                          ; This limit did not succeed.
+         (setq limited t
+               limits nil)))
+      (unless limited
+       (narrow-to-region (point) (point-max))
+       t))))
+
+(defun article-search-signature ()
+  "Search the current buffer for the signature separator.
+Put point at the beginning of the signature separator."
+  (let ((cur (point)))
+    (goto-char (point-max))
+    (if (if (stringp gnus-signature-separator)
+           (re-search-backward gnus-signature-separator nil t)
+         (let ((seps gnus-signature-separator))
+           (while (and seps
+                       (not (re-search-backward (car seps) nil t)))
+             (pop seps))
+           seps))
+       t
+      (goto-char cur)
+      nil)))
 
 (defun article-hidden-arg ()
   "Return the current prefix arg as a number, or 0 if no prefix."
@@ -608,12 +726,12 @@ If HIDE, hide the text instead."
        (setq beg (point))
        (forward-char)
        (if hide
-           (article-hide-text beg (point) article-hidden-properties)
+           (article-hide-text beg (point) gnus-hidden-properties)
          (article-unhide-text beg (point)))
        (setq beg (point)))
       t)))
 
-(defvar article-time-units
+(defconst article-time-units
   `((year . ,(* 365.25 24 60 60))
     (week . ,(* 7 24 60 60))
     (day . ,(* 24 60 60))
@@ -628,9 +746,9 @@ If TYPE is `local', convert to local time; if it is `lapsed', output
 how much time has lapsed since DATE."
   (interactive (list 'ut t))
   (let* ((header (or header (message-fetch-field "date") ""))
-        (date (and (vectorp header) (mail-header-date header)))
+        (date (if (vectorp header) (mail-header-date header)
+                header))
         (date-regexp "^Date: \\|^X-Sent: ")
-        (now (current-time))
         (inhibit-point-motion-hooks t)
         bface eface)
     (when (and date (not (string= date "")))
@@ -694,13 +812,14 @@ how much time has lapsed since DATE."
                 (gnus-encode-date
                  (timezone-make-date-arpa-standard
                   date nil "UT")))
-             (error '(0 0))))
-          (real-sec (+ (* (float (car real-time)) 65536)
-                       (cadr real-time)))
-          (sec (abs real-sec))
+             (error nil)))
+          (real-sec (and real-time
+                         (+ (* (float (car real-time)) 65536)
+                            (cadr real-time))))
+          (sec (and real-time (abs real-sec)))
           num prev)
       (cond
-       ((equal real-time '(0 0))
+       ((null real-time)
        "X-Sent: Unknown\n")
        ((zerop sec)
        "X-Sent: Now\n")
@@ -759,14 +878,14 @@ function and want to see what the date was before converting."
       (article-unhide-text (point-min) (point-max)))))
 
 (defun article-emphasize (&optional arg)
-  "Empasize text according to `article-emphasis-alist'."
+  "Emphasize text according to `gnus-emphasis-alist'."
   (interactive (article-hidden-arg))
   (unless (article-check-hidden-text 'emphasis arg)
     (save-excursion
-      (let ((alist article-emphasis-alist)
+      (let ((alist gnus-emphasis-alist)
            (buffer-read-only nil)
            (props (append '(article-type emphasis)
-                          article-hidden-properties))
+                          gnus-hidden-properties))
            regexp elem beg invisible visible face)
        (goto-char (point-min))
        (search-forward "\n\n" nil t)