git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-vm.el

   1 ;;; gnus-vm.el --- vm interface for Gnus
   2 ;; Copyright (C) 1994,95,96,97,98,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Per Persson <pp@gnu.ai.mit.edu>
   5 ;;         Katsumi Yamaoka <yamaoka@jpl.org>
   6 ;; Keywords: news, mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Major contributors:
  28 ;;      Christian Limpach <Christian.Limpach@nice.ch>
  29 ;; Some code stolen from:
  30 ;;      Rick Sladkey <jrs@world.std.com>
  31
  32 ;;; Code:
  33
  34 (eval-when-compile (require 'cl))
  35
  36 (require 'gnus-art)
  37
  38 (eval-when-compile
  39   (autoload 'vm-mode "vm")
  40   (autoload 'vm-read-file-name "vm")
  41   (autoload 'vm-save-message "vm"))
  42
  43 (when (not (featurep 'vm))
  44   (load "vm"))
  45
  46 (defvar vm-folder-directory)
  47 (defvar vm-folder-history)
  48 (defvar vm-primary-inbox)
  49 (defvar vm-use-toolbar)
  50
  51 (defun gnus-vm-make-folder (&optional buffer)
  52   (let ((article (or buffer (current-buffer)))
  53         (tmp-folder (generate-new-buffer " *tmp-folder*"))
  54         (start (point-min))
  55         (end (point-max)))
  56     (set-buffer tmp-folder)
  57     (insert-buffer-substring article start end)
  58     (goto-char (point-min))
  59     (if (looking-at "^\\(From [^ ]+ \\).*$")
  60         (replace-match (concat "\\1" (current-time-string)))
  61       (insert "From " gnus-newsgroup-name " "
  62               (current-time-string) "\n"))
  63     (while (re-search-forward "\n\nFrom " nil t)
  64       (replace-match "\n\n>From "))
  65     ;; insert a newline, otherwise the last line gets lost
  66     (goto-char (point-max))
  67     (insert "\n")
  68     (let (mime-display-header-hook
  69           mime-display-text/plain-hook mime-text-decode-hook
  70           mime-view-define-keymap-hook mime-view-mode-hook)
  71       (vm-mode))
  72     tmp-folder))
  73
  74 (defvar gnus-summary-save-article-vm-folder nil)
  75 (defvar gnus-summary-save-article-vm-count nil)
  76
  77 (defun gnus-summary-save-article-vm (&optional arg folder)
  78   "Append the current article to a vm folder.
  79 If N is a positive number, save the N next articles.
  80 If N is a negative number, save the N previous articles.
  81 If N is nil and any articles have been marked with the process mark,
  82 save those articles instead."
  83   (interactive
  84    (let ((prefix-arg current-prefix-arg)
  85          articles marks default-folder)
  86      (setq default-folder (or (car vm-folder-history) vm-primary-inbox))
  87      (if (numberp prefix-arg)
  88          (setq articles prefix-arg)
  89        (setq marks (delq nil (gnus-summary-work-articles nil))
  90              articles (length marks)))
  91      (list
  92       prefix-arg
  93       (unless (zerop articles)
  94         (vm-read-file-name
  95          (format
  96           "Save %s in VM folder: "
  97           (cond ((eq 1 articles)
  98                  (if (or (not marks) (eq gnus-current-article (car marks)))
  99                      "this article"
 100                    "the marked article"))
 101                 ((< 0 articles)
 102                  (if marks
 103                      (format "the marked %d articles" articles)
 104                    (format "the %d next articles" articles)))
 105                 ((> 0 articles)
 106                  (format "the %d previous articles" (- articles)))))
 107          (if default-folder "" vm-folder-directory)
 108          nil nil default-folder 'vm-folder-history)))))
 109   (if (interactive-p)
 110       (unless folder
 111         (error "No articles to be saved"))
 112     (unless (setq folder (or folder gnus-summary-save-article-vm-folder))
 113       (error "No VM folder is specified")))
 114   (unwind-protect
 115       (progn
 116         (setq gnus-summary-save-article-vm-folder folder
 117               gnus-summary-save-article-vm-count 0)
 118         (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)
 119               mime-display-header-hook mime-display-text/plain-hook
 120               mime-text-decode-hook mime-view-define-keymap-hook
 121               mime-view-mode-hook)
 122           (gnus-summary-save-article arg))
 123         (cond ((eq 1 gnus-summary-save-article-vm-count)
 124                (message "One article is saved in %s" folder))
 125               ((< 0 gnus-summary-save-article-vm-count)
 126                (message "%d articles are saved in %s"
 127                         gnus-summary-save-article-vm-count folder))
 128               (t
 129                (message "Maybe no articles are saved in %s" folder))))
 130     (setq gnus-summary-save-article-vm-folder nil
 131           gnus-summary-save-article-vm-count nil)))
 132
 133 (defun gnus-summary-save-in-vm (&optional folder)
 134   (interactive
 135    (let (default-folder)
 136      (setq default-folder (or (car vm-folder-history) vm-primary-inbox))
 137      (list (vm-read-file-name "Save this article in VM folder: "
 138                               (if default-folder "" vm-folder-directory)
 139                               nil nil default-folder 'vm-folder-history))))
 140   (unless (interactive-p)
 141     (setq folder (or folder gnus-summary-save-article-vm-folder)))
 142   (unless folder
 143     (error "No VM folder is specified"))
 144   (unless (interactive-p)
 145     (message "Saving the article %d in %s..." gnus-current-article folder)
 146     (when (numberp gnus-summary-save-article-vm-count)
 147       (incf gnus-summary-save-article-vm-count)))
 148   (save-window-excursion
 149     (apply 'gnus-summary-select-article gnus-show-all-headers
 150            (unless (interactive-p)
 151              (list nil nil gnus-current-article)))
 152     (gnus-eval-in-buffer-window gnus-original-article-buffer
 153       (save-excursion
 154         (save-restriction
 155           (widen)
 156           (let* ((vm-use-toolbar nil)
 157                  (vm-folder (gnus-vm-make-folder)))
 158             (vm-save-message folder)
 159             (when (interactive-p)
 160               (message "This article is saved in %s" folder))
 161             (kill-buffer vm-folder)))))))
 162
 163 (provide 'gnus-vm)
 164
 165 ;;; gnus-vm.el ends here.