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 Free Software Foundation, Inc.
   3
   4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   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 (require 'gnus-msg)
  30 (require 'gnus)
  31 (eval-when-compile (require 'cl))
  32
  33 ;;; User Variables:
  34
  35 (defvar gnus-soup-directory "~/SoupBrew/"
  36   "*Directory containing an unpacked SOUP packet.")
  37
  38 (defvar gnus-soup-replies-directory (concat gnus-soup-directory "SoupReplies/")
  39   "*Directory where Gnus will do processing of replies.")
  40
  41 (defvar gnus-soup-prefix-file "gnus-prefix"
  42   "*Name of the file where Gnus stores the last used prefix.")
  43
  44 (defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
  45   "Format string command for packing a SOUP packet.
  46 The SOUP files will be inserted where the %s is in the string.
  47 This string MUST contain both %s and %d. The file number will be
  48 inserted where %d appears.")
  49
  50 (defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
  51   "*Format string command for unpacking a SOUP packet.
  52 The SOUP packet file name will be inserted at the %s.")
  53
  54 (defvar gnus-soup-packet-directory "~/"
  55   "*Where gnus-soup will look for REPLIES packets.")
  56
  57 (defvar gnus-soup-packet-regexp "Soupin"
  58   "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
  59
  60 ;;; Internal Variables:
  61
  62 (defvar gnus-soup-encoding-type ?n
  63   "*Soup encoding type.
  64 `n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
  65 format.")
  66
  67 (defvar gnus-soup-index-type ?c
  68   "*Soup index type.
  69 `n' means no index file and `c' means standard Cnews overview
  70 format.")
  71
  72 (defvar gnus-soup-areas nil)
  73 (defvar gnus-soup-last-prefix nil)
  74 (defvar gnus-soup-prev-prefix nil)
  75 (defvar gnus-soup-buffers nil)
  76
  77 ;;; Access macros:
  78
  79 (defmacro gnus-soup-area-prefix (area)
  80   `(aref ,area 0))
  81 (defmacro gnus-soup-set-area-prefix (area prefix)
  82   `(aset ,area 0 ,prefix))
  83 (defmacro gnus-soup-area-name (area)
  84   `(aref ,area 1))
  85 (defmacro gnus-soup-area-encoding (area)
  86   `(aref ,area 2))
  87 (defmacro gnus-soup-area-description (area)
  88   `(aref ,area 3))
  89 (defmacro gnus-soup-area-number (area)
  90   `(aref ,area 4))
  91 (defmacro gnus-soup-area-set-number (area value)
  92   `(aset ,area 4 ,value))
  93
  94 (defmacro gnus-soup-encoding-format (encoding)
  95   `(aref ,encoding 0))
  96 (defmacro gnus-soup-encoding-index (encoding)
  97   `(aref ,encoding 1))
  98 (defmacro gnus-soup-encoding-kind (encoding)
  99   `(aref ,encoding 2))
 100
 101 (defmacro gnus-soup-reply-prefix (reply)
 102   `(aref ,reply 0))
 103 (defmacro gnus-soup-reply-kind (reply)
 104   `(aref ,reply 1))
 105 (defmacro gnus-soup-reply-encoding (reply)
 106   `(aref ,reply 2))
 107
 108 ;;; Commands:
 109
 110 (defun gnus-soup-send-replies ()
 111   "Unpack and send all replies in the reply packet."
 112   (interactive)
 113   (let ((packets (directory-files
 114                   gnus-soup-packet-directory t gnus-soup-packet-regexp)))
 115     (while packets
 116       (and (gnus-soup-send-packet (car packets))
 117            (delete-file (car packets)))
 118       (setq packets (cdr packets)))))
 119
 120 (defun gnus-soup-add-article (n)
 121   "Add the current article to SOUP packet.
 122 If N is a positive number, add the N next articles.
 123 If N is a negative number, add the N previous articles.
 124 If N is nil and any articles have been marked with the process mark,
 125 move those articles instead."
 126   (interactive "P")
 127   (gnus-set-global-variables)
 128   (let* ((articles (gnus-summary-work-articles n))
 129          (tmp-buf (get-buffer-create "*soup work*"))
 130          (area (gnus-soup-area gnus-newsgroup-name))
 131          (prefix (gnus-soup-area-prefix area))
 132          headers)
 133     (buffer-disable-undo tmp-buf)
 134     (save-excursion
 135       (while articles
 136         ;; Find the header of the article.
 137         (set-buffer gnus-summary-buffer)
 138         (when (setq headers (gnus-summary-article-header (car articles)))
 139           ;; Put the article in a buffer.
 140           (set-buffer tmp-buf)
 141           (when (gnus-request-article-this-buffer
 142                  (car articles) gnus-newsgroup-name)
 143             (gnus-soup-store gnus-soup-directory prefix headers
 144                              gnus-soup-encoding-type
 145                              gnus-soup-index-type)
 146             (gnus-soup-area-set-number
 147              area (1+ (or (gnus-soup-area-number area) 0)))))
 148         ;; Mark article as read.
 149         (set-buffer gnus-summary-buffer)
 150         (gnus-summary-remove-process-mark (car articles))
 151         (gnus-summary-mark-as-read (car articles) gnus-souped-mark)
 152         (setq articles (cdr articles)))
 153       (kill-buffer tmp-buf))
 154     (gnus-soup-save-areas)))
 155
 156 (defun gnus-soup-pack-packet ()
 157   "Make a SOUP packet from the SOUP areas."
 158   (interactive)
 159   (gnus-soup-read-areas)
 160   (gnus-soup-pack gnus-soup-directory gnus-soup-packer))
 161
 162 (defun gnus-group-brew-soup (n)
 163   "Make a soup packet from the current group.
 164 Uses the process/prefix convention."
 165   (interactive "P")
 166   (let ((groups (gnus-group-process-prefix n)))
 167     (while groups
 168       (gnus-group-remove-mark (car groups))
 169       (gnus-soup-group-brew (car groups))
 170       (setq groups (cdr groups)))
 171     (gnus-soup-save-areas)))
 172
 173 (defun gnus-brew-soup (&optional level)
 174   "Go through all groups on LEVEL or less and make a soup packet."
 175   (interactive "P")
 176   (let ((level (or level gnus-level-subscribed))
 177         (newsrc (cdr gnus-newsrc-alist)))
 178     (while newsrc
 179       (and (<= (nth 1 (car newsrc)) level)
 180            (gnus-soup-group-brew (caar newsrc)))
 181       (setq newsrc (cdr newsrc)))
 182     (gnus-soup-save-areas)))
 183
 184 ;;;###autoload
 185 (defun gnus-batch-brew-soup ()
 186   "Brew a SOUP packet from groups mention on the command line.
 187 Will use the remaining command line arguments as regular expressions
 188 for matching on group names.
 189
 190 For instance, if you want to brew on all the nnml groups, as well as
 191 groups with \"emacs\" in the name, you could say something like:
 192
 193 $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
 194   (interactive)
 195   )
 196
 197 ;;; Internal Functions:
 198
 199 ;; Store the current buffer.
 200 (defun gnus-soup-store (directory prefix headers format index)
 201   ;; Create the directory, if needed.
 202   (or (file-directory-p directory)
 203       (gnus-make-directory directory))
 204   (let* ((msg-buf (find-file-noselect
 205                    (concat directory prefix ".MSG")))
 206          (idx-buf (if (= index ?n)
 207                       nil
 208                     (find-file-noselect
 209                      (concat directory prefix ".IDX"))))
 210          (article-buf (current-buffer))
 211          from head-line beg type)
 212     (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
 213     (buffer-disable-undo msg-buf)
 214     (and idx-buf
 215          (progn
 216            (setq gnus-soup-buffers (cons idx-buf gnus-soup-buffers))
 217            (buffer-disable-undo idx-buf)))
 218     (save-excursion
 219       ;; Make sure the last char in the buffer is a newline.
 220       (goto-char (point-max))
 221       (or (= (current-column) 0)
 222           (insert "\n"))
 223       ;; Find the "from".
 224       (goto-char (point-min))
 225       (setq from
 226             (gnus-mail-strip-quoted-names
 227              (or (mail-fetch-field "from")
 228                  (mail-fetch-field "really-from")
 229                  (mail-fetch-field "sender"))))
 230       (goto-char (point-min))
 231       ;; Depending on what encoding is supposed to be used, we make
 232       ;; a soup header.
 233       (setq head-line
 234             (cond
 235              ((= gnus-soup-encoding-type ?n)
 236               (format "#! rnews %d\n" (buffer-size)))
 237              ((= gnus-soup-encoding-type ?m)
 238               (while (search-forward "\nFrom " nil t)
 239                 (replace-match "\n>From " t t))
 240               (concat "From " (or from "unknown")
 241                       " " (current-time-string) "\n"))
 242              ((= gnus-soup-encoding-type ?M)
 243               "\^a\^a\^a\^a\n")
 244              (t (error "Unsupported type: %c" gnus-soup-encoding-type))))
 245       ;; Insert the soup header and the article in the MSG buf.
 246       (set-buffer msg-buf)
 247       (goto-char (point-max))
 248       (insert head-line)
 249       (setq beg (point))
 250       (insert-buffer-substring article-buf)
 251       ;; Insert the index in the IDX buf.
 252       (cond ((= index ?c)
 253              (set-buffer idx-buf)
 254              (gnus-soup-insert-idx beg headers))
 255             ((/= index ?n)
 256              (error "Unknown index type: %c" type)))
 257       ;; Return the MSG buf.
 258       msg-buf)))
 259
 260 (defun gnus-soup-group-brew (group &optional not-all)
 261   "Enter GROUP and add all articles to a SOUP package.
 262 If NOT-ALL, don't pack ticked articles."
 263   (let ((gnus-expert-user t)
 264         (gnus-large-newsgroup nil))
 265     (when (gnus-summary-read-group group nil t)
 266       (let ((gnus-newsgroup-processable
 267              (if (not not-all)
 268                  (reverse (append gnus-newsgroup-marked
 269                                   gnus-newsgroup-unreads))
 270                (reverse gnus-newsgroup-unreads))))
 271         (gnus-soup-add-article nil))
 272       (gnus-summary-exit))))
 273
 274 (defun gnus-soup-insert-idx (offset header)
 275   ;; [number subject from date id references chars lines xref]
 276   (goto-char (point-max))
 277   (insert
 278    (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t%s\t\n"
 279            offset
 280            (or (mail-header-subject header) "(none)")
 281            (or (mail-header-from header) "(nobody)")
 282            (or (mail-header-date header) "")
 283            (or (mail-header-id header)
 284                (concat "soup-dummy-id-"
 285                        (mapconcat
 286                         (lambda (time) (int-to-string time))
 287                         (current-time) "-")))
 288            (or (mail-header-references header) "")
 289            (or (mail-header-chars header) 0)
 290            (or (mail-header-lines header) "0")
 291            (or (mail-header-xref header) ""))))
 292
 293 (defun gnus-soup-save-areas ()
 294   (gnus-soup-write-areas)
 295   (save-excursion
 296     (let (buf)
 297       (while gnus-soup-buffers
 298         (setq buf (car gnus-soup-buffers)
 299               gnus-soup-buffers (cdr gnus-soup-buffers))
 300         (if (not (buffer-name buf))
 301             ()
 302           (set-buffer buf)
 303           (and (buffer-modified-p) (save-buffer))
 304           (kill-buffer (current-buffer)))))
 305     (gnus-soup-write-prefixes)))
 306
 307 (defun gnus-soup-write-prefixes ()
 308   (let ((prefix gnus-soup-last-prefix))
 309     (save-excursion
 310       (while prefix
 311         (gnus-set-work-buffer)
 312         (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix)))
 313         (gnus-make-directory (caar prefix))
 314         (write-region (point-min) (point-max)
 315                       (concat (caar prefix) gnus-soup-prefix-file)
 316                       nil 'nomesg)
 317         (setq prefix (cdr prefix))))))
 318
 319 (defun gnus-soup-pack (dir packer)
 320   (let* ((files (mapconcat 'identity
 321                            '("AREAS" "*.MSG" "*.IDX" "INFO"
 322                              "LIST" "REPLIES" "COMMANDS" "ERRORS")
 323                            " "))
 324          (packer (if (< (string-match "%s" packer)
 325                         (string-match "%d" packer))
 326                      (format packer files
 327                              (string-to-int (gnus-soup-unique-prefix dir)))
 328                    (format packer
 329                            (string-to-int (gnus-soup-unique-prefix dir))
 330                            files)))
 331          (dir (expand-file-name dir)))
 332     (or (file-directory-p dir)
 333         (gnus-make-directory dir))
 334     (setq gnus-soup-areas nil)
 335     (message "Packing %s..." packer)
 336     (if (zerop (call-process "sh" nil nil nil "-c"
 337                              (concat "cd " dir " ; " packer)))
 338         (progn
 339           (call-process "sh" nil nil nil "-c"
 340                         (concat "cd " dir " ; rm " files))
 341           (message "Packing...done" packer))
 342       (error "Couldn't pack packet."))))
 343
 344 (defun gnus-soup-parse-areas (file)
 345   "Parse soup area file FILE.
 346 The result is a of vectors, each containing one entry from the AREA file.
 347 The vector contain five strings,
 348   [prefix name encoding description number]
 349 though the two last may be nil if they are missing."
 350   (let (areas)
 351     (save-excursion
 352       (set-buffer (find-file-noselect file 'force))
 353       (buffer-disable-undo (current-buffer))
 354       (goto-char (point-min))
 355       (while (not (eobp))
 356         (setq areas
 357               (cons (vector (gnus-soup-field)
 358                             (gnus-soup-field)
 359                             (gnus-soup-field)
 360                             (and (eq (preceding-char) ?\t)
 361                                  (gnus-soup-field))
 362                             (and (eq (preceding-char) ?\t)
 363                                  (string-to-int (gnus-soup-field))))
 364                     areas))
 365         (if (eq (preceding-char) ?\t)
 366             (beginning-of-line 2)))
 367       (kill-buffer (current-buffer)))
 368     areas))
 369
 370 (defun gnus-soup-parse-replies (file)
 371   "Parse soup REPLIES file FILE.
 372 The result is a of vectors, each containing one entry from the REPLIES
 373 file. The vector contain three strings, [prefix name encoding]."
 374   (let (replies)
 375     (save-excursion
 376       (set-buffer (find-file-noselect file))
 377       (buffer-disable-undo (current-buffer))
 378       (goto-char (point-min))
 379       (while (not (eobp))
 380         (setq replies
 381               (cons (vector (gnus-soup-field) (gnus-soup-field)
 382                             (gnus-soup-field))
 383                     replies))
 384         (if (eq (preceding-char) ?\t)
 385             (beginning-of-line 2)))
 386       (kill-buffer (current-buffer)))
 387     replies))
 388
 389 (defun gnus-soup-field ()
 390   (prog1
 391       (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
 392     (forward-char 1)))
 393
 394 (defun gnus-soup-read-areas ()
 395   (or gnus-soup-areas
 396       (setq gnus-soup-areas
 397             (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
 398
 399 (defun gnus-soup-write-areas ()
 400   "Write the AREAS file."
 401   (interactive)
 402   (when gnus-soup-areas
 403     (nnheader-temp-write (concat gnus-soup-directory "AREAS")
 404       (let ((areas gnus-soup-areas)
 405             area)
 406         (while (setq area (pop areas))
 407           (insert
 408            (format
 409             "%s\t%s\t%s%s\n"
 410             (gnus-soup-area-prefix area)
 411             (gnus-soup-area-name area)
 412             (gnus-soup-area-encoding area)
 413             (if (or (gnus-soup-area-description area)
 414                     (gnus-soup-area-number area))
 415                 (concat "\t" (or (gnus-soup-area-description
 416                                   area) "")
 417                         (if (gnus-soup-area-number area)
 418                             (concat "\t" (int-to-string
 419                                           (gnus-soup-area-number area)))
 420                           "")) ""))))))))
 421
 422 (defun gnus-soup-write-replies (dir areas)
 423   "Write a REPLIES file in DIR containing AREAS."
 424   (nnheader-temp-write (concat dir "REPLIES")
 425     (let (area)
 426       (while (setq area (pop areas))
 427         (insert (format "%s\t%s\t%s\n"
 428                         (gnus-soup-reply-prefix area)
 429                         (gnus-soup-reply-kind area)
 430                         (gnus-soup-reply-encoding area)))))))
 431
 432 (defun gnus-soup-area (group)
 433   (gnus-soup-read-areas)
 434   (let ((areas gnus-soup-areas)
 435         (real-group (gnus-group-real-name group))
 436         area result)
 437     (while areas
 438       (setq area (car areas)
 439             areas (cdr areas))
 440       (if (equal (gnus-soup-area-name area) real-group)
 441           (setq result area)))
 442     (or result
 443         (setq result
 444               (vector (gnus-soup-unique-prefix)
 445                       real-group
 446                       (format "%c%c%c"
 447                               gnus-soup-encoding-type
 448                               gnus-soup-index-type
 449                               (if (gnus-member-of-valid 'mail group) ?m ?n))
 450                       nil nil)
 451               gnus-soup-areas (cons result gnus-soup-areas)))
 452     result))
 453
 454 (defun gnus-soup-unique-prefix (&optional dir)
 455   (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
 456          (entry (assoc dir gnus-soup-last-prefix))
 457          gnus-soup-prev-prefix)
 458     (if entry
 459         ()
 460       (and (file-exists-p (concat dir gnus-soup-prefix-file))
 461            (condition-case nil
 462                (load (concat dir gnus-soup-prefix-file) nil t t)
 463              (error nil)))
 464       (setq gnus-soup-last-prefix
 465             (cons (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
 466                   gnus-soup-last-prefix)))
 467     (setcdr entry (1+ (cdr entry)))
 468     (gnus-soup-write-prefixes)
 469     (int-to-string (cdr entry))))
 470
 471 (defun gnus-soup-unpack-packet (dir unpacker packet)
 472   "Unpack PACKET into DIR using UNPACKER.
 473 Return whether the unpacking was successful."
 474   (gnus-make-directory dir)
 475   (message "Unpacking: %s" (format unpacker packet))
 476   (prog1
 477       (zerop (call-process
 478               "sh" nil nil nil "-c"
 479               (format "cd %s ; %s" (expand-file-name dir)
 480                       (format unpacker packet))))
 481     (message "Unpacking...done")))
 482
 483 (defun gnus-soup-send-packet (packet)
 484   (gnus-soup-unpack-packet
 485    gnus-soup-replies-directory gnus-soup-unpacker packet)
 486   (let ((replies (gnus-soup-parse-replies
 487                   (concat gnus-soup-replies-directory "REPLIES"))))
 488     (save-excursion
 489       (while replies
 490         (let* ((msg-file (concat gnus-soup-replies-directory
 491                                  (gnus-soup-reply-prefix (car replies))
 492                                  ".MSG"))
 493                (msg-buf (and (file-exists-p msg-file)
 494                              (find-file-noselect msg-file)))
 495                (tmp-buf (get-buffer-create " *soup send*"))
 496                beg end)
 497           (cond
 498            ((/= (gnus-soup-encoding-format
 499                  (gnus-soup-reply-encoding (car replies))) ?n)
 500             (error "Unsupported encoding"))
 501            ((null msg-buf)
 502             t)
 503            (t
 504             (buffer-disable-undo msg-buf)
 505             (buffer-disable-undo tmp-buf)
 506             (set-buffer msg-buf)
 507             (goto-char (point-min))
 508             (while (not (eobp))
 509               (or (looking-at "#! *rnews +\\([0-9]+\\)")
 510                   (error "Bad header."))
 511               (forward-line 1)
 512               (setq beg (point)
 513                     end (+ (point) (string-to-int
 514                                     (buffer-substring
 515                                      (match-beginning 1) (match-end 1)))))
 516               (switch-to-buffer tmp-buf)
 517               (erase-buffer)
 518               (insert-buffer-substring msg-buf beg end)
 519               (goto-char (point-min))
 520               (search-forward "\n\n")
 521               (forward-char -1)
 522               (insert mail-header-separator)
 523               (cond
 524                ((string= (gnus-soup-reply-kind (car replies)) "news")
 525                 (message "Sending news message to %s..."
 526                          (mail-fetch-field "newsgroups"))
 527                 (sit-for 1)
 528                 (gnus-inews-article))
 529                ((string= (gnus-soup-reply-kind (car replies)) "mail")
 530                 (message "Sending mail to %s..."
 531                          (mail-fetch-field "to"))
 532                 (sit-for 1)
 533                 (gnus-mail-send-and-exit))
 534                (t
 535                 (error "Unknown reply kind")))
 536               (set-buffer msg-buf)
 537               (goto-char end))
 538             (delete-file (buffer-file-name))
 539             (kill-buffer msg-buf)
 540             (kill-buffer tmp-buf)
 541             (message "Sent packet"))))
 542         (setq replies (cdr replies)))
 543       t)))
 544
 545 (provide 'gnus-soup)
 546
 547 ;;; gnus-soup.el ends here