home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / gnus-mark.el < prev    next >
Encoding:
Text File  |  1994-09-20  |  22.3 KB  |  590 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; gnus-mark.el v1.6
  4. ;;; Operating on more than one news article at a time.
  5. ;;; Created:  28-Jun-91 by Jamie Zawinski <jwz@lucid.com>
  6. ;;; Modified: 28-Jun-91 by Sebastian Kremer <sk@thp.Uni-Koeln.DE>
  7. ;;; Modified: 01-Dec-91 by Jamie Zawinski <jwz@lucid.com>
  8. ;;; Modified: 05-Dec-91 by Paul D. Smith <paul_smith@dg.com>
  9. ;;; Modified: 28-Nov-92 by A1C Tim Miller <tjm@hrt213.brooks.af.mil>
  10. ;;; Modified: 10-Jun-93 by Vivek Khera <khera@cs.duke.edu> (GNUS 3.15 fixes)
  11. ;;; Modified: 15-Sep-93 by Jamie Zawinski <jwz@lucid.com> (article saving)
  12. ;;;
  13. ;;; typing `@' in the subject buffer will mark the current article with
  14. ;;; an `@'.  After marking more than one article this way, you can use one
  15. ;;; of the commands in this file on all of them at once.
  16. ;;;
  17. ;;; `M-@' will prompt you for a regular expression, and will mark all f
  18. ;;; articles which match.
  19. ;;;
  20. ;;; `^U@' will prompt you for a mark-character to use other than `@'.
  21. ;;;
  22. ;;; To unmark an article, use `u', `d', or `^U M-@ SPC RET'.
  23. ;;;
  24. ;;; `F' (gnus-forward-marked-articles) will put you in a send-mail buffer 
  25. ;;; along with the contents of all of the marked articles in RFC-944 digest
  26. ;;; format, suitable for later explosion with any reasonable mail reader.
  27. ;;;
  28. ;;; `M-x gnus-uudecode-marked-messages' (M-x gnus-uu RET works) will strip the
  29. ;;; junk from the beginning and end of the marked articles, concatenate them
  30. ;;; together, and pipe the result through uudecode.  If the resultant file is
  31. ;;; a tar file and/or is compressed, this command offers to unpack/uncompress
  32. ;;; as well.  See also the variables gnus-uudecode-file-mode, 
  33. ;;; gnus-uudecode-auto-chmod, and gnus-uudecode-auto-touch.  If the first
  34. ;;; marked message is not the first part of the uuencoded file, or if the last
  35. ;;; marked message is not the last part of the uuencoded file, it complains.
  36. ;;; However, it's not possible to tell if the middle parts are out of order,
  37. ;;; so make sure you use ^C^S^S to get the articles in the right order first.
  38. ;;; It also complains about obviously-corrupted files.
  39. ;;;
  40. ;;; `M-x gnus-unshar-marked-articles' (M-x gnus-un RET works) will strip the 
  41. ;;; junk from the beginning and end of the marked articles, and run each of
  42. ;;; them through sh in turn.  This doesn't work on shar files that don't 
  43. ;;; begin with "#!".
  44. ;;;
  45. ;;; Both of the above commands prompt you for a directory in which to do the
  46. ;;; dirty work.  If the directory you specify doesn't exist, you have the
  47. ;;; option of creating it.
  48. ;;;
  49. ;;; `C-o' and `o' (`gnus-summary-save-in-mail' and `gnus-summary-save-article')
  50. ;;; will operate on the marked articles, assuming you are using one of the 
  51. ;;; standard functions for `gnus-default-article-saver', those being
  52. ;;; `gnus-summary-save-in-rmail', `gnus-summary-save-in-mail',
  53. ;;; `gnus-summary-save-in-folder', and `gnus-summary-save-in-file'.  If you 
  54. ;;; use a different function here, it should be pretty obvious from reading
  55. ;;; the code how to convert it to operate on the marked articles.
  56. ;;;
  57. ;;; When saving articles, the variable `gnus-save-marked-in-same-file' controls
  58. ;;; whether to prompt for the file/folder intowhich each article should be 
  59. ;;; written.  If t, you will be asked where to save them once, and all 
  60. ;;; messages will be saved to the same place.  If nil, you will be prompted
  61. ;;; for each article.
  62. ;;
  63. ;; LCD Archive Entry:
  64. ;; gnus-mark|Jamie Zawinski|jwz@lucid.com
  65. ;; |Operate on more than one news article at a time
  66. ;; |93-09-15|1.6|~/misc/gnus-mark.el.Z|
  67.  
  68. (require 'gnus)
  69.  
  70. (define-key gnus-summary-mode-map "@" 'gnus-summary-mark-article)
  71. (define-key gnus-summary-mode-map "\M-@" 'gnus-summary-mark-regexp)
  72.  
  73. (substitute-key-definition 'gnus-summary-mail-forward
  74.                'gnus-forward-marked-articles
  75.                gnus-summary-mode-map)
  76. ;(define-key gnus-summary-mode-map "\C-F" 'gnus-forward-marked-articles)
  77.  
  78. ;;; See also gnus-uudecode-marked-messages and gnus-unshar-marked-articles.
  79.  
  80. (defvar gnus-default-mark-char ?@
  81.   "*Character used to mark articles for later commands in GNUS.")
  82.  
  83. (defun gnus-summary-mark-article (mark)
  84. "Mark the current article for later commands.
  85. This marker comes from variable `gnus-default-mark-char'.
  86. You can change this variable by giving a prefix argument to this command,
  87. in which case you will be prompted for the character to use."
  88.   (interactive (list (if current-prefix-arg
  89.              (let ((cursor-in-echo-area t))
  90.                (message "Mark message with: ")
  91.                (setq gnus-default-mark-char (read-char)))
  92.              gnus-default-mark-char)))
  93.   (or (eq (current-buffer) (get-buffer gnus-summary-buffer))
  94.       (error "not in summary buffer"))
  95.   (gnus-summary-mark-as-read nil gnus-default-mark-char)
  96.   (gnus-summary-next-subject 1 nil))
  97.  
  98. ;; Actually, gnus-kill should have an interactive spec!
  99. (defun gnus-summary-mark-regexp (regexp &optional marker)
  100.   "Mark all articles with subjects matching REGEXP.
  101. With a prefix ARG, prompt for the marker.  Type RET immediately to
  102. mark them as unread or enter SPC RET to remove all kinds of marks."
  103.   (interactive
  104.    (list (read-string "Mark (regexp): ")
  105.      (if current-prefix-arg
  106.          (read-string
  107.           "Mark with char (RET to mark as unread, SPC RET to remove existing markers): "))))
  108.   (setq marker (or marker (char-to-string gnus-default-mark-char)))
  109.   (gnus-kill "Subject" regexp
  110.          (if (equal "" marker)
  111.          '(gnus-summary-mark-as-unread)
  112.            (list 'gnus-summary-mark-as-read nil marker))
  113.          ;; overwrite existing marks:
  114.          t))
  115.  
  116. (defun gnus-summary-mark-map-articles (mark function)
  117.   (save-excursion
  118.     (set-buffer gnus-summary-buffer)
  119.     (let ((str (concat "^"
  120.                (regexp-quote (make-string 1 mark))
  121.                "[^-0-9]*\\([-0-9]+\\):"))
  122.       got-one)
  123.       (save-excursion
  124.     (goto-char (point-min))
  125.     (while (not (eobp))
  126.       (if (looking-at str)
  127.           (progn
  128.         (setq got-one t)
  129.         (save-excursion
  130.           (funcall function
  131.             (gnus-find-header-by-number gnus-newsgroup-headers 
  132.               (string-to-int
  133.             (buffer-substring
  134.               (match-beginning 1) (match-end 1))))))))
  135.       (forward-line 1)))
  136.       (cond ((not got-one)
  137.          (let ((article (gnus-summary-article-number)))
  138.            (if (or (null gnus-current-article)
  139.                (/= article gnus-current-article))
  140.            ;; Selected subject is different from current article's.
  141.            (gnus-summary-display-article article))
  142.            (funcall function 
  143.             (gnus-find-header-by-number gnus-newsgroup-headers 
  144.                             article)))))
  145.       )))
  146.  
  147.  
  148. ;;; simpler, more specific to gnus-mark version of shell-command
  149.  
  150. (defun gnus-mark-shell-command (start end command erase)
  151.   "Execute string COMMAND in inferior shell with region as input.
  152. Display output (if any) in temp buffer interactively.
  153. If ERASE is non-nil the buffer is erased, otherwise the output is
  154. appended to the end of the buffer."
  155.     (let ((buffer (get-buffer-create "*Shell Command Output*"))
  156.       (orig-buffer (current-buffer)))
  157.       (set-buffer buffer)
  158.       (if erase
  159.       (erase-buffer)
  160.     (goto-char (point-max)))
  161.       (set-buffer orig-buffer)
  162.       (if (eq buffer orig-buffer)
  163.       (setq start 1 end 1))
  164.       (display-buffer buffer)
  165.       (bury-buffer buffer)
  166.       (call-process-region start end shell-file-name
  167.                nil buffer t "-c" command)))
  168.  
  169.  
  170. ;;; RFC944 forwarding of multiple messages
  171.  
  172. (defun gnus-forward-marked-articles ()
  173.   "Forward the marked messages to another user, RFC944 style."
  174.   (interactive)
  175.   (let (subj p
  176.     (state 'first)
  177.     tmp-buf)
  178.     (unwind-protect
  179.     (progn
  180.       (setq tmp-buf (get-buffer-create "*gnus-forward-tmp*"))
  181.       (save-excursion (set-buffer tmp-buf) (erase-buffer))
  182.       (gnus-summary-mark-map-articles
  183.        gnus-default-mark-char
  184.        (function (lambda (msg)
  185.          (if (eq state 'first) (setq state t) (setq state nil))
  186.          (message "Snarfing article %s..." (aref msg 0))
  187.          (if (eq gnus-current-article (aref msg 0))
  188.          (gnus-summary-mark-as-read)
  189.            (gnus-summary-display-article (aref msg 0)))
  190.          (set-buffer gnus-article-buffer)
  191.          (widen)
  192.          (set-buffer tmp-buf)
  193.          (goto-char (point-max))
  194.          (if subj
  195.          (insert "----------\n")
  196.            (setq subj (aref msg 1)))
  197.          (setq p (point))
  198.          (insert-buffer gnus-article-buffer)
  199.          (goto-char p)
  200.          (while (re-search-forward "^-" nil t)
  201.            (insert " -"))
  202.          )))
  203.       (mail nil nil (concat "[Fwd: " subj "]"))
  204.       (save-excursion
  205.         (goto-char (point-max))
  206.         (insert (if state
  207.             "---------- Begin forwarded message\n"
  208.               "---------- Begin digest\n"))
  209.         (insert-buffer tmp-buf)
  210.         (goto-char (point-max))
  211.         (insert (if state
  212.             "\n---------- End forwarded message\n"
  213.               "\n---------- End digest\n"))))
  214.       ;; protected
  215.       (and tmp-buf (kill-buffer tmp-buf)))))
  216.  
  217.  
  218. ;;; reading a directory name, and offering to create if it doesn't exist.
  219.  
  220. (defun gnus-mark-read-directory (prompt &optional default-dir)
  221.   (let ((dir
  222.      (read-file-name prompt
  223.              (or default-dir default-directory)
  224.              (or default-dir default-directory))))
  225.     (if (string-match "/$" dir)
  226.     (setq dir (substring dir 0 (match-beginning 0))))
  227.     (setq dir
  228.       (cond ((file-directory-p dir) dir)
  229.         ((file-exists-p dir)
  230.          (ding)
  231.          (message "%s exists and is not a directory!" dir)
  232.          (sleep-for 2)
  233.          (gnus-mark-read-directory prompt dir))
  234.         ((y-or-n-p (format "directory %s doesn't exist, create it? " dir))
  235.          (make-directory dir)
  236.          dir)
  237.         (t (gnus-mark-read-directory prompt dir))))
  238.     (if (string-match "/$" dir)
  239.     dir
  240.       (concat dir "/"))))
  241.  
  242.  
  243. ;;; uudecode
  244.  
  245. (defconst gnus-uudecode-begin-pattern
  246.     "^begin[ \t]+\\([0-9][0-9][0-9][0-9]?\\)[ \t]+\\([^ \t\n]*\\)$")
  247.  
  248. (defconst gnus-uudecode-body-pattern
  249.     "^M.............................................................?$")
  250.  
  251. (defconst gnus-uudecode-begin-or-body-pattern
  252.     (concat "\\(" gnus-uudecode-begin-pattern "\\|"
  253.         gnus-uudecode-body-pattern "\\)"))
  254.  
  255. (defvar gnus-uudecode-file-mode "644"
  256.   "*If non-nil, this overrides the mode specified in the `begin' line of
  257. a uuencoded file being unpacked by vm-uudecode.  This should be a string,
  258. which is the mode desired in octal.")
  259.  
  260. (defvar gnus-uudecode-auto-chmod "u+w"
  261.   "*If non-nil, then when gnus is untarring a file for you, it will
  262. apply this chmod modifier to each of the unpacked files.  This should be
  263. a string like \"u+w\".")
  264.  
  265. (defvar gnus-uudecode-auto-touch t
  266.   "*If non-nil, then when vm-uudecode is untarring a file for you, it will
  267. cause the write-date of each of the unpacked files to be the current time.
  268. Normally tar unpacks files with the time at which they are packed; this can
  269. cause your `make' commands to fail if you are installing a new version of
  270. a package which you have modified.")
  271.  
  272. (defvar gnus-uudecode-picture-pattern "\\.\\(gif\\|p[bgp]m\\|rast\\|pic\\|jpg\\|tiff?\\)$"
  273.   "*If non-nil, this should be a pattern which matches files which are 
  274. images.  When gnus-uudecode-marked-articles creates a file which matches
  275. this pattern, it will ask you if you want to look at it now.  If so, it
  276. invokes gnus-uudecode-picture-viewer with the filename as an argument.
  277. After doing this, it asks you if you want to keep the picture or delete it.")
  278.  
  279. (defvar gnus-uudecode-picture-viewer "xv"
  280.   "*The picture viewer that gnus-uudecode-marked-articles uses.  See doc of
  281. variable gnus-uudecode-picture-pattern.")
  282.  
  283. (defvar gnus-uudecode-default-directory nil "*")
  284.  
  285. (defun gnus-uudecode-marked-articles (directory)
  286.   "Strip the junk from the beginning and end of the marked articles, 
  287. concatenate them together, and pipe the result through uudecode.  If
  288. the resultant file is a tar file and/or is compressed, this command
  289. offers to unpack/uncompress as well.  See also the variables
  290. gnus-uudecode-file-mode, gnus-uudecode-auto-chmod, and
  291.  gnus-uudecode-auto-touch."
  292.   (interactive (list (gnus-mark-read-directory "uudecode in directory: "
  293.                gnus-uudecode-default-directory)))
  294.   (setq gnus-uudecode-default-directory directory)
  295.   (let ((state 'first)
  296.     tmp-buf
  297.     name)
  298.     (unwind-protect
  299.       (progn
  300.        (setq tmp-buf  (get-buffer-create "*gnus-uudecode-tmp*"))
  301.        (save-excursion (set-buffer tmp-buf) (erase-buffer))
  302.        (gnus-summary-mark-map-articles
  303.     gnus-default-mark-char
  304.     (function (lambda (msg)
  305.       (message "Snarfing article %s..." (aref msg 0))
  306.       (if (eq state 'last)
  307.           (error "articles out of order: articles follow `end' line."))
  308.       (if (eq gnus-current-article (aref msg 0))
  309.           (gnus-summary-mark-as-read)
  310.         (gnus-summary-display-article (aref msg 0)))
  311.       (set-buffer gnus-article-buffer)
  312.       (widen)
  313.       (set-buffer tmp-buf)
  314.       (goto-char (point-max))
  315.       (let ((p (point))
  316.         (case-fold-search nil))
  317.         (insert-buffer gnus-article-buffer)
  318.         (goto-char p)
  319.         ;; Some MSDOS losers post uuencoded articles with CRLF.
  320.         (while (search-forward "\r\n" nil t)
  321.           (forward-char -1)
  322.           (delete-char -1))
  323.         (goto-char p)
  324.         (cond
  325.          ((eq state 'first)
  326.           (or (re-search-forward gnus-uudecode-begin-pattern nil t)
  327.           (error "couldn't find `begin' line in first article."))
  328.           ;; I'd like to second-guess the losers who use mixed-case
  329.           ;; and upper-case filenames, but this trashes trailing ".Z"
  330.           ;;(downcase-region (match-beginning 2) (match-end 2))
  331.           (setq name (buffer-substring (match-beginning 2) (match-end 2)))
  332.           ;; don't tolerate bogus umasks.
  333.           (if gnus-uudecode-file-mode
  334.           (progn
  335.             (goto-char (match-beginning 1))
  336.             (delete-region (match-beginning 1) (match-end 1))
  337.             (insert gnus-uudecode-file-mode)))
  338.           (setq state 'middle))
  339.          (t
  340.           (or (re-search-forward gnus-uudecode-begin-or-body-pattern nil t)
  341.           (error "couldn't find beginning of data."))))
  342.         (beginning-of-line)
  343.         (delete-region p (point))
  344.         (let (c tmp)
  345.           ;; This could be sped up a lot, but then we'd lose the
  346.           ;; error checking it does; maybe that's ok.
  347.           (while (progn
  348.                (forward-line)
  349.                (setq c (- (following-char) ? ))
  350.                (end-of-line)
  351.                (setq tmp (/ (1- (current-column)) 4))
  352.                (beginning-of-line)
  353.                (= (+ tmp (+ tmp tmp)) c))
  354.         )
  355.           ;; Slack.
  356.           (setq p (point))
  357.           (if (or (looking-at "end\n")
  358.               (progn (forward-line 1) (looking-at "end\n"))
  359.               (progn (forward-line 1) (looking-at "end\n"))
  360.               (progn (forward-line 1) (looking-at "end\n")))
  361.           (progn
  362.             (forward-line 1)
  363.             (setq state 'last))
  364.         (goto-char p))
  365.           )
  366.         (delete-region (point) (point-max))))))
  367.        (or (eq state 'last) (error "no `end' line in last article."))
  368.        (set-buffer tmp-buf)
  369.        (let* ((base-file (file-name-nondirectory name))
  370.           (final-file (concat directory base-file))
  371.           (command (concat "cd " directory " ; uudecode"))
  372.           tar-p)
  373.      (cond ((string-match "\\.tar\\.\\(Z\\|z\\|gz\\)$" base-file)
  374.         (if (y-or-n-p "uncompress/untar? ")
  375.             (setq command (concat command " && zcat "
  376.                       base-file " | tar -vxf -")
  377.               final-file nil
  378.               tar-p t)))
  379.            ((string-match "\\.tar$" base-file)
  380.         (if (y-or-n-p "untar? ")
  381.             (setq command (concat command " && tar -vxf " base-file)
  382.               final-file nil
  383.               tar-p t)))
  384.            ((string-match "\\.\\(Z\\|z\\|gz\\)$" base-file)
  385.         (if (y-or-n-p "uncompress? ")
  386.             (setq command (concat command " ; uncompress " base-file)
  387.               final-file (substring base-file 0
  388.                         (match-beginning 0))))))
  389.      (let ((str (concat "executing \"" command "\" ...")))
  390.        (message str)
  391.        (gnus-mark-shell-command (point-min) (point-max) command t)
  392. ;       (if final-file
  393. ;          (dired-add-entry-all-buffers directory
  394. ;         (file-name-nondirectory final-file)))
  395.        (message (concat str " done.")))
  396.      (cond
  397.       (tar-p
  398.        (set-buffer (get-buffer "*Shell Command Output*"))
  399.        (let ((all (concat command "\n" (buffer-string)))
  400.          files files-str)
  401.          (goto-char (point-min))
  402.          (while (not (eobp))
  403.            (if (looking-at "^x \\([^,\n]+\\), ")
  404.            (setq files (cons (buffer-substring
  405.                       (match-beginning 1) (match-end 1))
  406.                      files)))
  407.            (forward-line 1))
  408.          (setq files (nreverse files)
  409.            files-str (mapconcat 'identity files " "))
  410.          (cond
  411.           (files
  412.            (cond
  413.         (gnus-uudecode-auto-chmod
  414.          (setq command (concat "cd " directory " ; chmod "
  415.                        gnus-uudecode-auto-chmod " " files-str))
  416.          (gnus-mark-shell-command (point) (point) command nil)
  417.          (setq all (concat all "\n" command "\n" (buffer-string)))))
  418.            (cond
  419.         (gnus-uudecode-auto-touch
  420.          (setq command (concat "cd " directory " ; touch " files-str))
  421.          (gnus-mark-shell-command (point) (point) command nil)
  422.          (setq all (concat all "\n" command "\n" (buffer-string)))))
  423.           (goto-char (point-min))
  424.           (insert all "\n")
  425. ;          (mapcar (function (lambda (x)
  426. ;            (dired-add-entry-all-buffers directory x)))
  427. ;              files)
  428.           ))))
  429.       (t
  430.        (message "wrote file %s" final-file)
  431.        (let ((case-fold-search t))
  432.          (cond ((null gnus-uudecode-picture-pattern) nil)
  433.            ((and (string-match gnus-uudecode-picture-pattern
  434.                        final-file)
  435.              (y-or-n-p
  436.                (format "look at the picture in %s? " final-file)))
  437.             (gnus-mark-shell-command (point) (point)
  438.               (if (string-match (regexp-quote directory) final-file)
  439.               (concat "cd " directory " ; "
  440.                                   gnus-uudecode-picture-viewer " "
  441.                   (substring final-file (match-end 0)))
  442.             (concat gnus-uudecode-picture-viewer " " final-file))
  443.               nil)
  444.             (if (y-or-n-p (format "delete file %s? " final-file))
  445.             (progn
  446.               (delete-file final-file)
  447.               (message "%s deleted." final-file))
  448.             )
  449.             (display-buffer "*Article*")))))
  450.       )))
  451.       ;; protected
  452.       (and tmp-buf (kill-buffer tmp-buf)))))
  453.  
  454.  
  455. ;;; shar (ack pffleughhh barf)
  456.  
  457. (defvar gnus-unshar-program "/bin/sh"
  458.   "*The program to use to unshar files; you might want to use something
  459. that is less of a gaping security hole than /bin/sh.")
  460.  
  461. (defvar gnus-unshar-default-directory nil "*")
  462.  
  463. (defun gnus-unshar-marked-articles (directory)
  464.   "For each of the marked articles, strip the junk from the beginning and end
  465. and then run the result through gnus-unshar-program (typically /bin/sh.)"
  466.   (interactive (list (gnus-mark-read-directory
  467.                "unshar in directory: " gnus-unshar-default-directory)))
  468.   (setq gnus-unshar-default-directory directory)
  469.   (let (tmp-buf
  470.     (command (concat "cd " directory " ; " gnus-unshar-program)))
  471.     (unwind-protect
  472.       (progn
  473.        (if (setq tmp-buf (get-buffer "*Shell Command Output*"))
  474.        (save-excursion
  475.          (set-buffer tmp-buf)
  476.          (erase-buffer)))
  477.        (setq tmp-buf (get-buffer-create "*gnus-unshar-tmp*"))
  478.        (gnus-summary-mark-map-articles
  479.     gnus-default-mark-char
  480.     (function (lambda (msg)
  481.       (message "Snarfing article %s..." (aref msg 0))
  482.       (if (eq gnus-current-article (aref msg 0))
  483.           (gnus-summary-mark-as-read)
  484.         (gnus-summary-display-article (aref msg 0)))
  485.       (set-buffer gnus-article-buffer)
  486.       (widen)
  487.       (set-buffer tmp-buf)
  488.       (erase-buffer)
  489.       (insert-buffer gnus-article-buffer)
  490.       (or (re-search-forward "^#!" nil t)
  491.           (re-search-forward "^: This is a shar archive" nil t)
  492.           (re-search-forward "^# This is a shell archive" nil t)
  493.           (re-search-forward "^# type \"sh file -c\"." nil t)
  494.           (re-search-forward "^#!" nil nil)) ; for the error message
  495.       (beginning-of-line)
  496.       (delete-region (point-min) (point))
  497.       (goto-char (point-max))
  498.       ;; what kind of shithead has a signature after a shar file?
  499.       (if (re-search-backward "^--" nil t)
  500.           (delete-region (point) (point-max)))
  501.       (message "unsharing article %s..." (aref msg 0))
  502.       (gnus-mark-shell-command (point-min) (point-max) command nil)
  503.       (message "unsharing article %s...done." (aref msg 0))
  504.       ))))
  505.       ;; protected
  506.       (kill-buffer tmp-buf)
  507. ;      (if (y-or-n-p "Display *Article* buffer? ")
  508. ;      (display-buffer "*Article*"))
  509.       )))
  510.  
  511.  
  512. ;;; This code encapsulates the definitions of the standard gnus-save-in-*
  513. ;;; functions to operate on the marked articles.
  514.  
  515. (defvar gnus-save-marked-in-same-file t
  516.   "*When saving multiple marked articles, whether to prompt each time.
  517. If t, you will be asked where to save them once, and all messages will
  518. be saved there.  If nil, you will be prompted for each article.")
  519.  
  520. (defvar inside-gnus-save-marked-articles-mapper)
  521. (defun gnus-save-marked-articles-mapper (saver filename var)
  522.   (let* ((count 0)
  523.      (fn (function (lambda (msg)
  524.             (if filename
  525.                 (funcall saver filename)
  526.               (call-interactively saver)
  527.               (if gnus-save-marked-in-same-file
  528.                   (setq filename (symbol-value var))))
  529.             (setq count (1+ count))))))
  530.     (if (and (boundp 'inside-gnus-save-marked-articles-mapper)
  531.          inside-gnus-save-marked-articles-mapper)
  532.     (funcall fn nil)
  533.       (let ((inside-gnus-save-marked-articles-mapper t))
  534.       (gnus-summary-mark-map-articles gnus-default-mark-char fn)
  535.       (if (> count 0)
  536.           (message "%s"
  537.                (concat (format "Saved %d article%s"
  538.                        count (if (= count 1) "" "s"))
  539.                    (if gnus-save-marked-in-same-file
  540.                    (format " to %s" filename)))))))))
  541.  
  542.  
  543. (defvar gm-orig-gnus-summary-save-in-rmail
  544.   (symbol-function 'gnus-summary-save-in-rmail))
  545.  
  546. (defun gnus-summary-save-in-rmail (&optional filename)
  547.   "Append the marked articles to an Rmail file.
  548. Optional argument FILENAME specifies file name.
  549. Directory to save to is default to `gnus-article-save-directory' which
  550. is initialized from the SAVEDIR environment variable."
  551.   (interactive)
  552.   (gnus-save-marked-articles-mapper gm-orig-gnus-summary-save-in-rmail
  553.                     filename 'gnus-newsgroup-last-rmail))
  554.  
  555. (defvar gm-orig-gnus-summary-save-in-mail
  556.   (symbol-function 'gnus-summary-save-in-mail))
  557.  
  558. (defun gnus-summary-save-in-mail (&optional filename)
  559.   "Append the marked articles to a Unix mail file.
  560. Optional argument FILENAME specifies file name.
  561. Directory to save to is default to `gnus-article-save-directory' which
  562. is initialized from the SAVEDIR environment variable."
  563.   (interactive)
  564.   (gnus-save-marked-articles-mapper gm-orig-gnus-summary-save-in-mail
  565.                     filename 'gnus-newsgroup-last-mail))
  566.  
  567. (defvar gm-orig-gnus-summary-save-in-file
  568.   (symbol-function 'gnus-summary-save-in-file))
  569.  
  570. (defun gnus-summary-save-in-file (&optional filename)
  571.   "Append the marked articles to a file.
  572. Optional argument FILENAME specifies file name.
  573. Directory to save to is default to `gnus-article-save-directory' which
  574. is initialized from the SAVEDIR environment variable."
  575.   (interactive)
  576.   (gnus-save-marked-articles-mapper gm-orig-gnus-summary-save-in-file
  577.                     filename 'gnus-newsgroup-last-file))
  578.  
  579. (defvar gm-orig-gnus-summary-save-in-folder
  580.   (symbol-function 'gnus-summary-save-in-folder))
  581.  
  582. (defun gnus-summary-save-in-folder (&optional folder)
  583.   "Save the marked articles to a MH folder (using `rcvstore' in MH library).
  584. Optional argument FOLDER specifies folder name."
  585.   (interactive)
  586.   (gnus-save-marked-articles-mapper gm-orig-gnus-summary-save-in-folder
  587.                     folder 'gnus-newsgroup-last-folder))
  588.  
  589. (provide 'gnus-mark)
  590.