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