Commit 350a1888 authored by Gnus developers's avatar Gnus developers Committed by Katsumi Yamaoka
Browse files

Merge changes made in Gnus master

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.
parent 20ef56db
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.
......
......@@ -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
......
......@@ -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)
......
......@@ -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))
......
......@@ -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))))
......
......@@ -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))))
......
......@@ -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)))))))
......
......@@ -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)))