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