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