cgit.sxemacs.org Git - gnus/blob - lisp/gnus-soup.el

   1 ;;; gnus-soup.el --- SOUP packet writing support for Gnus
   2 ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
   3
   4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
   5 ;;      Lars Magne Ingebrigtsen <larsi@gnus.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 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-art)
  33 (require 'message)
  34 (require 'gnus-start)
  35 (require 'gnus-range)
  36
  37 ;;; User Variables:
  38
  39 (defvar gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/")
  40   "*Directory containing an unpacked SOUP packet.")
  41
  42 (defvar gnus-soup-replies-directory
  43   (nnheader-concat gnus-soup-directory "SoupReplies/")
  44   "*Directory where Gnus will do processing of replies.")
  45
  46 (defvar gnus-soup-prefix-file "gnus-prefix"
  47   "*Name of the file where Gnus stores the last used prefix.")
  48
  49 (defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
  50   "Format string command for packing a SOUP packet.
  51 The SOUP files will be inserted where the %s is in the string.
  52 This string MUST contain both %s and %d.  The file number will be
  53 inserted where %d appears.")
  54
  55 (defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
  56   "*Format string command for unpacking a SOUP packet.
  57 The SOUP packet file name will be inserted at the %s.")
  58
  59 (defvar gnus-soup-packet-directory gnus-home-directory
  60   "*Where gnus-soup will look for REPLIES packets.")
  61
  62 (defvar gnus-soup-packet-regexp "Soupin"
  63   "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
  64
  65 (defvar gnus-soup-ignored-headers "^Xref:"
  66   "*Regexp to match headers to be removed when brewing SOUP packets.")
  67
  68 ;;; Internal Variables:
  69
  70 (defvar gnus-soup-encoding-type ?n
  71   "*Soup encoding type.
  72 `n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
  73 format.")
  74
  75 (defvar gnus-soup-index-type ?c
  76   "*Soup index type.
  77 `n' means no index file and `c' means standard Cnews overview
  78 format.")
  79
  80 (defvar gnus-soup-areas nil)
  81 (defvar gnus-soup-last-prefix nil)
  82 (defvar gnus-soup-prev-prefix nil)
  83 (defvar gnus-soup-buffers nil)
  84
  85 ;;; Access macros:
  86
  87 (defmacro gnus-soup-area-prefix (area)
  88   `(aref ,area 0))
  89 (defmacro gnus-soup-set-area-prefix (area prefix)
  90   `(aset ,area 0 ,prefix))
  91 (defmacro gnus-soup-area-name (area)
  92   `(aref ,area 1))
  93 (defmacro gnus-soup-area-encoding (area)
  94   `(aref ,area 2))
  95 (defmacro gnus-soup-area-description (area)
  96   `(aref ,area 3))
  97 (defmacro gnus-soup-area-number (area)
  98   `(aref ,area 4))
  99 (defmacro gnus-soup-area-set-number (area value)
 100   `(aset ,area 4 ,value))
 101
 102 (defmacro gnus-soup-encoding-format (encoding)
 103   `(aref ,encoding 0))
 104 (defmacro gnus-soup-encoding-index (encoding)
 105   `(aref ,encoding 1))
 106 (defmacro gnus-soup-encoding-kind (encoding)
 107   `(aref ,encoding 2))
 108
 109 (defmacro gnus-soup-reply-prefix (reply)
 110   `(aref ,reply 0))
 111 (defmacro gnus-soup-reply-kind (reply)
 112   `(aref ,reply 1))
 113 (defmacro gnus-soup-reply-encoding (reply)
 114   `(aref ,reply 2))
 115
 116 ;;; Commands:
 117
 118 (defun gnus-soup-send-replies ()
 119   "Unpack and send all replies in the reply packet."
 120   (interactive)
 121   (let ((packets (directory-files
 122                   gnus-soup-packet-directory t gnus-soup-packet-regexp)))
 123     (while packets
 124       (when (gnus-soup-send-packet (car packets))
 125         (delete-file (car packets)))
 126       (setq packets (cdr packets)))))
 127
 128 (defun gnus-soup-add-article (n)
 129   "Add the current article to SOUP packet.
 130 If N is a positive number, add the N next articles.
 131 If N is a negative number, add the N previous articles.
 132 If N is nil and any articles have been marked with the process mark,
 133 move those articles instead."
 134   (interactive "P")
 135   (let* ((articles (gnus-summary-work-articles n))
 136          (tmp-buf (gnus-get-buffer-create "*soup work*"))
 137          (area (gnus-soup-area gnus-newsgroup-name))
 138          (prefix (gnus-soup-area-prefix area))
 139          headers)
 140     (buffer-disable-undo tmp-buf)
 141     (save-excursion
 142       (while articles
 143         ;; Find the header of the article.
 144         (set-buffer gnus-summary-buffer)
 145         (when (setq headers (gnus-summary-article-header (car articles)))
 146           ;; Put the article in a buffer.
 147           (set-buffer tmp-buf)
 148           (when (gnus-request-article-this-buffer
 149                  (car articles) gnus-newsgroup-name)
 150             (save-restriction
 151               (message-narrow-to-head)
 152               (message-remove-header gnus-soup-ignored-headers t))
 153             (gnus-soup-store gnus-soup-directory prefix headers
 154                              gnus-soup-encoding-type
 155                              gnus-soup-index-type)
 156             (gnus-soup-area-set-number
 157              area (1+ (or (gnus-soup-area-number area) 0)))))
 158         ;; Mark article as read.
 159         (set-buffer gnus-summary-buffer)
 160         (gnus-summary-remove-process-mark (car articles))
 161         (gnus-summary-mark-as-read (car articles) gnus-souped-mark)
 162         (setq articles (cdr articles)))
 163       (kill-buffer tmp-buf))
 164     (gnus-soup-save-areas)
 165     (gnus-set-mode-line 'summary)))
 166
 167 (defun gnus-soup-pack-packet ()
 168   "Make a SOUP packet from the SOUP areas."
 169   (interactive)
 170   (gnus-soup-read-areas)
 171   (unless (file-exists-p gnus-soup-directory)
 172     (message "No such directory: %s" gnus-soup-directory))
 173   (when (null (directory-files gnus-soup-directory nil "\\.MSG$"))
 174     (message "No files to pack."))
 175   (gnus-soup-pack gnus-soup-directory gnus-soup-packer))
 176
 177 (defun gnus-group-brew-soup (n)
 178   "Make a soup packet from the current group.
 179 Uses the process/prefix convention."
 180   (interactive "P")
 181   (let ((groups (gnus-group-process-prefix n)))
 182     (while groups
 183       (gnus-group-remove-mark (car groups))
 184       (gnus-soup-group-brew (car groups) t)