diff lisp/gnus-soup.el @ 15512:47d9b7a1dee3

Initial revision

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/gnus-soup.el	Tue Jun 25 22:35:26 1996 +0000
@@ -0,0 +1,563 @@
+;;; gnus-soup.el --- SOUP packet writing support for Gnus
+;; Copyright (C) 1995,96 Free Software Foundation, Inc.
+
+;; Author: Per Abrahamsen <[e-mail]>
+;;	Lars Magne Ingebrigtsen <[e-mail]>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; 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, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus-msg)
+(require 'gnus)
+(eval-when-compile (require 'cl))
+
+;;; User Variables:
+
+(defvar gnus-soup-directory "~/SoupBrew/"
+  "*Directory containing an unpacked SOUP packet.")
+
+(defvar gnus-soup-replies-directory (concat gnus-soup-directory "SoupReplies/")
+  "*Directory where Gnus will do processing of replies.")
+
+(defvar gnus-soup-prefix-file "gnus-prefix"
+  "*Name of the file where Gnus stores the last used 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
+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 "~/"
+  "*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
+  "*Soup encoding type.
+`n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
+format.")
+
+(defvar gnus-soup-index-type ?c
+  "*Soup index type.
+`n' means no index file and `c' means standard Cnews overview
+format.") 
+
+(defvar gnus-soup-areas nil)
+(defvar gnus-soup-last-prefix nil)
+(defvar gnus-soup-prev-prefix nil)
+(defvar gnus-soup-buffers nil)
+
+;;; Access macros:
+
+(defmacro gnus-soup-area-prefix (area)
+  `(aref ,area 0))
+(defmacro gnus-soup-set-area-prefix (area prefix)
+  `(aset ,area 0 ,prefix))
+(defmacro gnus-soup-area-name (area)
+  `(aref ,area 1))
+(defmacro gnus-soup-area-encoding (area)
+  `(aref ,area 2))
+(defmacro gnus-soup-area-description (area)
+  `(aref ,area 3))
+(defmacro gnus-soup-area-number (area)
+  `(aref ,area 4))
+(defmacro gnus-soup-area-set-number (area value)
+  `(aset ,area 4 ,value))
+
+(defmacro gnus-soup-encoding-format (encoding)
+  `(aref ,encoding 0))
+(defmacro gnus-soup-encoding-index (encoding)
+  `(aref ,encoding 1))
+(defmacro gnus-soup-encoding-kind (encoding)
+  `(aref ,encoding 2))
+
+(defmacro gnus-soup-reply-prefix (reply)
+  `(aref ,reply 0))
+(defmacro gnus-soup-reply-kind (reply)
+  `(aref ,reply 1))
+(defmacro gnus-soup-reply-encoding (reply)
+  `(aref ,reply 2))
+
+;;; Commands:
+
+(defun gnus-soup-send-replies ()
+  "Unpack and send all replies in the reply packet."
+  (interactive)
+  (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)))
+      (setq packets (cdr packets)))))
+
+(defun gnus-soup-add-article (n)
+  "Add the current article to SOUP packet.
+If N is a positive number, add the N next articles.
+If N is a negative number, add the N previous articles.
+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))
+	 (prefix (gnus-soup-area-prefix area))
+	 headers)
+    (buffer-disable-undo tmp-buf)
+    (save-excursion
+      (while articles
+	;; Find the header of the article.
+	(set-buffer gnus-summary-buffer)
+	(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)))
+
+(defun gnus-soup-pack-packet ()
+  "Make a SOUP packet from the SOUP areas."
+  (interactive)
+  (gnus-soup-read-areas)
+  (gnus-soup-pack gnus-soup-directory gnus-soup-packer))
+
+(defun gnus-group-brew-soup (n)
+  "Make a soup packet from the current group.
+Uses the process/prefix convention."
+  (interactive "P")
+  (let ((groups (gnus-group-process-prefix n)))
+    (while groups
+      (gnus-group-remove-mark (car groups))
+      (gnus-soup-group-brew (car groups) t)
+      (setq groups (cdr groups)))
+    (gnus-soup-save-areas)))
+
+(defun gnus-brew-soup (&optional level)
+  "Go through all groups on LEVEL or less and make a soup packet."
+  (interactive "P")
+  (let ((level (or level gnus-level-subscribed))
+	(newsrc (cdr gnus-newsrc-alist)))
+    (while newsrc
+      (and (<= (nth 1 (car newsrc)) level)
+	   (gnus-soup-group-brew (caar newsrc) t))
+      (setq newsrc (cdr newsrc)))
+    (gnus-soup-save-areas)))
+
+;;;###autoload
+(defun gnus-batch-brew-soup ()
+  "Brew a SOUP packet from groups mention on the command line.
+Will use the remaining command line arguments as regular expressions
+for matching on group names.
+
+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.*\""
+  (interactive)
+  )
+  
+;;; Internal Functions:
+
+;; 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
+		   (concat directory prefix ".MSG")))
+	 (idx-buf (if (= index ?n)
+		      nil
+		    (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)))
+    (save-excursion
+      ;; Make sure the last char in the buffer is a newline.
+      (goto-char (point-max))
+      (or (= (current-column) 0)
+	  (insert "\n"))
+      ;; Find the "from".
+      (goto-char (point-min))
+      (setq from
+	    (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. 
+      (setq head-line
+	    (cond 
+	     ((= gnus-soup-encoding-type ?n)
+	      (format "#! rnews %d\n" (buffer-size)))
+	     ((= gnus-soup-encoding-type ?m)
+	      (while (search-forward "\nFrom " nil t)
+		(replace-match "\n>From " t t))
+	      (concat "From " (or from "unknown")
+		      " " (current-time-string) "\n"))
+	     ((= gnus-soup-encoding-type ?M)
+	      "\^a\^a\^a\^a\n")
+	     (t (error "Unsupported type: %c" gnus-soup-encoding-type))))
+      ;; Insert the soup header and the article in the MSG buf.
+      (set-buffer msg-buf)
+      (goto-char (point-max))
+      (insert head-line)
+      (setq beg (point))
+      (insert-buffer-substring article-buf)
+      ;; Insert the index in the IDX buf.
+      (cond ((= index ?c)
+	     (set-buffer idx-buf)
+	     (gnus-soup-insert-idx beg headers))
+	    ((/= index ?n)
+	     (error "Unknown index type: %c" type)))
+      ;; Return the MSG buf.
+      msg-buf)))
+
+(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)
+	(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)
+		   (append gnus-newsgroup-marked gnus-newsgroup-unreads)
+		 gnus-newsgroup-unreads)))
+	(gnus-soup-add-article nil)
+	(gnus-summary-exit)))))
+
+(defun gnus-soup-insert-idx (offset header)
+  ;; [number subject from date id references chars lines xref]
+  (goto-char (point-max))
+  (insert
+   (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n"
+	   offset
+	   (or (mail-header-subject header) "(none)")
+	   (or (mail-header-from header) "(nobody)")
+	   (or (mail-header-date header) "")
+	   (or (mail-header-id header)
+	       (concat "soup-dummy-id-" 
+		       (mapconcat 
+			(lambda (time) (int-to-string time))
+			(current-time) "-")))
+	   (or (mail-header-references header) "")
+	   (or (mail-header-chars header) 0) 
+	   (or (mail-header-lines header) "0"))))
+
+(defun gnus-soup-save-areas ()
+  (gnus-soup-write-areas)
+  (save-excursion
+    (let (buf)
+      (while gnus-soup-buffers
+	(setq buf (car gnus-soup-buffers)
+	      gnus-soup-buffers (cdr gnus-soup-buffers))
+	(if (not (buffer-name buf))
+	    ()
+	  (set-buffer buf)
+	  (and (buffer-modified-p) (save-buffer))
+	  (kill-buffer (current-buffer)))))
+    (gnus-soup-write-prefixes)))
+
+(defun gnus-soup-write-prefixes ()
+  (let ((prefix gnus-soup-last-prefix))
+    (save-excursion
+      (while prefix
+	(gnus-set-work-buffer)
+	(insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix)))
+	(gnus-make-directory (caar prefix))
+	(write-region (point-min) (point-max)
+		      (concat (caar prefix) gnus-soup-prefix-file) 
+		      nil 'nomesg)
+	(setq prefix (cdr prefix))))))
+
+(defun gnus-soup-pack (dir packer)
+  (let* ((files (mapconcat 'identity
+			   '("AREAS" "*.MSG" "*.IDX" "INFO"
+			     "LIST" "REPLIES" "COMMANDS" "ERRORS")
+			   " "))
+	 (packer (if (< (string-match "%s" packer)
+			(string-match "%d" packer))
+		     (format packer files
+			     (string-to-int (gnus-soup-unique-prefix dir)))
+		   (format packer 
+			   (string-to-int (gnus-soup-unique-prefix dir))
+			   files)))
+	 (dir (expand-file-name dir)))
+    (or (file-directory-p dir)
+	(gnus-make-directory dir))
+    (setq gnus-soup-areas nil)
+    (gnus-message 4 "Packing %s..." packer)
+    (if (zerop (call-process shell-file-name
+			     nil nil nil shell-command-switch 
+			     (concat "cd " dir " ; " packer)))
+	(progn
+	  (call-process shell-file-name nil nil nil shell-command-switch 
+			(concat "cd " dir " ; rm " files))
+	  (gnus-message 4 "Packing...done" packer))
+      (error "Couldn't pack packet."))))
+
+(defun gnus-soup-parse-areas (file)
+  "Parse soup area file FILE.
+The result is a of vectors, each containing one entry from the AREA file.
+The vector contain five strings, 
+  [prefix name encoding description number]
+though the two last may be nil if they are missing."
+  (let (areas)
+    (save-excursion
+      (set-buffer (find-file-noselect file 'force))
+      (buffer-disable-undo (current-buffer))
+      (goto-char (point-min))
+      (while (not (eobp))
+	(setq areas
+	      (cons (vector (gnus-soup-field) 
+			    (gnus-soup-field)
+			    (gnus-soup-field)
+			    (and (eq (preceding-char) ?\t)
+				 (gnus-soup-field))
+			    (and (eq (preceding-char) ?\t)
+				 (string-to-int (gnus-soup-field))))
+		    areas))
+	(if (eq (preceding-char) ?\t)
+	    (beginning-of-line 2)))
+      (kill-buffer (current-buffer)))
+    areas))
+
+(defun gnus-soup-parse-replies (file)
+  "Parse soup REPLIES file FILE.
+The result is a of vectors, each containing one entry from the REPLIES
+file. The vector contain three strings, [prefix name encoding]."
+  (let (replies)
+    (save-excursion
+      (set-buffer (find-file-noselect file))
+      (buffer-disable-undo (current-buffer))
+      (goto-char (point-min))
+      (while (not (eobp))
+	(setq replies
+	      (cons (vector (gnus-soup-field) (gnus-soup-field)
+			    (gnus-soup-field))
+		    replies))
+	(if (eq (preceding-char) ?\t)
+	    (beginning-of-line 2)))
+      (kill-buffer (current-buffer)))
+    replies))
+
+(defun gnus-soup-field ()
+  (prog1
+      (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
+    (forward-char 1)))
+
+(defun gnus-soup-read-areas ()
+  (or gnus-soup-areas
+      (setq gnus-soup-areas
+	    (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
+
+(defun gnus-soup-write-areas ()
+  "Write the AREAS file."
+  (interactive)
+  (when gnus-soup-areas
+    (nnheader-temp-write (concat gnus-soup-directory "AREAS")
+      (let ((areas gnus-soup-areas)
+	    area)
+	(while (setq area (pop areas))
+	  (insert
+	   (format 
+	    "%s\t%s\t%s%s\n"
+	    (gnus-soup-area-prefix area)
+	    (gnus-soup-area-name area) 
+	    (gnus-soup-area-encoding area)
+	    (if (or (gnus-soup-area-description area) 
+		    (gnus-soup-area-number area))
+		(concat "\t" (or (gnus-soup-area-description
+				  area) "")
+			(if (gnus-soup-area-number area)
+			    (concat "\t" (int-to-string 
+					  (gnus-soup-area-number area)))
+			  "")) ""))))))))
+
+(defun gnus-soup-write-replies (dir areas)
+  "Write a REPLIES file in DIR containing AREAS."
+  (nnheader-temp-write (concat dir "REPLIES")
+    (let (area)
+      (while (setq area (pop areas))
+	(insert (format "%s\t%s\t%s\n"
+			(gnus-soup-reply-prefix area)
+			(gnus-soup-reply-kind area) 
+			(gnus-soup-reply-encoding area)))))))
+
+(defun gnus-soup-area (group)
+  (gnus-soup-read-areas)
+  (let ((areas gnus-soup-areas)
+	(real-group (gnus-group-real-name group))
+	area result)
+    (while areas
+      (setq area (car areas)
+	    areas (cdr areas))
+      (if (equal (gnus-soup-area-name area) real-group)
+	  (setq result area)))
+    (or result
+	(setq result
+	      (vector (gnus-soup-unique-prefix)
+		      real-group 
+		      (format "%c%c%c"
+			      gnus-soup-encoding-type
+			      gnus-soup-index-type
+			      (if (gnus-member-of-valid 'mail group) ?m ?n))
+		      nil nil)
+	      gnus-soup-areas (cons result gnus-soup-areas)))
+    result))
+
+(defun gnus-soup-unique-prefix (&optional dir)
+  (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
+	 (entry (assoc dir gnus-soup-last-prefix))
+	 gnus-soup-prev-prefix)
+    (if entry
+	()
+      (and (file-exists-p (concat dir gnus-soup-prefix-file))
+	   (condition-case nil
+	       (load (concat dir gnus-soup-prefix-file) nil t t)
+	     (error nil)))
+      (setq gnus-soup-last-prefix 
+	    (cons (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
+		  gnus-soup-last-prefix)))
+    (setcdr entry (1+ (cdr entry)))
+    (gnus-soup-write-prefixes)
+    (int-to-string (cdr entry))))
+
+(defun gnus-soup-unpack-packet (dir unpacker packet)
+  "Unpack PACKET into DIR using UNPACKER.
+Return whether the unpacking was successful."
+  (gnus-make-directory dir)
+  (gnus-message 4 "Unpacking: %s" (format unpacker packet))
+  (prog1
+      (zerop (call-process
+	      shell-file-name nil nil nil shell-command-switch
+	      (format "cd %s ; %s" (expand-file-name dir) 
+		      (format unpacker packet))))
+    (gnus-message 4 "Unpacking...done")))
+
+(defun gnus-soup-send-packet (packet)
+  (gnus-soup-unpack-packet 
+   gnus-soup-replies-directory gnus-soup-unpacker packet)
+  (let ((replies (gnus-soup-parse-replies 
+		  (concat gnus-soup-replies-directory "REPLIES"))))
+    (save-excursion
+      (while replies
+	(let* ((msg-file (concat gnus-soup-replies-directory
+				 (gnus-soup-reply-prefix (car replies))
+				 ".MSG"))
+	       (msg-buf (and (file-exists-p msg-file)
+			     (find-file-noselect msg-file)))
+	       (tmp-buf (get-buffer-create " *soup send*"))
+	       beg end)
+	  (cond 
+	   ((/= (gnus-soup-encoding-format 
+		 (gnus-soup-reply-encoding (car replies))) ?n)
+	    (error "Unsupported encoding"))
+	   ((null msg-buf)
+	    t)
+	   (t
+	    (buffer-disable-undo msg-buf)
+	    (buffer-disable-undo tmp-buf)
+	    (set-buffer msg-buf)
+	    (goto-char (point-min))
+	    (while (not (eobp))
+	      (or (looking-at "#! *rnews +\\([0-9]+\\)")
+		  (error "Bad header."))
+	      (forward-line 1)
+	      (setq beg (point)
+		    end (+ (point) (string-to-int 
+				    (buffer-substring 
+				     (match-beginning 1) (match-end 1)))))
+	      (switch-to-buffer tmp-buf)
+	      (erase-buffer)
+	      (insert-buffer-substring msg-buf beg end)
+	      (goto-char (point-min))
+	      (search-forward "\n\n")
+	      (forward-char -1)
+	      (insert mail-header-separator)
+	      (setq message-newsreader (setq message-mailer
+					     (gnus-extended-version)))
+	      (cond 
+	       ((string= (gnus-soup-reply-kind (car replies)) "news")
+		(gnus-message 5 "Sending news message to %s..."
+			      (mail-fetch-field "newsgroups"))
+		(sit-for 1)
+		(funcall message-send-news-function))
+	       ((string= (gnus-soup-reply-kind (car replies)) "mail")
+		(gnus-message 5 "Sending mail to %s..."
+			 (mail-fetch-field "to"))
+		(sit-for 1)
+		(message-send-mail))
+	       (t
+		(error "Unknown reply kind")))
+	      (set-buffer msg-buf)
+	      (goto-char end))
+	    (delete-file (buffer-file-name))
+	    (kill-buffer msg-buf)
+	    (kill-buffer tmp-buf)
+	    (gnus-message 4 "Sent packet"))))
+	(setq replies (cdr replies)))
+      t)))
+		   
+(provide 'gnus-soup)
+
+;;; gnus-soup.el ends here