(gnus-summary-save-in-vm): To read the name of FOLDER in the way of VM; give
[elisp/gnus.git-] / 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 (require 'gnus-art)
35
36 (eval-when-compile
37   (require 'cl)
38   (autoload 'vm-mode "vm")
39   (autoload 'vm-save-message "vm"))
40
41 (when (not (featurep 'vm))
42   (load "vm"))
43
44 (defvar vm-folder-directory)
45 (defvar vm-folder-history)
46 (defvar vm-primary-inbox)
47 (defvar vm-use-toolbar)
48   
49 (defun gnus-vm-make-folder (&optional buffer)
50   (let ((article (or buffer (current-buffer)))
51         (tmp-folder (generate-new-buffer " *tmp-folder*"))
52         (start (point-min))
53         (end (point-max)))
54     (set-buffer tmp-folder)
55     (insert-buffer-substring article start end)
56     (goto-char (point-min))
57     (if (looking-at "^\\(From [^ ]+ \\).*$")
58         (replace-match (concat "\\1" (current-time-string)))
59       (insert "From " gnus-newsgroup-name " "
60               (current-time-string) "\n"))
61     (while (re-search-forward "\n\nFrom " nil t)
62       (replace-match "\n\n>From "))
63     ;; insert a newline, otherwise the last line gets lost
64     (goto-char (point-max))
65     (insert "\n")
66     (let (mime-display-header-hook
67           mime-display-text/plain-hook mime-text-decode-hook
68           mime-view-define-keymap-hook mime-view-mode-hook)
69       (vm-mode))
70     tmp-folder))
71
72 (defvar gnus-summary-save-article-vm-folder nil)
73 (defvar gnus-summary-save-article-vm-count nil)
74
75 (defun gnus-summary-save-article-vm (&optional arg folder)
76   "Append the current article to a vm folder.
77 If N is a positive number, save the N next articles.
78 If N is a negative number, save the N previous articles.
79 If N is nil and any articles have been marked with the process mark,
80 save those articles instead."
81   (interactive
82    (let ((prefix-arg current-prefix-arg)
83          articles marks default-folder)
84      (setq default-folder (or (car vm-folder-history) vm-primary-inbox))
85      (if (numberp prefix-arg)
86          (setq articles prefix-arg)
87        (setq marks (delq nil (gnus-summary-work-articles nil))
88              articles (length marks)))
89      (list
90       prefix-arg
91       (unless (zerop articles)
92         (read-file-name
93          (format
94           "Save %s in VM folder: "
95           (cond ((eq 1 articles)
96                  (if (or (not marks) (eq gnus-current-article (car marks)))
97                      "this article"
98                    "the marked article"))
99                 ((< 0 articles)
100                  (if marks
101                      (format "the marked %d articles" articles)
102                    (format "the %d next articles" articles)))
103                 ((> 0 articles)
104                  (format "the %d previous articles" (- articles)))))
105          (if default-folder "" vm-folder-directory)
106          nil nil default-folder 'vm-folder-history)))))
107   (if (interactive-p)
108       (unless folder
109         (error "No articles to be saved"))
110     (unless (setq folder (or folder gnus-summary-save-article-vm-folder))
111       (error "No VM folder is specified")))
112   (unwind-protect
113       (progn
114         (setq gnus-summary-save-article-vm-folder folder
115               gnus-summary-save-article-vm-count 0)
116         (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)
117               mime-display-header-hook mime-display-text/plain-hook
118               mime-text-decode-hook mime-view-define-keymap-hook
119               mime-view-mode-hook)
120           (gnus-summary-save-article arg))
121         (cond ((eq 1 gnus-summary-save-article-vm-count)
122                (message "One article is saved in %s" folder))
123               ((< 0 gnus-summary-save-article-vm-count)
124                (message "%d articles are saved in %s"
125                         gnus-summary-save-article-vm-count folder))
126               (t
127                (message "Maybe no articles are saved in %s" folder))))
128     (setq gnus-summary-save-article-vm-folder nil
129           gnus-summary-save-article-vm-count nil)))
130
131 (defun gnus-summary-save-in-vm (&optional folder)
132   (interactive
133    (let (default-folder)
134      (setq default-folder (or (car vm-folder-history) vm-primary-inbox))
135      (list (read-file-name "Save this article in VM folder: "
136                            (if default-folder "" vm-folder-directory)
137                            nil nil default-folder 'vm-folder-history))))
138   (unless (interactive-p)
139     (setq folder (or folder gnus-summary-save-article-vm-folder)))
140   (unless folder
141     (error "No VM folder is specified"))
142   (unless (interactive-p)
143     (message "Saving the article %d in %s..." gnus-current-article folder)
144     (when (numberp gnus-summary-save-article-vm-count)
145       (incf gnus-summary-save-article-vm-count)))
146   (save-window-excursion
147     (apply 'gnus-summary-select-article gnus-show-all-headers
148            (unless (interactive-p)
149              (list nil nil gnus-current-article)))
150     (gnus-eval-in-buffer-window gnus-original-article-buffer
151       (save-excursion
152         (save-restriction
153           (widen)
154           (let* ((vm-use-toolbar nil)
155                  (vm-folder (gnus-vm-make-folder)))
156             (vm-save-message folder)
157             (when (interactive-p)
158               (message "This article is saved in %s" folder))
159             (kill-buffer vm-folder)))))))
160
161 (provide 'gnus-vm)
162
163 ;;; gnus-vm.el ends here.