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