("^cn\\>\\|\\<chinese\\>" cn-gb-2312)
("^fj\\>\\|^japan\\>" iso-2022-jp-2)
("^relcom\\>" koi8-r)
- ("^\\(cz\\|hun\\|pl\\|sk\\)\\>" iso-8859-2)
+ ("^\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2)
("^israel\\>" iso-8859-1)
("^han\\>" euc-kr)
("^\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1)
:type '(repeat symbol)
:group 'gnus-charset)
+(defcustom gnus-group-highlight-words-alist nil
+ "Alist of group regexps and highlight regexps.
+This variable uses the same syntax as `gnus-emphasis-alist'."
+ :type '(repeat (cons (regexp :tag "Group")
+ (repeat (list (regexp :tag "Highlight regexp")
+ (number :tag "Group for entire word" 0)
+ (number :tag "Group for displayed part" 0)
+ (symbol :tag "Face"
+ gnus-emphasis-highlight-words)))))
+ :group 'gnus-summary-visual)
+
;;; Internal variables
(defvar gnus-article-mime-handles nil)
(defvar gnus-last-article nil)
(defvar gnus-newsgroup-history nil)
(defvar gnus-newsgroup-charset nil)
+(defvar gnus-newsgroup-emphasis-alist nil)
(defconst gnus-summary-local-variables
'(gnus-newsgroup-name
gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay
gnus-newsgroup-scored gnus-newsgroup-kill-headers
gnus-thread-expunge-below
- gnus-score-alist gnus-current-score-file gnus-summary-expunge-below
+ gnus-score-alist gnus-current-score-file
+ (gnus-summary-expunge-below . global)
(gnus-summary-mark-below . global)
gnus-newsgroup-active gnus-scores-exclude-files
gnus-newsgroup-history gnus-newsgroup-ancient
gnus-cache-removable-articles gnus-newsgroup-cached
gnus-newsgroup-data gnus-newsgroup-data-reverse
gnus-newsgroup-limit gnus-newsgroup-limits
- gnus-newsgroup-charset)
+ gnus-newsgroup-charset gnus-newsgroup-emphasis-alist)
"Variables that are buffer-local to the summary buffers.")
;; Byte-compiler warning.
"T" gnus-summary-limit-include-thread
"d" gnus-summary-limit-exclude-dormant
"t" gnus-summary-limit-to-age
+ "x" gnus-summary-limit-to-extra
"E" gnus-summary-limit-include-expunged
"c" gnus-summary-limit-exclude-childless-dormant
"C" gnus-summary-limit-mark-excluded-as-read)
"e" gnus-summary-end-of-article
"^" gnus-summary-refer-parent-article
"r" gnus-summary-refer-parent-article
+ "D" gnus-summary-enter-digest-group
"R" gnus-summary-refer-references
"T" gnus-summary-refer-thread
"g" gnus-summary-show-article
"s" gnus-summary-isearch-article
- "P" gnus-summary-print-article)
+ "P" gnus-summary-print-article
+ "t" gnus-article-babel)
(gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map)
"b" gnus-article-add-buttons
"t" gnus-article-hide-headers
"v" gnus-summary-verbose-headers
"h" gnus-article-treat-html
+ "H" gnus-article-strip-headers-in-body
"d" gnus-article-treat-dumbquotes)
(gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map)
("Cache"
["Enter article" gnus-cache-enter-article t]
["Remove article" gnus-cache-remove-article t])
+ ["Translate" gnus-article-babel t]
["Select article buffer" gnus-summary-select-article-buffer t]
["Enter digest buffer" gnus-summary-enter-digest-group t]
["Isearch article..." gnus-summary-isearch-article t]
["Subject..." gnus-summary-limit-to-subject t]
["Author..." gnus-summary-limit-to-author t]
["Age..." gnus-summary-limit-to-age t]
+ ["Extra..." gnus-summary-limit-to-extra t]
["Score" gnus-summary-limit-to-score t]
["Unread" gnus-summary-limit-to-unread t]
["Non-dormant" gnus-summary-limit-exclude-dormant t]
(gac gnus-article-current)
(reffed gnus-reffed-article-number)
(score-file gnus-current-score-file)
- (default-charset gnus-newsgroup-charset))
+ (default-charset gnus-newsgroup-charset)
+ (emphasis-alist gnus-newsgroup-emphasis-alist))
(save-excursion
(set-buffer gnus-group-buffer)
(setq gnus-newsgroup-name name
gnus-original-article-buffer original
gnus-reffed-article-number reffed
gnus-current-score-file score-file
- gnus-newsgroup-charset default-charset)
+ gnus-newsgroup-charset default-charset
+ gnus-newsgroup-emphasis-alist emphasis-alist)
;; The article buffer also has local variables.
(when (gnus-buffer-live-p gnus-article-buffer)
(set-buffer gnus-article-buffer)
(setq gnus-newsgroup-unselected nil)
(setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group))
(gnus-summary-setup-default-charset)
+ (gnus-summary-setup-highlight-words)
;; Adjust and set lists of article marks.
(when info
(uncompressed '(score bookmark killed))
type list newmarked symbol delta-marks)
(when info
- ;; Add all marks lists that are non-nil to the list of marks lists.
+ ;; Add all marks lists to the list of marks lists.
(while (setq type (pop types))
- (when (setq list (symbol-value
+ (setq list (symbol-value
(setq symbol
(intern (format "gnus-newsgroup-%s"
(car type))))))
+ (when list
;; Get rid of the entries of the articles that have the
;; default score.
(when (and (eq (cdr type) 'score)
(setcdr prev (cdr arts))
(setq prev arts))
(setq arts (cdr arts)))
- (setq list (cdr all))))
-
- (when (gnus-check-backend-function 'request-set-mark
- gnus-newsgroup-name)
- ;; score & bookmark are not proper flags (they are cons cells)
- ;; cache is a internal gnus flag
- (unless (memq (cdr type) '(cache score bookmark))
- (let* ((old (cdr (assq (cdr type) (gnus-info-marks info))))
- (del (gnus-remove-from-range old list))
- (add (gnus-remove-from-range list old)))
- (if add
- (push (list add 'add (list (cdr type))) delta-marks))
- (if del
- (push (list del 'del (list (cdr type))) delta-marks)))))
-
- (push (cons (cdr type)
- (if (memq (cdr type) uncompressed) list
- (gnus-compress-sequence
- (set symbol (sort list '<)) t)))
- newmarked)))
-
- (if delta-marks
- (gnus-request-set-mark gnus-newsgroup-name delta-marks))
-
+ (setq list (cdr all)))))
+
+ (or (memq (cdr type) uncompressed)
+ (setq list (gnus-compress-sequence (set symbol (sort list '<)) t)))
+
+ (when (gnus-check-backend-function 'request-set-mark
+ gnus-newsgroup-name)
+ ;; uncompressed:s are not proper flags (they are cons cells)
+ ;; cache is a internal gnus flag
+ (unless (memq (cdr type) (cons 'cache uncompressed))
+ (let* ((old (cdr (assq (cdr type) (gnus-info-marks info))))
+ (del (gnus-remove-from-range (gnus-copy-sequence old) list))
+ (add (gnus-remove-from-range (gnus-copy-sequence list) old)))
+ (if add
+ (push (list add 'add (list (cdr type))) delta-marks))
+ (if del
+ (push (list del 'del (list (cdr type))) delta-marks)))))
+
+ (when list
+ (push (cons (cdr type) list) newmarked)))
+
+ (when delta-marks
+ (unless (gnus-check-group gnus-newsgroup-name)
+ (error "Can't open server for %s" gnus-newsgroup-name))
+ (gnus-request-set-mark gnus-newsgroup-name delta-marks))
+
;; Enter these new marks into the info of the group.
(if (nthcdr 3 info)
(setcar (nthcdr 3 info) newmarked)
;; Update the group buffer.
(gnus-group-update-group group t)))))
-(defun gnus-methods-equal-p (m1 m2)
- (let ((m1 (or m1 gnus-select-method))
- (m2 (or m2 gnus-select-method)))
- (or (equal m1 m2)
- (and (eq (car m1) (car m2))
- (or (not (memq 'address (assoc (symbol-name (car m1))
- gnus-valid-select-methods)))
- (equal (nth 1 m1) (nth 1 m2)))))))
-
(defvar gnus-newsgroup-none-id 0)
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
`(let ((,articles (gnus-summary-work-articles ,arg)))
(while ,articles
(gnus-summary-goto-subject (car ,articles))
- ,@forms))))
+ ,@forms
+ (pop ,articles)))))
(put 'gnus-summary-iterate 'lisp-indent-function 1)
(put 'gnus-summary-iterate 'edebug-form-spec '(form body))
"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
articles that are younger than AGE days."
- (interactive "nTime in days: \nP")
+ (interactive "nLimit to articles older than (in days): \nP")
(prog1
(let ((data gnus-newsgroup-data)
(cutoff (days-to-time age))
(gnus-summary-limit (nreverse articles)))
(gnus-summary-position-point)))
+(defun gnus-summary-limit-to-extra (header regexp)
+ "Limit the summary buffer to articles that match an 'extra' header."
+ (interactive
+ (let ((header
+ (intern
+ (gnus-completing-read
+ (symbol-name (car gnus-extra-headers))
+ "Score extra header:"
+ (mapcar (lambda (x)
+ (cons (symbol-name x) x))
+ gnus-extra-headers)
+ nil
+ t))))
+ (list header
+ (read-string (format "Limit to header %s (regexp): " header)))))
+ (when (not (equal "" regexp))
+ (prog1
+ (let ((articles (gnus-summary-find-matching
+ (cons 'extra header) regexp 'all)))
+ (unless articles
+ (error "Found no matches for \"%s\"" regexp))
+ (gnus-summary-limit articles))
+ (gnus-summary-position-point))))
+
(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
(make-obsolete
'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
(let ((data (if (eq backward 'all) gnus-newsgroup-data
(gnus-data-find-list
(gnus-summary-article-number) (gnus-data-list backward))))
- (func `(lambda (h) (,(intern (concat "mail-header-" header)) h)))
(case-fold-search (not not-case-fold))
- articles d)
- (unless (fboundp (intern (concat "mail-header-" header)))
- (error "%s is not a valid header" header))
+ articles d func)
+ (if (consp header)
+ (if (eq (car header) 'extra)
+ (setq func
+ `(lambda (h)
+ (or (cdr (assq ',(cdr header) (mail-header-extra h)))
+ "")))
+ (error "%s is an invalid header" header))
+ (unless (fboundp (intern (concat "mail-header-" header)))
+ (error "%s is not a valid header" header))
+ (setq func `(lambda (h) (,(intern (concat "mail-header-" header)) h))))
(while data
(setq d (car data))
(and (or (not unread) ; We want all articles...
(save-restriction
(let* ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
- (hidden (gnus-article-hidden-text-p 'headers))
- e)
+ hidden e)
+ (save-restriction
+ (article-narrow-to-head)
+ (setq hidden (gnus-article-hidden-text-p 'headers)))
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (point-min) (1- (point))))
(insert-buffer-substring gnus-original-article-buffer 1 e)
(save-restriction
(narrow-to-region (point-min) (point))
+ (article-decode-encoded-words)
(if (or hidden
(and (numberp arg) (< arg 0)))
(let ((gnus-treat-hide-headers nil)
(when gnus-use-cache
(gnus-cache-possibly-enter-article
to-group to-article
- (let ((header (copy-sequence
- (gnus-summary-article-header article))))
- (mail-header-set-number header to-article)
- header)
(memq article gnus-newsgroup-marked)
(memq article gnus-newsgroup-dormant)
(memq article gnus-newsgroup-unreads)))
;; There are expirable articles in this group, so we run them
;; through the expiry process.
(gnus-message 6 "Expiring articles...")
+ (unless (gnus-check-group gnus-newsgroup-name)
+ (error "Can't open server for %s" gnus-newsgroup-name))
;; The list of articles that weren't expired is returned.
(save-excursion
(if expiry-wait
(save-excursion
(gnus-cache-possibly-enter-article
gnus-newsgroup-name article
- (gnus-summary-article-header article)
(= mark gnus-ticked-mark)
(= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
(save-excursion
(gnus-cache-possibly-enter-article
gnus-newsgroup-name article
- (gnus-summary-article-header article)
(= mark gnus-ticked-mark)
(= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
split-name))
((consp result)
(setq split-name (append result split-name)))))))))
- split-name))
+ (nreverse split-name)))
(defun gnus-valid-move-group-p (group)
(and (boundp group)
(symbol-name group)
(symbol-value group)
- (memq 'respool
- (assoc (symbol-name
- (car (gnus-find-method-for-group
- (symbol-name group))))
- gnus-valid-select-methods))))
+ (gnus-get-function (gnus-find-method-for-group
+ (symbol-name group)) 'request-accept-article t)))
(defun gnus-read-move-group-name (prompt default articles prefix)
"Read a group name."
(error "No such group: %s" to-newsgroup)))
to-newsgroup))
+(defun gnus-summary-save-parts (type dir n reverse)
+ "Save parts matching TYPE to DIR.
+If REVERSE, save parts that do not match TYPE."
+ (interactive
+ (list (read-string "Save parts of type: " "image/.*")
+ (read-file-name "Save to directory: " t nil t)
+ current-prefix-arg))
+ (gnus-summary-iterate n
+ (let ((gnus-display-mime-function nil)
+ (gnus-inhibit-treatment t))
+ (gnus-summary-select-article))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((handles (or (mm-dissect-buffer) (mm-uu-dissect))))
+ (when handles
+ (gnus-summary-save-parts-1 type dir handles reverse))))))
+
+(defun gnus-summary-save-parts-1 (type dir handle reverse)
+ (if (stringp (car handle))
+ (mapcar (lambda (h) (gnus-summary-save-parts-1 type dir h reverse))
+ (cdr handle))
+ (when (if reverse
+ (not (string-match type (car (mm-handle-type handle))))
+ (string-match type (car (mm-handle-type handle))))
+ (let ((file (expand-file-name
+ (file-name-nondirectory
+ (or
+ (mail-content-type-get
+ (mm-handle-disposition handle) 'filename)
+ (concat gnus-newsgroup-name "." gnus-current-article)))
+ dir)))
+ (unless (file-exists-p file)
+ (mm-save-part-to-file handle file))))))
+
;; Summary extract commands
(defun gnus-summary-insert-pseudos (pslist &optional not-view)
(let ((del (gnus-remove-from-range (gnus-info-read info) read))
(add (gnus-remove-from-range read (gnus-info-read info))))
(when (or add del)
+ (unless (gnus-check-group group)
+ (error "Can't open server for %s" group))
(gnus-request-set-mark
group (delq nil (list (if add (list add 'add '(read)))
(if del (list del 'del '(read)))))))))
(gnus-summary-show-article))
(gnus-summary-show-article)))
+;;;
+;;; with article
+;;;
+
+(defmacro gnus-with-article (article &rest forms)
+ "Select ARTICLE and perform FORMS in the original article buffer.
+Then replace the article with the result."
+ `(progn
+ ;; We don't want the article to be marked as read.
+ (let (gnus-mark-article-hook)
+ (gnus-summary-select-article t t nil ,article))
+ (set-buffer gnus-original-article-buffer)
+ ,@forms
+ (if (not (gnus-check-backend-function
+ 'request-replace-article (car gnus-article-current)))
+ (gnus-message 5 "Read-only group; not replacing")
+ (unless (gnus-request-replace-article
+ ,article (car gnus-article-current)
+ (current-buffer) t)
+ (error "Couldn't replace article")))
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current)))))
+
+(put 'gnus-with-article 'lisp-indent-function 1)
+(put 'gnus-with-article 'edebug-form-spec '(form body))
+
+;;;
+;;; Generic summary marking commands
+;;;
+
+(defvar gnus-summary-marking-alist
+ '((read gnus-del-mark "d")
+ (unread gnus-unread-mark "u")
+ (ticked gnus-ticked-mark "!")
+ (dormant gnus-dormant-mark "?")
+ (expirable gnus-expirable-mark "e"))
+ "An alist of names/marks/keystrokes.")
+
+(defvar gnus-summary-generic-mark-map (make-sparse-keymap))
+(defvar gnus-summary-mark-map)
+
+(defun gnus-summary-make-all-marking-commands ()
+ (define-key gnus-summary-mark-map "M" gnus-summary-generic-mark-map)
+ (dolist (elem gnus-summary-marking-alist)
+ (apply 'gnus-summary-make-marking-command elem)))
+
+(defun gnus-summary-make-marking-command (name mark keystroke)
+ (let ((map (make-sparse-keymap)))
+ (define-key gnus-summary-generic-mark-map keystroke map)
+ (dolist (lway `((next "next" next nil "n")
+ (next-unread "next unread" next t "N")
+ (prev "previous" prev nil "p")
+ (prev-unread "previous unread" prev t "P")
+ (nomove "" nil nil ,keystroke)))
+ (let ((func (gnus-summary-make-marking-command-1
+ mark (car lway) lway name)))
+ (setq func (eval func))
+ (define-key map (nth 4 lway) func)))))
+
+(defun gnus-summary-make-marking-command-1 (mark way lway name)
+ `(defun ,(intern
+ (format "gnus-summary-put-mark-as-%s%s"
+ name (if (eq way 'nomove)
+ ""
+ (concat "-" (symbol-name way)))))
+ (n)
+ ,(format
+ "Mark the current article as %s%s.
+If N, the prefix, then repeat N times.
+If N is negative, move in reverse order.
+The difference between N and the actual number of articles marked is
+returned."
+ name (cadr lway))
+ (interactive "p")
+ (gnus-summary-generic-mark n ,mark ',(nth 2 lway) ,(nth 3 lway))))
+
+(defun gnus-summary-generic-mark (n mark move unread)
+ "Mark N articles with MARK."
+ (unless (eq major-mode 'gnus-summary-mode)
+ (error "This command can only be used in the summary buffer"))
+ (gnus-summary-show-thread)
+ (let ((nummove
+ (cond
+ ((eq move 'next) 1)
+ ((eq move 'prev) -1)
+ (t 0))))
+ (if (zerop nummove)
+ (setq n 1)
+ (when (< n 0)
+ (setq n (abs n)
+ nummove (* -1 nummove))))
+ (while (and (> n 0)
+ (gnus-summary-mark-article nil mark)
+ (zerop (gnus-summary-next-subject nummove unread t)))
+ (setq n (1- n)))
+ (when (/= 0 n)
+ (gnus-message 7 "No more %sarticles" (if mark "" "unread ")))
+ (gnus-summary-recenter)
+ (gnus-summary-position-point)
+ (gnus-set-mode-line 'summary)
+ n))
+
+;; Added by Shenghuo Zhu <zsh@cs.rochester.edu>
+(defun gnus-summary-setup-highlight-words (&optional highlight-words)
+ "Setup newsgroup emphasis alist."
+ (let ((name (and gnus-newsgroup-name
+ (gnus-group-real-name gnus-newsgroup-name))))
+ (setq gnus-newsgroup-emphasis-alist
+ (nconc
+ (let ((alist gnus-group-highlight-words-alist) elem highlight)
+ (while (setq elem (pop alist))
+ (when (and name (string-match (car elem) name))
+ (setq alist nil
+ highlight (copy-list (cdr elem)))))
+ highlight)
+ (copy-list highlight-words)
+ (if gnus-newsgroup-name
+ (copy-list (gnus-group-find-parameter
+ gnus-newsgroup-name 'highlight-words t)))
+ gnus-emphasis-alist))))
+
+(gnus-summary-make-all-marking-commands)
+
(gnus-ems-redefine)
(provide 'gnus-sum)
projects / elisp / gnus.git- / blobdiff