;; 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
+;; 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
If this variable is `adopt', Gnus will make one of the \"children\"
the parent and mark all the step-children as such.
If this variable is `empty', the \"children\" are printed with empty
-subject fields. (Or rather, they will be printed with a string
+subject fields. (Or rather, they will be printed with a string
given by the `gnus-summary-same-subject' variable.)"
:group 'gnus-thread
:type '(choice (const :tag "off" nil)
"/" gnus-summary-limit-to-subject
"n" gnus-summary-limit-to-articles
"b" gnus-summary-limit-to-bodies
+ "h" gnus-summary-limit-to-headers
"w" gnus-summary-pop-limit
"s" gnus-summary-limit-to-subject
"a" gnus-summary-limit-to-author
t
(not (cdr (gnus-data-find-list article)))))
-(defun gnus-make-thread-indent-array ()
- (let ((n 200))
- (unless (and gnus-thread-indent-array
- (= gnus-thread-indent-level gnus-thread-indent-array-level))
- (setq gnus-thread-indent-array (make-vector 201 "")
- gnus-thread-indent-array-level gnus-thread-indent-level)
- (while (>= n 0)
- (aset gnus-thread-indent-array n
- (make-string (* n gnus-thread-indent-level) ? ))
- (setq n (1- n))))))
+(defun gnus-make-thread-indent-array (&optional n)
+ (when (or n
+ (progn (setq n 200) nil)
+ (null gnus-thread-indent-array)
+ (/= gnus-thread-indent-level gnus-thread-indent-array-level))
+ (setq gnus-thread-indent-array (make-vector (1+ n) "")
+ gnus-thread-indent-array-level gnus-thread-indent-level)
+ (while (>= n 0)
+ (aset gnus-thread-indent-array n
+ (make-string (* n gnus-thread-indent-level) ?\s))
+ (setq n (1- n)))))
(defun gnus-update-summary-mark-positions ()
"Compute where the summary marks are to go."
gnus-tmp-expirable gnus-tmp-subject-or-nil
&optional gnus-tmp-dummy gnus-tmp-score
gnus-tmp-process)
+ (if (>= gnus-tmp-level (length gnus-thread-indent-array))
+ (gnus-make-thread-indent-array (max (* 2 (length gnus-thread-indent-array))
+ gnus-tmp-level)))
(let* ((gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level))
(gnus-tmp-lines (mail-header-lines gnus-tmp-header))
(gnus-tmp-score (or gnus-tmp-score gnus-summary-default-score 0))
infloop))
(defun gnus-make-threads ()
- "Go through the dependency hashtb and find the roots. Return all threads."
+ "Go through the dependency hashtb and find the roots. Return all threads."
(let (threads)
(while (catch 'infloop
(mapatoms
;; First go up in this thread until we find the root.
(setq last-id (gnus-root-id id)
headers (message-flatten-list (gnus-id-to-thread last-id)))
- ;; We have now found the real root of this thread. It might have
+ ;; We have now found the real root of this thread. It might have
;; been gathered into some loose thread, so we have to search
;; through the threads to find the thread we wanted.
(let ((threads gnus-newsgroup-threads)
(1+ (point-at-eol))
(gnus-delete-line)))))))
-(defun gnus-sort-threads-1 (threads func)
+(defun gnus-sort-threads-recursive (threads func)
(sort (mapcar (lambda (thread)
(cons (car thread)
(and (cdr thread)
- (gnus-sort-threads-1 (cdr thread) func))))
+ (gnus-sort-threads-recursive (cdr thread) func))))
threads) func))
+(defun gnus-sort-threads-loop (threads func)
+ (let* ((superthread (cons nil threads))
+ (stack (list (cons superthread threads)))
+ remaining-threads thread)
+ (while stack
+ (setq remaining-threads (cdr (car stack)))
+ (if remaining-threads
+ (progn (setq thread (car remaining-threads))
+ (setcdr (car stack) (cdr remaining-threads))
+ (if (cdr thread)
+ (push (cons thread (cdr thread)) stack)))
+ (setq thread (caar stack))
+ (setcdr thread (sort (cdr thread) func))
+ (pop stack)))
+ (cdr superthread)))
+
(defun gnus-sort-threads (threads)
"Sort THREADS."
(if (not gnus-thread-sort-functions)
threads
(gnus-message 8 "Sorting threads...")
- (let ((max-lisp-eval-depth 5000))
- (prog1 (gnus-sort-threads-1
- threads
- (gnus-make-sort-function gnus-thread-sort-functions))
- (gnus-message 8 "Sorting threads...done")))))
+ (prog1
+ (condition-case nil
+ (let ((max-lisp-eval-depth (max max-lisp-eval-depth 5000)))
+ (gnus-sort-threads-recursive
+ threads (gnus-make-sort-function gnus-thread-sort-functions)))
+ ;; Even after binding max-lisp-eval-depth, the recursive
+ ;; sorter might fail for very long threads. In that case,
+ ;; try using a (less well-tested) non-recursive sorter.
+ (error (gnus-sort-threads-loop
+ threads (gnus-make-sort-function
+ gnus-thread-sort-functions))))
+ (gnus-message 8 "Sorting threads...done"))))
(defun gnus-sort-articles (articles)
"Sort ARTICLES."
gnus-tmp-closing-bracket ?\>)
(setq gnus-tmp-opening-bracket ?\[
gnus-tmp-closing-bracket ?\]))
+ (if (>= gnus-tmp-level (length gnus-thread-indent-array))
+ (gnus-make-thread-indent-array
+ (max (* 2 (length gnus-thread-indent-array))
+ gnus-tmp-level)))
(setq
gnus-tmp-indentation
(aref gnus-thread-indent-array gnus-tmp-level)
(when (equal major-mode 'gnus-summary-mode)
(gnus-kill-buffer (current-buffer)))
(error "Couldn't activate group %s: %s"
- group (gnus-status-message group))))
+ (gnus-group-decoded-name group) (gnus-status-message group))))
(unless (gnus-request-group group t)
(when (equal major-mode 'gnus-summary-mode)
(gnus-kill-buffer (current-buffer)))
(error "Couldn't request group %s: %s"
- group (gnus-status-message group)))
+ (gnus-group-decoded-name group) (gnus-status-message group)))
(when gnus-agent
(gnus-agent-possibly-alter-active group (gnus-active group) info)
(let* ((mformat (symbol-value
(intern
(format "gnus-%s-mode-line-format-spec" where))))
- (gnus-tmp-group-name (gnus-group-decoded-name
- gnus-newsgroup-name))
+ (gnus-tmp-group-name (gnus-mode-string-quote
+ (gnus-group-decoded-name
+ gnus-newsgroup-name)))
(gnus-tmp-article-number (or gnus-current-article 0))
(gnus-tmp-unread gnus-newsgroup-unreads)
(gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads))
(let ((case-fold-search t)
in-reply-to header p lines chars)
(goto-char (point-min))
- ;; Search to the beginning of the next header. Error messages
+ ;; Search to the beginning of the next header. Error messages
;; do not begin with 2 or 3.
(while (re-search-forward "^[23][0-9]+ " nil t)
(setq id nil
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and
;; a case (which basically was the old function) is actually
- ;; about twice as fast, even though it looks messier. You
+ ;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance
;; doesn't always go hand in hand.
(setq
;; possible valid number, or the second line from the top,
;; whichever is the least.
(let ((top-pos (save-excursion (forward-line (- top)) (point))))
+ (message "%s" top-pos)
(if (> bottom top-pos)
;; Keep the second line from the top visible
- (set-window-start window top-pos t)
+ (set-window-start window top-pos)
;; Try to keep the bottom line visible; if it's partially
;; obscured, either scroll one more line to make it fully
;; visible, or revert to using TOP-POS.
(gnus-summary-limit articles))
(gnus-summary-position-point))))
+(defun gnus-summary-limit-strange-charsets-predicate (header)
+ (let ((string (concat (mail-header-subject header)
+ (mail-header-from header)))
+ charset found)
+ (dotimes (i (1- (length string)))
+ (setq charset (format "%s" (char-charset (aref string (1+ i)))))
+ (when (string-match "unicode\\|big\\|japanese" charset)
+ (setq found t)))
+ found))
+
+(defun gnus-summary-limit-to-predicate (predicate)
+ "Limit to articles where PREDICATE returns non-nil.
+PREDICATE will be called with the header structures of the
+articles."
+ (let ((articles nil)
+ (case-fold-search t))
+ (dolist (header gnus-newsgroup-headers)
+ (when (funcall predicate header)
+ (push (mail-header-number header) articles)))
+ (gnus-summary-limit (nreverse articles))))
+
(defun gnus-summary-limit-to-age (age &optional younger-p)
"Limit the summary buffer to articles that are older than (or equal) AGE days.
If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to
gnus-duplicate-mark gnus-souped-mark)
'reverse)))
-(defun gnus-summary-limit-to-bodies (match &optional reverse)
+(defun gnus-summary-limit-to-headers (match &optional reverse)
+ "Limit the summary buffer to articles that have headers that match MATCH.
+If REVERSE (the prefix), limit to articles that don't match."
+ (interactive "sMatch headers (regexp): \nP")
+ (gnus-summary-limit-to-bodies match reverse t))
+
+(defun gnus-summary-limit-to-bodies (match &optional reverse headersp)
"Limit the summary buffer to articles that have bodies that match MATCH.
If REVERSE (the prefix), limit to articles that don't match."
(interactive "sMatch body (regexp): \nP")
(set-buffer gnus-article-buffer)
(article-goto-body)
(let* ((case-fold-search t)
- (found (re-search-forward match nil t)))
+ (found (if headersp
+ (re-search-backward match nil t)
+ (re-search-forward match nil t))))
(when (or (and found
(not reverse))
(and (not found)
;; will really go down to a leaf article first, before slowly
;; working its way up towards the root.
(when thread
- (let* ((max-lisp-eval-depth 5000)
+ (let* ((max-lisp-eval-depth (max 5000 max-lisp-eval-depth))
(children
(if (cdr thread)
(apply '+ (mapcar 'gnus-summary-limit-children
(to-method (gnus-find-method-for-group
to-newsgroup))
(move-is-internal (gnus-method-equal from-method to-method)))
- (gnus-request-move-article
- article ; Article to move
- gnus-newsgroup-name ; From newsgroup
- (nth 1 (gnus-find-method-for-group
- gnus-newsgroup-name)) ; Server
- (list 'gnus-request-accept-article
- to-newsgroup (list 'quote select-method)
- (not articles) t) ; Accept form
- (not articles) ; Only save nov last time
- move-is-internal))) ; is this move internal?
+ (gnus-request-move-article
+ article ; Article to move
+ gnus-newsgroup-name ; From newsgroup
+ (nth 1 (gnus-find-method-for-group
+ gnus-newsgroup-name)) ; Server
+ (list 'gnus-request-accept-article
+ to-newsgroup (list 'quote select-method)
+ (not articles) t) ; Accept form
+ (not articles) ; Only save nov last time
+ move-is-internal))) ; is this move internal?
;; Copy the article.
((eq action 'copy)
(save-excursion
(gnus-request-article-this-buffer article gnus-newsgroup-name)
(when (consp (setq art-group
(gnus-request-accept-article
- to-newsgroup select-method (not articles))))
+ to-newsgroup select-method (not articles) t)))
(setq new-xref (concat new-xref " " (car art-group)
":"
(number-to-string (cdr art-group))))
;; it and replace the new article.
(nnheader-replace-header "Xref" new-xref)
(gnus-request-replace-article
- (cdr art-group) to-newsgroup (current-buffer))
+ (cdr art-group) to-newsgroup (current-buffer) t)
art-group))))))
(cond
((not art-group)
(gnus-request-article-this-buffer article gnus-newsgroup-name)
(nnheader-replace-header "Xref" new-xref)
(gnus-request-replace-article
- article gnus-newsgroup-name (current-buffer))))
+ article gnus-newsgroup-name (current-buffer) t)))
;; run the move/copy/crosspost/respool hook
(run-hook-with-args 'gnus-summary-article-move-hook
;;;!!!Why is this necessary?
(set-buffer gnus-summary-buffer)
-
+
(gnus-summary-goto-subject article)
(when (eq action 'move)
(gnus-summary-mark-article article gnus-canceled-mark))))
(set-buffer gnus-group-buffer)
(let ((gnus-group-marked to-groups))
(gnus-group-get-new-news-this-group nil t)))
-
+
(gnus-kill-buffer copy-buf)
(gnus-summary-position-point)
(gnus-set-mode-line 'summary)))
gnus-newsgroup-dormant nil))
(setq gnus-newsgroup-unreads
(gnus-sorted-nunion
- (gnus-intersection gnus-newsgroup-unreads
- gnus-newsgroup-downloadable)
+ (gnus-sorted-intersection gnus-newsgroup-unreads
+ gnus-newsgroup-downloadable)
gnus-newsgroup-unfetched)))
;; We actually mark all articles as canceled, which we
;; have to do when using auto-expiry or adaptive scoring.
projects / gnus / blobdiff