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