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

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