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) t)
 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) t))
 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         (entry (gnus-gethash group gnus-newsrc-hashtb)))
 266     (when (or (null entry)
 267               (eq (car entry) t)
 268               (and (car entry)
 269                    (> (car entry) 0))
 270               (and (not not-all)
 271                    (gnus-range-length (cdr (assq 'tick (gnus-info-marks
 272                                                         (nth 2 entry)))))))
 273       (when (gnus-summary-read-group group nil t)
 274         (let ((gnus-newsgroup-processable
 275                (if (not not-all)
 276                    (reverse (append gnus-newsgroup-marked
 277                                     gnus-newsgroup-unreads))
 278                  (reverse gnus-newsgroup-unreads))))
 279           (gnus-soup-add-article nil))
 280         (gnus-summary-exit)))))
 281
 282 (defun gnus-soup-insert-idx (offset header)
 283   ;; [number subject from date id references chars lines xref]
 284   (goto-char (point-max))
 285   (insert
 286    (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t%s\t\n"
 287            offset
 288            (or (mail-header-subject header) "(none)")
 289            (or (mail-header-from header) "(nobody)")
 290            (or (mail-header-date header) "")
 291            (or (mail-header-id header)
 292                (concat "soup-dummy-id-"
 293                        (mapconcat
 294                         (lambda (time) (int-to-string time))
 295                         (current-time) "-")))
 296            (or (mail-header-references header) "")
 297            (or (mail-header-chars header) 0)
 298            (or (mail-header-lines header) "0")
 299            (or (mail-header-xref header) ""))))
 300
 301 (defun gnus-soup-save-areas ()
 302   (gnus-soup-write-areas)
 303   (save-excursion
 304     (let (buf)
 305       (while gnus-soup-buffers
 306         (setq buf (car gnus-soup-buffers)
 307               gnus-soup-buffers (cdr gnus-soup-buffers))
 308         (if (not (buffer-name buf))
 309             ()
 310           (set-buffer buf)
 311           (and (buffer-modified-p) (save-buffer))
 312           (kill-buffer (current-buffer)))))
 313     (gnus-soup-write-prefixes)))
 314
 315 (defun gnus-soup-write-prefixes ()
 316   (let ((prefix gnus-soup-last-prefix))
 317     (save-excursion
 318       (while prefix
 319         (gnus-set-work-buffer)
 320         (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix)))
 321         (gnus-make-directory (caar prefix))
 322         (write-region (point-min) (point-max)
 323                       (concat (caar prefix) gnus-soup-prefix-file)
 324                       nil 'nomesg)
 325         (setq prefix (cdr prefix))))))
 326
 327 (defun gnus-soup-pack (dir packer)
 328   (let* ((files (mapconcat 'identity
 329                            '("AREAS" "*.MSG" "*.IDX" "INFO"
 330                              "LIST" "REPLIES" "COMMANDS" "ERRORS")
 331                            " "))
 332          (packer (if (< (string-match "%s" packer)
 333                         (string-match "%d" packer))
 334                      (format packer files
 335                              (string-to-int (gnus-soup-unique-prefix dir)))
 336                    (format packer
 337                            (string-to-int (gnus-soup-unique-prefix dir))
 338                            files)))
 339          (dir (expand-file-name dir)))
 340     (or (file-directory-p dir)
 341         (gnus-make-directory dir))
 342     (setq gnus-soup-areas nil)
 343     (message "Packing %s..." packer)
 344     (if (zerop (call-process "sh" nil nil nil "-c"
 345                              (concat "cd " dir " ; " packer)))
 346         (progn
 347           (call-process "sh" nil nil nil "-c"
 348                         (concat "cd " dir " ; rm " files))
 349           (message "Packing...done" packer))
 350       (error "Couldn't pack packet."))))
 351
 352 (defun gnus-soup-parse-areas (file)
 353   "Parse soup area file FILE.
 354 The result is a of vectors, each containing one entry from the AREA file.
 355 The vector contain five strings,
 356   [prefix name encoding description number]
 357 though the two last may be nil if they are missing."
 358   (let (areas)
 359     (save-excursion
 360       (set-buffer (find-file-noselect file 'force))
 361       (buffer-disable-undo (current-buffer))
 362       (goto-char (point-min))
 363       (while (not (eobp))
 364         (setq areas
 365               (cons (vector (gnus-soup-field)
 366                             (gnus-soup-field)
 367                             (gnus-soup-field)
 368                             (and (eq (preceding-char) ?\t)
 369                                  (gnus-soup-field))
 370                             (and (eq (preceding-char) ?\t)
 371                                  (string-to-int (gnus-soup-field))))
 372                     areas))
 373         (if (eq (preceding-char) ?\t)
 374             (beginning-of-line 2)))
 375       (kill-buffer (current-buffer)))
 376     areas))
 377
 378 (defun gnus-soup-parse-replies (file)
 379   "Parse soup REPLIES file FILE.
 380 The result is a of vectors, each containing one entry from the REPLIES
 381 file. The vector contain three strings, [prefix name encoding]."
 382   (let (replies)
 383     (save-excursion
 384       (set-buffer (find-file-noselect file))
 385       (buffer-disable-undo (current-buffer))
 386       (goto-char (point-min))
 387       (while (not (eobp))
 388         (setq replies
 389               (cons (vector (gnus-soup-field) (gnus-soup-field)
 390                             (gnus-soup-field))
 391                     replies))
 392         (if (eq (preceding-char) ?\t)
 393             (beginning-of-line 2)))
 394       (kill-buffer (current-buffer)))
 395     replies))
 396
 397 (defun gnus-soup-field ()
 398   (prog1
 399       (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
 400     (forward-char 1)))
 401
 402 (defun gnus-soup-read-areas ()
 403   (or gnus-soup-areas
 404       (setq gnus-soup-areas
 405             (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
 406
 407 (defun gnus-soup-write-areas ()
 408   "Write the AREAS file."
 409   (interactive)
 410   (when gnus-soup-areas
 411     (nnheader-temp-write (concat gnus-soup-directory "AREAS")
 412       (let ((areas gnus-soup-areas)
 413             area)
 414         (while (setq area (pop areas))
 415           (insert
 416            (format
 417             "%s\t%s\t%s%s\n"
 418             (gnus-soup-area-prefix area)
 419             (gnus-soup-area-name area)
 420             (gnus-soup-area-encoding area)
 421             (if (or (gnus-soup-area-description area)
 422                     (gnus-soup-area-number area))
 423                 (concat "\t" (or (gnus-soup-area-description
 424                                   area) "")
 425                         (if (gnus-soup-area-number area)
 426                             (concat "\t" (int-to-string
 427                                           (gnus-soup-area-number area)))
 428                           "")) ""))))))))
 429
 430 (defun gnus-soup-write-replies (dir areas)
 431   "Write a REPLIES file in DIR containing AREAS."
 432   (nnheader-temp-write (concat dir "REPLIES")
 433     (let (area)
 434       (while (setq area (pop areas))
 435         (insert (format "%s\t%s\t%s\n"
 436                         (gnus-soup-reply-prefix area)
 437                         (gnus-soup-reply-kind area)
 438                         (gnus-soup-reply-encoding area)))))))
 439
 440 (defun gnus-soup-area (group)
 441   (gnus-soup-read-areas)
 442   (let ((areas gnus-soup-areas)
 443         (real-group (gnus-group-real-name group))
 444         area result)
 445     (while areas
 446       (setq area (car areas)
 447             areas (cdr areas))
 448       (if (equal (gnus-soup-area-name area) real-group)
 449           (setq result area)))
 450     (or result
 451         (setq result
 452               (vector (gnus-soup-unique-prefix)
 453                       real-group
 454                       (format "%c%c%c"
 455                               gnus-soup-encoding-type
 456                               gnus-soup-index-type
 457                               (if (gnus-member-of-valid 'mail group) ?m ?n))
 458                       nil nil)
 459               gnus-soup-areas (cons result gnus-soup-areas)))
 460     result))
 461
 462 (defun gnus-soup-unique-prefix (&optional dir)
 463   (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
 464          (entry (assoc dir gnus-soup-last-prefix))
 465          gnus-soup-prev-prefix)
 466     (if entry
 467         ()
 468       (and (file-exists-p (concat dir gnus-soup-prefix-file))
 469            (condition-case nil
 470                (load (concat dir gnus-soup-prefix-file) nil t t)
 471              (error nil)))
 472       (setq gnus-soup-last-prefix
 473             (cons (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
 474                   gnus-soup-last-prefix)))
 475     (setcdr entry (1+ (cdr entry)))
 476     (gnus-soup-write-prefixes)
 477     (int-to-string (cdr entry))))
 478
 479 (defun gnus-soup-unpack-packet (dir unpacker packet)
 480   "Unpack PACKET into DIR using UNPACKER.
 481 Return whether the unpacking was successful."
 482   (gnus-make-directory dir)
 483   (message "Unpacking: %s" (format unpacker packet))
 484   (prog1
 485       (zerop (call-process
 486               "sh" nil nil nil "-c"
 487               (format "cd %s ; %s" (expand-file-name dir)
 488                       (format unpacker packet))))
 489     (message "Unpacking...done")))
 490
 491 (defun gnus-soup-send-packet (packet)
 492   (gnus-soup-unpack-packet
 493    gnus-soup-replies-directory gnus-soup-unpacker packet)
 494   (let ((replies (gnus-soup-parse-replies
 495                   (concat gnus-soup-replies-directory "REPLIES"))))
 496     (save-excursion
 497       (while replies
 498         (let* ((msg-file (concat gnus-soup-replies-directory
 499                                  (gnus-soup-reply-prefix (car replies))
 500                                  ".MSG"))
 501                (msg-buf (and (file-exists-p msg-file)
 502                              (find-file-noselect msg-file)))
 503                (tmp-buf (get-buffer-create " *soup send*"))
 504                beg end)
 505           (cond
 506            ((/= (gnus-soup-encoding-format
 507                  (gnus-soup-reply-encoding (car replies))) ?n)
 508             (error "Unsupported encoding"))
 509            ((null msg-buf)
 510             t)
 511            (t
 512             (buffer-disable-undo msg-buf)
 513             (buffer-disable-undo tmp-buf)
 514             (set-buffer msg-buf)
 515             (goto-char (point-min))
 516             (while (not (eobp))
 517               (or (looking-at "#! *rnews +\\([0-9]+\\)")
 518                   (error "Bad header."))
 519               (forward-line 1)
 520               (setq beg (point)
 521                     end (+ (point) (string-to-int
 522                                     (buffer-substring
 523                                      (match-beginning 1) (match-end 1)))))
 524               (switch-to-buffer tmp-buf)
 525               (erase-buffer)
 526               (insert-buffer-substring msg-buf beg end)
 527               (goto-char (point-min))
 528               (search-forward "\n\n")
 529               (forward-char -1)
 530               (insert mail-header-separator)
 531               (cond
 532                ((string= (gnus-soup-reply-kind (car replies)) "news")
 533                 (message "Sending news message to %s..."
 534                          (mail-fetch-field "newsgroups"))
 535                 (sit-for 1)
 536                 (gnus-inews-article))
 537                ((string= (gnus-soup-reply-kind (car replies)) "mail")
 538                 (message "Sending mail to %s..."
 539                          (mail-fetch-field "to"))
 540                 (sit-for 1)
 541                 (gnus-mail-send-and-exit))
 542                (t
 543                 (error "Unknown reply kind")))
 544               (set-buffer msg-buf)
 545               (goto-char end))
 546             (delete-file (buffer-file-name))
 547             (kill-buffer msg-buf)
 548             (kill-buffer tmp-buf)
 549             (message "Sent packet"))))
 550         (setq replies (cdr replies)))
 551       t)))
 552
 553 (provide 'gnus-soup)
 554
 555 ;;; gnus-soup.el ends here