mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-23 07:19:15 +00:00
Code Issues Releases Activity
5aa75bd889
emacs/lisp/gnus/nnsoup.el
Glenn Morris ae940284fa Add 2009 to copyright years.
2009-01-05 03:18:22 +00:00

813 lines
26 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; nnsoup.el --- SOUP access for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'nnheader)
(require 'nnmail)
(require 'gnus-soup)
(require 'gnus-msg)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnsoup)
(defvoo nnsoup-directory (nnheader-concat gnus-home-directory "SOUP/")
"*SOUP packet directory.")
(defvoo nnsoup-tmp-directory
(cond ((fboundp 'temp-directory) (temp-directory))
((boundp 'temporary-file-directory) temporary-file-directory)
("/tmp/"))
"*Where nnsoup will store temporary files.")
(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory)
"*Directory where outgoing packets will be composed.")
(defvoo nnsoup-replies-format-type ?u ;; u is USENET news format.
"*Format of the replies packages.")
(defvoo nnsoup-replies-index-type ?n
"*Index type of the replies packages.")
(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory)
"Active file.")
(defvoo nnsoup-packer (concat "tar cf - %s | gzip > "
(expand-file-name gnus-home-directory)
"Soupin%d.tgz")
"Format string command for packing a SOUP packet.
The SOUP files will be inserted where the %s is in the string.
This string MUST contain both %s and %d. The file number will be
inserted where %d appears.")
(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
"*Format string command for unpacking a SOUP packet.
The SOUP packet file name will be inserted at the %s.")
(defvoo nnsoup-packet-directory gnus-home-directory
"*Where nnsoup will look for incoming packets.")
(defvoo nnsoup-packet-regexp "Soupout"
"*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
(defvoo nnsoup-always-save t
"If non-nil commit the reply buffer on each message send.
This is necessary if using message mode outside Gnus with nnsoup as a
backend for the messages.")
(defconst nnsoup-version "nnsoup 0.0"
"nnsoup version.")
(defvoo nnsoup-status-string "")
(defvoo nnsoup-group-alist nil)
(defvoo nnsoup-current-prefix 0)
(defvoo nnsoup-replies-list nil)
(defvoo nnsoup-buffers nil)
(defvoo nnsoup-current-group nil)
(defvoo nnsoup-group-alist-touched nil)
(defvoo nnsoup-article-alist nil)
;;; Interface functions.
(nnoo-define-basics nnsoup)
(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
(nnsoup-possibly-change-group group)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
(articles sequence)
(use-nov t)
useful-areas this-area-seq msg-buf)
(if (stringp (car sequence))
;; We don't support fetching by Message-ID.
'headers
;; We go through all the areas and find which files the
;; articles in SEQUENCE come from.
(while (and areas sequence)
;; Peel off areas that are below sequence.
(while (and areas (< (cdar (car areas)) (car sequence)))
(setq areas (cdr areas)))
(when areas
;; This is a useful area.
(push (car areas) useful-areas)
(setq this-area-seq nil)
;; We take note whether this MSG has a corresponding IDX
;; for later use.
(when (or (= (gnus-soup-encoding-index
(gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
(not (file-exists-p
(nnsoup-file
(gnus-soup-area-prefix (nth 1 (car areas)))))))
(setq use-nov nil))
;; We assign the portion of `sequence' that is relevant to
;; this MSG packet to this packet.
(while (and sequence (<= (car sequence) (cdar (car areas))))
(push (car sequence) this-area-seq)
(setq sequence (cdr sequence)))
(setcar useful-areas (cons (nreverse this-area-seq)
(car useful-areas)))))
;; We now have a list of article numbers and corresponding
;; areas.
(setq useful-areas (nreverse useful-areas))
;; Two different approaches depending on whether all the MSG
;; files have corresponding IDX files. If they all do, we
;; simply return the relevant IDX files and let Gnus sort out
;; what lines are relevant. If some of the IDX files are
;; missing, we must return HEADs for all the articles.
(if use-nov
;; We have IDX files for all areas.
(progn
(while useful-areas
(goto-char (point-max))
(let ((b (point))
(number (car (nth 1 (car useful-areas))))
(index-buffer (nnsoup-index-buffer
(gnus-soup-area-prefix
(nth 2 (car useful-areas))))))
(when index-buffer
(insert-buffer-substring index-buffer)
(goto-char b)
;; We have to remove the index number entries and
;; insert article numbers instead.
(while (looking-at "[0-9]+")
(replace-match (int-to-string number) t t)
(incf number)
(forward-line 1))))
(setq useful-areas (cdr useful-areas)))
'nov)
;; We insert HEADs.
(while useful-areas
(setq articles (caar useful-areas)
useful-areas (cdr useful-areas))
(while articles
(when (setq msg-buf
(nnsoup-narrow-to-article
(car articles) (cdar useful-areas) 'head))
(goto-char (point-max))
(insert (format "221 %d Article retrieved.\n" (car articles)))
(insert-buffer-substring msg-buf)
(goto-char (point-max))
(insert ".\n"))
(setq articles (cdr articles))))
(nnheader-fold-continuation-lines)
'headers)))))
(deffoo nnsoup-open-server (server &optional defs)
(nnoo-change-server 'nnsoup server defs)
(when (not (file-exists-p nnsoup-directory))
(condition-case ()
(make-directory nnsoup-directory t)
(error t)))
(cond
((not (file-exists-p nnsoup-directory))
(nnsoup-close-server)
(nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
((not (file-directory-p (file-truename nnsoup-directory)))
(nnsoup-close-server)
(nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
(t
(nnsoup-read-active-file)
(nnheader-report 'nnsoup "Opened server %s using directory %s"
server nnsoup-directory)
t)))
(deffoo nnsoup-request-close ()
(nnsoup-write-active-file)
(nnsoup-write-replies)
(gnus-soup-save-areas)
;; Kill all nnsoup buffers.
(let (buffer)
(while nnsoup-buffers
(setq buffer (cdr (pop nnsoup-buffers)))
(and buffer
(buffer-name buffer)
(kill-buffer buffer))))
(setq nnsoup-group-alist nil
nnsoup-group-alist-touched nil
nnsoup-current-group nil
nnsoup-replies-list nil)
(nnoo-close-server 'nnoo)
t)
(deffoo nnsoup-request-article (id &optional newsgroup server buffer)
(nnsoup-possibly-change-group newsgroup)
(let (buf)
(save-excursion
(set-buffer (or buffer nntp-server-buffer))
(erase-buffer)
(when (and (not (stringp id))
(setq buf (nnsoup-narrow-to-article id)))
(insert-buffer-substring buf)
t))))
(deffoo nnsoup-request-group (group &optional server dont-check)
(nnsoup-possibly-change-group group)
(if dont-check
t
(let ((active (cadr (assoc group nnsoup-group-alist))))
(if (not active)
(nnheader-report 'nnsoup "No such group: %s" group)
(nnheader-insert
"211 %d %d %d %s\n"
(max (1+ (- (cdr active) (car active))) 0)
(car active) (cdr active) group)))))
(deffoo nnsoup-request-type (group &optional article)
(nnsoup-possibly-change-group group)
;; Try to guess the type based on the first article in the group.
(when (not article)
(setq article
(cdar (car (cddr (assoc group nnsoup-group-alist))))))
(if (not article)
'unknown
(let ((kind (gnus-soup-encoding-kind
(gnus-soup-area-encoding
(nth 1 (nnsoup-article-to-area
article nnsoup-current-group))))))
(cond ((= kind ?m) 'mail)
((= kind ?n) 'news)
(t 'unknown)))))
(deffoo nnsoup-close-group (group &optional server)
;; Kill all nnsoup buffers.
(let ((buffers nnsoup-buffers)
elem)
(while buffers
(when (equal (car (setq elem (pop buffers))) group)
(setq nnsoup-buffers (delq elem nnsoup-buffers))
(and (cdr elem) (buffer-name (cdr elem))
(kill-buffer (cdr elem))))))
t)
(deffoo nnsoup-request-list (&optional server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(unless nnsoup-group-alist
(nnsoup-read-active-file))
(let ((alist nnsoup-group-alist)
(standard-output (current-buffer))
entry)
(while (setq entry (pop alist))
(insert (car entry) " ")
(princ (cdadr entry))
(insert " ")
(princ (caadr entry))
(insert " y\n"))
t)))
(deffoo nnsoup-request-scan (group &optional server)
(nnsoup-unpack-packets))
(deffoo nnsoup-request-newgroups (date &optional server)
(nnsoup-request-list))
(deffoo nnsoup-request-list-newsgroups (&optional server)
nil)
(deffoo nnsoup-request-post (&optional server)
(nnsoup-store-reply "news")
t)
(deffoo nnsoup-request-mail (&optional server)
(nnsoup-store-reply "mail")
t)
(deffoo nnsoup-request-expire-articles (articles group &optional server force)
(nnsoup-possibly-change-group group)
(let* ((total-infolist (assoc group nnsoup-group-alist))
(active (cadr total-infolist))
(infolist (cddr total-infolist))
info range-list mod-time prefix)
(while infolist
(setq info (pop infolist)
range-list (gnus-uncompress-range (car info))
prefix (gnus-soup-area-prefix (nth 1 info)))
(when;; All the articles in this file are marked for expiry.
(and (or (setq mod-time (nth 5 (file-attributes
(nnsoup-file prefix))))
(setq mod-time (nth 5 (file-attributes
(nnsoup-file prefix t)))))
(gnus-sublist-p articles range-list)
;; This file is old enough.
(nnmail-expired-article-p group mod-time force))
;; Ok, we delete this file.
(when (ignore-errors
(nnheader-message
5 "Deleting %s in group %s..." (nnsoup-file prefix)
group)
(when (file-exists-p (nnsoup-file prefix))
(delete-file (nnsoup-file prefix)))
(nnheader-message
5 "Deleting %s in group %s..." (nnsoup-file prefix t)
group)
(when (file-exists-p (nnsoup-file prefix t))
(delete-file (nnsoup-file prefix t)))
t)
(setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
(setq articles (gnus-sorted-difference articles range-list))))
(when (not mod-time)
(setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
(if (cddr total-infolist)
(setcar active (caaadr (cdr total-infolist)))
(setcar active (1+ (cdr active))))
(nnsoup-write-active-file t)
;; Return the articles that weren't expired.
articles))
;;; Internal functions
(defun nnsoup-possibly-change-group (group &optional force)
(when (and group
(not (equal nnsoup-current-group group)))
(setq nnsoup-article-alist nil)
(setq nnsoup-current-group group))
t)
(defun nnsoup-read-active-file ()
(setq nnsoup-group-alist nil)
(when (file-exists-p nnsoup-active-file)
(ignore-errors
(load nnsoup-active-file t t t))
;; Be backwards compatible.
(when (and nnsoup-group-alist
(not (atom (caadar nnsoup-group-alist))))
(let ((alist nnsoup-group-alist)
entry e min max)
(while (setq e (cdr (setq entry (pop alist))))
(setq min (caaar e))
(setq max (cdar (car (last e))))
(setcdr entry (cons (cons min max) (cdr entry)))))
(setq nnsoup-group-alist-touched t))
nnsoup-group-alist))
(defun nnsoup-write-active-file (&optional force)
(when (and nnsoup-group-alist
(or force
nnsoup-group-alist-touched))
(setq nnsoup-group-alist-touched nil)
(with-temp-file nnsoup-active-file
(gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
(insert "\n")
(gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
(insert "\n"))))
(defun nnsoup-next-prefix ()
"Return the next free prefix."
(let (prefix)
(while (or (file-exists-p
(nnsoup-file (setq prefix (int-to-string
nnsoup-current-prefix))))
(file-exists-p (nnsoup-file prefix t)))
(incf nnsoup-current-prefix))
(incf nnsoup-current-prefix)
prefix))
(defun nnsoup-file-name (dir file)
"Return the full name of FILE (in any case) in DIR."
(let* ((case-fold-search t)
(files (directory-files dir t))
(regexp (concat (regexp-quote file) "$")))
(car (delq nil
(mapcar
(lambda (file)
(if (string-match regexp file)
file
nil))
files)))))
(defun nnsoup-read-areas ()
(let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas")))
(when areas-file
(save-excursion
(set-buffer nntp-server-buffer)
(let ((areas (gnus-soup-parse-areas areas-file))
entry number area lnum cur-prefix file)
;; Go through all areas in the new AREAS file.
(while (setq area (pop areas))
;; Change the name to the permanent name and move the files.
(setq cur-prefix (nnsoup-next-prefix))
(nnheader-message 5 "Incorporating file %s..." cur-prefix)
(when (file-exists-p
(setq file
(expand-file-name
(concat (gnus-soup-area-prefix area) ".IDX")
nnsoup-tmp-directory)))
(rename-file file (nnsoup-file cur-prefix)))
(when (file-exists-p
(setq file (expand-file-name
(concat (gnus-soup-area-prefix area) ".MSG")
nnsoup-tmp-directory)))
(rename-file file (nnsoup-file cur-prefix t))
(gnus-soup-set-area-prefix area cur-prefix)
;; Find the number of new articles in this area.
(setq number (nnsoup-number-of-articles area))
(if (not (setq entry (assoc (gnus-soup-area-name area)
nnsoup-group-alist)))
;; If this is a new area (group), we just add this info to
;; the group alist.
(push (list (gnus-soup-area-name area)
(cons 1 number)
(list (cons 1 number) area))
nnsoup-group-alist)
;; There are already articles in this group, so we add this
;; info to the end of the entry.
(nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
(+ lnum number))
area)))
(setcdr (cadr entry) (+ lnum number))))))
(nnsoup-write-active-file t)
(delete-file areas-file)))))
(defun nnsoup-number-of-articles (area)
(save-excursion
(cond
;; If the number is in the area info, we just return it.
((gnus-soup-area-number area)
(gnus-soup-area-number area))
;; If there is an index file, we just count the lines.
((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
(set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
(count-lines (point-min) (point-max)))
;; We do it the hard way - re-searching through the message
;; buffer.
(t
(set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
(unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist)
(nnsoup-dissect-buffer area))
(length (cdr (assoc (gnus-soup-area-prefix area)
nnsoup-article-alist)))))))
(defun nnsoup-dissect-buffer (area)
(let ((mbox-delim (concat "^" message-unix-mail-delimiter))
(format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
(i 0)
alist len)
(goto-char (point-min))
(cond
;; rnews batch format
((or (= format ?u)
(= format ?n)) ;; Gnus back compatibility.
(while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
(forward-line 1)
(push (list
(incf i) (point)
(progn
(forward-char (string-to-number (match-string 1)))
(point)))
alist)))
;; Unix mbox format
((= format ?m)
(while (looking-at mbox-delim)
(forward-line 1)
(push (list
(incf i) (point)
(progn
(if (re-search-forward mbox-delim nil t)
(beginning-of-line)
(goto-char (point-max)))
(point)))
alist)))
;; MMDF format
((= format ?M)
(while (looking-at "\^A\^A\^A\^A\n")
(forward-line 1)
(push (list
(incf i) (point)
(progn
(if (search-forward "\n\^A\^A\^A\^A\n" nil t)
(beginning-of-line)
(goto-char (point-max)))
(point)))
alist)))
;; Binary format
((or (= format ?B) (= format ?b))
(while (not (eobp))
(setq len (+ (* (char-after (point)) (expt 2.0 24))
(* (char-after (+ (point) 1)) (expt 2 16))
(* (char-after (+ (point) 2)) (expt 2 8))
(char-after (+ (point) 3))))
(push (list
(incf i) (+ (point) 4)
(progn
(forward-char (floor (+ len 4)))
(point)))
alist)))
(t
(error "Unknown format: %c" format)))
(push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist)))
(defun nnsoup-index-buffer (prefix &optional message)
(let* ((file (concat prefix (if message ".MSG" ".IDX")))
(buffer-name (concat " *nnsoup " file "*")))
(or (get-buffer buffer-name) ; File already loaded.
(when (file-exists-p (expand-file-name file nnsoup-directory))
(save-excursion ; Load the file.
(set-buffer (get-buffer-create buffer-name))
(buffer-disable-undo)
(push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
(nnheader-insert-file-contents
(expand-file-name file nnsoup-directory))
(current-buffer))))))
(defun nnsoup-file (prefix &optional message)
(expand-file-name
(concat prefix (if message ".MSG" ".IDX"))
nnsoup-directory))
(defun nnsoup-message-buffer (prefix)
(nnsoup-index-buffer prefix 'msg))
(defun nnsoup-unpack-packets ()
"Unpack all packets in `nnsoup-packet-directory'."
(let ((packets (directory-files
nnsoup-packet-directory t nnsoup-packet-regexp)))
(dolist (packet packets)
(nnheader-message 5 "nnsoup: unpacking %s..." packet)
(if (not (gnus-soup-unpack-packet
nnsoup-tmp-directory nnsoup-unpacker packet))
(nnheader-message 5 "Couldn't unpack %s" packet)
(delete-file packet)
(nnsoup-read-areas)
(nnheader-message 5 "Unpacking...done")))))
(defun nnsoup-narrow-to-article (article &optional area head)
(let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
(prefix (and area (gnus-soup-area-prefix (nth 1 area))))
(msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
beg end)
(when area
(save-excursion
(cond
;; There is no MSG file.
((null msg-buf)
nil)
;; We use the index file to find out where the article
;; begins and ends.
((and (= (gnus-soup-encoding-index
(gnus-soup-area-encoding (nth 1 area)))
?c)
(file-exists-p (nnsoup-file prefix)))
(set-buffer (nnsoup-index-buffer prefix))
(widen)
(goto-char (point-min))
(forward-line (- article (caar area)))
(setq beg (read (current-buffer)))
(forward-line 1)
(if (looking-at "[0-9]+")
(progn
(setq end (read (current-buffer)))
(set-buffer msg-buf)
(widen)
(let ((format (gnus-soup-encoding-format
(gnus-soup-area-encoding (nth 1 area)))))
(goto-char end)
(when (or (= format ?u) (= format ?n) (= format ?m))
(setq end (progn (forward-line -1) (point))))))
(set-buffer msg-buf))
(widen)
(narrow-to-region beg (or end (point-max))))
(t
(set-buffer msg-buf)
(widen)
(unless (assoc (gnus-soup-area-prefix (nth 1 area))
nnsoup-article-alist)
(nnsoup-dissect-buffer (nth 1 area)))
(let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix
(nth 1 area))
nnsoup-article-alist)))))
(when entry
(narrow-to-region (cadr entry) (caddr entry))))))
(goto-char (point-min))
(if (not head)
()
(narrow-to-region
(point-min)
(if (search-forward "\n\n" nil t)
(1- (point))
(point-max))))
msg-buf))))
;;;###autoload
(defun nnsoup-pack-replies ()
"Make an outbound package of SOUP replies."
(interactive)
(unless (file-exists-p nnsoup-replies-directory)
(nnheader-message 5 "No such directory: %s" nnsoup-replies-directory))
;; Write all data buffers.
(gnus-soup-save-areas)
;; Write the active file.
(nnsoup-write-active-file)
;; Write the REPLIES file.
(nnsoup-write-replies)
;; Check whether there is anything here.
(when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
(error "No files to pack"))
;; Pack all these files into a SOUP packet.
(gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
(defun nnsoup-write-replies ()
"Write the REPLIES file."
(when nnsoup-replies-list
(gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
(setq nnsoup-replies-list nil)))
(defun nnsoup-article-to-area (article group)
"Return the area that ARTICLE in GROUP is located in."
(let ((areas (cddr (assoc group nnsoup-group-alist))))
(while (and areas (< (cdar (car areas)) article))
(setq areas (cdr areas)))
(and areas (car areas))))
(defvar nnsoup-old-functions
(list message-send-mail-real-function message-send-news-function))
;;;###autoload
(defun nnsoup-set-variables ()
"Use the SOUP methods for posting news and mailing mail."
(interactive)
(setq message-send-news-function 'nnsoup-request-post)
(setq message-send-mail-real-function 'nnsoup-request-mail))
;;;###autoload
(defun nnsoup-revert-variables ()
"Revert posting and mailing methods to the standard Emacs methods."
(interactive)
(setq message-send-mail-real-function (car nnsoup-old-functions))
(setq message-send-news-function (cadr nnsoup-old-functions)))
(defun nnsoup-store-reply (kind)
;; Mostly stolen from `message.el'.
(require 'mail-utils)
(let ((tembuf (generate-new-buffer " message temp"))
(case-fold-search nil)
delimline
(mailbuf (current-buffer)))
(unwind-protect
(save-excursion
(save-restriction
(message-narrow-to-headers)
(if (equal kind "mail")
(message-generate-headers message-required-mail-headers)
(message-generate-headers message-required-news-headers)))
(set-buffer tembuf)
(erase-buffer)
(insert-buffer-substring mailbuf)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
;; Remove some headers.
(message-remove-header message-ignored-mail-headers t))
(goto-char (point-max))
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
(let ((case-fold-search t))
;; Change header-delimiter to be what sendmail expects.
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(backward-char 1)
(setq delimline (point-marker))
(goto-char (1+ delimline))
(let ((msg-buf
(gnus-soup-store
nnsoup-replies-directory
(nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
nnsoup-replies-index-type))
(num 0))
(when (and msg-buf (bufferp msg-buf))
(save-excursion
(set-buffer msg-buf)
(goto-char (point-min))
(while (re-search-forward "^#! *rnews" nil t)
(incf num))
(when nnsoup-always-save
(save-buffer)))
(nnheader-message 5 "Stored %d messages" num)))
(nnsoup-write-replies)
(kill-buffer tembuf))))))
(defun nnsoup-kind-to-prefix (kind)
(unless nnsoup-replies-list
(setq nnsoup-replies-list
(gnus-soup-parse-replies
(expand-file-name "REPLIES" nnsoup-replies-directory))))
(let ((replies nnsoup-replies-list))
(while (and replies
(not (string= kind (gnus-soup-reply-kind (car replies)))))
(setq replies (cdr replies)))
(if replies
(gnus-soup-reply-prefix (car replies))
(push (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
kind
(format "%c%c%c"
nnsoup-replies-format-type
nnsoup-replies-index-type
(if (string= kind "news")
?n ?m)))
nnsoup-replies-list)
(gnus-soup-reply-prefix (car nnsoup-replies-list)))))
(defun nnsoup-make-active ()
"(Re-)create the SOUP active file."
(interactive)
(let ((files (sort (directory-files nnsoup-directory t "IDX$")
(lambda (f1 f2)
(< (progn (string-match "/\\([0-9]+\\)\\." f1)
(string-to-number (match-string 1 f1)))
(progn (string-match "/\\([0-9]+\\)\\." f2)
(string-to-number (match-string 1 f2)))))))
active group lines ident elem min)
(set-buffer (get-buffer-create " *nnsoup work*"))
(dolist (file files)
(nnheader-message 5 "Doing %s..." file)
(erase-buffer)
(nnheader-insert-file-contents file)
(goto-char (point-min))
(if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
(setq group "unknown")
(setq group (match-string 2)))
(setq lines (count-lines (point-min) (point-max)))
(setq ident (progn (string-match
"/\\([0-9]+\\)\\." file)
(match-string 1 file)))
(if (not (setq elem (assoc group active)))
(push (list group (cons 1 lines)
(list (cons 1 lines)
(vector ident group "ucm" "" lines)))
active)
(nconc elem
(list
(list (cons (1+ (setq min (cdadr elem)))
(+ min lines))
(vector ident group "ucm" "" lines))))
(setcdr (cadr elem) (+ min lines))))
(nnheader-message 5 "")
(setq nnsoup-group-alist active)
(nnsoup-write-active-file t)))
(defun nnsoup-delete-unreferenced-message-files ()
"Delete any *.MSG and *.IDX files that aren't known by nnsoup."
(interactive)
(let* ((known (apply 'nconc (mapcar
(lambda (ga)
(mapcar
(lambda (area)
(gnus-soup-area-prefix (cadr area)))
(cddr ga)))
nnsoup-group-alist)))
(regexp "\\.MSG$\\|\\.IDX$")
(files (directory-files nnsoup-directory nil regexp))
non-files)
;; Find all files that aren't known by nnsoup.
(dolist (file files)
(string-match regexp file)
(unless (member (substring file 0 (match-beginning 0)) known)
(push file non-files)))
;; Sort and delete the files.
(setq non-files (sort non-files 'string<))
(map-y-or-n-p "Delete file %s? "
(lambda (file) (delete-file
(expand-file-name file nnsoup-directory)))
non-files)))
(provide 'nnsoup)
;; arch-tag: b0451389-5703-4450-9425-f66f6b38c828
;;; nnsoup.el ends here
Reference in New Issue View Git Blame Copy Permalink