;;; gnus-soup.el --- SOUP packet writing support for Gnus
-;; Copyright (C) 1995,96 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
-;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
-(require 'gnus-msg)
+(eval-when-compile (require 'cl))
+
(require 'gnus)
+(require 'gnus-art)
+(require 'message)
+(require 'gnus-start)
+(require 'gnus-range)
;;; User Variables:
-(defvar gnus-soup-directory "~/SoupBrew/"
+(defvar gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/")
"*Directory containing an unpacked SOUP packet.")
-(defvar gnus-soup-replies-directory (concat gnus-soup-directory "SoupReplies/")
+(defvar gnus-soup-replies-directory
+ (nnheader-concat gnus-soup-directory "SoupReplies/")
"*Directory where Gnus will do processing of replies.")
(defvar gnus-soup-prefix-file "gnus-prefix"
(defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
"Format string command for packing a SOUP packet.
The SOUP files will be inserted where the %s is in the string.
-This string MUST contain both %s and %d. The file number will be
+This string MUST contain both %s and %d. The file number will be
inserted where %d appears.")
(defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
"*Format string command for unpacking a SOUP packet.
The SOUP packet file name will be inserted at the %s.")
-(defvar gnus-soup-packet-directory "~/"
+(defvar gnus-soup-packet-directory gnus-home-directory
"*Where gnus-soup will look for REPLIES packets.")
(defvar gnus-soup-packet-regexp "Soupin"
"*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
+(defvar gnus-soup-ignored-headers "^Xref:"
+ "*Regexp to match headers to be removed when brewing SOUP packets.")
+
;;; Internal Variables:
(defvar gnus-soup-encoding-type ?n
(defvar gnus-soup-index-type ?c
"*Soup index type.
`n' means no index file and `c' means standard Cnews overview
-format.")
+format.")
(defvar gnus-soup-areas nil)
(defvar gnus-soup-last-prefix nil)
;;; Access macros:
(defmacro gnus-soup-area-prefix (area)
- (` (aref (, area) 0)))
+ `(aref ,area 0))
+(defmacro gnus-soup-set-area-prefix (area prefix)
+ `(aset ,area 0 ,prefix))
(defmacro gnus-soup-area-name (area)
- (` (aref (, area) 1)))
+ `(aref ,area 1))
(defmacro gnus-soup-area-encoding (area)
- (` (aref (, area) 2)))
+ `(aref ,area 2))
(defmacro gnus-soup-area-description (area)
- (` (aref (, area) 3)))
+ `(aref ,area 3))
(defmacro gnus-soup-area-number (area)
- (` (aref (, area) 4)))
+ `(aref ,area 4))
(defmacro gnus-soup-area-set-number (area value)
- (` (aset (, area) 4 (, value))))
+ `(aset ,area 4 ,value))
(defmacro gnus-soup-encoding-format (encoding)
- (` (aref (, encoding) 0)))
+ `(aref ,encoding 0))
(defmacro gnus-soup-encoding-index (encoding)
- (` (aref (, encoding) 1)))
+ `(aref ,encoding 1))
(defmacro gnus-soup-encoding-kind (encoding)
- (` (aref (, encoding) 2)))
+ `(aref ,encoding 2))
(defmacro gnus-soup-reply-prefix (reply)
- (` (aref (, reply) 0)))
+ `(aref ,reply 0))
(defmacro gnus-soup-reply-kind (reply)
- (` (aref (, reply) 1)))
+ `(aref ,reply 1))
(defmacro gnus-soup-reply-encoding (reply)
- (` (aref (, reply) 2)))
+ `(aref ,reply 2))
;;; Commands:
(let ((packets (directory-files
gnus-soup-packet-directory t gnus-soup-packet-regexp)))
(while packets
- (and (gnus-soup-send-packet (car packets))
- (delete-file (car packets)))
+ (when (gnus-soup-send-packet (car packets))
+ (delete-file (car packets)))
(setq packets (cdr packets)))))
(defun gnus-soup-add-article (n)
If N is nil and any articles have been marked with the process mark,
move those articles instead."
(interactive "P")
- (gnus-set-global-variables)
(let* ((articles (gnus-summary-work-articles n))
(tmp-buf (get-buffer-create "*soup work*"))
(area (gnus-soup-area gnus-newsgroup-name))
(while articles
;; Find the header of the article.
(set-buffer gnus-summary-buffer)
- (setq headers (gnus-summary-article-header (car articles)))
- ;; Put the article in a buffer.
- (set-buffer tmp-buf)
- (gnus-request-article-this-buffer
- (car articles) gnus-newsgroup-name)
- (gnus-soup-store gnus-soup-directory prefix headers
- gnus-soup-encoding-type
- gnus-soup-index-type)
- (gnus-soup-area-set-number area
- (1+ (or (gnus-soup-area-number area) 0)))
- ;; Mark article as read.
+ (when (setq headers (gnus-summary-article-header (car articles)))
+ ;; Put the article in a buffer.
+ (set-buffer tmp-buf)
+ (when (gnus-request-article-this-buffer
+ (car articles) gnus-newsgroup-name)
+ (save-restriction
+ (message-narrow-to-head)
+ (message-remove-header gnus-soup-ignored-headers t))
+ (gnus-soup-store gnus-soup-directory prefix headers
+ gnus-soup-encoding-type
+ gnus-soup-index-type)
+ (gnus-soup-area-set-number
+ area (1+ (or (gnus-soup-area-number area) 0)))))
+ ;; Mark article as read.
(set-buffer gnus-summary-buffer)
(gnus-summary-remove-process-mark (car articles))
(gnus-summary-mark-as-read (car articles) gnus-souped-mark)
(setq articles (cdr articles)))
(kill-buffer tmp-buf))
- (gnus-soup-save-areas)))
+ (gnus-soup-save-areas)
+ (gnus-set-mode-line 'summary)))
(defun gnus-soup-pack-packet ()
"Make a SOUP packet from the SOUP areas."
(interactive)
(gnus-soup-read-areas)
+ (unless (file-exists-p gnus-soup-directory)
+ (message "No such directory: %s" gnus-soup-directory))
+ (when (null (directory-files gnus-soup-directory nil "\\.MSG$"))
+ (message "No files to pack."))
(gnus-soup-pack gnus-soup-directory gnus-soup-packer))
(defun gnus-group-brew-soup (n)
(let ((groups (gnus-group-process-prefix n)))
(while groups
(gnus-group-remove-mark (car groups))
- (gnus-soup-group-brew (car groups))
+ (gnus-soup-group-brew (car groups) t)
(setq groups (cdr groups)))
(gnus-soup-save-areas)))
(let ((level (or level gnus-level-subscribed))
(newsrc (cdr gnus-newsrc-alist)))
(while newsrc
- (and (<= (nth 1 (car newsrc)) level)
- (gnus-soup-group-brew (car (car newsrc))))
+ (when (<= (nth 1 (car newsrc)) level)
+ (gnus-soup-group-brew (caar newsrc) t))
(setq newsrc (cdr newsrc)))
(gnus-soup-save-areas)))
For instance, if you want to brew on all the nnml groups, as well as
groups with \"emacs\" in the name, you could say something like:
-$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
+$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"
+
+Note -- this function hasn't been implemented yet."
(interactive)
- )
-
+ nil)
+
;;; Internal Functions:
-;; Store the current buffer.
+;; Store the current buffer.
(defun gnus-soup-store (directory prefix headers format index)
- ;; Create the directory, if needed.
- (or (file-directory-p directory)
- (gnus-make-directory directory))
- (let* ((msg-buf (find-file-noselect
+ ;; Create the directory, if needed.
+ (gnus-make-directory directory)
+ (let* ((msg-buf (nnheader-find-file-noselect
(concat directory prefix ".MSG")))
(idx-buf (if (= index ?n)
nil
- (find-file-noselect
+ (nnheader-find-file-noselect
(concat directory prefix ".IDX"))))
(article-buf (current-buffer))
from head-line beg type)
(setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
(buffer-disable-undo msg-buf)
- (and idx-buf
- (progn
- (setq gnus-soup-buffers (cons idx-buf gnus-soup-buffers))
- (buffer-disable-undo idx-buf)))
+ (when idx-buf
+ (push idx-buf gnus-soup-buffers)
+ (buffer-disable-undo idx-buf))
(save-excursion
;; Make sure the last char in the buffer is a newline.
(goto-char (point-max))
- (or (= (current-column) 0)
- (insert "\n"))
+ (unless (= (current-column) 0)
+ (insert "\n"))
;; Find the "from".
(goto-char (point-min))
(setq from
- (mail-strip-quoted-names
+ (gnus-mail-strip-quoted-names
(or (mail-fetch-field "from")
(mail-fetch-field "really-from")
(mail-fetch-field "sender"))))
(goto-char (point-min))
;; Depending on what encoding is supposed to be used, we make
- ;; a soup header.
+ ;; a soup header.
(setq head-line
- (cond
+ (cond
((= gnus-soup-encoding-type ?n)
(format "#! rnews %d\n" (buffer-size)))
((= gnus-soup-encoding-type ?m)
;; Return the MSG buf.
msg-buf)))
-(defun gnus-soup-group-brew (group)
+(defun gnus-soup-group-brew (group &optional not-all)
+ "Enter GROUP and add all articles to a SOUP package.
+If NOT-ALL, don't pack ticked articles."
(let ((gnus-expert-user t)
- (gnus-large-newsgroup nil))
- (and (gnus-summary-read-group group)
- (let ((gnus-newsgroup-processable
- (gnus-sorted-complement
- gnus-newsgroup-unreads
- (append gnus-newsgroup-dormant gnus-newsgroup-marked))))
- (gnus-soup-add-article nil)))
- (gnus-summary-exit)))
+ (gnus-large-newsgroup nil)
+ (entry (gnus-gethash group gnus-newsrc-hashtb)))
+ (when (or (null entry)
+ (eq (car entry) t)
+ (and (car entry)
+ (> (car entry) 0))
+ (and (not not-all)
+ (gnus-range-length (cdr (assq 'tick (gnus-info-marks
+ (nth 2 entry)))))))
+ (when (gnus-summary-read-group group nil t)
+ (setq gnus-newsgroup-processable
+ (reverse
+ (if (not not-all)
+
projects / gnus / blobdiff