Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-sum.el @ 104:cf808b4c4290 r20-1b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b4
author cvs
date Mon, 13 Aug 2007 09:16:51 +0200
parents 4be1180a9e89
children 8ff55ebd4be9
comparison
equal deleted inserted replaced
103:30eda07fe280 104:cf808b4c4290
1280 "f" gnus-article-display-x-face 1280 "f" gnus-article-display-x-face
1281 "l" gnus-summary-stop-page-breaking 1281 "l" gnus-summary-stop-page-breaking
1282 "r" gnus-summary-caesar-message 1282 "r" gnus-summary-caesar-message
1283 "t" gnus-article-hide-headers 1283 "t" gnus-article-hide-headers
1284 "v" gnus-summary-verbose-headers 1284 "v" gnus-summary-verbose-headers
1285 "m" gnus-summary-toggle-mime) 1285 "m" gnus-summary-toggle-mime
1286 "h" gnus-article-treat-html)
1286 1287
1287 (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) 1288 (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map)
1288 "a" gnus-article-hide 1289 "a" gnus-article-hide
1289 "h" gnus-article-hide-headers 1290 "h" gnus-article-hide-headers
1290 "b" gnus-article-hide-boring-headers 1291 "b" gnus-article-hide-boring-headers
2071 (memq article gnus-newsgroup-unselected) 2072 (memq article gnus-newsgroup-unselected)
2072 (memq article gnus-newsgroup-dormant)))) 2073 (memq article gnus-newsgroup-dormant))))
2073 2074
2074 ;; Some summary mode macros. 2075 ;; Some summary mode macros.
2075 2076
2076 (defmacro gnus-summary-article-number () 2077 (defun gnus-summary-article-number ()
2077 "The article number of the article on the current line. 2078 "The article number of the article on the current line.
2078 If there isn's an article number here, then we return the current 2079 If there isn's an article number here, then we return the current
2079 article number." 2080 article number."
2080 '(progn 2081 '(progn
2081 (gnus-summary-skip-intangible) 2082 (gnus-summary-skip-intangible)
2911 (gnus-delete-line) 2912 (gnus-delete-line)
2912 (gnus-summary-insert-line 2913 (gnus-summary-insert-line
2913 header level nil (gnus-article-mark article) 2914 header level nil (gnus-article-mark article)
2914 (memq article gnus-newsgroup-replied) 2915 (memq article gnus-newsgroup-replied)
2915 (memq article gnus-newsgroup-expirable) 2916 (memq article gnus-newsgroup-expirable)
2916 (mail-header-subject header) 2917 ;; Only insert the Subject string when it's different
2918 ;; from the previous Subject string.
2919 (unless (gnus-subject-equal
2920 (condition-case ()
2921 (mail-header-subject
2922 (gnus-data-header
2923 (cadr
2924 (gnus-data-find-list
2925 article
2926 (gnus-data-list t)))))
2927 (error ""))
2928 (mail-header-subject header))
2929 (mail-header-subject header))
2917 nil (cdr (assq article gnus-newsgroup-scored)) 2930 nil (cdr (assq article gnus-newsgroup-scored))
2918 (memq article gnus-newsgroup-processable)) 2931 (memq article gnus-newsgroup-processable))
2919 (when length 2932 (when length
2920 (gnus-data-update-list 2933 (gnus-data-update-list
2921 (cdr datal) (- length (- (gnus-data-pos data) (point)))))))) 2934 (cdr datal) (- length (- (gnus-data-pos data) (point))))))))
3866 (if (and gnus-current-headers 3879 (if (and gnus-current-headers
3867 (vectorp gnus-current-headers)) 3880 (vectorp gnus-current-headers))
3868 (gnus-mode-string-quote 3881 (gnus-mode-string-quote
3869 (mail-header-subject gnus-current-headers)) 3882 (mail-header-subject gnus-current-headers))
3870 "")) 3883 ""))
3871 max-len 3884 bufname-length max-len
3872 gnus-tmp-header);; passed as argument to any user-format-funcs 3885 gnus-tmp-header);; passed as argument to any user-format-funcs
3873 (setq mode-string (eval mformat)) 3886 (setq mode-string (eval mformat))
3887 (setq bufname-length (if (string-match "%b" mode-string)
3888 (- (length
3889 (buffer-name
3890 (if (eq where 'summary)
3891 nil
3892 (get-buffer gnus-article-buffer))))
3893 2)
3894 0))
3874 (setq max-len (max 4 (if gnus-mode-non-string-length 3895 (setq max-len (max 4 (if gnus-mode-non-string-length
3875 (- (window-width) 3896 (- (window-width)
3876 gnus-mode-non-string-length) 3897 gnus-mode-non-string-length
3898 bufname-length)
3877 (length mode-string)))) 3899 (length mode-string))))
3878 ;; We might have to chop a bit of the string off... 3900 ;; We might have to chop a bit of the string off...
3879 (when (> (length mode-string) max-len) 3901 (when (> (length mode-string) max-len)
3880 (setq mode-string 3902 (setq mode-string
3881 (concat (gnus-truncate-string mode-string (- max-len 3)) 3903 (concat (gnus-truncate-string mode-string (- max-len 3))
4297 ;; article may not have been generated yet, so this may fail. 4319 ;; article may not have been generated yet, so this may fail.
4298 ;; We work around this problem by retrieving the last few 4320 ;; We work around this problem by retrieving the last few
4299 ;; headers using HEAD. 4321 ;; headers using HEAD.
4300 (if (or (not also-fetch-heads) 4322 (if (or (not also-fetch-heads)
4301 (not sequence)) 4323 (not sequence))
4324 ;; We (probably) got all the headers.
4302 (nreverse headers) 4325 (nreverse headers)
4303 (let ((gnus-nov-is-evil t) 4326 (let ((gnus-nov-is-evil t))
4304 (nntp-nov-is-evil t))
4305 (nconc 4327 (nconc
4306 (nreverse headers) 4328 (nreverse headers)
4307 (when (gnus-retrieve-headers sequence group) 4329 (when (gnus-retrieve-headers sequence group)
4308 (gnus-get-newsgroup-headers)))))))) 4330 (gnus-get-newsgroup-headers))))))))
4309 4331
5258 ;; Go to next/previous group. 5280 ;; Go to next/previous group.
5259 (t 5281 (t
5260 (unless (gnus-ephemeral-group-p gnus-newsgroup-name) 5282 (unless (gnus-ephemeral-group-p gnus-newsgroup-name)
5261 (gnus-summary-jump-to-group gnus-newsgroup-name)) 5283 (gnus-summary-jump-to-group gnus-newsgroup-name))
5262 (let ((cmd last-command-char) 5284 (let ((cmd last-command-char)
5285 (point
5286 (save-excursion
5287 (set-buffer gnus-group-buffer)
5288 (point)))
5263 (group 5289 (group
5264 (if (eq gnus-keep-same-level 'best) 5290 (if (eq gnus-keep-same-level 'best)
5265 (gnus-summary-best-group gnus-newsgroup-name) 5291 (gnus-summary-best-group gnus-newsgroup-name)
5266 (gnus-summary-search-group backward gnus-keep-same-level)))) 5292 (gnus-summary-search-group backward gnus-keep-same-level))))
5267 ;; For some reason, the group window gets selected. We change 5293 ;; For some reason, the group window gets selected. We change
5286 "exiting")) 5312 "exiting"))
5287 (gnus-summary-next-group nil group backward))) 5313 (gnus-summary-next-group nil group backward)))
5288 (t 5314 (t
5289 (when (gnus-key-press-event-p last-input-event) 5315 (when (gnus-key-press-event-p last-input-event)
5290 (gnus-summary-walk-group-buffer 5316 (gnus-summary-walk-group-buffer
5291 gnus-newsgroup-name cmd unread backward)))))))) 5317 gnus-newsgroup-name cmd unread backward point))))))))
5292 5318
5293 (defun gnus-summary-walk-group-buffer (from-group cmd unread backward) 5319 (defun gnus-summary-walk-group-buffer (from-group cmd unread backward start)
5294 (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1)) 5320 (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1))
5295 (?\C-p (gnus-group-prev-unread-group 1)))) 5321 (?\C-p (gnus-group-prev-unread-group 1))))
5296 (cursor-in-echo-area t) 5322 (cursor-in-echo-area t)
5297 keve key group ended) 5323 keve key group ended)
5298 (save-excursion 5324 (save-excursion
5299 (set-buffer gnus-group-buffer) 5325 (set-buffer gnus-group-buffer)
5300 (gnus-summary-jump-to-group from-group) 5326 (goto-char start)
5301 (setq group 5327 (setq group
5302 (if (eq gnus-keep-same-level 'best) 5328 (if (eq gnus-keep-same-level 'best)
5303 (gnus-summary-best-group gnus-newsgroup-name) 5329 (gnus-summary-best-group gnus-newsgroup-name)
5304 (gnus-summary-search-group backward gnus-keep-same-level)))) 5330 (gnus-summary-search-group backward gnus-keep-same-level))))
5305 (while (not ended) 5331 (while (not ended)
6965 (let (gnus-mark-article-hook) 6991 (let (gnus-mark-article-hook)
6966 (gnus-summary-select-article) 6992 (gnus-summary-select-article)
6967 (save-excursion 6993 (save-excursion
6968 (set-buffer gnus-article-buffer) 6994 (set-buffer gnus-article-buffer)
6969 (save-restriction 6995 (save-restriction
6970 (goto-char (point-min)) 6996 (gnus-narrow-to-body)
6971 (search-forward "\n\n")
6972 (narrow-to-region (point-min) (point))
6973 (message "This message would go to %s" 6997 (message "This message would go to %s"
6974 (mapconcat 'car (nnmail-article-group 'identity) ", ")))))) 6998 (mapconcat 'car (nnmail-article-group 'identity) ", "))))))
6975 6999
6976 ;; Summary marking commands. 7000 ;; Summary marking commands.
6977 7001
7692 (error "No article on the current line")) 7716 (error "No article on the current line"))
7693 (gnus-rebuild-thread id) 7717 (gnus-rebuild-thread id)
7694 (gnus-summary-goto-subject article))) 7718 (gnus-summary-goto-subject article)))
7695 7719
7696 (defun gnus-summary-reparent-thread () 7720 (defun gnus-summary-reparent-thread ()
7697 "Make current article child of the marked (or previous) article. 7721 "Make the current article child of the marked (or previous) article.
7698 7722
7699 Note that the re-threading will only work if `gnus-thread-ignore-subject' 7723 Note that the re-threading will only work if `gnus-thread-ignore-subject'
7700 is non-nil or the Subject: of both articles are the same." 7724 is non-nil or the Subject: of both articles are the same."
7701 (interactive) 7725 (interactive)
7702 (unless (not (gnus-group-read-only-p)) 7726 (unless (not (gnus-group-read-only-p))
7704 (unless (<= (length gnus-newsgroup-processable) 1) 7728 (unless (<= (length gnus-newsgroup-processable) 1)
7705 (error "No more than one article may be marked.")) 7729 (error "No more than one article may be marked."))
7706 (save-window-excursion 7730 (save-window-excursion
7707 (let ((gnus-article-buffer " *reparent*") 7731 (let ((gnus-article-buffer " *reparent*")
7708 (current-article (gnus-summary-article-number)) 7732 (current-article (gnus-summary-article-number))
7709 ; first grab the marked article, otherwise one line up. 7733 ;; First grab the marked article, otherwise one line up.
7710 (parent-article (if (not (null gnus-newsgroup-processable)) 7734 (parent-article (if (not (null gnus-newsgroup-processable))
7711 (car gnus-newsgroup-processable) 7735 (car gnus-newsgroup-processable)
7712 (save-excursion 7736 (save-excursion
7713 (if (eq (forward-line -1) 0) 7737 (if (eq (forward-line -1) 0)
7714 (gnus-summary-article-number) 7738 (gnus-summary-article-number)
7718 (let ((message-id (mail-header-id 7742 (let ((message-id (mail-header-id
7719 (gnus-summary-article-header parent-article)))) 7743 (gnus-summary-article-header parent-article))))
7720 (unless (and message-id (not (equal message-id ""))) 7744 (unless (and message-id (not (equal message-id "")))
7721 (error "No message-id in desired parent.")) 7745 (error "No message-id in desired parent."))
7722 (gnus-summary-select-article t t nil current-article) 7746 (gnus-summary-select-article t t nil current-article)
7723 (set-buffer gnus-article-buffer) 7747 (set-buffer gnus-original-article-buffer)
7724 (setq buffer-read-only nil)
7725 (let ((buf (format "%s" (buffer-string)))) 7748 (let ((buf (format "%s" (buffer-string))))
7726 (erase-buffer) 7749 (nnheader-temp-write nil
7727 (insert buf)) 7750 (insert buf)
7728 (goto-char (point-min)) 7751 (goto-char (point-min))
7729 (if (search-forward-regexp "^References: " nil t) 7752 (if (search-forward-regexp "^References: " nil t)
7730 (insert message-id " " ) 7753 (insert message-id " " )
7731 (insert "References: " message-id "\n")) 7754 (insert "References: " message-id "\n"))
7732 (unless (gnus-request-replace-article current-article 7755 (unless (gnus-request-replace-article
7733 (car gnus-article-current) 7756 current-article (car gnus-article-current)
7734 gnus-article-buffer) 7757 (current-buffer))
7735 (error "Couldn't replace article.")) 7758 (error "Couldn't replace article."))))
7736 (set-buffer gnus-summary-buffer) 7759 (set-buffer gnus-summary-buffer)
7737 (gnus-summary-unmark-all-processable) 7760 (gnus-summary-unmark-all-processable)
7738 (gnus-summary-rethread-current) 7761 (gnus-summary-rethread-current)
7739 (gnus-message 3 "Article %d is now the child of article %d." 7762 (gnus-message 3 "Article %d is now the child of article %d."
7740 current-article parent-article))))) 7763 current-article parent-article)))))