Function: nnml-request-compact-group
nnml-request-compact-group is a byte-compiled function defined in
nnml.el.gz.
Signature
(nnml-request-compact-group GROUP &optional SERVER SAVE)
Source Code
;; Defined in /usr/src/emacs/lisp/gnus/nnml.el.gz
;;;
;;; Group and server compaction. -- dvl
;;;
;; #### FIXME: this function handles self Xref: entry correctly, but I don't
;; #### know how to handle external cross-references. I actually don't know if
;; #### this is handled correctly elsewhere. For instance, what happens if you
;; #### move all articles to a new group (that's what people do for manual
;; #### compaction) ?
;; #### NOTE: the function below handles the article backlog. This is
;; #### conceptually the wrong place to do it because the backend is at a
;; #### lower level. However, this is the only place where we have the needed
;; #### information to do the job. Ideally, this function should not handle
;; #### the backlog by itself, but return a list of moved groups / articles to
;; #### the caller. This will become important to avoid code duplication when
;; #### other backends get a compaction feature. Also, note that invalidating
;; #### the "original article buffer" is already done at an upper level.
;; Shouldn't `nnml-request-compact-group' be interactive? --rsteib
(defun nnml-request-compact-group (group &optional server save)
(nnml-possibly-change-directory group server)
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(sort (nnml-current-group-article-to-file-alist)
#'car-less-than-car)))
(if (not nnml-article-file-alist)
;; The group is empty: do nothing but return t
t
;; The group is not empty:
(let* ((group-full-name
(gnus-group-prefixed-name
group
(gnus-server-to-method (format "nnml:%s" server))))
(info (gnus-get-info group-full-name))
(new-number 1)
compacted)
(let ((articles nnml-article-file-alist)
article)
(while (setq article (pop articles))
(let ((old-number (car article)))
(when (> old-number new-number)
;; There is a gap here:
(let ((old-number-string (int-to-string old-number))
(new-number-string (int-to-string new-number)))
(setq compacted t)
;; #### NOTE: `nnml-article-to-file' calls
;; #### `nnml-update-file-alist' (which in turn calls
;; #### `nnml-current-group-article-to-file-alist', which
;; #### might use the NOV database). This might turn out to be
;; #### inefficient. In that case, we will do the work
;; #### manually.
;; 1/ Move the article to a new file:
(let* ((oldfile (nnml-article-to-file old-number))
(newfile
(replace-regexp-in-string
;; nnml-use-compressed-files might be any string, but
;; probably it's sufficient to take into account only
;; "\\.[a-z0-9]+". Note that we can't only use the
;; value of nnml-use-compressed-files because old
;; articles might have been saved with a different
;; value.
(concat
"\\(" old-number-string "\\)\\(\\(\\.[a-z0-9]+\\)?\\)$")
(concat new-number-string "\\2")
oldfile)))
(with-current-buffer nntp-server-buffer
(nnmail-find-file oldfile)
;; Update the Xref header in the article itself:
(when (and (re-search-forward "^Xref: [^ ]+ " nil t)
(re-search-forward
(concat "\\<"
(regexp-quote
(concat group ":" old-number-string))
"\\>")
(point-at-eol) t))
(replace-match
(concat group ":" new-number-string)))
;; Save to the new file:
(nnmail-write-region (point-min) (point-max) newfile))
(condition-case ()
(funcall nnmail-delete-file-function oldfile)
(file-error
(message "Couldn't delete %s" oldfile))))
;; 2/ Update all marks for this article:
;; #### NOTE: it is possible that the new article number
;; #### already belongs to a range, whereas the corresponding
;; #### article doesn't exist (for example, if you delete an
;; #### article). For that reason, it is important to update
;; #### the ranges (meaning remove nonexistent articles) before
;; #### doing anything on them.
;; 2 a/ read articles:
(let ((read (gnus-info-read info)))
(setq read (gnus-remove-from-range read (list new-number)))
(when (gnus-member-of-range old-number read)
(setq read (gnus-remove-from-range read (list old-number)))
(setq read (gnus-add-to-range read (list new-number))))
(setf (gnus-info-read info) read))
;; 2 b/ marked articles:
(let ((oldmarks (gnus-info-marks info))
mark newmarks)
(while (setq mark (pop oldmarks))
(setcdr mark (gnus-remove-from-range (cdr mark)
(list new-number)))
(when (gnus-member-of-range old-number (cdr mark))
(setcdr mark (gnus-remove-from-range (cdr mark)
(list old-number)))
(setcdr mark (gnus-add-to-range (cdr mark)
(list new-number))))
(push mark newmarks))
(setf (gnus-info-marks info) newmarks))
;; 3/ Update the NOV entry for this article:
(unless nnml-nov-is-evil
(with-current-buffer (nnml-open-nov group)
(when (nnheader-find-nov-line old-number)
;; Replace the article number:
(looking-at old-number-string)
(replace-match new-number-string nil t)
;; Update the Xref header:
(when (re-search-forward
(concat "\\(Xref:[^\t\n]* \\)\\<"
(regexp-quote
(concat group ":" old-number-string))
"\\>")
(point-at-eol) t)
(replace-match
(concat "\\1" group ":" new-number-string))))))
;; 4/ Possibly remove the article from the backlog:
(when gnus-keep-backlog
;; #### NOTE: instead of removing the article, we could
;; #### modify the backlog to reflect the numbering change,
;; #### but I don't think it's worth it.
(gnus-backlog-remove-article group-full-name old-number)
(gnus-backlog-remove-article group-full-name new-number))))
(setq new-number (1+ new-number)))))
(if (not compacted)
;; No compaction had to be done:
t
;; Some articles have actually been renamed:
;; 1/ Rebuild active information:
(let ((entry (assoc group nnml-group-alist))
(active (cons 1 (1- new-number))))
(setq nnml-group-alist (delq entry nnml-group-alist))
(push (list group active) nnml-group-alist)
;; Update the active hashtable to let the *Group* buffer display
;; up-to-date lines. I don't think that either gnus-newsrc-hashtb or
;; gnus-newwrc-alist are out of date, since all we did is to modify
;; the info of the group internally.
(gnus-set-active group-full-name active))
;; 1 bis/
;; #### NOTE: normally, we should save the overview (NOV) file
;; #### here. However, there is no such function as
;; #### nnml-save-nov for a single group. Only for all
;; #### groups. Gnus inconsistency is getting worse every
;; #### day... ;; 3/ Save everything if this was not part of
;; #### a bigger operation:
(if (not save)
;; Nothing to save (yet):
t
;; Something to save:
;; a/ Save the NOV databases:
;; #### NOTE: this should be done directory per directory in 1bis
;; #### above. See comment there.
(nnml-save-nov)
;; b/ Save the active file:
(nnmail-save-active nnml-group-alist nnml-active-file)
t)))))