;;; article.el --- article treatment functions
;; Copyright (C) 1996 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(require 'nnheader)
(require 'gnus-util)
(require 'message)
(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."
  :type '(repeat string)		;Leave monster regexp to lisp.
  :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, `gnus-article-ignored-headers' will be ignored."
  :type '(repeat string)		;Leave monster regexp to lisp.
  :group 'article)

(defcustom gnus-sorted-header-list
  '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:"
    "^Cc:" "^Date:" "^Organization:")
  "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."
  :type '(repeat string)
  :group 'article)

(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'."
  :type '(set (item :tag "Headers with no content." empty)
	      (item :tag "Newsgroups with only one group." newsgroups)
	      (item :tag "Followup-to identical to newsgroups." followup-to)
	      (item :tag "Reply-to identical to from." reply-to)
	      (item :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 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 string)
  :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."
  :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:

  (\"_\\\\([[\\w+\\\\)_\" 0 1 'underline)

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."
  :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")
  (autoload 'timezone-make-date-arpa-standard "timezone")
  (autoload 'mail-extract-address-components "mail-extr"))

;;; Internal variables.

(defvar gnus-inhibit-hiding nil)
(defvar gnus-newsgroup-name)

(defsubst article-hide-text (b e props)
  "Set text PROPS on the B to E region, extending `intangible' 1 past B."
  (add-text-properties b e props)
  (when (memq 'intangible props)
    (put-text-property 
     (max (1- b) (point-min))
     b 'intangible (cddr (memq 'intangible props)))))

(defsubst article-unhide-text (b e)
  "Remove hidden text properties from region between B and E."
  (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)))

(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 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 gnus-hidden-properties)))
  (when (memq 'intangible gnus-hidden-properties)
    (put-text-property (max (1- b) (point-min))
		       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 gnus-sorted-header-list)
	(i 0))
    (while list
      (when (looking-at (car list))
	(setq list nil))
      (setq list (cdr list))
      (incf i))
    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."
  (interactive (article-hidden-arg))
  (if (article-check-hidden-text 'headers arg)
      ;; Show boring headers as well.
      (article-show-hidden-text 'boring-headers)
    ;; This function might be inhibited.
    (unless gnus-inhibit-hiding
      (save-excursion
	(save-restriction
	  (let ((buffer-read-only nil)
		(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)
		want-list beg)
	    ;; First we narrow to just the headers.
	    (widen)
	    (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))
		(article-hide-text (point-min) (point) props)))
	    ;; Then treat the rest of the header lines.
	    (narrow-to-region
	     (point)
	     (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
	    ;; 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))))
		   (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>.
		(article-hide-text-type beg (point-max) 'headers))
	      ;; Work around XEmacs lossage.
	      (put-text-property (point-min) beg 'invisible nil))))))))

(defun article-hide-boring-headers (&optional arg)
  "Toggle hiding of headers that aren't very interesting.
If given a negative prefix, always show; if given a positive prefix,
always hide."
  (interactive (article-hidden-arg))
  (unless (article-check-hidden-text 'boring-headers arg)
    (save-excursion
      (save-restriction
	(let ((buffer-read-only nil)
	      (list gnus-boring-article-headers)
	      (inhibit-point-motion-hooks t)
	      elem)
	  (nnheader-narrow-to-headers)
	  (while list
	    (setq elem (pop list))
	    (goto-char (point-min))
	    (cond
	     ;; Hide empty headers.
	     ((eq elem 'empty)
	      (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
		(forward-line -1)
		(article-hide-text-type
		 (progn (beginning-of-line) (point))
		 (progn 
		   (end-of-line)
		   (if (re-search-forward "^[^ \t]" nil t)
		       (match-beginning 0)
		     (point-max)))
		 'boring-headers)))
	     ;; Hide boring Newsgroups header.
	     ((eq elem 'newsgroups)
	      (when (equal (gnus-fetch-field "newsgroups")
			   (gnus-group-real-name
			    (if (boundp 'gnus-newsgroup-name)
				gnus-newsgroup-name
			      "")))
		(article-hide-header "newsgroups")))
	     ((eq elem 'followup-to)
	      (when (equal (message-fetch-field "followup-to")
			   (message-fetch-field "newsgroups"))
		(article-hide-header "followup-to")))
	     ((eq elem 'reply-to)
	      (let ((from (message-fetch-field "from"))
		    (reply-to (message-fetch-field "reply-to")))
		(when (and
		       from reply-to
		       (equal 
			(nth 1 (mail-extract-address-components from))
			(nth 1 (mail-extract-address-components reply-to))))
		  (article-hide-header "reply-to"))))
	     ((eq elem 'date)
	      (let ((date (message-fetch-field "date")))
		(when (and date
			   (< (gnus-days-between date (current-time-string))
			      4))
		  (article-hide-header "date")))))))))))

(defun article-hide-header (header)
  (save-excursion
    (goto-char (point-min))
    (when (re-search-forward (concat "^" header ":") nil t)
      (article-hide-text-type
       (progn (beginning-of-line) (point))
       (progn 
	 (end-of-line)
	 (if (re-search-forward "^[^ \t]" nil t)
	     (match-beginning 0)
	   (point-max)))
       'boring-headers))))

;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun article-treat-overstrike ()
  "Translate overstrikes into bold text."
  (interactive)
  (save-excursion
    (let ((buffer-read-only nil))
      (while (search-forward "\b" nil t)
	(let ((next (following-char))
	      (previous (char-after (- (point) 2))))
	  ;; We do the boldification/underlining by hiding the
	  ;; overstrikes and putting the proper text property
	  ;; on the letters.
	  (cond 
	   ((eq next previous)
	    (article-hide-text-type (- (point) 2) (point) 'overstrike)
	    (put-text-property (point) (1+ (point)) 'face 'bold))
	   ((eq next ?_)
	    (article-hide-text-type (1- (point)) (1+ (point)) 'overstrike)
	    (put-text-property
	     (- (point) 2) (1- (point)) 'face 'underline))
	   ((eq previous ?_)
	    (article-hide-text-type (- (point) 2) (point) 'overstrike)
	    (put-text-property
	     (point) (1+ (point)) 'face 'underline))))))))

(defun article-fill ()
  "Format too long lines."
  (interactive)
  (save-excursion
    (let ((buffer-read-only nil))
      (widen)
      (goto-char (point-min))
      (search-forward "\n\n" nil t)
      (end-of-line 1)
      (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
	    (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
	    (adaptive-fill-mode t))
	(while (not (eobp))
	  (and (>= (current-column) (min fill-column (window-width)))
	       (/= (preceding-char) ?:)
	       (fill-paragraph nil))
	  (end-of-line 2))))))

(defun article-remove-cr ()
  "Remove carriage returns from an article."
  (interactive)
  (save-excursion
    (let ((buffer-read-only nil))
      (goto-char (point-min))
      (while (search-forward "\r" nil t)
	(replace-match "" t t)))))

(defun article-remove-trailing-blank-lines ()
  "Remove all trailing blank lines from the article."
  (interactive)
  (save-excursion
    (let ((buffer-read-only nil))
      (goto-char (point-max))
      (delete-region
       (point)
       (progn
	 (while (looking-at "^[ \t]*$")
	   (forward-line -1))
	 (forward-line 1)
	 (point))))))

(defun article-display-x-face (&optional force)
  "Look for an X-Face header and display it if present."
  (interactive (list 'force))
  (save-excursion
    ;; Delete the old process, if any.
    (when (process-status "article-x-face")
      (delete-process "article-x-face"))
    (let ((inhibit-point-motion-hooks t)
	  (case-fold-search nil)
	  from)
      (save-restriction
	(nnheader-narrow-to-headers)
	(setq from (message-fetch-field "from"))
	(goto-char (point-min))
	(when (and gnus-article-x-face-command
		   (or force
		       ;; Check whether this face is censored.
		       (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))
	  ;; We now have the area of the buffer where the X-Face is stored.
	  (let ((beg (point))
		(end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
	    ;; We display the face.
	    (if (symbolp gnus-article-x-face-command)
		;; The command is a lisp function, so we call it.
		(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
		  gnus-article-x-face-command))
		(process-send-region "article-x-face" beg end)
		(process-send-eof "article-x-face")))))))))

(defun article-decode-rfc1522 ()
  "Hack to remove QP encoding from headers."
  (let ((case-fold-search t)
	(inhibit-point-motion-hooks t)
	(buffer-read-only nil)
	string)
    (save-restriction
      (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))
	(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)))
	(if (looking-at "\\([ \t\n]+\\)=\\?")
	    (replace-match "" t t nil 1))
	(goto-char (point-min))))))

(defun article-de-quoted-unreadable (&optional force)
  "Do a naive translation of a quoted-printable-encoded article.
This is in no way, shape or form meant as a replacement for real MIME
processing, but is simply a stop-gap measure until MIME support is
written.
If FORCE, decode the article whether it is marked as quoted-printable
or not."
  (interactive (list 'force))
  (save-excursion
    (let ((case-fold-search t)
	  (buffer-read-only nil)
	  (type (gnus-fetch-field "content-transfer-encoding")))
      (article-decode-rfc1522)
      (when (or force
		(and type (string-match "quoted-printable" (downcase type))))
	(goto-char (point-min))
	(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")
  (goto-char from)
  (while (search-forward "=" to t)
    (cond ((eq (following-char) ?\n)
	   (delete-char -1)
	   (delete-char 1))
	  ((looking-at "[0-9A-F][0-9A-F]")
	   (subst-char-in-region
	    (1- (point)) (point) ?=
	    (hexl-hex-string-to-integer
	     (buffer-substring (point) (+ 2 (point)))))
	   (delete-char 2))
	  ((looking-at "=")
	   (delete-char 1))
	  ((gnus-message 3 "Malformed MIME quoted-printable message")))))

(defun article-hide-pgp (&optional arg)
  "Toggle hiding of any PGP headers and signatures in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
  (interactive (article-hidden-arg))
  (unless (article-check-hidden-text 'pgp arg)
    (save-excursion
      (let (buffer-read-only beg end)
	(widen)
	(goto-char (point-min))
	;; Hide the "header".
	(and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
	     (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp))
	(setq beg (point))
	;; Hide the actual signature.
	(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
	     (setq end (1+ (match-beginning 0)))
	     (article-hide-text-type
	      end
	      (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
		  (match-end 0)
		;; Perhaps we shouldn't hide to the end of the buffer
		;; if there is no end to the signature?
		(point-max))
	      'pgp))
	;; Hide "- " PGP quotation markers.
	(when (and beg end)
	  (narrow-to-region beg end)
	  (goto-char (point-min))
	  (while (re-search-forward "^- " nil t)
	    (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp))
	  (widen))))))

(defun article-hide-pem (&optional arg)
  "Toggle hiding of any PEM headers and signatures in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
  (interactive (article-hidden-arg))
  (unless (article-check-hidden-text 'pem arg)
    (save-excursion
      (let (buffer-read-only end)
	(widen)
	(goto-char (point-min))
	;; hide the horrendously ugly "header".
	(and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
			     nil
			     t)
	     (setq end (1+ (match-beginning 0)))
	     (article-hide-text-type
	      end
	      (if (search-forward "\n\n" nil t)
		  (match-end 0)
		(point-max))
	      'pem))
	;; hide the trailer as well
	(and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
			     nil
			     t)
	     (article-hide-text-type
	      (match-beginning 0) (match-end 0) 'pem))))))

(defun article-hide-signature (&optional arg)
  "Hide the signature in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
  (interactive (article-hidden-arg))
  (unless (article-check-hidden-text 'signature arg)
    (save-excursion
      (save-restriction
	(let ((buffer-read-only nil))
	  (when (article-narrow-to-signature)
	    (article-hide-text-type (point-min) (point-max) 'signature)))))))

(defun article-strip-leading-blank-lines ()
  "Remove all blank lines from the beginning of the article."
  (interactive)
  (save-excursion
    (let (buffer-read-only)
      (goto-char (point-min))
      (when (search-forward "\n\n" nil t)
	(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)
  (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)
    ;; 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."
  (list (if current-prefix-arg
	    (prefix-numeric-value current-prefix-arg)
	  0)))

(defun article-check-hidden-text (type arg)
  "Return nil if hiding is necessary.
Arg can be nil or a number.  Nil and positive means hide, negative
means show, 0 means toggle."
  (save-excursion
    (let ((hide (article-hidden-text-p type)))
      (cond
       ((or (null arg)
	    (> arg 0))
	nil)
       ((< arg 0)
	(article-show-hidden-text type))
       (t
	(if (eq hide 'hidden)
	    (article-show-hidden-text type)
	  nil))))))

(defun article-hidden-text-p (type)
  "Say whether the current buffer contains hidden text of type TYPE."
  (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
    (when pos
      (if (get-text-property pos 'invisible)
	  'hidden
	'shown))))

(defun article-show-hidden-text (type &optional hide)
  "Show all hidden text of type TYPE.
If HIDE, hide the text instead."
  (save-excursion
    (let ((buffer-read-only nil)
	  (inhibit-point-motion-hooks t)
	  (beg (point-min)))
      (while (gnus-goto-char (text-property-any
			      beg (point-max) 'article-type type))
	(setq beg (point))
	(forward-char)
	(if hide
	    (article-hide-text beg (point) gnus-hidden-properties)
	  (article-unhide-text beg (point)))
	(setq beg (point)))
      t)))

(defconst article-time-units
  `((year . ,(* 365.25 24 60 60))
    (week . ,(* 7 24 60 60))
    (day . ,(* 24 60 60))
    (hour . ,(* 60 60))
    (minute . 60)
    (second . 1))
  "Mapping from time units to seconds.")

(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."
  (interactive (list 'ut t))
  (let* ((header (or header (message-fetch-field "date") ""))
	 (date (if (vectorp header) (mail-header-date header)
		 header))
	 (date-regexp "^Date: \\|^X-Sent: ")
	 (inhibit-point-motion-hooks t)
	 bface eface)
    (when (and date (not (string= date "")))
      (save-excursion
	(save-restriction
	  (nnheader-narrow-to-headers)
	  (let ((buffer-read-only nil))
	    ;; Delete any old Date headers.
	    (if (re-search-forward date-regexp nil t)
		(progn
		  (setq bface (get-text-property (gnus-point-at-bol) 'face)
			eface (get-text-property (1- (gnus-point-at-eol))
						 'face))
		  (message-remove-header date-regexp t)
		  (beginning-of-line))
	      (goto-char (point-max)))
	    (insert (article-make-date-line date type))
	    ;; Do highlighting.
	    (forward-line -1)
	    (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
	      (put-text-property (match-beginning 1) (match-end 1)
				 'face bface)
	      (put-text-property (match-beginning 2) (match-end 2)
				 'face eface))))))))

(defun article-make-date-line (date type)
  "Return a DATE line of TYPE."
  (cond
   ;; Convert to the local timezone.  We have to slap a
   ;; `condition-case' round the calls to the timezone
   ;; functions since they aren't particularly resistant to
   ;; buggy dates.
   ((eq type 'local)
    (concat "Date: " (condition-case ()
			 (timezone-make-date-arpa-standard date)
		       (error date))
	    "\n"))
   ;; Convert to Universal Time.
   ((eq type 'ut)
    (concat "Date: "
	    (condition-case ()
		(timezone-make-date-arpa-standard date nil "UT")
	      (error date))
	    "\n"))
   ;; Get the original date from the article.
   ((eq type 'original)
    (concat "Date: " date "\n"))
   ;; Do an X-Sent lapsed format.
   ((eq type 'lapsed)
    ;; If the date is seriously mangled, the timezone
    ;; functions are liable to bug out, so we condition-case
    ;; the entire thing.
    (let* ((now (current-time))
	   (real-time
	    (condition-case ()
		(gnus-time-minus
		 (gnus-encode-date
		  (timezone-make-date-arpa-standard
		   (current-time-string now)
		   (current-time-zone now) "UT"))
		 (gnus-encode-date
		  (timezone-make-date-arpa-standard
		   date nil "UT")))
	      (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
       ((null real-time)
	"X-Sent: Unknown\n")
       ((zerop sec)
	"X-Sent: Now\n")
       (t
	(concat
	 "X-Sent: "
	 ;; This is a bit convoluted, but basically we go
	 ;; through the time units for years, weeks, etc,
	 ;; and divide things to see whether that results
	 ;; in positive answers.
	 (mapconcat
	  (lambda (unit)
	    (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
		;; The (remaining) seconds are too few to
		;; be divided into this time unit.
		""
	      ;; It's big enough, so we output it.
	      (setq sec (- sec (* num (cdr unit))))
	      (prog1
		  (concat (if prev ", " "") (int-to-string
					     (floor num))
			  " " (symbol-name (car unit)) 
			  (if (> num 1) "s" ""))
		(setq prev t))))
	  article-time-units "")
	 ;; If dates are odd, then it might appear like the
	 ;; article was sent in the future.
	 (if (> real-sec 0)
	     " ago\n"
	   " in the future\n"))))))
   (t
    (error "Unknown conversion type: %s" type))))

(defun article-date-local (&optional highlight)
  "Convert the current article date to the local timezone."
  (interactive (list t))
  (article-date-ut 'local highlight))

(defun article-date-original (&optional highlight)
  "Convert the current article date to what it was originally.
This is only useful if you have used some other date conversion
function and want to see what the date was before converting."
  (interactive (list t))
  (article-date-ut 'original highlight))

(defun article-date-lapsed (&optional highlight)
  "Convert the current article date to time lapsed since it was sent."
  (interactive (list t))
  (article-date-ut 'lapsed highlight))

(defun article-show-all ()
  "Show all hidden text in the article buffer."
  (interactive)
  (save-excursion
    (let ((buffer-read-only nil))
      (article-unhide-text (point-min) (point-max)))))

(defun article-emphasize (&optional arg)
  "Emphasize text according to `gnus-emphasis-alist'."
  (interactive (article-hidden-arg))
  (unless (article-check-hidden-text 'emphasis arg)
    (save-excursion
      (let ((alist gnus-emphasis-alist)
	    (buffer-read-only nil)
	    (props (append '(article-type emphasis)
			   gnus-hidden-properties))
	    regexp elem beg invisible visible face)
	(goto-char (point-min))
	(search-forward "\n\n" nil t)
	(setq beg (point))
	(while (setq elem (pop alist))
	  (goto-char beg)
	  (setq regexp (car elem)
		invisible (nth 1 elem)
		visible (nth 2 elem)
		face (nth 3 elem))
	  (while (re-search-forward regexp nil t)
	    (article-hide-text
	     (match-beginning invisible) (match-end invisible) props)
	    (article-unhide-text-type
	     (match-beginning visible) (match-end visible) 'emphasis)
	    (put-text-property 
	     (match-beginning visible) (match-end visible)
	     'face face)))))))

(provide 'article)

;;; article.el ends here