cgit.sxemacs.org Git - gnus/blob - lisp/article.el

   1 ;;; article.el --- article treatment functions
   2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'nnheader)
  29 (require 'gnus-util)
  30 (require 'message)
  31 (require 'custom)
  32
  33 (defgroup article nil
  34   "Article display."
  35   :group 'gnus)
  36
  37 (defcustom gnus-ignored-headers
  38   '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:"
  39     "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:"
  40     "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:"
  41     "^Approved:" "^Sender:" "^Received:" "^Mail-from:")
  42   "All headers that match this regexp will be hidden.
  43 This variable can also be a list of regexps of headers to be ignored.
  44 If `article-visible-headers' is non-nil, this variable will be ignored."
  45   :type '(repeat string)                ;Leave monster regexp to lisp.
  46   :group 'article)
  47
  48 (defcustom gnus-visible-headers
  49   '("^From:" "^Newsgroups:" "^Subject:" "^Date:" "^Followup-To:"
  50     "^Reply-To:" "^Organization:" "^Summary:" "^Keywords:" "^To:"
  51     "^Cc:" "^Posted-To:" "^Mail-Copies-To:" "^Apparently-To:"
  52     "^Gnus-Warning:" "^Resent-")
  53   "All headers that do not match this regexp will be hidden.
  54 This variable can also be a list of regexp of headers to remain visible.
  55 If this variable is non-nil, `gnus-article-ignored-headers' will be ignored."
  56   :type '(repeat string)                ;Leave monster regexp to lisp.
  57   :group 'article)
  58
  59 (defcustom gnus-sorted-header-list
  60   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:"
  61     "^Cc:" "^Date:" "^Organization:")
  62   "This variable is a list of regular expressions.
  63 If it is non-nil, headers that match the regular expressions will
  64 be placed first in the article buffer in the sequence specified by
  65 this list."
  66   :type '(repeat string)
  67   :group 'article)
  68
  69 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
  70   "Headers that are only to be displayed if they have interesting data.
  71 Possible values in this list are `empty', `newsgroups', `followup-to',
  72 `reply-to', and `date'."
  73   :type '(set (item :tag "Headers with no content." empty)
  74               (item :tag "Newsgroups with only one group." newsgroups)
  75               (item :tag "Followup-to identical to newsgroups." followup-to)
  76               (item :tag "Reply-to identical to from." reply-to)
  77               (item :tag "Date less than four days old." date))
  78   :group 'article)
  79
  80 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
  81   "Regexp matching signature separator.
  82 This can also be a list of regexps.  In that case, it will be checked
  83 from head to tail looking for a separator.  Searches will be done from
  84 the end of the buffer."
  85   :type '(repeat string)
  86   :group 'article)
  87
  88 (defcustom gnus-signature-limit nil
  89    "Provide a limit to what is considered a signature.
  90 If it is a number, no signature may not be longer (in characters) than
  91 that number.  If it is a floating point number, no signature may be
  92 longer (in lines) than that number.  If it is a function, the function
  93 will be called without any parameters, and if it returns nil, there is
  94 no signature in the buffer.  If it is a string, it will be used as a
  95 regexp.  If it matches, the text in question is not a signature."
  96   :type '(choice integer number function string)
  97   :group 'article)
  98
  99 (defcustom gnus-hidden-properties '(invisible t intangible t)
 100   "Property list to use for hiding text."
 101   :type 'sexp
 102   :group 'article)
 103
 104 (defcustom gnus-article-x-face-command
 105   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
 106   "String or function to be executed to display an X-Face header.
 107 If it is a string, the command will be executed in a sub-shell
 108 asynchronously.  The compressed face will be piped to this command."
 109   :type 'string                         ;Leave function case to Lisp.
 110   :group 'article)
 111
 112 (defcustom gnus-article-x-face-too-ugly nil
 113   "Regexp matching posters whose face shouldn't be shown automatically."
 114   :type 'regexp
 115   :group 'article)
 116
 117 (defcustom gnus-emphasis-alist
 118   '(("_\\(\\w+\\)_" 0 1 underline)
 119     ("\\W\\(/\\(\\w+\\)/\\)\\W" 1 2 italic)
 120     ("\\(_\\*\\|\\*_\\)\\(\\w+\\)\\(_\\*\\|\\*_\\)" 0 2 bold-underline)
 121     ("\\*\\(\\w+\\)\\*" 0 1 bold))
 122   "Alist that says how to fontify certain phrases.
 123 Each item looks like this:
 124
 125   (\"_\\\\([[\\w+\\\\)_\" 0 1 'underline)
 126
 127 The first element is a regular expression to be matched.  The second
 128 is a number that says what regular expression grouping used to find
 129 the entire emphasized word.  The third is a number that says what
 130 regexp grouping should be displayed and highlighted.  The fourth
 131 is the face used for highlighting."
 132   :type '(repeat (list :value ("" 0 0 default)
 133                        regexp
 134                        (integer :tag "Match group")
 135                        (integer :tag "Emphasize group")
 136                        face))
 137   :group 'article)
 138
 139 (eval-and-compile
 140   (autoload 'hexl-hex-string-to-integer "hexl")
 141   (autoload 'timezone-make-date-arpa-standard "timezone")
 142   (autoload 'mail-extract-address-components "mail-extr"))
 143
 144 ;;; Internal variables.
 145
 146 (defvar gnus-inhibit-hiding nil)
 147 (defvar gnus-newsgroup-name)
 148
 149 (defsubst article-hide-text (b e props)
 150   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
 151   (add-text-properties b e props)
 152   (when (memq 'intangible props)
 153     (put-text-property
 154      (max (1- b) (point-min))
 155      b 'intangible (cddr (memq 'intangible props)))))
 156
 157 (defsubst article-unhide-text (b e)
 158   "Remove hidden text properties from region between B and E."
 159   (remove-text-properties b e gnus-hidden-properties)
 160   (when (memq 'intangible gnus-hidden-properties)
 161     (put-text-property (max (1- b) (point-min))
 162                        b 'intangible nil)))
 163
 164 (defun article-hide-text-type (b e type)
 165   "Hide text of TYPE between B and E."
 166   (article-hide-text
 167    b e (cons 'article-type (cons type gnus-hidden-properties))))
 168
 169 (defun article-unhide-text-type (b e type)
 170   "Hide text of TYPE between B and E."
 171   (remove-text-properties
 172    b e (cons 'article-type (cons type gnus-hidden-properties)))
 173   (when (memq 'intangible gnus-hidden-properties)
 174     (put-text-property (max (1- b) (point-min))
 175                        b 'intangible nil)))
 176
 177 (defun article-hide-text-of-type (type)
 178   "Hide text of TYPE in the current buffer."
 179   (save-excursion
 180     (let ((b (point-min))
 181           (e (point-max)))
 182       (while (setq b (text-property-any b e 'article-type type))
 183         (add-text-properties b (incf b) gnus-hidden-properties)))))
 184
 185 (defun article-delete-text-of-type (type)
 186   "Delete text of TYPE in the current buffer."
 187   (save-excursion
 188     (let ((b (point-min))
 189           (e (point-max)))
 190       (while (setq b (text-property-any b e 'article-type type))
 191         (delete-region b (incf b))))))
 192
 193 (defun article-text-type-exists-p (type)
 194   "Say whether any text of type TYPE exists in the buffer."
 195   (text-property-any (point-min) (point-max) 'article-type type))
 196
 197 (defsubst article-header-rank ()
 198   "Give the rank of the string HEADER as given by `article-sorted-header-list'."
 199   (let ((list gnus-sorted-header-list)
 200         (i 0))
 201     (while list
 202       (when (looking-at (car list))
 203         (setq list nil))
 204       (setq list (cdr list))
 205       (incf i))
 206     i))
 207
 208 (defun article-hide-headers (&optional arg delete)
 209   "Toggle whether to hide unwanted headers and possibly sort them as well.
 210 If given a negative prefix, always show; if given a positive prefix,
 211 always hide."
 212   (interactive (article-hidden-arg))
 213   (if (article-check-hidden-text 'headers arg)
 214       ;; Show boring headers as well.
 215       (article-show-hidden-text 'boring-headers)
 216     ;; This function might be inhibited.
 217     (unless gnus-inhibit-hiding
 218       (save-excursion
 219         (save-restriction
 220           (let ((buffer-read-only nil)
 221                 (props (nconc (list 'article-type 'headers)
 222                               gnus-hidden-properties))
 223                 (max (1+ (length gnus-sorted-header-list)))
 224                 (ignored (when (not gnus-visible-headers)
 225                            (cond ((stringp gnus-ignored-headers)
 226                                   gnus-ignored-headers)
 227                                  ((listp gnus-ignored-headers)
 228                                   (mapconcat 'identity gnus-ignored-headers
 229                                              "\\|")))))
 230                 (visible
 231                  (cond ((stringp gnus-visible-headers)
 232                         gnus-visible-headers)
 233                        ((and gnus-visible-headers
 234                              (listp gnus-visible-headers))
 235                         (mapconcat 'identity gnus-visible-headers "\\|"))))
 236                 (inhibit-point-motion-hooks t)
 237                 want-list beg)
 238             ;; First we narrow to just the headers.
 239             (widen)
 240             (goto-char (point-min))
 241             ;; Hide any "From " lines at the beginning of (mail) articles.
 242             (while (looking-at "From ")
 243               (forward-line 1))
 244             (unless (bobp)
 245               (if delete
 246                   (delete-region (point-min) (point))
 247                 (article-hide-text (point-min) (point) props)))
 248             ;; Then treat the rest of the header lines.
 249             (narrow-to-region
 250              (point)
 251              (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
 252             ;; Then we use the two regular expressions
 253             ;; `gnus-ignored-headers' and `gnus-visible-headers' to
 254             ;; select which header lines is to remain visible in the
 255             ;; article buffer.
 256             (goto-char (point-min))
 257             (while (re-search-forward "^[^ \t]*:" nil t)
 258               (beginning-of-line)
 259               ;; Mark the rank of the header.
 260               (put-text-property
 261                (point) (1+ (point)) 'message-rank
 262                (if (or (and visible (looking-at visible))
 263                        (and ignored
 264                             (not (looking-at ignored))))
 265                    (article-header-rank)
 266                  (+ 2 max)))
 267               (forward-line 1))
 268             (message-sort-headers-1)
 269             (when (setq beg (text-property-any
 270                              (point-min) (point-max) 'message-rank (+ 2 max)))
 271               ;; We make the unwanted headers invisible.
 272               (if delete
 273                   (delete-region beg (point-max))
 274                 ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
 275                 (article-hide-text-type beg (point-max) 'headers))
 276               ;; Work around XEmacs lossage.
 277               (put-text-property (point-min) beg 'invisible nil))))))))
 278
 279 (defun article-hide-boring-headers (&optional arg)
 280   "Toggle hiding of headers that aren't very interesting.
 281 If given a negative prefix, always show; if given a positive prefix,
 282 always hide."
 283   (interactive (article-hidden-arg))
 284   (unless (article-check-hidden-text 'boring-headers arg)
 285     (save-excursion
 286       (save-restriction
 287         (let ((buffer-read-only nil)
 288               (list gnus-boring-article-headers)
 289               (inhibit-point-motion-hooks t)
 290               elem)
 291           (nnheader-narrow-to-headers)
 292           (while list
 293             (setq elem (pop list))
 294             (goto-char (point-min))
 295             (cond
 296              ;; Hide empty headers.
 297              ((eq elem 'empty)
 298               (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
 299                 (forward-line -1)
 300                 (article-hide-text-type
 301                  (progn (beginning-of-line) (point))
 302                  (progn
 303                    (end-of-line)
 304                    (if (re-search-forward "^[^ \t]" nil t)
 305                        (match-beginning 0)
 306                      (point-max)))
 307                  'boring-headers)))
 308              ;; Hide boring Newsgroups header.
 309              ((eq elem 'newsgroups)
 310               (when (equal (gnus-fetch-field "newsgroups")
 311                            (gnus-group-real-name
 312                             (if (boundp 'gnus-newsgroup-name)
 313                                 gnus-newsgroup-name
 314                               "")))
 315                 (article-hide-header "newsgroups")))
 316              ((eq elem 'followup-to)
 317               (when (equal (message-fetch-field "followup-to")
 318                            (message-fetch-field "newsgroups"))
 319                 (article-hide-header "followup-to")))
 320              ((eq elem 'reply-to)
 321               (let ((from (message-fetch-field "from"))
 322                     (reply-to (message-fetch-field "reply-to")))
 323                 (when (and
 324                        from reply-to
 325                        (equal
 326                         (nth 1 (mail-extract-address-components from))
 327                         (nth 1 (mail-extract-address-components reply-to))))
 328                   (article-hide-header "reply-to"))))
 329              ((eq elem 'date)
 330               (let ((date (message-fetch-field "date")))
 331                 (when (and date
 332                            (< (gnus-days-between date (current-time-string))
 333                               4))
 334                   (article-hide-header "date")))))))))))
 335
 336 (defun article-hide-header (header)
 337   (save-excursion
 338     (goto-char (point-min))
 339     (when (re-search-forward (concat "^" header ":") nil t)
 340       (article-hide-text-type
 341        (progn (beginning-of-line) (point))
 342        (progn
 343          (end-of-line)
 344          (if (re-search-forward "^[^ \t]" nil t)
 345              (match-beginning 0)
 346            (point-max)))
 347        'boring-headers))))
 348
 349 ;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
 350 (defun article-treat-overstrike ()
 351   "Translate overstrikes into bold text."
 352   (interactive)
 353   (save-excursion
 354     (let ((buffer-read-only nil))
 355       (while (search-forward "\b" nil t)
 356         (let ((next (following-char))
 357               (previous (char-after (- (point) 2))))
 358           ;; We do the boldification/underlining by hiding the
 359           ;; overstrikes and putting the proper text property
 360           ;; on the letters.
 361           (cond
 362            ((eq next previous)
 363             (article-hide-text-type (- (point) 2) (point) 'overstrike)
 364             (put-text-property (point) (1+ (point)) 'face 'bold))
 365            ((eq next ?_)
 366             (article-hide-text-type (1- (point)) (1+ (point)) 'overstrike)
 367             (put-text-property
 368              (- (point) 2) (1- (point)) 'face 'underline))
 369            ((eq previous ?_)
 370             (article-hide-text-type (- (point) 2) (point) 'overstrike)
 371             (put-text-property
 372              (point) (1+ (point)) 'face 'underline))))))))
 373
 374 (defun article-fill ()
 375   "Format too long lines."
 376   (interactive)
 377   (save-excursion
 378     (let ((buffer-read-only nil))
 379       (widen)
 380       (goto-char (point-min))
 381       (search-forward "\n\n" nil t)
 382       (end-of-line 1)
 383       (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
 384             (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
 385             (adaptive-fill-mode t))
 386         (while (not (eobp))
 387           (and (>= (current-column) (min fill-column (window-width)))
 388                (/= (preceding-char) ?:)
 389                (fill-paragraph nil))
 390           (end-of-line 2))))))
 391
 392 (defun article-remove-cr ()
 393   "Remove carriage returns from an article."
 394   (interactive)
 395   (save-excursion
 396     (let ((buffer-read-only nil))
 397       (goto-char (point-min))
 398       (while (search-forward "\r" nil t)
 399         (replace-match "" t t)))))
 400
 401 (defun article-remove-trailing-blank-lines ()
 402   "Remove all trailing blank lines from the article."
 403   (interactive)
 404   (save-excursion
 405     (let ((buffer-read-only nil))
 406       (goto-char (point-max))
 407       (delete-region
 408        (point)
 409        (progn
 410          (while (looking-at "^[ \t]*$")
 411            (forward-line -1))
 412          (forward-line 1)
 413          (point))))))
 414
 415 (defun article-display-x-face (&optional force)
 416   "Look for an X-Face header and display it if present."
 417   (interactive (list 'force))
 418   (save-excursion
 419     ;; Delete the old process, if any.
 420     (when (process-status "article-x-face")
 421       (delete-process "article-x-face"))
 422     (let ((inhibit-point-motion-hooks t)
 423           (case-fold-search nil)
 424           from)
 425       (save-restriction
 426         (nnheader-narrow-to-headers)
 427         (setq from (message-fetch-field "from"))
 428         (goto-char (point-min))
 429         (when (and gnus-article-x-face-command
 430                    (or force
 431                        ;; Check whether this face is censored.
 432                        (not gnus-article-x-face-too-ugly)
 433                        (and gnus-article-x-face-too-ugly from
 434                             (not (string-match gnus-article-x-face-too-ugly
 435                                                from))))
 436                    ;; Has to be present.
 437                    (re-search-forward "^X-Face: " nil t))
 438           ;; We now have the area of the buffer where the X-Face is stored.
 439           (let ((beg (point))
 440                 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
 441             ;; We display the face.
 442             (if (symbolp gnus-article-x-face-command)
 443                 ;; The command is a lisp function, so we call it.
 444                 (if (gnus-functionp gnus-article-x-face-command)
 445                     (funcall gnus-article-x-face-command beg end)
 446                   (error "%s is not a function" gnus-article-x-face-command))
 447               ;; The command is a string, so we interpret the command
 448               ;; as a, well, command, and fork it off.
 449               (let ((process-connection-type nil))
 450                 (process-kill-without-query
 451                  (start-process
 452                   "article-x-face" nil shell-file-name shell-command-switch
 453                   gnus-article-x-face-command))
 454                 (process-send-region "article-x-face" beg end)
 455                 (process-send-eof "article-x-face")))))))))
 456
 457 (defun article-decode-rfc1522 ()
 458   "Hack to remove QP encoding from headers."
 459   (let ((case-fold-search t)
 460         (inhibit-point-motion-hooks t)
 461         (buffer-read-only nil)
 462         string)
 463     (save-restriction
 464       (narrow-to-region
 465        (goto-char (point-min))
 466        (or (search-forward "\n\n" nil t) (point-max)))
 467       (goto-char (point-min))
 468       (while (re-search-forward
 469               "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
 470         (setq string (match-string 1))
 471         (save-restriction
 472           (narrow-to-region (match-beginning 0) (match-end 0))
 473           (delete-region (point-min) (point-max))
 474           (insert string)
 475           (article-mime-decode-quoted-printable (goto-char (point-min))
 476                                                 (point-max))
 477           (subst-char-in-region (point-min) (point-max) ?_ ? )
 478           (goto-char (point-max)))
 479         (if (looking-at "\\([ \t\n]+\\)=\\?")
 480             (replace-match "" t t nil 1))
 481         (goto-char (point-min))))))
 482
 483 (defun article-de-quoted-unreadable (&optional force)
 484   "Do a naive translation of a quoted-printable-encoded article.
 485 This is in no way, shape or form meant as a replacement for real MIME
 486 processing, but is simply a stop-gap measure until MIME support is
 487 written.
 488 If FORCE, decode the article whether it is marked as quoted-printable
 489 or not."
 490   (interactive (list 'force))
 491   (save-excursion
 492     (let ((case-fold-search t)
 493           (buffer-read-only nil)
 494           (type (gnus-fetch-field "content-transfer-encoding")))
 495       (article-decode-rfc1522)
 496       (when (or force
 497                 (and type (string-match "quoted-printable" (downcase type))))
 498         (goto-char (point-min))
 499         (search-forward "\n\n" nil 'move)
 500         (article-mime-decode-quoted-printable (point) (point-max))))))
 501
 502 (defun article-mime-decode-quoted-printable-buffer ()
 503   "Decode Quoted-Printable in the current buffer."
 504   (article-mime-decode-quoted-printable (point-min) (point-max)))
 505
 506 (defun article-mime-decode-quoted-printable (from to)
 507   "Decode Quoted-Printable in the region between FROM and TO."
 508   (interactive "r")
 509   (goto-char from)
 510   (while (search-forward "=" to t)
 511     (cond ((eq (following-char) ?\n)
 512            (delete-char -1)
 513            (delete-char 1))
 514           ((looking-at "[0-9A-F][0-9A-F]")
 515            (subst-char-in-region
 516             (1- (point)) (point) ?=
 517             (hexl-hex-string-to-integer
 518              (buffer-substring (point) (+ 2 (point)))))
 519            (delete-char 2))
 520           ((looking-at "=")
 521            (delete-char 1))
 522           ((gnus-message 3 "Malformed MIME quoted-printable message")))))
 523
 524 (defun article-hide-pgp (&optional arg)
 525   "Toggle hiding of any PGP headers and signatures in the current article.
 526 If given a negative prefix, always show; if given a positive prefix,
 527 always hide."
 528   (interactive (article-hidden-arg))
 529   (unless (article-check-hidden-text 'pgp arg)
 530     (save-excursion
 531       (let (buffer-read-only beg end)
 532         (widen)
 533         (goto-char (point-min))
 534         ;; Hide the "header".
 535         (and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
 536              (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp))
 537         (setq beg (point))
 538         ;; Hide the actual signature.
 539         (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
 540              (setq end (1+ (match-beginning 0)))
 541              (article-hide-text-type
 542               end
 543               (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
 544                   (match-end 0)
 545                 ;; Perhaps we shouldn't hide to the end of the buffer
 546                 ;; if there is no end to the signature?
 547                 (point-max))
 548               'pgp))
 549         ;; Hide "- " PGP quotation markers.
 550         (when (and beg end)
 551           (narrow-to-region beg end)
 552           (goto-char (point-min))
 553           (while (re-search-forward "^- " nil t)
 554             (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp))
 555           (widen))))))
 556
 557 (defun article-hide-pem (&optional arg)
 558   "Toggle hiding of any PEM headers and signatures in the current article.
 559 If given a negative prefix, always show; if given a positive prefix,
 560 always hide."
 561   (interactive (article-hidden-arg))
 562   (unless (article-check-hidden-text 'pem arg)
 563     (save-excursion
 564       (let (buffer-read-only end)
 565         (widen)
 566         (goto-char (point-min))
 567         ;; hide the horrendously ugly "header".
 568         (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
 569                              nil
 570                              t)
 571              (setq end (1+ (match-beginning 0)))
 572              (article-hide-text-type
 573               end
 574               (if (search-forward "\n\n" nil t)
 575                   (match-end 0)
 576                 (point-max))
 577               'pem))
 578         ;; hide the trailer as well
 579         (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
 580                              nil
 581                              t)
 582              (article-hide-text-type
 583               (match-beginning 0) (match-end 0) 'pem))))))
 584
 585 (defun article-hide-signature (&optional arg)
 586   "Hide the signature in the current article.
 587 If given a negative prefix, always show; if given a positive prefix,
 588 always hide."
 589   (interactive (article-hidden-arg))
 590   (unless (article-check-hidden-text 'signature arg)
 591     (save-excursion
 592       (save-restriction
 593         (let ((buffer-read-only nil))
 594           (when (article-narrow-to-signature)
 595             (article-hide-text-type (point-min) (point-max) 'signature)))))))
 596
 597 (defun article-strip-leading-blank-lines ()
 598   "Remove all blank lines from the beginning of the article."
 599   (interactive)
 600   (save-excursion
 601     (let (buffer-read-only)
 602       (goto-char (point-min))
 603       (when (search-forward "\n\n" nil t)
 604         (while (looking-at "[ \t]$")
 605           (gnus-delete-line))))))
 606
 607 (defun article-strip-multiple-blank-lines ()
 608   "Replace consecutive blank lines with one empty line."
 609   (interactive)
 610   (save-excursion
 611     (let (buffer-read-only)
 612       ;; First make all blank lines empty.
 613       (goto-char (point-min))
 614       (while (re-search-forward "^[ \t]+$" nil t)
 615         (replace-match "" nil t))
 616       ;; Then replace multiple empty lines with a single empty line.
 617       (goto-char (point-min))
 618       (while (re-search-forward "\n\n\n+" nil t)
 619         (replace-match "\n\n" t t)))))
 620
 621 (defun article-strip-blank-lines ()
 622   "Strip leading, trailing and multiple blank lines."
 623   (interactive)
 624   (article-strip-leading-blank-lines)
 625   (article-remove-trailing-blank-lines)
 626   (article-strip-multiple-blank-lines))
 627
 628 (defvar mime::preview/content-list)
 629 (defvar mime::preview-content-info/point-min)
 630 (defun article-narrow-to-signature ()
 631   "Narrow to the signature."
 632   (widen)
 633   (when (and (boundp 'mime::preview/content-list)
 634              mime::preview/content-list)
 635     ;; We have a MIMEish article, so we use the MIME data to narrow.
 636     (let ((pcinfo (car (last mime::preview/content-list))))
 637       (condition-case ()
 638           (narrow-to-region
 639            (funcall (intern "mime::preview-content-info/point-min") pcinfo)
 640            (point-max))
 641         (error nil))))
 642
 643   (when (article-search-signature)
 644     (forward-line 1)
 645     ;; Check whether we have some limits to what we consider
 646     ;; to be a signature.
 647     (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
 648                     (list gnus-signature-limit)))
 649           limit limited)
 650       (while (setq limit (pop limits))
 651         (if (or (and (integerp limit)
 652                      (< (- (point-max) (point)) limit))
 653                 (and (floatp limit)
 654                      (< (count-lines (point) (point-max)) limit))
 655                 (and (gnus-functionp limit)
 656                      (funcall limit))
 657                 (and (stringp limit)
 658                      (not (re-search-forward limit nil t))))
 659             ()                          ; This limit did not succeed.
 660           (setq limited t
 661                 limits nil)))
 662       (unless limited
 663         (narrow-to-region (point) (point-max))
 664         t))))
 665
 666 (defun article-search-signature ()
 667   "Search the current buffer for the signature separator.
 668 Put point at the beginning of the signature separator."
 669   (let ((cur (point)))
 670     (goto-char (point-max))
 671     (if (if (stringp gnus-signature-separator)
 672             (re-search-backward gnus-signature-separator nil t)
 673           (let ((seps gnus-signature-separator))
 674             (while (and seps
 675                         (not (re-search-backward (car seps) nil t)))
 676               (pop seps))
 677             seps))
 678         t
 679       (goto-char cur)
 680       nil)))
 681
 682 (defun article-hidden-arg ()
 683   "Return the current prefix arg as a number, or 0 if no prefix."
 684   (list (if current-prefix-arg
 685             (prefix-numeric-value current-prefix-arg)
 686           0)))
 687
 688 (defun article-check-hidden-text (type arg)
 689   "Return nil if hiding is necessary.
 690 Arg can be nil or a number.  Nil and positive means hide, negative
 691 means show, 0 means toggle."
 692   (save-excursion
 693     (let ((hide (article-hidden-text-p type)))
 694       (cond
 695        ((or (null arg)
 696             (> arg 0))
 697         nil)
 698        ((< arg 0)
 699         (article-show-hidden-text type))
 700        (t
 701         (if (eq hide 'hidden)
 702             (article-show-hidden-text type)
 703           nil))))))
 704
 705 (defun article-hidden-text-p (type)
 706   "Say whether the current buffer contains hidden text of type TYPE."
 707   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
 708     (when pos
 709       (if (get-text-property pos 'invisible)
 710           'hidden
 711         'shown))))
 712
 713 (defun article-show-hidden-text (type &optional hide)
 714   "Show all hidden text of type TYPE.
 715 If HIDE, hide the text instead."
 716   (save-excursion
 717     (let ((buffer-read-only nil)
 718           (inhibit-point-motion-hooks t)
 719           (beg (point-min)))
 720       (while (gnus-goto-char (text-property-any
 721                               beg (point-max) 'article-type type))
 722         (setq beg (point))
 723         (forward-char)
 724         (if hide
 725             (article-hide-text beg (point) gnus-hidden-properties)
 726           (article-unhide-text beg (point)))
 727         (setq beg (point)))
 728       t)))
 729
 730 (defconst article-time-units
 731   `((year . ,(* 365.25 24 60 60))
 732     (week . ,(* 7 24 60 60))
 733     (day . ,(* 24 60 60))
 734     (hour . ,(* 60 60))
 735     (minute . 60)
 736     (second . 1))
 737   "Mapping from time units to seconds.")
 738
 739 (defun article-date-ut (&optional type highlight header)
 740   "Convert DATE date to universal time in the current article.
 741 If TYPE is `local', convert to local time; if it is `lapsed', output
 742 how much time has lapsed since DATE."
 743   (interactive (list 'ut t))
 744   (let* ((header (or header (message-fetch-field "date") ""))
 745          (date (if (vectorp header) (mail-header-date header)
 746                  header))
 747          (date-regexp "^Date: \\|^X-Sent: ")
 748          (inhibit-point-motion-hooks t)
 749          bface eface)
 750     (when (and date (not (string= date "")))
 751       (save-excursion
 752         (save-restriction
 753           (nnheader-narrow-to-headers)
 754           (let ((buffer-read-only nil))
 755             ;; Delete any old Date headers.
 756             (if (re-search-forward date-regexp nil t)
 757                 (progn
 758                   (setq bface (get-text-property (gnus-point-at-bol) 'face)
 759                         eface (get-text-property (1- (gnus-point-at-eol))
 760                                                  'face))
 761                   (message-remove-header date-regexp t)
 762                   (beginning-of-line))
 763               (goto-char (point-max)))
 764             (insert (article-make-date-line date type))
 765             ;; Do highlighting.
 766             (forward-line -1)
 767             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
 768               (put-text-property (match-beginning 1) (match-end 1)
 769                                  'face bface)
 770               (put-text-property (match-beginning 2) (match-end 2)
 771                                  'face eface))))))))
 772
 773 (defun article-make-date-line (date type)
 774   "Return a DATE line of TYPE."
 775   (cond
 776    ;; Convert to the local timezone.  We have to slap a
 777    ;; `condition-case' round the calls to the timezone
 778    ;; functions since they aren't particularly resistant to
 779    ;; buggy dates.
 780    ((eq type 'local)
 781     (concat "Date: " (condition-case ()
 782                          (timezone-make-date-arpa-standard date)
 783                        (error date))
 784             "\n"))
 785    ;; Convert to Universal Time.
 786    ((eq type 'ut)
 787     (concat "Date: "
 788             (condition-case ()
 789                 (timezone-make-date-arpa-standard date nil "UT")
 790               (error date))
 791             "\n"))
 792    ;; Get the original date from the article.
 793    ((eq type 'original)
 794     (concat "Date: " date "\n"))
 795    ;; Do an X-Sent lapsed format.
 796    ((eq type 'lapsed)
 797     ;; If the date is seriously mangled, the timezone
 798     ;; functions are liable to bug out, so we condition-case
 799     ;; the entire thing.
 800     (let* ((now (current-time))
 801            (real-time
 802             (condition-case ()
 803                 (gnus-time-minus
 804                  (gnus-encode-date
 805                   (timezone-make-date-arpa-standard
 806                    (current-time-string now)
 807                    (current-time-zone now) "UT"))
 808                  (gnus-encode-date
 809                   (timezone-make-date-arpa-standard
 810                    date nil "UT")))
 811               (error nil)))
 812            (real-sec (and real-time
 813                           (+ (* (float (car real-time)) 65536)
 814                              (cadr real-time))))
 815            (sec (and real-time (abs real-sec)))
 816            num prev)
 817       (cond
 818        ((null real-time)
 819         "X-Sent: Unknown\n")
 820        ((zerop sec)
 821         "X-Sent: Now\n")
 822        (t
 823         (concat
 824          "X-Sent: "
 825          ;; This is a bit convoluted, but basically we go
 826          ;; through the time units for years, weeks, etc,
 827          ;; and divide things to see whether that results
 828          ;; in positive answers.
 829          (mapconcat
 830           (lambda (unit)
 831             (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
 832                 ;; The (remaining) seconds are too few to
 833                 ;; be divided into this time unit.
 834                 ""
 835               ;; It's big enough, so we output it.
 836               (setq sec (- sec (* num (cdr unit))))
 837               (prog1
 838                   (concat (if prev ", " "") (int-to-string
 839                                              (floor num))
 840                           " " (symbol-name (car unit))
 841                           (if (> num 1) "s" ""))
 842                 (setq prev t))))
 843           article-time-units "")
 844          ;; If dates are odd, then it might appear like the
 845          ;; article was sent in the future.
 846          (if (> real-sec 0)
 847              " ago\n"
 848            " in the future\n"))))))
 849    (t
 850     (error "Unknown conversion type: %s" type))))
 851
 852 (defun article-date-local (&optional highlight)
 853   "Convert the current article date to the local timezone."
 854   (interactive (list t))
 855   (article-date-ut 'local highlight))
 856
 857 (defun article-date-original (&optional highlight)
 858   "Convert the current article date to what it was originally.
 859 This is only useful if you have used some other date conversion
 860 function and want to see what the date was before converting."
 861   (interactive (list t))
 862   (article-date-ut 'original highlight))
 863
 864 (defun article-date-lapsed (&optional highlight)
 865   "Convert the current article date to time lapsed since it was sent."
 866   (interactive (list t))
 867   (article-date-ut 'lapsed highlight))
 868
 869 (defun article-show-all ()
 870   "Show all hidden text in the article buffer."
 871   (interactive)
 872   (save-excursion
 873     (let ((buffer-read-only nil))
 874       (article-unhide-text (point-min) (point-max)))))
 875
 876 (defun article-emphasize (&optional arg)
 877   "Emphasize text according to `gnus-emphasis-alist'."
 878   (interactive (article-hidden-arg))
 879   (unless (article-check-hidden-text 'emphasis arg)
 880     (save-excursion
 881       (let ((alist gnus-emphasis-alist)
 882             (buffer-read-only nil)
 883             (props (append '(article-type emphasis)
 884                            gnus-hidden-properties))
 885             regexp elem beg invisible visible face)
 886         (goto-char (point-min))
 887         (search-forward "\n\n" nil t)
 888         (setq beg (point))
 889         (while (setq elem (pop alist))
 890           (goto-char beg)
 891           (setq regexp (car elem)
 892                 invisible (nth 1 elem)
 893                 visible (nth 2 elem)
 894                 face (nth 3 elem))
 895           (while (re-search-forward regexp nil t)
 896             (article-hide-text
 897              (match-beginning invisible) (match-end invisible) props)
 898             (article-unhide-text-type
 899              (match-beginning visible) (match-end visible) 'emphasis)
 900             (put-text-property
 901              (match-beginning visible) (match-end visible)
 902              'face face)))))))
 903
 904 (provide 'article)
 905
 906 ;;; article.el ends here