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

   1 ;;; gnus-art.el --- article mode commands for Gnus
   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 'gnus-load)
  29 (require 'gnus-sum)
  30 (require 'article)
  31 (require 'gnus-spec)
  32 (require 'gnus-int)
  33 (require 'browse-url)
  34
  35 (defcustom gnus-article-save-directory gnus-directory
  36   "*Name of the directory articles will be saved in (default \"~/News\")."
  37   :group 'article
  38   :type 'directory)
  39
  40 (defcustom gnus-save-all-headers t
  41   "*If non-nil, don't remove any headers before saving."
  42   :group 'article
  43   :type 'boolean)
  44
  45 (defcustom gnus-prompt-before-saving 'always
  46   "*This variable says how much prompting is to be done when saving articles.
  47 If it is nil, no prompting will be done, and the articles will be
  48 saved to the default files.  If this variable is `always', each and
  49 every article that is saved will be preceded by a prompt, even when
  50 saving large batches of articles.  If this variable is neither nil not
  51 `always', there the user will be prompted once for a file name for
  52 each invocation of the saving commands."
  53   :group 'article
  54   :type '(choice (item always)
  55                  (item :tag "never" nil)
  56                  (sexp :tag "once" :format "%t")))
  57
  58 (defcustom gnus-saved-headers gnus-visible-headers
  59   "Headers to keep if `gnus-save-all-headers' is nil.
  60 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
  61 If that variable is nil, however, all headers that match this regexp
  62 will be kept while the rest will be deleted before saving."
  63   :group 'article
  64   :type '(repeat string))
  65
  66 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
  67   "A function to save articles in your favourite format.
  68 The function must be interactively callable (in other words, it must
  69 be an Emacs command).
  70
  71 Gnus provides the following functions:
  72
  73 * gnus-summary-save-in-rmail (Rmail format)
  74 * gnus-summary-save-in-mail (Unix mail format)
  75 * gnus-summary-save-in-folder (MH folder)
  76 * gnus-summary-save-in-file (article format).
  77 * gnus-summary-save-in-vm (use VM's folder format)."
  78   :group 'article
  79   :type '(radio (function-item gnus-summary-save-in-rmail)
  80                 (function-item gnus-summary-save-in-mail)
  81                 (function-item gnus-summary-save-in-folder)
  82                 (function-item gnus-summary-save-in-file)
  83                 (function-item gnus-summary-save-in-vm)))
  84
  85 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
  86   "A function generating a file name to save articles in Rmail format.
  87 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
  88   :group 'article
  89   :type 'function)
  90
  91 (defcustom gnus-mail-save-name 'gnus-plain-save-name
  92   "A function generating a file name to save articles in Unix mail format.
  93 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
  94   :group 'article
  95   :type 'function)
  96
  97 (defcustom gnus-folder-save-name 'gnus-folder-save-name
  98   "A function generating a file name to save articles in MH folder.
  99 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
 100   :group 'article
 101   :type 'function)
 102
 103 (defcustom gnus-file-save-name 'gnus-numeric-save-name
 104   "A function generating a file name to save articles in article format.
 105 The function is called with NEWSGROUP, HEADERS, and optional
 106 LAST-FILE."
 107   :group 'article
 108   :type 'function)
 109
 110 (defcustom gnus-split-methods
 111   '((gnus-article-archive-name))
 112   "Variable used to suggest where articles are to be saved.
 113 For instance, if you would like to save articles related to Gnus in
 114 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
 115 you could set this variable to something like:
 116
 117  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
 118    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
 119
 120 This variable is an alist where the where the key is the match and the
 121 value is a list of possible files to save in if the match is non-nil.
 122
 123 If the match is a string, it is used as a regexp match on the
 124 article.  If the match is a symbol, that symbol will be funcalled
 125 from the buffer of the article to be saved with the newsgroup as the
 126 parameter.  If it is a list, it will be evaled in the same buffer.
 127
 128 If this form or function returns a string, this string will be used as
 129 a possible file name; and if it returns a non-nil list, that list will
 130 be used as possible file names."
 131   :group 'article
 132   :type '(repeat (choice (list function)
 133                          (cons regexp (repeat string))
 134                          sexp)))
 135
 136 (defcustom gnus-strict-mime t
 137   "*If nil, MIME-decode even if there is no Mime-Version header."
 138   :group 'article
 139   :type 'boolean)
 140
 141 (defcustom gnus-show-mime-method 'metamail-buffer
 142   "Function to process a MIME message.
 143 The function is called from the article buffer."
 144   :group 'article
 145   :type 'function)
 146
 147 (defcustom gnus-decode-encoded-word-method (lambda ())
 148   "*Function to decode a MIME encoded-words.
 149 The function is called from the article buffer."
 150   :group 'article
 151   :type 'function)
 152
 153 (defcustom gnus-page-delimiter "^\^L"
 154   "*Regexp describing what to use as article page delimiters.
 155 The default value is \"^\^L\", which is a form linefeed at the
 156 beginning of a line."
 157   :type 'regexp
 158   :group 'article)
 159
 160 (defcustom gnus-article-mode-line-format "Gnus: %%b %S"
 161   "*The format specification for the article mode line.
 162 See `gnus-summary-mode-line-format' for a closer description."
 163   :type 'string
 164   :group 'article)
 165
 166 (defcustom gnus-article-mode-hook nil
 167   "*A hook for Gnus article mode."
 168   :type 'hook
 169   :group 'article)
 170
 171 (defcustom gnus-article-menu-hook nil
 172   "*Hook run after the creation of the article mode menu."
 173   :type 'hook
 174   :group 'article)
 175
 176 (defcustom gnus-article-prepare-hook nil
 177   "*A hook called after an article has been prepared in the article buffer.
 178 If you want to run a special decoding program like nkf, use this hook."
 179   :type 'hook
 180   :group 'article)
 181
 182 (defcustom gnus-article-button-face 'bold
 183   "Face used for highlighting buttons in the article buffer.
 184
 185 An article button is a piece of text that you can activate by pressing
 186 `RET' or `mouse-2' above it."
 187   :type 'face
 188   :group 'article)
 189
 190 (defcustom gnus-article-mouse-face 'highlight
 191   "Face used for mouse highlighting in the article buffer.
 192
 193 Article buttons will be displayed in this face when the cursor is
 194 above them."
 195   :type 'face
 196   :group 'article)
 197
 198 (defcustom gnus-signature-face 'italic
 199   "Face used for highlighting a signature in the article buffer."
 200   :type 'face
 201   :group 'article)
 202
 203 (defface gnus-header-from-face
 204   '((((class color)
 205       (background dark))
 206      (:foreground "light blue" :bold t :italic t))
 207     (((class color)
 208       (background light))
 209      (:foreground "MidnightBlue" :bold t :italic t))
 210     (t
 211      (:bold t :italic t)))
 212   "Face used for displaying from headers."
 213   :group 'article)
 214
 215 (defface gnus-header-subject-face
 216   '((((class color)
 217       (background dark))
 218      (:foreground "pink" :bold t :italic t))
 219     (((class color)
 220       (background light))
 221      (:foreground "firebrick" :bold t :italic t))
 222     (t
 223      (:bold t :italic t)))
 224   "Face used for displaying subject headers."
 225   :group 'article)
 226
 227 (defface gnus-header-newsgroups-face
 228   '((((class color)
 229       (background dark))
 230      (:foreground "yellow" :bold t :italic t))
 231     (((class color)
 232       (background light))
 233      (:foreground "indianred" :bold t :italic t))
 234     (t
 235      (:bold t :italic t)))
 236   "Face used for displaying newsgroups headers."
 237   :group 'article)
 238
 239 (defface gnus-header-name-face
 240   '((((class color)
 241       (background dark))
 242      (:foreground "cyan" :bold t))
 243     (((class color)
 244       (background light))
 245      (:foreground "DarkGreen" :bold t))
 246     (t
 247      (:bold t)))
 248   "Face used for displaying header names."
 249   :group 'article)
 250
 251 (defface gnus-header-content-face
 252   '((((class color)
 253       (background dark))
 254      (:foreground "forest green" :italic t))
 255     (((class color)
 256       (background light))
 257      (:foreground "DarkGreen" :italic t))
 258     (t
 259      (:italic t)))  "Face used for displaying header content."
 260   :group 'article)
 261
 262 (defcustom gnus-header-face-alist
 263   '(("From" nil gnus-header-from-face)
 264     ("Subejct" nil gnus-header-subject-face)
 265     ("Newsgroups:.*," nil gnus-header-newsgroups-face)
 266     ("" gnus-header-name-face gnus-header-content-face))
 267   "Controls highlighting of article header.
 268
 269 An alist of the form (HEADER NAME CONTENT).
 270
 271 HEADER is a regular expression which should match the name of an
 272 header header and NAME and CONTENT are either face names or nil.
 273
 274 The name of each header field will be displayed using the face
 275 specified by the first element in the list where HEADER match the
 276 header name and NAME is non-nil.  Similarly, the content will be
 277 displayed by the first non-nil matching CONTENT face."
 278   :group 'article
 279   :type '(repeat (list (regexp :tag "Header")
 280                        (choice :tag "Name"
 281                                (item :tag "skip" nil)
 282                                (face :value default))
 283                        (choice :tag "Content"
 284                                (item :tag "skip" nil)
 285                                (face :value default)))))
 286
 287 ;;; Internal variables
 288
 289 (defvar gnus-article-mode-line-format-alist
 290     (nconc '((?w (gnus-article-wash-status) ?s))
 291            gnus-summary-mode-line-format-alist))
 292
 293 (defvar gnus-number-of-articles-to-be-saved nil)
 294
 295 ;;; Provide a mapping from `gnus-*' commands to Article commands.
 296
 297 (eval-and-compile
 298   (mapcar
 299    (lambda (func)
 300      (let (afunc gfunc)
 301        (if (consp func)
 302            (setq afunc (car func)
 303                  gfunc (cdr func))
 304          (setq afunc func
 305                gfunc (intern (format "gnus-%s" func))))
 306        (fset gfunc
 307              `(lambda (&optional interactive &rest args)
 308                 ,(documentation afunc t)
 309                 (interactive (list t))
 310                 (save-excursion
 311                   (set-buffer gnus-article-buffer)
 312                   (if interactive
 313                       (call-interactively ',afunc)
 314                     (apply ',afunc args)))))))
 315    '(article-hide-headers
 316      article-hide-boring-headers
 317      article-treat-overstrike
 318      (article-fill . gnus-article-word-wrap)
 319      article-remove-cr
 320      article-display-x-face
 321      article-de-quoted-unreadable
 322      article-mime-decode-quoted-printable
 323      article-hide-pgp
 324      article-hide-pem
 325      article-hide-signature
 326      article-remove-trailing-blank-lines
 327      article-strip-leading-blank-lines
 328      article-strip-multiple-blank-lines
 329      article-strip-blank-lines
 330      article-date-local
 331      article-date-original
 332      article-date-lapsed
 333      article-emphasize
 334      (article-show-all . gnus-article-show-all-headers))))
 335
 336 (defalias 'gnus-decode-rfc1522 'article-decode-rfc1522)
 337
 338 ;;; Saving functions.
 339
 340 (defun gnus-article-save (save-buffer file &optional num)
 341   "Save the currently selected article."
 342   (unless gnus-save-all-headers
 343     ;; Remove headers according to `gnus-saved-headers'.
 344     (let ((gnus-visible-headers
 345            (or gnus-saved-headers gnus-visible-headers))
 346           (gnus-article-buffer save-buffer))
 347       (gnus-article-hide-headers 1 t)))
 348   (save-window-excursion
 349     (if (not gnus-default-article-saver)
 350         (error "No default saver is defined.")
 351       ;; !!! Magic!  The saving functions all save
 352       ;; `gnus-original-article-buffer' (or so they think),
 353       ;; but we bind that variable to our save-buffer.
 354       (set-buffer gnus-article-buffer)
 355       (let* ((gnus-original-article-buffer save-buffer)
 356              (filename
 357               (cond
 358                ((not gnus-prompt-before-saving)
 359                 'default)
 360                ((eq gnus-prompt-before-saving 'always)
 361                 nil)
 362                (t file)))
 363              (gnus-number-of-articles-to-be-saved
 364               (when (eq gnus-prompt-before-saving t) num))) ; Magic
 365         (set-buffer gnus-summary-buffer)
 366         (funcall gnus-default-article-saver filename)))))
 367
 368 (defun gnus-read-save-file-name (prompt default-name &optional filename)
 369   (cond
 370    ((eq filename 'default)
 371     default-name)
 372    (filename filename)
 373    (t
 374     (let* ((split-name (gnus-get-split-value gnus-split-methods))
 375            (prompt
 376             (format prompt (if (and gnus-number-of-articles-to-be-saved
 377                                     (> gnus-number-of-articles-to-be-saved 1))
 378                                (format "these %d articles"
 379                                        gnus-number-of-articles-to-be-saved)
 380                              "this article")))
 381            (file
 382             ;; Let the split methods have their say.
 383             (cond
 384              ;; No split name was found.
 385              ((null split-name)
 386               (read-file-name
 387                (concat prompt " (default "
 388                        (file-name-nondirectory default-name) ") ")
 389                (file-name-directory default-name)
 390                default-name))
 391              ;; A single split name was found
 392              ((= 1 (length split-name))
 393               (let* ((name (car split-name))
 394                      (dir (cond ((file-directory-p name)
 395                                  (file-name-as-directory name))
 396                                 ((file-exists-p name) name)
 397                                 (t gnus-article-save-directory))))
 398                 (read-file-name
 399                  (concat prompt " (default " name ") ")
 400                  dir name)))
 401              ;; A list of splits was found.
 402              (t
 403               (setq split-name (nreverse split-name))
 404               (let (result)
 405                 (let ((file-name-history (nconc split-name file-name-history)))
 406                   (setq result
 407                         (read-file-name
 408                          (concat prompt " (`M-p' for defaults) ")
 409                          gnus-article-save-directory
 410                          (car split-name))))
 411                 (car (push result file-name-history)))))))
 412       ;; Create the directory.
 413       (gnus-make-directory (file-name-directory file))
 414       ;; If we have read a directory, we append the default file name.
 415       (when (file-directory-p file)
 416         (setq file (concat (file-name-as-directory file)
 417                            (file-name-nondirectory default-name))))
 418       ;; Possibly translate some characters.
 419       (nnheader-translate-file-chars file)))))
 420
 421 (defun gnus-article-archive-name (group)
 422   "Return the first instance of an \"Archive-name\" in the current buffer."
 423   (let ((case-fold-search t))
 424     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
 425       (nnheader-concat gnus-article-save-directory
 426                        (match-string 1)))))
 427
 428 (defun gnus-summary-save-in-rmail (&optional filename)
 429   "Append this article to Rmail file.
 430 Optional argument FILENAME specifies file name.
 431 Directory to save to is default to `gnus-article-save-directory'."
 432   (interactive)
 433   (gnus-set-global-variables)
 434   (let ((default-name
 435           (funcall gnus-rmail-save-name gnus-newsgroup-name
 436                    gnus-current-headers gnus-newsgroup-last-rmail)))
 437     (setq filename (gnus-read-save-file-name
 438                     "Save %s in rmail file:" default-name filename))
 439     (gnus-make-directory (file-name-directory filename))
 440     (gnus-eval-in-buffer-window gnus-original-article-buffer
 441       (save-excursion
 442         (save-restriction
 443           (widen)
 444           (gnus-output-to-rmail filename))))
 445     ;; Remember the directory name to save articles
 446     (setq gnus-newsgroup-last-rmail filename)))
 447
 448 (defun gnus-summary-save-in-mail (&optional filename)
 449   "Append this article to Unix mail file.
 450 Optional argument FILENAME specifies file name.
 451 Directory to save to is default to `gnus-article-save-directory'."
 452   (interactive)
 453   (gnus-set-global-variables)
 454   (let ((default-name
 455           (funcall gnus-mail-save-name gnus-newsgroup-name
 456                    gnus-current-headers gnus-newsgroup-last-mail)))
 457     (setq filename (gnus-read-save-file-name
 458                     "Save %s in Unix mail file:" default-name filename))
 459     (setq filename
 460           (expand-file-name filename
 461                             (and default-name
 462                                  (file-name-directory default-name))))
 463     (gnus-make-directory (file-name-directory filename))
 464     (gnus-eval-in-buffer-window gnus-original-article-buffer
 465       (save-excursion
 466         (save-restriction
 467           (widen)
 468           (if (and (file-readable-p filename) (mail-file-babyl-p filename))
 469               (gnus-output-to-rmail filename)
 470             (let ((mail-use-rfc822 t))
 471               (rmail-output filename 1 t t))))))
 472     ;; Remember the directory name to save articles.
 473     (setq gnus-newsgroup-last-mail filename)))
 474
 475 (defun gnus-summary-save-in-file (&optional filename)
 476   "Append this article to file.
 477 Optional argument FILENAME specifies file name.
 478 Directory to save to is default to `gnus-article-save-directory'."
 479   (interactive)
 480   (gnus-set-global-variables)
 481   (let ((default-name
 482           (funcall gnus-file-save-name gnus-newsgroup-name
 483                    gnus-current-headers gnus-newsgroup-last-file)))
 484     (setq filename (gnus-read-save-file-name
 485                     "Save %s in file:" default-name filename))
 486     (gnus-make-directory (file-name-directory filename))
 487     (gnus-eval-in-buffer-window gnus-original-article-buffer
 488       (save-excursion
 489         (save-restriction
 490           (widen)
 491           (gnus-output-to-file filename))))
 492     ;; Remember the directory name to save articles.
 493     (setq gnus-newsgroup-last-file filename)))
 494
 495 (defun gnus-summary-save-body-in-file (&optional filename)
 496   "Append this article body to a file.
 497 Optional argument FILENAME specifies file name.
 498 The directory to save in defaults to `gnus-article-save-directory'."
 499   (interactive)
 500   (gnus-set-global-variables)
 501   (let ((default-name
 502           (funcall gnus-file-save-name gnus-newsgroup-name
 503                    gnus-current-headers gnus-newsgroup-last-file)))
 504     (setq filename (gnus-read-save-file-name
 505                     "Save %s body in file:" default-name filename))
 506     (gnus-make-directory (file-name-directory filename))
 507     (gnus-eval-in-buffer-window gnus-original-article-buffer