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-text-type-exists-p (type)
 241   "Say whether any text of type TYPE exists in the buffer."
 242   (text-property-any (point-min) (point-max) 'article-type type))
 243
 244 (defsubst article-header-rank ()
 245   "Give the rank of the string HEADER as given by `article-sorted-header-list'."
 246   (let ((list gnus-sorted-header-list)
 247         (i 0))
 248     (while list
 249       (when (looking-at (car list))
 250         (setq list nil))
 251       (setq list (cdr list))
 252       (incf i))
 253     i))
 254
 255 (defun article-hide-headers (&optional arg delete)
 256   "Toggle whether to hide unwanted headers and possibly sort them as well.
 257 If given a negative prefix, always show; if given a positive prefix,
 258 always hide."
 259   (interactive (article-hidden-arg))
 260   (if (article-check-hidden-text 'headers arg)
 261       ;; Show boring headers as well.
 262       (article-show-hidden-text 'boring-headers)
 263     ;; This function might be inhibited.
 264     (unless gnus-inhibit-hiding
 265       (save-excursion
 266         (save-restriction
 267           (let ((buffer-read-only nil)
 268                 (props (nconc (list 'article-type 'headers)
 269                               gnus-hidden-properties))
 270                 (max (1+ (length gnus-sorted-header-list)))
 271                 (ignored (when (not gnus-visible-headers)
 272                            (cond ((stringp gnus-ignored-headers)
 273                                   gnus-ignored-headers)
 274                                  ((listp gnus-ignored-headers)
 275                                   (mapconcat 'identity gnus-ignored-headers
 276                                              "\\|")))))
 277                 (visible
 278                  (cond ((stringp gnus-visible-headers)
 279                         gnus-visible-headers)
 280                        ((and gnus-visible-headers
 281                              (listp gnus-visible-headers))
 282                         (mapconcat 'identity gnus-visible-headers "\\|"))))
 283                 (inhibit-point-motion-hooks t)
 284                 want-list beg)
 285             ;; First we narrow to just the headers.
 286             (widen)
 287             (goto-char (point-min))
 288             ;; Hide any "From " lines at the beginning of (mail) articles.
 289             (while (looking-at "From ")
 290               (forward-line 1))
 291             (unless (bobp)
 292               (if delete
 293                   (delete-region (point-min) (point))
 294                 (article-hide-text (point-min) (point) props)))
 295             ;; Then treat the rest of the header lines.
 296             (narrow-to-region
 297              (point)
 298              (if (search-forward "\n\n" nil t) ; if there's a body
 299                  (progn (forward-line -1) (point))
 300                (point-max)))
 301             ;; Then we use the two regular expressions
 302             ;; `gnus-ignored-headers' and `gnus-visible-headers' to
 303             ;; select which header lines is to remain visible in the
 304             ;; article buffer.
 305             (goto-char (point-min))
 306             (while (re-search-forward "^[^ \t]*:" nil t)
 307               (beginning-of-line)
 308               ;; Mark the rank of the header.
 309               (put-text-property
 310                (point) (1+ (point)) 'message-rank
 311                (if (or (and visible (looking-at visible))
 312                        (and ignored
 313                             (not (looking-at ignored))))
 314                    (article-header-rank)
 315                  (+ 2 max)))
 316               (forward-line 1))
 317             (message-sort-headers-1)
 318             (when (setq beg (text-property-any
 319                              (point-min) (point-max) 'message-rank (+ 2 max)))
 320               ;; We make the unwanted headers invisible.
 321               (if delete
 322                   (delete-region beg (point-max))
 323                 ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
 324                 (article-hide-text-type beg (point-max) 'headers))
 325               ;; Work around XEmacs lossage.
 326               (put-text-property (point-min) beg 'invisible nil))))))))
 327
 328 (defun article-hide-boring-headers (&optional arg)
 329   "Toggle hiding of headers that aren't very interesting.
 330 If given a negative prefix, always show; if given a positive prefix,
 331 always hide."
 332   (interactive (article-hidden-arg))
 333   (unless (article-check-hidden-text 'boring-headers arg)
 334     (save-excursion
 335       (save-restriction
 336         (let ((buffer-read-only nil)
 337               (list gnus-boring-article-headers)
 338               (inhibit-point-motion-hooks t)
 339               elem)
 340           (nnheader-narrow-to-headers)
 341           (while list
 342             (setq elem (pop list))
 343             (goto-char (point-min))
 344             (cond
 345              ;; Hide empty headers.
 346              ((eq elem 'empty)
 347               (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
 348                 (forward-line -1)
 349                 (article-hide-text-type
 350                  (progn (beginning-of-line) (point))
 351                  (progn
 352                    (end-of-line)
 353                    (if (re-search-forward "^[^ \t]" nil t)
 354                        (match-beginning 0)
 355                      (point-max)))
 356                  'boring-headers)))
 357              ;; Hide boring Newsgroups header.
 358              ((eq elem 'newsgroups)
 359               (when (equal (gnus-fetch-field "newsgroups")
 360                            (gnus-group-real-name
 361                             (if (boundp 'gnus-newsgroup-name)
 362                                 gnus-newsgroup-name
 363                               "")))
 364                 (article-hide-header "newsgroups")))
 365              ((eq elem 'followup-to)
 366               (when (equal (message-fetch-field "followup-to")
 367                            (message-fetch-field "newsgroups"))
 368                 (article-hide-header "followup-to")))
 369              ((eq elem 'reply-to)
 370               (let ((from (message-fetch-field "from"))
 371                     (reply-to (message-fetch-field "reply-to")))
 372                 (when (and
 373                        from reply-to
 374                        (equal
 375                         (nth 1 (mail-extract-address-components from))
 376                         (nth 1 (mail-extract-address-components reply-to))))
 377                   (article-hide-header "reply-to"))))
 378              ((eq elem 'date)
 379               (let ((date (message-fetch-field "date")))
 380                 (when (and date
 381                            (< (gnus-days-between (current-time-string) date)
 382                               4))
 383                   (article-hide-header "date")))))))))))
 384
 385 (defun article-hide-header (header)
 386   (save-excursion
 387     (goto-char (point-min))
 388     (when (re-search-forward (concat "^" header ":") nil t)
 389       (article-hide-text-type
 390        (progn (beginning-of-line) (point))
 391        (progn
 392          (end-of-line)
 393          (if (re-search-forward "^[^ \t]" nil t)
 394              (match-beginning 0)
 395            (point-max)))
 396        'boring-headers))))
 397
 398 ;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
 399 (defun article-treat-overstrike ()
 400   "Translate overstrikes into bold text."
 401   (interactive)
 402   (save-excursion
 403     (let ((buffer-read-only nil))
 404       (while (search-forward "\b" nil t)
 405         (let ((next (following-char))
 406               (previous (char-after (- (point) 2))))
 407           ;; We do the boldification/underlining by hiding the
 408           ;; overstrikes and putting the proper text property
 409           ;; on the letters.
 410           (cond
 411            ((eq next previous)
 412             (article-hide-text-type (- (point) 2) (point) 'overstrike)
 413             (put-text-property (point) (1+ (point)) 'face 'bold))
 414            ((eq next ?_)
 415             (article-hide-text-type (1- (point)) (1+ (point)) 'overstrike)
 416             (put-text-property
 417              (- (point) 2) (1- (point)) 'face 'underline))
 418            ((eq previous ?_)
 419             (article-hide-text-type (- (point) 2) (point) 'overstrike)
 420             (put-text-property
 421              (point) (1+ (point)) 'face 'underline))))))))
 422
 423 (defun article-fill ()
 424   "Format too long lines."
 425   (interactive)
 426   (save-excursion
 427     (let ((buffer-read-only nil))
 428       (widen)
 429       (goto-char (point-min))
 430       (search-forward "\n\n" nil t)
 431       (end-of-line 1)
 432       (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
 433             (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
 434             (adaptive-fill-mode t))
 435         (while (not (eobp))
 436           (and (>= (current-column) (min fill-column (window-width)))
 437                (/= (preceding-char) ?:)
 438                (fill-paragraph nil))
 439           (end-of-line 2))))))
 440
 441 (defun article-remove-cr ()
 442   "Remove carriage returns from an article."
 443   (interactive)
 444   (save-excursion
 445     (let ((buffer-read-only nil))
 446       (goto-char (point-min))
 447       (while (search-forward "\r" nil t)
 448         (replace-match "" t t)))))
 449
 450 (defun article-remove-trailing-blank-lines ()
 451   "Remove all trailing blank lines from the article."
 452   (interactive)
 453   (save-excursion
 454     (let ((buffer-read-only nil))
 455       (goto-char (point-max))
 456       (delete-region
 457        (point)
 458        (progn
 459          (while (and (not (bobp))
 460                      (looking-at "^[ \t]*$"))
 461            (forward-line -1))
 462          (forward-line 1)
 463          (point))))))
 464
 465 (defun article-display-x-face (&optional force)
 466   "Look for an X-Face header and display it if present."
 467   (interactive (list 'force))
 468   (save-excursion
 469     ;; Delete the old process, if any.
 470     (when (process-status "article-x-face")
 471       (delete-process "article-x-face"))
 472     (let ((inhibit-point-motion-hooks t)
 473           (case-fold-search nil)
 474           from)
 475       (save-restriction
 476         (nnheader-narrow-to-headers)
 477         (setq from (message-fetch-field "from"))
 478         (goto-char (point-min))
 479         (when (and gnus-article-x-face-command
 480                    (or force
 481                        ;; Check whether this face is censored.
 482                        (not gnus-article-x-face-too-ugly)
 483                        (and gnus-article-x-face-too-ugly from
 484                             (not (string-match gnus-article-x-face-too-ugly
 485                                                from))))
 486                    ;; Has to be present.
 487                    (re-search-forward "^X-Face: " nil t))
 488           ;; We now have the area of the buffer where the X-Face is stored.
 489           (let ((beg (point))
 490                 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
 491             ;; We display the face.
 492             (if (symbolp gnus-article-x-face-command)
 493                 ;; The command is a lisp function, so we call it.
 494                 (if (gnus-functionp gnus-article-x-face-command)
 495                     (funcall gnus-article-x-face-command beg end)
 496                   (error "%s is not a function" gnus-article-x-face-command))
 497               ;; The command is a string, so we interpret the command
 498               ;; as a, well, command, and fork it off.
 499               (let ((process-connection-type nil))
 500                 (process-kill-without-query
 501                  (start-process
 502                   "article-x-face" nil shell-file-name shell-command-switch
 503                   gnus-article-x-face-command))
 504                 (process-send-region "article-x-face" beg end)
 505                 (process-send-eof "article-x-face")))))))))
 506
 507 (defun article-decode-rfc1522 ()
 508   "Hack to remove QP encoding from headers."
 509   (let ((case-fold-search t)
 510         (inhibit-point-motion-hooks t)
 511         (buffer-read-only nil)
 512         string)
 513     (save-restriction
 514       (narrow-to-region
 515        (goto-char (point-min))
 516        (or (search-forward "\n\n" nil t) (point-max)))
 517       (goto-char (point-min))
 518       (while (re-search-forward
 519               "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t)
 520         (setq string (match-string 1))
 521         (save-restriction
 522           (narrow-to-region (match-beginning 0) (match-end 0))
 523           (delete-region (point-min) (point-max))
 524           (insert string)
 525           (article-mime-decode-quoted-printable
 526            (goto-char (point-min)) (point-max))
 527           (subst-char-in-region (point-min) (point-max) ?_ ? )
 528           (goto-char (point-max)))
 529         (when (looking-at "\\([ \t\n]+\\)=\\?")
 530           (replace-match "" t t nil 1))
 531         (goto-char (point-min))))))
 532
 533 (defun article-de-quoted-unreadable (&optional force)
 534   "Do a naive translation of a quoted-printable-encoded article.
 535 This is in no way, shape or form meant as a replacement for real MIME
 536 processing, but is simply a stop-gap measure until MIME support is
 537 written.
 538 If FORCE, decode the article whether it is marked as quoted-printable
 539 or not."
 540   (interactive (list 'force))
 541   (save-excursion
 542     (let ((case-fold-search t)
 543           (buffer-read-only nil)
 544           (type (gnus-fetch-field "content-transfer-encoding")))
 545       (article-decode-rfc1522)
 546       (when (or force
 547                 (and type (string-match "quoted-printable" (downcase type))))
 548         (goto-char (point-min))
 549         (search-forward "\n\n" nil 'move)
 550         (article-mime-decode-quoted-printable (point) (point-max))))))
 551
 552 (defun article-mime-decode-quoted-printable-buffer ()
 553   "Decode Quoted-Printable in the current buffer."
 554   (article-mime-decode-quoted-printable (point-min) (point-max)))
 555
 556 (defun article-mime-decode-quoted-printable (from to)
 557   "Decode Quoted-Printable in the region between FROM and TO."
 558   (interactive "r")
 559   (goto-char from)
 560   (while (search-forward "=" to t)
 561     (cond ((eq (following-char) ?\n)
 562            (delete-char -1)
 563            (delete-char 1))
 564           ((looking-at "[0-9A-F][0-9A-F]")
 565            (subst-char-in-region
 566             (1- (point)) (point) ?=
 567             (hexl-hex-string-to-integer
 568              (buffer-substring (point) (+ 2 (point)))))
 569            (delete-char 2))
 570           ((looking-at "=")
 571            (delete-char 1))
 572           ((gnus-message 3 "Malformed MIME quoted-printable message")))))
 573
 574 (defun article-hide-pgp (&optional arg)
 575   "Toggle hiding of any PGP headers and signatures in the current article.
 576 If given a negative prefix, always show; if given a positive prefix,
 577 always hide."
 578   (interactive (article-hidden-arg))
 579   (unless (article-check-hidden-text 'pgp arg)
 580     (save-excursion
 581       (let (buffer-read-only beg end)
 582         (widen)
 583         (goto-char (point-min))
 584         ;; Hide the "header".
 585         (and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
 586              (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp))
 587         (setq beg (point))
 588         ;; Hide the actual signature.
 589         (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
 590              (setq end (1+ (match-beginning 0)))
 591              (article-hide-text-type
 592               end
 593               (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
 594                   (match-end 0)
 595                 ;; Perhaps we shouldn't hide to the end of the buffer
 596                 ;; if there is no end to the signature?
 597                 (point-max))
 598               'pgp))
 599         ;; Hide "- " PGP quotation markers.
 600         (when (and beg end)
 601           (narrow-to-region beg end)
 602           (goto-char (point-min))
 603           (while (re-search-forward "^- " nil t)
 604             (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp))
 605           (widen))))))
 606
 607 (defun article-hide-pem (&optional arg)
 608   "Toggle hiding of any PEM headers and signatures in the current article.
 609 If given a negative prefix, always show; if given a positive prefix,
 610 always hide."
 611   (interactive (article-hidden-arg))
 612   (unless (article-check-hidden-text 'pem arg)
 613     (save-excursion
 614       (let (buffer-read-only end)
 615         (widen)
 616         (goto-char (point-min))
 617         ;; hide the horrendously ugly "header".
 618         (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
 619                              nil
 620                              t)
 621              (setq end (1+ (match-beginning 0)))
 622              (article-hide-text-type
 623               end
 624               (if (search-forward "\n\n" nil t)
 625                   (match-end 0)
 626                 (point-max))
 627               'pem))
 628         ;; hide the trailer as well
 629         (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
 630                              nil
 631                              t)
 632              (article-hide-text-type
 633               (match-beginning 0) (match-end 0) 'pem))))))
 634
 635 (defun article-hide-signature (&optional arg)
 636   "Hide the signature in the current article.
 637 If given a negative prefix, always show; if given a positive prefix,
 638 always hide."
 639   (interactive (article-hidden-arg))
 640   (unless (article-check-hidden-text 'signature arg)
 641     (save-excursion
 642       (save-restriction
 643         (let ((buffer-read-only nil))
 644           (when (article-narrow-to-signature)
 645             (article-hide-text-type (point-min) (point-max) 'signature)))))))
 646
 647 (defun article-strip-leading-blank-lines ()
 648   "Remove all blank lines from the beginning of the article."
 649   (interactive)
 650   (save-excursion
 651     (let ((inhibit-point-motion-hooks t)
 652           buffer-read-only)
 653       (goto-char (point-min))
 654       (when (search-forward "\n\n" nil t)
 655         (while (and (not (eobp))
 656                     (looking-at "[ \t]*$"))
 657           (gnus-delete-line))))))
 658
 659 (defun article-strip-multiple-blank-lines ()
 660   "Replace consecutive blank lines with one empty line."
 661   (interactive)
 662   (save-excursion
 663     (let (buffer-read-only)
 664       ;; First make all blank lines empty.
 665       (goto-char (point-min))
 666       (while (re-search-forward "^[ \t]+$" nil t)
 667         (replace-match "" nil t))
 668       ;; Then replace multiple empty lines with a single empty line.
 669       (goto-char (point-min))
 670       (while (re-search-forward "\n\n\n+" nil t)
 671         (replace-match "\n\n" t t)))))
 672
 673 (defun article-strip-blank-lines ()
 674   "Strip leading, trailing and multiple blank lines."
 675   (interactive)
 676   (article-strip-leading-blank-lines)
 677   (article-remove-trailing-blank-lines)
 678   (article-strip-multiple-blank-lines))
 679
 680 (defvar mime::preview/content-list)
 681 (defvar mime::preview-content-info/point-min)
 682 (defun article-narrow-to-signature ()
 683   "Narrow to the signature; return t if a signature is found, else nil."
 684   (widen)
 685   (when (and (boundp 'mime::preview/content-list)
 686              mime::preview/content-list)
 687     ;; We have a MIMEish article, so we use the MIME data to narrow.
 688     (let ((pcinfo (car (last mime::preview/content-list))))
 689       (ignore-errors
 690         (narrow-to-region
 691          (funcall (intern "mime::preview-content-info/point-min") pcinfo)
 692          (point-max)))))
 693
 694   (when (article-search-signature)
 695     (forward-line 1)
 696     ;; Check whether we have some limits to what we consider
 697     ;; to be a signature.
 698     (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
 699                     (list gnus-signature-limit)))
 700           limit limited)
 701       (while (setq limit (pop limits))
 702         (if (or (and (integerp limit)
 703                      (< (- (point-max) (point)) limit))
 704                 (and (floatp limit)
 705                      (< (count-lines (point) (point-max)) limit))
 706                 (and (gnus-functionp limit)
 707                      (funcall limit))
 708                 (and (stringp limit)
 709                      (not (re-search-forward limit nil t))))
 710             ()                          ; This limit did not succeed.
 711           (setq limited t
 712                 limits nil)))
 713       (unless limited
 714         (narrow-to-region (point) (point-max))
 715         t))))
 716
 717 (defun article-search-signature ()
 718   "Search the current buffer for the signature separator.
 719 Put point at the beginning of the signature separator."
 720   (let ((cur (point)))
 721     (goto-char (point-max))
 722     (if (if (stringp gnus-signature-separator)
 723             (re-search-backward gnus-signature-separator nil t)
 724           (let ((seps gnus-signature-separator))
 725             (while (and seps
 726                         (not (re-search-backward (car seps) nil t)))
 727               (pop seps))
 728             seps))
 729         t
 730       (goto-char cur)
 731       nil)))
 732
 733 (defun article-hidden-arg ()
 734   "Return the current prefix arg as a number, or 0 if no prefix."
 735   (list (if current-prefix-arg
 736             (prefix-numeric-value current-prefix-arg)
 737           0)))
 738
 739 (defun article-check-hidden-text (type arg)
 740   "Return nil if hiding is necessary.
 741 Arg can be nil or a number.  Nil and positive means hide, negative
 742 means show, 0 means toggle."
 743   (save-excursion
 744     (let ((hide (article-hidden-text-p type)))
 745       (cond
 746        ((or (null arg)
 747             (> arg 0))
 748         nil)
 749        ((< arg 0)
 750         (article-show-hidden-text type))
 751        (t
 752         (if (eq hide 'hidden)
 753             (article-show-hidden-text type)
 754           nil))))))
 755
 756 (defun article-hidden-text-p (type)
 757   "Say whether the current buffer contains hidden text of type TYPE."
 758   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
 759     (when pos
 760       (if (get-text-property pos 'invisible)
 761           'hidden
 762         'shown))))
 763
 764 (defun article-show-hidden-text (type &optional hide)
 765   "Show all hidden text of type TYPE.
 766 If HIDE, hide the text instead."
 767   (save-excursion
 768     (let ((buffer-read-only nil)
 769           (inhibit-point-motion-hooks t)
 770           (beg (point-min)))
 771       (while (gnus-goto-char (text-property-any
 772                               beg (point-max) 'article-type type))
 773         (setq beg (point))
 774         (forward-char)
 775         (if hide
 776             (article-hide-text beg (point) gnus-hidden-properties)
 777           (article-unhide-text beg (point)))
 778         (setq beg (point)))
 779       t)))
 780
 781 (defconst article-time-units
 782   `((year . ,(* 365.25 24 60 60))
 783     (week . ,(* 7 24 60 60))
 784     (day . ,(* 24 60 60))
 785     (hour . ,(* 60 60))
 786     (minute . 60)
 787     (second . 1))
 788   "Mapping from time units to seconds.")
 789
 790 (defun article-date-ut (&optional type highlight header)
 791   "Convert DATE date to universal time in the current article.
 792 If TYPE is `local', convert to local time; if it is `lapsed', output
 793 how much time has lapsed since DATE."
 794   (interactive (list 'ut t))
 795   (let* ((header (or header (message-fetch-field "date")
 796                      (mail-header-date gnus-current-headers)
 797                      ""))
 798          (date (if (vectorp header) (mail-header-date header)
 799                  header))
 800          (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
 801          (inhibit-point-motion-hooks t)
 802          bface eface)
 803     (when (and date (not (string= date "")))
 804       (save-excursion
 805         (save-restriction
 806           (nnheader-narrow-to-headers)
 807           (let ((buffer-read-only nil))
 808             ;; Delete any old Date headers.
 809             (if (re-search-forward date-regexp nil t)
 810                 (progn
 811                   (setq bface (get-text-property (gnus-point-at-bol) 'face)
 812                         eface (get-text-property (1- (gnus-point-at-eol))
 813                                                  'face))
 814                   (message-remove-header date-regexp t)
 815                   (beginning-of-line))
 816               (goto-char (point-max)))
 817             (insert (article-make-date-line date type))
 818             ;; Do highlighting.
 819             (forward-line -1)
 820             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
 821               (put-text-property (match-beginning 1) (match-end 1)
 822                                  'face bface)
 823               (put-text-property (match-beginning 2) (match-end 2)
 824                                  'face eface))))))))
 825
 826 (defun article-make-date-line (date type)
 827   "Return a DATE line of TYPE."
 828   (cond
 829    ;; Convert to the local timezone.  We have to slap a
 830    ;; `condition-case' round the calls to the timezone
 831    ;; functions since they aren't particularly resistant to
 832    ;; buggy dates.
 833    ((eq type 'local)
 834     (concat "Date: " (condition-case ()
 835                          (timezone-make-date-arpa-standard date)
 836                        (error date))
 837             "\n"))
 838    ;; Convert to Universal Time.
 839    ((eq type 'ut)
 840     (concat "Date: "
 841             (condition-case ()
 842                 (timezone-make-date-arpa-standard date nil "UT")
 843               (error date))
 844             "\n"))
 845    ;; Get the original date from the article.
 846    ((eq type 'original)
 847     (concat "Date: " date "\n"))
 848    ;; Do an X-Sent lapsed format.
 849    ((eq type 'lapsed)
 850     ;; If the date is seriously mangled, the timezone functions are
 851     ;; liable to bug out, so we ignore all errors.
 852     (let* ((now (current-time))
 853            (real-time
 854             (ignore-errors
 855               (gnus-time-minus
 856                (gnus-encode-date
 857                 (timezone-make-date-arpa-standard
 858                  (current-time-string now)
 859                  (current-time-zone now) "UT"))
 860                (gnus-encode-date
 861                 (timezone-make-date-arpa-standard
 862                  date nil "UT")))))
 863            (real-sec (and real-time
 864                           (+ (* (float (car real-time)) 65536)
 865                              (cadr real-time))))
 866            (sec (and real-time (abs real-sec)))
 867            num prev)
 868       (cond
 869        ((null real-time)
 870         "X-Sent: Unknown\n")
 871        ((zerop sec)
 872         "X-Sent: Now\n")
 873        (t
 874         (concat
 875          "X-Sent: "
 876          ;; This is a bit convoluted, but basically we go
 877          ;; through the time units for years, weeks, etc,
 878          ;; and divide things to see whether that results
 879          ;; in positive answers.
 880          (mapconcat
 881           (lambda (unit)
 882             (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
 883                 ;; The (remaining) seconds are too few to
 884                 ;; be divided into this time unit.
 885                 ""
 886               ;; It's big enough, so we output it.
 887               (setq sec (- sec (* num (cdr unit))))
 888               (prog1
 889                   (concat (if prev ", " "") (int-to-string
 890                                              (floor num))
 891                           " " (symbol-name (car unit))
 892                           (if (> num 1) "s" ""))
 893                 (setq prev t))))
 894           article-time-units "")
 895          ;; If dates are odd, then it might appear like the
 896          ;; article was sent in the future.
 897          (if (> real-sec 0)
 898              " ago\n"
 899            " in the future\n"))))))
 900    (t
 901     (error "Unknown conversion type: %s" type))))
 902
 903 (defun article-date-local (&optional highlight)
 904   "Convert the current article date to the local timezone."
 905   (interactive (list t))
 906   (article-date-ut 'local highlight))
 907
 908 (defun article-date-original (&optional highlight)
 909   "Convert the current article date to what it was originally.
 910 This is only useful if you have used some other date conversion
 911 function and want to see what the date was before converting."
 912   (interactive (list t))
 913   (article-date-ut 'original highlight))
 914
 915 (defun article-date-lapsed (&optional highlight)
 916   "Convert the current article date to time lapsed since it was sent."
 917   (interactive (list t))
 918   (article-date-ut 'lapsed highlight))
 919
 920 (defun article-show-all ()
 921   "Show all hidden text in the article buffer."
 922   (interactive)
 923   (save-excursion
 924     (let ((buffer-read-only nil))
 925       (article-unhide-text (point-min) (point-max)))))
 926
 927 (defun article-emphasize (&optional arg)
 928   "Emphasize text according to `gnus-emphasis-alist'."
 929   (interactive (article-hidden-arg))
 930   (unless (article-check-hidden-text 'emphasis arg)
 931     (save-excursion
 932       (let ((alist gnus-emphasis-alist)
 933             (buffer-read-only nil)
 934             (props (append '(article-type emphasis)
 935                            gnus-hidden-properties))
 936             regexp elem beg invisible visible face)
 937         (goto-char (point-min))
 938         (search-forward "\n\n" nil t)
 939         (setq beg (point))
 940         (while (setq elem (pop alist))
 941           (goto-char beg)
 942           (setq regexp (car elem)
 943                 invisible (nth 1 elem)
 944                 visible (nth 2 elem)
 945                 face (nth 3 elem))
 946           (while (re-search-forward regexp nil t)
 947             (when (and (match-beginning visible) (match-beginning invisible))
 948               (article-hide-text
 949                (match-beginning invisible) (match-end invisible) props)
 950               (article-unhide-text-type
 951                (match-beginning visible) (match-end visible) 'emphasis)
 952               (put-text-property
 953                (match-beginning visible) (match-end visible) 'face face)
 954               (goto-char (match-end invisible)))))))))
 955
 956 (provide 'article)
 957
 958 ;;; article.el ends here