diff options
Diffstat (limited to 'lisp/gnus/gnus-soup.el')
| -rw-r--r-- | lisp/gnus/gnus-soup.el | 565 |
1 files changed, 565 insertions, 0 deletions
diff --git a/lisp/gnus/gnus-soup.el b/lisp/gnus/gnus-soup.el new file mode 100644 index 00000000000..a04b96aad7e --- /dev/null +++ b/lisp/gnus/gnus-soup.el @@ -0,0 +1,565 @@ +;;; gnus-soup.el --- SOUP packet writing support for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen <abraham@iesd.auc.dk> +;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; 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) +(require 'gnus-art) +(require 'message) +(require 'gnus-start) +(require 'gnus-range) + +;;; User Variables: + +(defvar gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/") + "*Directory containing an unpacked SOUP packet.") + +(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" + "*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 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 + "*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 + (when (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) + (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) + "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 + (when (<= (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) + nil) + +;;; Internal Functions: + +;; Store the current buffer. +(defun gnus-soup-store (directory prefix headers format index) + ;; 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 + (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) + (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)) + (unless (= (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) + (when (buffer-modified-p) + (save-buffer)) + (kill-buffer (current-buffer))))) + (gnus-soup-write-prefixes))) + +(defun gnus-soup-write-prefixes () + (let ((prefixes gnus-soup-last-prefix) + prefix) + (save-excursion + (gnus-set-work-buffer) + (while (setq prefix (pop prefixes)) + (erase-buffer) + (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) + (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))) + +(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))) + (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 (nnheader-find-file-noselect file 'force)) + (buffer-disable-undo (current-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (push (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) + (when (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 (nnheader-find-file-noselect file)) + (buffer-disable-undo (current-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (push (vector (gnus-soup-field) (gnus-soup-field) + (gnus-soup-field)) + replies) + (when (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)) + (when (equal (gnus-soup-area-name area) real-group) + (setq result area))) + (unless 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 + () + (when (file-exists-p (concat dir gnus-soup-prefix-file)) + (ignore-errors + (load (concat dir gnus-soup-prefix-file) nil t t))) + (push (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) + (nnheader-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)) + (unless (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) + (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (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 |