mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-22 07:09:54 +00:00
Code Issues Releases Activity

Merge changes made in Gnus master

Browse Source 
2012-09-05 Julien Danjou <julien@danjou.info>
* gnus-srvr.el (gnus-server-open-server): Don't message on failure:
  this hide the real reason with a message giving absolutely no hint.

2012-09-05 Lars Ingebrigtsen <larsi@gnus.org>
* gnus-group.el (gnus-group-mark-article-read): Propagate the read mark
  to the backend (bug#11804).
* message.el (message-insert-newsgroups): Don't insert newsgroup
  duplicates (bug#12275).

2012-09-05 John Wiegley <johnw@newartisans.com>
* gnus.el (gnus-expand-group-parameters): Allow regexp substitutions in
  sieve rules.

2012-09-05 Jan Tatarik <jan.tatarik@gmail.com>
* gnus-score.el (gnus-score-decode-text-parts): Use #' for the local
  function.
* gnus-logic.el (gnus-advanced-body): Allow scoring on decoded bodies.
* gnus-score.el (gnus-score-decode-text-parts): Ditto.

2012-09-05 Magnus Henoch <magnus.henoch@gmail.com>
* nnmaildir.el: Make nnmaildir understand and write maildir flags.
  That is, rename files from "unique:2," to "unique:2,S" for "seen", etc.
  This should make nnmaildir more usable with offlineimap.
This commit is contained in:
Gnus developers 2012-09-05 22:35:32 +00:00 committed by Katsumi Yamaoka
parent 20ef56dbc8
commit 350a188850
8 changed files with 487 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
lisp/gnus/ChangeLog
View File

@ -1,3 +1,36 @@
2012-09-05 Julien Danjou <julien@danjou.info>
* gnus-srvr.el (gnus-server-open-server): Don't message on failure:
this hide the real reason with a message giving absolutely no hint.
2012-09-05 Lars Ingebrigtsen <larsi@gnus.org>
* gnus-group.el (gnus-group-mark-article-read): Propagate the read mark
to the backend (bug#11804).
* message.el (message-insert-newsgroups): Don't insert newsgroup
duplicates (bug#12275).
2012-09-05 John Wiegley <johnw@newartisans.com>
* gnus.el (gnus-expand-group-parameters): Allow regexp substitutions in
sieve rules.
2012-09-05 Jan Tatarik <jan.tatarik@gmail.com>
* gnus-score.el (gnus-score-decode-text-parts): Use #' for the local
function.
* gnus-logic.el (gnus-advanced-body): Allow scoring on decoded bodies.
* gnus-score.el (gnus-score-decode-text-parts): Ditto.
2012-09-05 Magnus Henoch <magnus.henoch@gmail.com>
* nnmaildir.el: Make nnmaildir understand and write maildir flags.
That is, rename files from "unique:2," to "unique:2,S" for "seen", etc.
This should make nnmaildir more usable with offlineimap.
2012-09-03 Lars Ingebrigtsen <larsi@gnus.org>
* gnus-notifications.el (gnus-notifications-notify): Use it.

2
lisp/gnus/gnus-group.el
View File

@ -4670,6 +4670,8 @@ you the groups that have both dormant articles and cached articles."
(setq mark gnus-expirable-mark))
(setq mark (gnus-request-update-mark
group article mark))
(gnus-request-set-mark
group (list (list (list article) 'add '(read))))
(gnus-mark-article-as-read article mark)
(setq gnus-newsgroup-active (gnus-active group))
(when active

73
lisp/gnus/gnus-logic.el
View File

@ -180,46 +180,51 @@
(setq header "article"))
(with-current-buffer nntp-server-buffer
(let* ((request-func (cond ((string= "head" header)
'gnus-request-head)
((string= "body" header)
'gnus-request-body)
(t 'gnus-request-article)))
ofunc article)
'gnus-request-head)
;; We need to peek at the headers to detect the
;; content encoding
((string= "body" header)
'gnus-request-article)
(t 'gnus-request-article)))
ofunc article handles)
;; Not all backends support partial fetching. In that case, we
;; just fetch the entire article.
(unless (gnus-check-backend-function
(intern (concat "request-" header))
gnus-newsgroup-name)
(setq ofunc request-func)
(setq request-func 'gnus-request-article))
(intern (concat "request-" header))
gnus-newsgroup-name)
(setq ofunc request-func)
(setq request-func 'gnus-request-article))
(setq article (mail-header-number gnus-advanced-headers))
(gnus-message 7 "Scoring article %s..." article)
(when (funcall request-func article gnus-newsgroup-name)
(goto-char (point-min))
;; If just parts of the article is to be searched and the
;; backend didn't support partial fetching, we just narrow to
;; the relevant parts.
(when ofunc
(if (eq ofunc 'gnus-request-head)
(narrow-to-region
(point)
(or (search-forward "\n\n" nil t) (point-max)))
(narrow-to-region
(or (search-forward "\n\n" nil t) (point))
(point-max))))
(let* ((case-fold-search (not (eq (downcase (symbol-name type))
(symbol-name type))))
(search-func
(cond ((memq type '(r R regexp Regexp))
're-search-forward)
((memq type '(s S string String))
'search-forward)
(t
(error "Invalid match type: %s" type)))))
(goto-char (point-min))
(prog1
(funcall search-func match nil t)
(widen)))))))
(when (string= "body" header)
(setq handles (gnus-score-decode-text-parts)))
(goto-char (point-min))
;; If just parts of the article is to be searched and the
;; backend didn't support partial fetching, we just narrow to
;; the relevant parts.
(when ofunc
(if (eq ofunc 'gnus-request-head)
(narrow-to-region
(point)
(or (search-forward "\n\n" nil t) (point-max)))
(narrow-to-region
(or (search-forward "\n\n" nil t) (point))
(point-max))))
(let* ((case-fold-search (not (eq (downcase (symbol-name type))
(symbol-name type))))
(search-func
(cond ((memq type '(r R regexp Regexp))
're-search-forward)
((memq type '(s S string String))
'search-forward)
(t
(error "Invalid match type: %s" type)))))
(goto-char (point-min))
(prog1
(funcall search-func match nil t)
(widen)))
(when handles (mm-destroy-parts handles))))))
(provide 'gnus-logic)

231
lisp/gnus/gnus-score.el
View File

@ -1717,105 +1717,140 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq entries rest)))))
nil)
(defun gnus-score-decode-text-parts ()
(labels ((mm-text-parts (handle)
(cond ((stringp (car handle))
(let ((parts (mapcan 'mm-text-parts (cdr handle))))
(if (equal "multipart/alternative" (car handle))
;; pick the first supported alternative
(list (car parts))
parts)))
((bufferp (car handle))
(when (string-match "^text/" (mm-handle-media-type handle))
(list handle)))
(t (mapcan 'mm-text-parts handle))))
(my-mm-display-part (handle)
(when handle
(save-restriction
(narrow-to-region (point) (point))
(mm-display-inline handle)
(goto-char (point-max))))))
(let (;(mm-text-html-renderer 'w3m-standalone)
(handles (mm-dissect-buffer t)))
(save-excursion
(article-goto-body)
(delete-region (point) (point-max))
(mapc #'my-mm-display-part (mm-text-parts handles))
handles))))
(defun gnus-score-body (scores header now expire &optional trace)
(if gnus-agent-fetching
nil
(save-excursion
(setq gnus-scores-articles
(sort gnus-scores-articles
(lambda (a1 a2)
(< (mail-header-number (car a1))
(mail-header-number (car a2))))))
(set-buffer nntp-server-buffer)
(save-restriction
(let* ((buffer-read-only nil)
(articles gnus-scores-articles)
(all-scores scores)
(request-func (cond ((string= "head" header)
'gnus-request-head)
((string= "body" header)
'gnus-request-body)
(t 'gnus-request-article)))
entries alist ofunc article last)
(when articles
(setq last (mail-header-number (caar (last articles))))
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
(unless (gnus-check-backend-function
(and (string-match "^gnus-" (symbol-name request-func))
(intern (substring (symbol-name request-func)
(match-end 0))))
gnus-newsgroup-name)
(setq ofunc request-func)
(setq request-func 'gnus-request-article))
(while articles
(setq article (mail-header-number (caar articles)))
(gnus-message 7 "Scoring article %s of %s..." article last)
(widen)
(when (funcall request-func article gnus-newsgroup-name)
(goto-char (point-min))
;; If just parts of the article is to be searched, but the
;; backend didn't support partial fetching, we just narrow
;; to the relevant parts.
(when ofunc
(if (eq ofunc 'gnus-request-head)
(narrow-to-region
(point)
(or (search-forward "\n\n" nil t) (point-max)))
(narrow-to-region
(or (search-forward "\n\n" nil t) (point))
(point-max))))
(setq scores all-scores)
;; Find matches.
(while scores
(setq alist (pop scores)
entries (assoc header alist))
(while (cdr entries) ;First entry is the header index.
(let* ((rest (cdr entries))
(kill (car rest))
(match (nth 0 kill))
(type (or (nth 3 kill) 's))
(score (or (nth 1 kill)
gnus-score-interactive-default-score))
(date (nth 2 kill))
(found nil)
(case-fold-search
(not (or (eq type 'R) (eq type 'S)
(eq type 'Regexp) (eq type 'String))))
(search-func
(cond ((or (eq type 'r) (eq type 'R)
(eq type 'regexp) (eq type 'Regexp))
're-search-forward)
((or (eq type 's) (eq type 'S)
(eq type 'string) (eq type 'String))
'search-forward)
(t
(error "Invalid match type: %s" type)))))
(goto-char (point-min))
(when (funcall search-func match nil t)
;; Found a match, update scores.
(setcdr (car articles) (+ score (cdar articles)))
(setq found t)
(when trace
(push
(cons (car-safe (rassq alist gnus-score-cache))
kill)
gnus-score-trace)))
;; Update expire date
(unless trace
(cond
((null date)) ;Permanent entry.
((and found gnus-update-score-entry-dates)
;; Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries))))
(setq entries rest)))))
(setq articles (cdr articles)))))))
nil))
(if gnus-agent-fetching
nil
(save-excursion
(setq gnus-scores-articles
(sort gnus-scores-articles
(lambda (a1 a2)
(< (mail-header-number (car a1))
(mail-header-number (car a2))))))
(set-buffer nntp-server-buffer)
(save-restriction
(let* ((buffer-read-only nil)
(articles gnus-scores-articles)
(all-scores scores)
(request-func (cond ((string= "head" header)
'gnus-request-head)
;; We need to peek at the headers to detect
;; the content encoding
((string= "body" header)
'gnus-request-article)
(t 'gnus-request-article)))
entries alist ofunc article last)
(when articles
(setq last (mail-header-number (caar (last articles))))
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
(unless (gnus-check-backend-function
(and (string-match "^gnus-" (symbol-name request-func))
(intern (substring (symbol-name request-func)
(match-end 0))))
gnus-newsgroup-name)
(setq ofunc request-func)
(setq request-func 'gnus-request-article))
(while articles
(setq article (mail-header-number (caar articles)))
(gnus-message 7 "Scoring article %s of %s..." article last)
(widen)
(let (handles)
(when (funcall request-func article gnus-newsgroup-name)
(when (string= "body" header)
(setq handles (gnus-score-decode-text-parts)))
(goto-char (point-min))
;; If just parts of the article is to be searched, but the
;; backend didn't support partial fetching, we just narrow
;; to the relevant parts.
(when ofunc
(if (eq ofunc 'gnus-request-head)
(narrow-to-region
(point)
(or (search-forward "\n\n" nil t) (point-max)))
(narrow-to-region
(or (search-forward "\n\n" nil t) (point))
(point-max))))
(setq scores all-scores)
;; Find matches.
(while scores
(setq alist (pop scores)
entries (assoc header alist))
(while (cdr entries) ;First entry is the header index.
(let* ((rest (cdr entries))
(kill (car rest))
(match (nth 0 kill))
(type (or (nth 3 kill) 's))
(score (or (nth 1 kill)
gnus-score-interactive-default-score))
(date (nth 2 kill))
(found nil)
(case-fold-search
(not (or (eq type 'R) (eq type 'S)
(eq type 'Regexp) (eq type 'String))))
(search-func
(cond ((or (eq type 'r) (eq type 'R)
(eq type 'regexp) (eq type 'Regexp))
're-search-forward)
((or (eq type 's) (eq type 'S)
(eq type 'string) (eq type 'String))
'search-forward)
(t
(error "Invalid match type: %s" type)))))
(goto-char (point-min))
(when (funcall search-func match nil t)
;; Found a match, update scores.
(setcdr (car articles) (+ score (cdar articles)))
(setq found t)
(when trace
(push
(cons (car-safe (rassq alist gnus-score-cache))
kill)
gnus-score-trace)))
;; Update expire date
(unless trace
(cond
((null date)) ;Permanent entry.
((and found gnus-update-score-entry-dates)
;; Match, update date.
(gnus-score-set 'touched '(t) alist)
(setcar (nthcdr 2 kill) now))
((and expire (< date expire)) ;Old entry, remove.
(gnus-score-set 'touched '(t) alist)
(setcdr entries (cdr rest))
(setq rest entries))))
(setq entries rest))))
(when handles (mm-destroy-parts handles))))
(setq articles (cdr articles)))))))
nil))
(defun gnus-score-thread (scores header now expire &optional trace)
(gnus-score-followup scores header now expire trace t))

3
lisp/gnus/gnus-srvr.el
View File

@ -490,8 +490,7 @@ The following commands are available:
(error "No such server: %s" server))
(gnus-server-set-status method 'ok)
(prog1
(or (gnus-open-server method)
(progn (message "Couldn't open %s" server) nil))
(gnus-open-server method)
(gnus-server-update-server server)
(gnus-server-position-point))))

45
lisp/gnus/gnus.el
View File

@ -3824,12 +3824,28 @@ You should probably use `gnus-find-method-for-group' instead."
"Go through PARAMETERS and expand them according to the match data."
(let (new)
(dolist (elem parameters)
(if (and (stringp (cdr elem))
(string-match "\\\\[0-9&]" (cdr elem)))
(push (cons (car elem)
(gnus-expand-group-parameter match (cdr elem) group))
new)
(push elem new)))
(cond
((and (stringp (cdr elem))
(string-match "\\\\[0-9&]" (cdr elem)))
(push (cons (car elem)
(gnus-expand-group-parameter match (cdr elem) group))
new))
;; For `sieve' group parameters, perform substitutions for every
;; string within the match rule. This allows for parameters such
;; as:
;; ("list\\.\\(.*\\)"
;; (sieve header :is "list-id" "<\\1.domain.org>"))
((eq 'sieve (car elem))
(push (mapcar (lambda (sieve-elem)
(if (and (stringp sieve-elem)
(string-match "\\\\[0-9&]" sieve-elem))
(gnus-expand-group-parameter match sieve-elem
group)
sieve-elem))
(cdr elem))
new))
(t
(push elem new))))
new))
(defun gnus-group-fast-parameter (group symbol &optional allow-list)
@ -3861,9 +3877,20 @@ The function `gnus-group-find-parameter' will do that for you."
(when this-result
(setq result (car this-result))
;; Expand if necessary.
(if (and (stringp result) (string-match "\\\\[0-9&]" result))
(setq result (gnus-expand-group-parameter
(car head) result group)))))))
(cond
((and (stringp result) (string-match "\\\\[0-9&]" result))
(setq result (gnus-expand-group-parameter
(car head) result group)))
;; For `sieve' group parameters, perform substitutions
;; for every string within the match rule (see above).
((eq symbol 'sieve)
(setq result
(mapcar (lambda (elem)
(if (stringp elem)
(gnus-expand-group-parameter (car head)
elem group)
elem))
result))))))))
;; Done.
result))))

32
lisp/gnus/message.el
View File

@ -3292,11 +3292,33 @@ or in the synonym headers, defined by `message-header-synonyms'."
(defun message-insert-newsgroups ()
"Insert the Newsgroups header from the article being replied to."
(interactive)
(when (and (message-position-on-field "Newsgroups")
(mail-fetch-field "newsgroups")
(not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
(insert ","))
(insert (or (message-fetch-reply-field "newsgroups") "")))
(let ((old-newsgroups (mail-fetch-field "newsgroups"))
(new-newsgroups (message-fetch-reply-field "newsgroups"))
(first t)
insert-newsgroups)
(message-position-on-field "Newsgroups")
(cond
((not new-newsgroups)
(error "No Newsgroups to insert"))
((not old-newsgroups)
(insert new-newsgroups))
(t
(setq new-newsgroups (split-string new-newsgroups "[, ]+")
old-newsgroups (split-string old-newsgroups "[, ]+"))
(dolist (group new-newsgroups)
(unless (member group old-newsgroups)
(push group insert-newsgroups)))
(if (null insert-newsgroups)
(error "Newgroup%s already in the header"
(if (> (length new-newsgroups) 1)
"s" ""))
(when old-newsgroups
(setq first nil))
(dolist (group insert-newsgroups)
(unless first
(insert ","))
(setq first nil)
(insert group)))))))

286
lisp/gnus/nnmaildir.el
View File

@ -77,6 +77,66 @@
(defconst nnmaildir-version "Gnus")
(defconst nnmaildir-flag-mark-mapping
'((?F . tick)
(?R . reply)
(?S . read))
"Alist mapping Maildir filename flags to Gnus marks.
Maildir filenames are of the form \"unique-id:2,FLAGS\",
where FLAGS are a string of characters in ASCII order.
Some of the FLAGS correspond to Gnus marks.")
(defsubst nnmaildir--mark-to-flag (mark)
"Find the Maildir flag that corresponds to MARK (an atom).
Return a character, or `nil' if not found.
See `nnmaildir-flag-mark-mapping'."
(car (rassq mark nnmaildir-flag-mark-mapping)))
(defsubst nnmaildir--flag-to-mark (flag)
"Find the Gnus mark that corresponds to FLAG (a character).
Return an atom, or `nil' if not found.
See `nnmaildir-flag-mark-mapping'."
(cdr (assq flag nnmaildir-flag-mark-mapping)))
(defun nnmaildir--ensure-suffix (filename)
"Ensure that FILENAME contains the suffix \":2,\"."
(if (string-match-p ":2," filename)
filename
(concat filename ":2,")))
(defun nnmaildir--add-flag (flag suffix)
"Return a copy of SUFFIX where FLAG is set.
SUFFIX should start with \":2,\"."
(unless (string-match-p "^:2," suffix)
(error "Invalid suffix `%s'" suffix))
(let* ((flags (substring suffix 3))
(flags-as-list (append flags nil))
(new-flags
(concat (gnus-delete-duplicates
;; maildir flags must be sorted
(sort (cons flag flags-as-list) '<)))))
(concat ":2," new-flags)))
(defun nnmaildir--remove-flag (flag suffix)
"Return a copy of SUFFIX where FLAG is cleared.
SUFFIX should start with \":2,\"."
(unless (string-match-p "^:2," suffix)
(error "Invalid suffix `%s'" suffix))
(let* ((flags (substring suffix 3))
(flags-as-list (append flags nil))
(new-flags (concat (delq flag flags-as-list))))
(concat ":2," new-flags)))
(defun nnmaildir--article-set-flags (article new-suffix curdir)
(let* ((prefix (nnmaildir--art-prefix article))
(suffix (nnmaildir--art-suffix article))
(article-file (concat curdir prefix suffix))
(new-name (concat curdir prefix new-suffix)))
(unless (file-exists-p article-file)
(error "Couldn't find article file %s" article-file))
(rename-file article-file new-name 'replace)
(setf (nnmaildir--art-suffix article) new-suffix)))
(defvar nnmaildir-article-file-name nil
"*The filename of the most recently requested article. This variable is set
by nnmaildir-request-article.")
@ -208,29 +268,33 @@ by nnmaildir-request-article.")
(eval param))
(defmacro nnmaildir--with-nntp-buffer (&rest body)
(declare (debug (body)))
`(with-current-buffer nntp-server-buffer
,@body))
(defmacro nnmaildir--with-work-buffer (&rest body)
(declare (debug (body)))
`(with-current-buffer (get-buffer-create " *nnmaildir work*")
,@body))
(defmacro nnmaildir--with-nov-buffer (&rest body)
(declare (debug (body)))
`(with-current-buffer (get-buffer-create " *nnmaildir nov*")
,@body))
(defmacro nnmaildir--with-move-buffer (&rest body)
(declare (debug (body)))
`(with-current-buffer (get-buffer-create " *nnmaildir move*")
,@body))
(defmacro nnmaildir--subdir (dir subdir)
`(file-name-as-directory (concat ,dir ,subdir)))
(defmacro nnmaildir--srvgrp-dir (srv-dir gname)
`(nnmaildir--subdir ,srv-dir ,gname))
(defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp"))
(defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new"))
(defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur"))
(defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir"))
(defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov"))
(defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks"))
(defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num"))
(defsubst nnmaildir--subdir (dir subdir)
(file-name-as-directory (concat dir subdir)))
(defsubst nnmaildir--srvgrp-dir (srv-dir gname)
(nnmaildir--subdir srv-dir gname))
(defsubst nnmaildir--tmp (dir) (nnmaildir--subdir dir "tmp"))
(defsubst nnmaildir--new (dir) (nnmaildir--subdir dir "new"))
(defsubst nnmaildir--cur (dir) (nnmaildir--subdir dir "cur"))
(defsubst nnmaildir--nndir (dir) (nnmaildir--subdir dir ".nnmaildir"))
(defsubst nnmaildir--nov-dir (dir) (nnmaildir--subdir dir "nov"))
(defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks"))
(defsubst nnmaildir--num-dir (dir) (nnmaildir--subdir dir "num"))
(defmacro nnmaildir--unlink (file-arg)
`(let ((file ,file-arg))
@ -305,6 +369,7 @@ by nnmaildir-request-article.")
string)
(defmacro nnmaildir--condcase (errsym body &rest handler)
(declare (debug (sexp form body)))
`(condition-case ,errsym
(let ((system-messages-locale "C")) ,body)
(error . ,handler)))
@ -759,7 +824,7 @@ by nnmaildir-request-article.")
(dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort))
(setq x (concat ndir file))
(and (time-less-p (nth 5 (file-attributes x)) (current-time))
(rename-file x (concat cdir file ":2,"))))
(rename-file x (concat cdir (nnmaildir--ensure-suffix file)))))
(setf (nnmaildir--grp-new group) nattr))
(setq cattr (nth 5 (file-attributes cdir)))
(if (equal cattr (nnmaildir--grp-cur group))
@ -784,11 +849,23 @@ by nnmaildir-request-article.")
cdir (nnmaildir--marks-dir nndir)
ndir (nnmaildir--subdir cdir "tick")
cdir (nnmaildir--subdir cdir "read"))
(dolist (file files)
(setq file (car file))
(if (or (not (file-exists-p (concat cdir file)))
(file-exists-p (concat ndir file)))
(setq num (1+ num)))))
(dolist (prefix-suffix files)
(let ((prefix (car prefix-suffix))
(suffix (cdr prefix-suffix)))
;; increase num for each unread or ticked article
(when (or
;; first look for marks in suffix, if it's valid...
(when (and (stringp suffix)
(string-prefix-p ":2," suffix))
(or
(not (string-match-p
(string (nnmaildir--mark-to-flag 'read)) suffix))
(string-match-p
(string (nnmaildir--mark-to-flag 'tick)) suffix)))
;; then look in marks directories
(not (file-exists-p (concat cdir prefix)))
(file-exists-p (concat ndir prefix)))
(incf num)))))
(setf (nnmaildir--grp-cache group) (make-vector num nil))
(let ((inhibit-quit t))
(set (intern gname groups) group))
@ -916,12 +993,15 @@ by nnmaildir-request-article.")
"\n")))))
'group)
(defun nnmaildir-request-marks (gname info &optional server)
(let ((group (nnmaildir--prepare server gname))
pgname flist always-marks never-marks old-marks dotfile num dir
markdirs marks mark ranges markdir article read end new-marks ls
old-mmth new-mmth mtime mark-sym existing missing deactivate-mark
article-list)
(defun nnmaildir-request-update-info (gname info &optional server)
(let* ((group (nnmaildir--prepare server gname))
(curdir (nnmaildir--cur
(nnmaildir--srvgrp-dir
(nnmaildir--srv-dir nnmaildir--cur-server) gname)))
(curdir-mtime (nth 5 (file-attributes curdir)))
pgname flist always-marks never-marks old-marks dotfile num dir
all-marks marks mark ranges markdir read end new-marks ls
old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
(catch 'return
(unless group
(setf (nnmaildir--srv-error nnmaildir--cur-server)
@ -950,34 +1030,71 @@ by nnmaildir-request-article.")
dir (nnmaildir--nndir dir)
dir (nnmaildir--marks-dir dir)
ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
new-mmth (nnmaildir--up2-1 (length markdirs))
all-marks (gnus-delete-duplicates
;; get mark names from mark dirs and from flag
;; mappings
(append
(mapcar 'cdr nnmaildir-flag-mark-mapping)
(mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort))))
new-mmth (nnmaildir--up2-1 (length all-marks))
new-mmth (make-vector new-mmth 0)
old-mmth (nnmaildir--grp-mmth group))
(dolist (mark markdirs)
(setq markdir (nnmaildir--subdir dir mark)
mark-sym (intern mark)
(dolist (mark all-marks)
(setq markdir (nnmaildir--subdir dir (symbol-name mark))
ranges nil)
(catch 'got-ranges
(if (memq mark-sym never-marks) (throw 'got-ranges nil))
(when (memq mark-sym always-marks)
(if (memq mark never-marks) (throw 'got-ranges nil))
(when (memq mark always-marks)
(setq ranges existing)
(throw 'got-ranges nil))
(setq mtime (nth 5 (file-attributes markdir)))
(set (intern mark new-mmth) mtime)
(when (equal mtime (symbol-value (intern-soft mark old-mmth)))
(setq ranges (assq mark-sym old-marks))
;; Find the mtime for this mark. If this mark can be expressed as
;; a filename flag, get the later of the mtimes for markdir and
;; curdir, otherwise only the markdir counts.
(setq mtime
(let ((markdir-mtime (nth 5 (file-attributes markdir))))
(cond
((null (nnmaildir--mark-to-flag mark))
markdir-mtime)
((null markdir-mtime)
curdir-mtime)
((null curdir-mtime)
;; this should never happen...
markdir-mtime)
((time-less-p markdir-mtime curdir-mtime)
curdir-mtime)
(t
markdir-mtime))))
(set (intern (symbol-name mark) new-mmth) mtime)
(when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth)))
(setq ranges (assq mark old-marks))
(if ranges (setq ranges (cdr ranges)))
(throw 'got-ranges nil))
(setq article-list nil)
(dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
(setq article (nnmaildir--flist-art flist prefix))
(if article
(setq article-list
(cons (nnmaildir--art-num article) article-list))))
(setq ranges (gnus-add-to-range ranges (sort article-list '<))))
(if (eq mark-sym 'read) (setq read ranges)
(if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
(let ((article-list nil))
;; Consider the article marked if it either has the flag in the
;; filename, or is in the markdir. As you'd rarely remove a
;; flag/mark, this should avoid losing information in the most
;; common usage pattern.
(or
(let ((flag (nnmaildir--mark-to-flag mark)))
;; If this mark has a corresponding maildir flag...
(when flag
(let ((regexp
(concat "\\`[^.].*:2,[A-Z]*" (string flag))))
;; ...then find all files with that flag.
(dolist (filename (funcall ls curdir nil regexp 'nosort))
(let* ((prefix (car (split-string filename ":2,")))
(article (nnmaildir--flist-art flist prefix)))
(when article
(push (nnmaildir--art-num article) article-list)))))))
;; Also check Gnus-specific mark directory, if it exists.
(when (file-directory-p markdir)
(dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
(let ((article (nnmaildir--flist-art flist prefix)))
(when article
(push (nnmaildir--art-num article) article-list))))))
(setq ranges (gnus-add-to-range ranges (sort article-list '<)))))
(if (eq mark 'read) (setq read ranges)
(if ranges (setq marks (cons (cons mark ranges) marks)))))
(gnus-info-set-read info (gnus-range-add read missing))
(gnus-info-set-marks info marks 'extend)
(setf (nnmaildir--grp-mmth group) new-mmth)
@ -1525,39 +1642,63 @@ by nnmaildir-request-article.")
didnt)))
(defun nnmaildir-request-set-mark (gname actions &optional server)
(let ((group (nnmaildir--prepare server gname))
(coding-system-for-write nnheader-file-coding-system)
(buffer-file-coding-system nil)
(file-coding-system-alist nil)
del-mark del-action add-action set-action marksdir nlist
ranges begin end article all-marks todo-marks mdir mfile
pgname ls permarkfile deactivate-mark)
(let* ((group (nnmaildir--prepare server gname))
(curdir (nnmaildir--cur
(nnmaildir--srvgrp-dir
(nnmaildir--srv-dir nnmaildir--cur-server)
gname)))
(coding-system-for-write nnheader-file-coding-system)
(buffer-file-coding-system nil)
(file-coding-system-alist nil)
del-mark del-action add-action set-action marksdir nlist
ranges begin end article all-marks todo-marks mdir mfile
pgname ls permarkfile deactivate-mark)
(setq del-mark
(lambda (mark)
(setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
mfile (concat mfile (nnmaildir--art-prefix article)))
(nnmaildir--unlink mfile))
(let ((prefix (nnmaildir--art-prefix article))
(suffix (nnmaildir--art-suffix article))
(flag (nnmaildir--mark-to-flag mark)))
(when flag
;; If this mark corresponds to a flag, remove the flag from
;; the file name.
(nnmaildir--article-set-flags
article (nnmaildir--remove-flag flag suffix) curdir))
;; We still want to delete the hardlink in the marks dir if
;; present, regardless of whether this mark has a maildir flag or
;; not, to avoid getting out of sync.
(setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
mfile (concat mfile prefix))
(nnmaildir--unlink mfile)))
del-action (lambda (article) (mapcar del-mark todo-marks))
add-action
(lambda (article)
(mapcar
(lambda (mark)
(setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
permarkfile (concat mdir ":")
mfile (concat mdir (nnmaildir--art-prefix article)))
(nnmaildir--condcase err (add-name-to-file permarkfile mfile)
(cond
((nnmaildir--eexist-p err))
((nnmaildir--enoent-p err)
(nnmaildir--mkdir mdir)
(nnmaildir--mkfile permarkfile)
(add-name-to-file permarkfile mfile))
((nnmaildir--emlink-p err)
(let ((permarkfilenew (concat permarkfile "{new}")))
(nnmaildir--mkfile permarkfilenew)
(rename-file permarkfilenew permarkfile 'replace)
(add-name-to-file permarkfile mfile)))
(t (signal (car err) (cdr err))))))
(let ((prefix (nnmaildir--art-prefix article))
(suffix (nnmaildir--art-suffix article))
(flag (nnmaildir--mark-to-flag mark)))
(if flag
;; If there is a corresponding maildir flag, just rename
;; the file.
(nnmaildir--article-set-flags
article (nnmaildir--add-flag flag suffix) curdir)
;; Otherwise, use nnmaildir-specific marks dir.
(setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
permarkfile (concat mdir ":")
mfile (concat mdir prefix))
(nnmaildir--condcase err (add-name-to-file permarkfile mfile)
(cond
((nnmaildir--eexist-p err))
((nnmaildir--enoent-p err)
(nnmaildir--mkdir mdir)
(nnmaildir--mkfile permarkfile)
(add-name-to-file permarkfile mfile))
((nnmaildir--emlink-p err)
(let ((permarkfilenew (concat permarkfile "{new}")))
(nnmaildir--mkfile permarkfilenew)
(rename-file permarkfilenew permarkfile 'replace)
(add-name-to-file permarkfile mfile)))
(t (signal (car err) (cdr err))))))))
todo-marks))
set-action (lambda (article)
(funcall add-action article)
@ -1581,7 +1722,12 @@ by nnmaildir-request-article.")
pgname (nnmaildir--pgname nnmaildir--cur-server gname)
ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
all-marks (mapcar 'intern all-marks))
all-marks (gnus-delete-duplicates
;; get mark names from mark dirs and from flag
;; mappings
(append
(mapcar 'cdr nnmaildir-flag-mark-mapping)
(mapcar 'intern all-marks))))
(dolist (action actions)
(setq ranges (car action)
todo-marks (caddr action))