mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-30 04:10:54 -08:00
Code Issues Projects Releases Wiki Activity

*** empty log message ***

Browse source
This commit is contained in:
Lars Magne Ingebrigtsen 1997-09-24 01:50:24 +00:00
parent 5f016f4003
commit a8151ef7e5
38 changed files with 1044 additions and 708 deletions
Download patch file Download diff file Expand all files Collapse all files

234
lisp/gnus/gnus-art.el
View file

@ -191,7 +191,7 @@ asynchronously. The compressed face will be piped to this command."
(lambda (spec)
(list
(format format (car spec) (cadr spec))
2 3 (intern (format "gnus-emphasis-%s" (car (cddr spec))))))
2 3 (intern (format "gnus-emphasis-%s" (caddr spec)))))
types)))
"Alist that says how to fontify certain phrases.
Each item looks like this:
@ -397,6 +397,11 @@ If you want to run a special decoding program like nkf, use this hook."
:type 'hook
:group 'gnus-article-various)
(defcustom gnus-article-hide-pgp-hook nil
"*A hook called after successfully hiding a PGP signature."
:type 'hook
:group 'gnus-article-various)
(defcustom gnus-article-button-face 'bold
"Face used for highlighting buttons in the article buffer.
@ -413,12 +418,20 @@ above them."
:type 'face
:group 'gnus-article-buttons)
(defcustom gnus-signature-face 'italic
"Face used for highlighting a signature in the article buffer."
(defcustom gnus-signature-face 'gnus-signature-face
"Face used for highlighting a signature in the article buffer.
Obsolete; use the face `gnus-signature-face' for customizations instead."
:type 'face
:group 'gnus-article-highlight
:group 'gnus-article-signature)
(defface gnus-signature-face
'((((type x))
(:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
(defface gnus-header-from-face
'((((class color)
(background dark))
@ -569,20 +582,20 @@ Initialized from `text-mode-syntax-table.")
(defun gnus-article-delete-text-of-type (type)
"Delete text of TYPE in the current buffer."
(save-excursion
(let ((e (point-min))
b)
(while (setq b (text-property-any e (point-max) 'article-type type))
(setq e (text-property-not-all b (point-max) 'article-type type))
(delete-region b e)))))
(let ((b (point-min)))
(while (setq b (text-property-any b (point-max) 'article-type type))
(delete-region
b (or (text-property-not-all b (point-max) 'article-type type)
(point-max)))))))
(defun gnus-article-delete-invisible-text ()
"Delete all invisible text in the current buffer."
(save-excursion
(let ((e (point-min))
b)
(while (setq b (text-property-any e (point-max) 'invisible t))
(setq e (text-property-not-all b (point-max) 'invisible t))
(delete-region b e)))))
(let ((b (point-min)))
(while (setq b (text-property-any b (point-max) 'invisible t))
(delete-region
b (or (text-property-not-all b (point-max) 'invisible t)
(point-max)))))))
(defun gnus-article-text-type-exists-p (type)
"Say whether any text of type TYPE exists in the buffer."
@ -828,33 +841,46 @@ always hide."
(nnheader-narrow-to-headers)
(setq from (message-fetch-field "from"))
(goto-char (point-min))
(when (and gnus-article-x-face-command
(or force
;; Check whether this face is censored.
(not gnus-article-x-face-too-ugly)
(and gnus-article-x-face-too-ugly from
(not (string-match gnus-article-x-face-too-ugly
from))))
;; Has to be present.
(re-search-forward "^X-Face: " nil t))
(while (and gnus-article-x-face-command
(or force
;; Check whether this face is censored.
(not gnus-article-x-face-too-ugly)
(and gnus-article-x-face-too-ugly from
(not (string-match gnus-article-x-face-too-ugly
from))))
;; Has to be present.
(re-search-forward "^X-Face: " nil t))
;; We now have the area of the buffer where the X-Face is stored.
(let ((beg (point))
(end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
;; We display the face.
(if (symbolp gnus-article-x-face-command)
;; The command is a lisp function, so we call it.
(if (gnus-functionp gnus-article-x-face-command)
(funcall gnus-article-x-face-command beg end)
(error "%s is not a function" gnus-article-x-face-command))
;; The command is a string, so we interpret the command
;; as a, well, command, and fork it off.
(let ((process-connection-type nil))
(process-kill-without-query
(start-process
"article-x-face" nil shell-file-name shell-command-switch
gnus-article-x-face-command))
(process-send-region "article-x-face" beg end)
(process-send-eof "article-x-face")))))))))
(save-excursion
(let ((beg (point))
(end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
;; We display the face.
(if (symbolp gnus-article-x-face-command)
;; The command is a lisp function, so we call it.
(if (gnus-functionp gnus-article-x-face-command)
(funcall gnus-article-x-face-command beg end)
(error "%s is not a function" gnus-article-x-face-command))
;; The command is a string, so we interpret the command
;; as a, well, command, and fork it off.
(let ((process-connection-type nil))
(process-kill-without-query
(start-process
"article-x-face" nil shell-file-name shell-command-switch
gnus-article-x-face-command))
(process-send-region "article-x-face" beg end)
(process-send-eof "article-x-face"))))))))))
(defun gnus-hack-decode-rfc1522 ()
"Emergency hack function for avoiding problems when decoding."
(let ((buffer-read-only nil))
(goto-char (point-min))
;; Remove encoded TABs.
(while (search-forward "=09" nil t)
(replace-match " " t t))
;; Remove encoded newlines.
(goto-char (point-min))
(while (search-forward "=10" nil t)
(replace-match " " t t))))
(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522)
(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522)
@ -937,27 +963,28 @@ always hide."
;; Hide the "header".
(when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
(gnus-article-hide-text-type (1+ (match-beginning 0))
(match-end 0) 'pgp))
(setq beg (point))
;; Hide the actual signature.
(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
(setq end (1+ (match-beginning 0)))
(gnus-article-hide-text-type
end
(if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
(match-end 0)
;; Perhaps we shouldn't hide to the end of the buffer
;; if there is no end to the signature?
(point-max))
'pgp))
;; Hide "- " PGP quotation markers.
(when (and beg end)
(narrow-to-region beg end)
(goto-char (point-min))
(while (re-search-forward "^- " nil t)
(gnus-article-hide-text-type
(match-beginning 0) (match-end 0) 'pgp))
(widen))))))
(match-end 0) 'pgp)
(setq beg (point))
;; Hide the actual signature.
(and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
(setq end (1+ (match-beginning 0)))
(gnus-article-hide-text-type
end
(if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
(match-end 0)
;; Perhaps we shouldn't hide to the end of the buffer
;; if there is no end to the signature?
(point-max))
'pgp))
;; Hide "- " PGP quotation markers.
(when (and beg end)
(narrow-to-region beg end)
(goto-char (point-min))
(while (re-search-forward "^- " nil t)
(gnus-article-hide-text-type
(match-beginning 0) (match-end 0) 'pgp))
(widen))
(run-hooks 'gnus-article-hide-pgp-hook))))))
(defun article-hide-pem (&optional arg)
"Toggle hiding of any PEM headers and signatures in the current article.
@ -1101,7 +1128,8 @@ Put point at the beginning of the signature separator."
nil)))
(eval-and-compile
(autoload 'w3-parse-buffer "w3-parse"))
(autoload 'w3-display "w3-parse")
(autoload 'w3-do-setup "w3" "" t))
(defun gnus-article-treat-html ()
"Render HTML."
@ -1109,6 +1137,7 @@ Put point at the beginning of the signature separator."
(let ((cbuf (current-buffer)))
(set-buffer gnus-article-buffer)
(let (buf buffer-read-only b e)
(w3-do-setup)
(goto-char (point-min))
(narrow-to-region
(if (search-forward "\n\n" nil t)
@ -1117,12 +1146,13 @@ Put point at the beginning of the signature separator."
(setq e (point-max)))
(nnheader-temp-write nil
(insert-buffer-substring gnus-article-buffer b e)
(require 'url)
(save-window-excursion
(setq buf (car (w3-parse-buffer (current-buffer))))))
(w3-region (point-min) (point-max))
(setq buf (buffer-substring-no-properties (point-min) (point-max)))))
(when buf
(delete-region (point-min) (point-max))
(insert-buffer-substring buf)
(kill-buffer buf))
(insert buf))
(widen)
(goto-char (point-min))
(set-window-start (get-buffer-window (current-buffer)) (point-min))
@ -1391,7 +1421,7 @@ This format is defined by the `gnus-article-time-format' variable."
(gnus-article-hide-headers 1 t)))
(save-window-excursion
(if (not gnus-default-article-saver)
(error "No default saver is defined.")
(error "No default saver is defined")
;; !!! Magic! The saving functions all save
;; `gnus-original-article-buffer' (or so they think), but we
;; bind that variable to our save-buffer.
@ -1452,7 +1482,8 @@ This format is defined by the `gnus-article-time-format' variable."
default-name))
;; A single split name was found
((= 1 (length split-name))
(let* ((name (car split-name))
(let* ((name (expand-file-name
(car split-name) gnus-article-save-directory))
(dir (cond ((file-directory-p name)
(file-name-as-directory name))
((file-exists-p name) name)
@ -1718,34 +1749,33 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(put 'gnus-article-mode 'mode-class 'special)
(when t
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
"\177" gnus-article-goto-prev-page
[delete] gnus-article-goto-prev-page
"\C-c^" gnus-article-refer-article
"h" gnus-article-show-summary
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
gnus-mouse-2 gnus-article-push-button
"\r" gnus-article-press-button
"\t" gnus-article-next-button
"\M-\t" gnus-article-prev-button
"e" gnus-article-edit
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
"\177" gnus-article-goto-prev-page
[delete] gnus-article-goto-prev-page
"\C-c^" gnus-article-refer-article
"h" gnus-article-show-summary
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
gnus-mouse-2 gnus-article-push-button
"\r" gnus-article-press-button
"\t" gnus-article-next-button
"\M-\t" gnus-article-prev-button
"e" gnus-article-edit
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
"\M-#" gnus-article-read-summary-keys
"\M-^" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
"\M-#" gnus-article-read-summary-keys
"\M-^" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
(substitute-key-definition
'undefined 'gnus-article-read-summary-keys gnus-article-mode-map))
(substitute-key-definition
'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
(defun gnus-article-make-menu-bar ()
(gnus-turn-off-edit-menu 'article)
@ -2032,7 +2062,8 @@ Provided for backwards compatibility."
;; save it to file.
(goto-char (point-max))
(insert "\n")
(append-to-file (point-min) (point-max) file-name))))
(append-to-file (point-min) (point-max) file-name)
t)))
(defun gnus-narrow-to-page (&optional arg)
"Narrow the article buffer to a page.
@ -2151,6 +2182,7 @@ Argument LINES specifies lines to be scrolled down."
(interactive)
(if (not (gnus-buffer-live-p gnus-summary-buffer))
(error "There is no summary buffer for this article buffer")
(gnus-article-set-globals)
(gnus-configure-windows 'article)
(gnus-summary-goto-subject gnus-current-article)))
@ -2442,7 +2474,7 @@ groups."
(interactive "P")
(when (and (not force)
(gnus-group-read-only-p))
(error "The current newsgroup does not support article editing."))
(error "The current newsgroup does not support article editing"))
(gnus-article-edit-article
`(lambda ()
(gnus-summary-edit-article-done
@ -2454,7 +2486,7 @@ groups."
(let ((winconf (current-window-configuration)))
(set-buffer gnus-article-buffer)
(gnus-article-edit-mode)
(set-text-properties (point-min) (point-max) nil)
(gnus-set-text-properties (point-min) (point-max) nil)
(gnus-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
@ -2532,14 +2564,14 @@ groups."
(defcustom gnus-button-alist
`(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t
gnus-button-message-id 2)
("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*+\\)" 0 t gnus-button-message-id 1)
("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1)
("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t
gnus-button-fetch-group 4)
("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
t gnus-button-message-id 3)
("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 1)
("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2)
("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
;; This is how URLs _should_ be embedded in text...
("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
;; Raw URLs.
@ -2572,6 +2604,7 @@ variable it the real callback function."
("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
0 t gnus-button-mailto 0)
("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
gnus-button-message-id 3))
@ -2846,6 +2879,11 @@ specified by `gnus-button-alist'."
;;; Internal functions:
(defun gnus-article-set-globals ()
(save-excursion
(set-buffer gnus-summary-buffer)
(gnus-set-global-variables)))
(defun gnus-signature-toggle (end)
(save-excursion
(set-buffer gnus-article-buffer)

59
lisp/gnus/gnus-cache.el
View file

@ -146,7 +146,8 @@ variable to \"^nnml\"."
(mail-header-set-number headers (cdr result))))
(let ((number (mail-header-number headers))
file dir)
(when (and (> number 0) ; Reffed article.
(when (and number
(> number 0) ; Reffed article.
(or force
(and (or (not gnus-uncacheable-groups)
(not (string-match
@ -256,15 +257,13 @@ variable to \"^nnml\"."
(defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when (equal group "no.norsk") (error "hie"))
(when gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
(and cache-active
(< (car cache-active) (car active))
(setcar active (car cache-active)))
(and cache-active
(> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active))))))
(when cache-active
(when (< (car cache-active) (car active))
(setcar active (car cache-active)))
(when (> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active)))))))
(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
"Retrieve the headers for ARTICLES in GROUP."
@ -453,13 +452,20 @@ Returns the list of articles removed."
(defun gnus-cache-articles-in-group (group)
"Return a sorted list of cached articles in GROUP."
(let ((dir (file-name-directory (gnus-cache-file-name group 1))))
(let ((dir (file-name-directory (gnus-cache-file-name group 1)))
articles)
(when (file-exists-p dir)
(sort (mapcar (lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))
'<))))
(setq articles
(sort (mapcar (lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))
'<))
;; Update the cache active file, just to synch more.
(when articles
(gnus-cache-update-active group (car articles) t)
(gnus-cache-update-active group (car (last articles))))
articles)))
(defun gnus-cache-braid-nov (group cached)
(defun gnus-cache-braid-nov (group cached &optional file)
(let ((cache-buf (get-buffer-create " *gnus-cache*"))
beg end)
(gnus-cache-save-buffers)
@ -467,7 +473,7 @@ Returns the list of articles removed."
(set-buffer cache-buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-file-contents (gnus-cache-file-name group ".overview"))
(insert-file-contents (or file (gnus-cache-file-name group ".overview")))
(goto-char (point-min))
(insert "\n")
(goto-char (point-min)))
@ -540,22 +546,21 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
(gnus)
;; Go through all groups...
(gnus-group-mark-buffer)
(gnus-group-universal-argument
nil nil
(lambda ()
(interactive)
(gnus-summary-read-group (gnus-group-group-name) nil t)
;; ... and enter the articles into the cache.
(when (eq major-mode 'gnus-summary-mode)
(gnus-uu-mark-buffer)
(gnus-cache-enter-article)
(kill-buffer (current-buffer)))))))
(gnus-group-iterate nil
(lambda (group)
(let (gnus-auto-select-next)
(gnus-summary-read-group group nil t)
;; ... and enter the articles into the cache.
(when (eq major-mode 'gnus-summary-mode)
(gnus-uu-mark-buffer)
(gnus-cache-enter-article)
(kill-buffer (current-buffer))))))))
(defun gnus-cache-read-active (&optional force)
"Read the cache active file."
(gnus-make-directory gnus-cache-directory)
(if (not (and (file-exists-p gnus-cache-active-file)
(or force (not gnus-cache-active-hashtb))))
(if (or (not (file-exists-p gnus-cache-active-file))
force)
;; There is no active file, so we generate one.
(gnus-cache-generate-active)
;; We simply read the active file.
@ -651,7 +656,7 @@ If LOW, update the lower bound instead."
(defun gnus-cache-move-cache (dir)
"Move the cache tree to somewhere else."
(interactive "DMove the cache tree to: ")
(interactive "FMove the cache tree to: ")
(rename-file gnus-cache-directory dir))
(provide 'gnus-cache)

8
lisp/gnus/gnus-cite.el
View file

@ -100,13 +100,14 @@ The first regexp group should match the Supercite attribution."
:group 'gnus-cite
:type 'integer)
(defcustom gnus-cite-attribution-prefix "in article\\|in <"
(defcustom gnus-cite-attribution-prefix
"in article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),"
"Regexp matching the beginning of an attribution line."
:group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-attribution-suffix
"\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
"\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\)[ ]*$"
"Regexp matching the end of an attribution line.
The text matching the first grouping will be used as a button."
:group 'gnus-cite
@ -439,7 +440,8 @@ If WIDTH (the numerical prefix), use that text width when filling."
(setq gnus-cite-prefix-alist nil
gnus-cite-attribution-alist nil
gnus-cite-loose-prefix-alist nil
gnus-cite-loose-attribution-alist nil)))))
gnus-cite-loose-attribution-alist nil
gnus-cite-article nil)))))
(defun gnus-article-hide-citation (&optional arg force)
"Toggle hiding of all cited text except attribution lines.

56
lisp/gnus/gnus-demon.el
View file

@ -152,21 +152,35 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
"Find out how many seconds to TIME, which is on the form \"17:43\"."
(if (not (stringp time))
time
(let* ((date (current-time-string))
(dv (timezone-parse-date date))
(tdate (timezone-make-arpa-date
(string-to-number (aref dv 0))
(string-to-number (aref dv 1))
(string-to-number (aref dv 2)) time
(or (aref dv 4) "UT")))
(nseconds (gnus-time-minus
(gnus-encode-date tdate) (gnus-encode-date date))))
(round
(/ (+ (if (< (car nseconds) 0)
86400 0)
(* 65536 (car nseconds))
(nth 1 nseconds))
gnus-demon-timestep)))))
(let* ((now (current-time))
;; obtain NOW as discrete components -- make a vector for speed
(nowParts (apply 'vector (decode-time now)))
;; obtain THEN as discrete components
(thenParts (timezone-parse-time time))
(thenHour (string-to-int (elt thenParts 0)))
(thenMin (string-to-int (elt thenParts 1)))
;; convert time as elements into number of seconds since EPOCH.
(then (encode-time 0
thenMin
thenHour
;; If THEN is earlier than NOW, make it
;; same time tomorrow. Doc for encode-time
;; says that this is OK.
(+ (elt nowParts 3)
(if (or (< thenHour (elt nowParts 2))
(and (= thenHour (elt nowParts 2))
(<= thenMin (elt nowParts 1))))
1 0))
(elt nowParts 4)
(elt nowParts 5)
(elt nowParts 6)
(elt nowParts 7)
(elt nowParts 8)))
;; calculate number of seconds between NOW and THEN
(diff (+ (* 65536 (- (car then) (car now)))
(- (cadr then) (cadr now)))))
;; return number of timesteps in the number of seconds
(round (/ diff gnus-demon-timestep)))))
(defun gnus-demon ()
"The Gnus daemon that takes care of running all Gnus handlers."
@ -202,7 +216,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle.
;; So we call the handler.
(progn
(funcall (car handler))
(ignore-errors (funcall (car handler)))
;; And reset the timer.
(setcar (nthcdr 1 handler)
(gnus-demon-time-to-step
@ -211,24 +225,26 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
((null (setq idle (nth 2 handler)))
;; We do nothing.
)
((not (numberp idle))
((and (not (numberp idle))
(gnus-demon-is-idle-p))
;; We want to call this handler each and every time that
;; Emacs is idle.
(funcall (car handler)))
(ignore-errors (funcall (car handler))))
(t
;; We want to call this handler only if Emacs has been idle
;; for a specified number of timesteps.
(and (not (memq (car handler) gnus-demon-idle-has-been-called))
(< idle gnus-demon-idle-time)
(gnus-demon-is-idle-p)
(progn
(funcall (car handler))
(ignore-errors (funcall (car handler)))
;; Make sure the handler won't be called once more in
;; this idle-cycle.
(push (car handler) gnus-demon-idle-has-been-called)))))))))
(defun gnus-demon-add-nocem ()
"Add daemonic NoCeM handling to Gnus."
(gnus-demon-add-handler 'gnus-demon-scan-nocem 60 t))
(gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30))
(defun gnus-demon-scan-nocem ()
"Scan NoCeM groups for NoCeM messages."

28
lisp/gnus/gnus-ems.el
View file

@ -34,11 +34,16 @@
(defvar gnus-mouse-2 [mouse-2])
(defvar gnus-down-mouse-2 [down-mouse-2])
(defvar gnus-mode-line-modified
(if (or gnus-xemacs
(< emacs-major-version 20))
'("--**-" . "-----")
'("**" "--")))
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
(autoload 'appt-select-lowest-window "appt.el"))
(autoload 'appt-select-lowest-window "appt"))
(or (fboundp 'mail-file-babyl-p)
(fset 'mail-file-babyl-p 'rmail-file-p))
@ -70,18 +75,15 @@
(truncate-string valstr (, max-width))
valstr))))
(defun gnus-encode-coding-string (string system)
string)
(eval-and-compile
(if (string-match "XEmacs\\|Lucid" emacs-version)
nil
(defvar gnus-mouse-face-prop 'mouse-face
"Property used for highlighting mouse regions.")
(defvar gnus-article-x-face-command
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
"String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."))
"Property used for highlighting mouse regions."))
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
@ -171,6 +173,7 @@ asynchronously. The compressed face will be piped to this command."))
(fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
(fset 'gnus-max-width-function 'gnus-mule-max-width-function)
(fset 'gnus-summary-set-display-table 'ignore)
(fset 'gnus-encode-coding-string 'encode-coding-string)
(when (boundp 'gnus-check-before-posting)
(setq gnus-check-before-posting
@ -203,6 +206,15 @@ asynchronously. The compressed face will be piped to this command."))
(boundp 'mark-active)
mark-active))
(defun gnus-add-minor-mode (mode name map)
(if (fboundp 'add-minor-mode)
(add-minor-mode mode name map)
(unless (assq mode minor-mode-alist)
(push `(,mode ,name) minor-mode-alist))
(unless (assq mode minor-mode-map-alist)
(push (cons mode map)
minor-mode-map-alist))))
(provide 'gnus-ems)
;; Local Variables:

7
lisp/gnus/gnus-gl.el
View file

@ -851,11 +851,8 @@ recommend using both scores and grouplens predictions together."
(when (and menu-bar-mode
(gnus-visual-p 'grouplens-menu 'menu))
(gnus-grouplens-make-menu-bar))
(unless (assq 'gnus-grouplens-mode minor-mode-alist)
(push '(gnus-grouplens-mode " GroupLens") minor-mode-alist))
(unless (assq 'gnus-grouplens-mode minor-mode-map-alist)
(push (cons 'gnus-grouplens-mode gnus-grouplens-mode-map)
minor-mode-map-alist))
(gnus-add-minor-mode
'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map)
(run-hooks 'gnus-grouplens-mode-hook))))
(provide 'gnus-gl)

114
lisp/gnus/gnus-group.el
View file

@ -84,8 +84,10 @@ with the best level."
(defcustom gnus-permanently-visible-groups nil
"*Regexp to match groups that should always be listed in the group buffer.
This means that they will still be listed when there are no unread
articles in the groups."
This means that they will still be listed even when there are no
unread articles in the groups.
If nil, no groups are permanently visible."
:group 'gnus-group-listing
:type '(choice regexp (const nil)))
@ -446,7 +448,7 @@ ticked: The number of ticked articles."
"r" gnus-group-read-init-file
"B" gnus-group-browse-foreign-server
"b" gnus-group-check-bogus-groups
"F" gnus-find-new-newsgroups
"F" gnus-group-find-new-groups
"\C-c\C-d" gnus-group-describe-group
"\M-d" gnus-group-describe-all-groups
"\C-c\C-a" gnus-group-apropos
@ -485,7 +487,7 @@ ticked: The number of ticked articles."
"m" gnus-group-mark-group
"u" gnus-group-unmark-group
"w" gnus-group-mark-region
"m" gnus-group-mark-buffer
"b" gnus-group-mark-buffer
"r" gnus-group-mark-regexp
"U" gnus-group-unmark-all-groups)
@ -604,8 +606,7 @@ ticked: The number of ticked articles."
(gnus-group-group-name)]
["Info" gnus-group-edit-group (gnus-group-group-name)]
["Local kill file" gnus-group-edit-local-kill (gnus-group-group-name)]
["Global kill file" gnus-group-edit-global-kill t])
))
["Global kill file" gnus-group-edit-global-kill t])))
(easy-menu-define
gnus-group-group-menu gnus-group-mode-map ""
@ -692,11 +693,10 @@ ticked: The number of ticked articles."
["First unread group" gnus-group-first-unread-group t]
["Best unread group" gnus-group-best-unread-group t])
["Delete bogus groups" gnus-group-check-bogus-groups t]
["Find new newsgroups" gnus-find-new-newsgroups t]
["Find new newsgroups" gnus-group-find-new-groups t]
["Transpose" gnus-group-transpose-groups
(gnus-group-group-name)]
["Read a directory as a group..." gnus-group-enter-directory t]
))
["Read a directory as a group..." gnus-group-enter-directory t]))
(easy-menu-define
gnus-group-misc-menu gnus-group-mode-map ""
@ -727,8 +727,7 @@ ticked: The number of ticked articles."
["Flush score cache" gnus-score-flush-cache t]
["Toggle topics" gnus-topic-mode t]
["Exit from Gnus" gnus-group-exit t]
["Exit without saving" gnus-group-quit t]
))
["Exit without saving" gnus-group-quit t]))
(run-hooks 'gnus-group-menu-hook)))
@ -1218,7 +1217,9 @@ already."
(not (zerop (buffer-size))))))
(mode-string (eval gformat)))
;; Say whether the dribble buffer has been modified.
(setq mode-line-modified (if modified "**" "--"))
(setq mode-line-modified
(if modified (car gnus-mode-line-modified)
(cdr gnus-mode-line-modified)))
;; If the line is too long, we chop it off.
(when (> (length mode-string) max-len)
(setq mode-string (substring mode-string 0 (- max-len 4))))
@ -1278,24 +1279,26 @@ If FIRST-TOO, the current line is also eligible as a target."
(not (eobp))
(not (setq
found
(and (or all
(and
(let ((unread
(get-text-property (point) 'gnus-unread)))
(and (numberp unread) (> unread 0)))
(setq lev (get-text-property (point)
(and
(get-text-property (point) 'gnus-group)
(or all
(and
(let ((unread
(get-text-property (point) 'gnus-unread)))
(and (numberp unread) (> unread 0)))
(setq lev (get-text-property (point)
'gnus-level))
(<= lev gnus-level-subscribed)))
(or (not level)
(and (setq lev (get-text-property (point)
'gnus-level))
(<= lev gnus-level-subscribed)))
(or (not level)
(and (setq lev (get-text-property (point)
'gnus-level))
(or (= lev level)
(and (< lev low)
(< level lev)
(progn
(setq low lev)
(setq pos (point))
nil))))))))
(or (= lev level)
(and (< lev low)
(< level lev)
(progn
(setq low lev)
(setq pos (point))
nil))))))))
(zerop (forward-line way)))))
(if found
(progn (gnus-group-position-point) t)
@ -1449,10 +1452,14 @@ Take into consideration N (the prefix) and the list of marked groups."
FUNCTION will be called with the group name as the paremeter
and with point over the group in question."
(let ((groups (gnus-group-process-prefix arg))
(window (selected-window))
group)
(while (setq group (pop groups))
(select-window window)
(gnus-group-remove-mark group)
(funcall function group))))
(save-selected-window
(save-excursion
(funcall function group))))))
(put 'gnus-group-iterate 'lisp-indent-function 1)
@ -1961,7 +1968,7 @@ and NEW-NAME will be prompted for."
(let ((entry (assoc (completing-read "Create group: " gnus-useful-groups
nil t)
gnus-useful-groups)))
(list (cadr entry) (nth 2 entry))))
(list (cadr entry) (caddr entry))))
(setq method (gnus-copy-sequence method))
(let (entry)
(while (setq entry (memq (assq 'eval method) method))
@ -2026,15 +2033,16 @@ If SOLID (the prefix), create a solid group."
(let* ((group
(if solid (gnus-read-group "Group name: ")
(message-unique-id)))
(default-type (or (car gnus-group-web-type-history)
(symbol-name (caar nnweb-type-definition))))
(type
(completing-read
"Search engine type: "
(mapcar (lambda (elem) (list (symbol-name (car elem))))
nnweb-type-definition)
nil t (cons (or (car gnus-group-web-type-history)
(symbol-name (caar nnweb-type-definition)))
0)
'gnus-group-web-type-history))
(gnus-string-or
(completing-read
(format "Search engine type (default %s): " default-type)
(mapcar (lambda (elem) (list (symbol-name (car elem))))
nnweb-type-definition)
nil t nil 'gnus-group-web-type-history)
default-type))
(search
(read-string
"Search string: "
@ -2147,7 +2155,7 @@ score file entries for articles to include in the group."
(pgroup (gnus-group-prefixed-name group method)))
;; Check whether it exists already.
(when (gnus-gethash pgroup gnus-newsrc-hashtb)
(error "Group %s already exists." pgroup))
(error "Group %s already exists" pgroup))
;; Subscribe the new group after the group on the current line.
(gnus-subscribe-group pgroup (gnus-group-group-name) method)
(gnus-group-update-group pgroup)
@ -2878,7 +2886,7 @@ re-scanning. If ARG is non-nil and not a number, this will force
(gnus-group-list-groups (and (numberp arg)
(max (car gnus-group-list-mode) arg)))))
(defun gnus-group-get-new-news-this-group (&optional n)
(defun gnus-group-get-new-news-this-group (&optional n dont-scan)
"Check for newly arrived news in the current group (and the N-1 next groups).
The difference between N and the number of newsgroup checked is returned.
If N is negative, this group and the N-1 previous groups will be checked."
@ -2892,7 +2900,7 @@ If N is negative, this group and the N-1 previous groups will be checked."
(gnus-group-remove-mark group)
;; Bypass any previous denials from the server.
(gnus-remove-denial (gnus-find-method-for-group group))
(if (gnus-activate-group group 'scan)
(if (gnus-activate-group group (if dont-scan nil 'scan))
(progn
(gnus-get-unread-articles-in-group
(gnus-get-info group) (gnus-active group) t)
@ -2917,11 +2925,11 @@ to use."
(interactive
(list
(gnus-group-group-name)
(cond (current-prefix-arg
(completing-read
"Faq dir: " (and (listp gnus-group-faq-directory)
(mapcar (lambda (file) (list file))
gnus-group-faq-directory)))))))
(when current-prefix-arg
(completing-read
"Faq dir: " (and (listp gnus-group-faq-directory)
(mapcar (lambda (file) (list file))
gnus-group-faq-directory))))))
(unless group
(error "No group name given"))
(let ((dirs (or faq-dir gnus-group-faq-directory))
@ -3082,7 +3090,8 @@ If FORCE, force saving whether it is necessary or not."
(defun gnus-group-read-init-file ()
"Read the Gnus elisp init file."
(interactive)
(gnus-read-init-file))
(gnus-read-init-file)
(gnus-message 5 "Read %s" gnus-init-file))
(defun gnus-group-check-bogus-groups (&optional silent)
"Check bogus newsgroups.
@ -3092,6 +3101,15 @@ group."
(gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user)))
(gnus-group-list-groups))
(defun gnus-group-find-new-groups (&optional arg)
"Search for new groups and add them.
Each new group will be treated with `gnus-subscribe-newsgroup-method.'
If ARG (the prefix), use the `ask-server' method to query
the server for new groups."
(interactive "P")
(gnus-find-new-newsgroups arg)
(gnus-group-list-groups))
(defun gnus-group-edit-global-kill (&optional article group)
"Edit the global kill file.
If GROUP, edit that local kill file instead."

2
lisp/gnus/gnus-int.el
View file

@ -377,7 +377,7 @@ If GROUP is nil, all groups on METHOD are scanned."
last)))
(defun gnus-request-replace-article (article group buffer)
(let ((func (car (gnus-find-method-for-group group))))
(let ((func (car (gnus-group-name-to-method group))))
(funcall (intern (format "%s-request-replace-article" func))
article (gnus-group-real-name group) buffer)))

14
lisp/gnus/gnus-move.el
View file

@ -61,15 +61,18 @@ Update the .newsrc.eld file to reflect the change of nntp server."
"Move group INFO from FROM-SERVER to TO-SERVER."
(let ((group (gnus-info-group info))
to-active hashtb type mark marks
to-article to-reads to-marks article)
to-article to-reads to-marks article
act-articles)
(gnus-message 7 "Translating %s..." group)
(when (gnus-request-group group nil to-server)
(setq to-active (gnus-parse-active)
hashtb (gnus-make-hashtable 1024))
hashtb (gnus-make-hashtable 1024)
act-articles (gnus-uncompress-range to-active))
;; Fetch the headers from the `to-server'.
(when (and to-active
act-articles
(setq type (gnus-retrieve-headers
(gnus-uncompress-range to-active)
act-articles
group to-server)))
;; Convert HEAD headers. I don't care.
(when (eq type 'headers)
@ -127,7 +130,7 @@ Update the .newsrc.eld file to reflect the change of nntp server."
;; into the Gnus info format.
(setq to-reads
(gnus-range-add
(gnus-compress-sequence (sort to-reads '<) t)
(gnus-compress-sequence (and to-reads (sort to-reads '<)) t)
(cons 1 (1- (car to-active)))))
(gnus-info-set-read info to-reads)
;; Do the marks. I'm sure y'all understand what's
@ -144,7 +147,8 @@ Update the .newsrc.eld file to reflect the change of nntp server."
(cons article (cdr a)))))
(setq a lists)
(while a
(setcdr (car a) (gnus-compress-sequence (sort (cdar a) '<)))
(setcdr (car a) (gnus-compress-sequence
(and (cdar a) (sort (cdar a) '<))))
(pop a))
(gnus-info-set-marks info lists t)))))
(gnus-message 7 "Translating %s...done" group)))

7
lisp/gnus/gnus-msg.el
View file

@ -514,6 +514,7 @@ If SILENT, don't prompt the user."
;; Dummy to avoid byte-compile warning.
(defvar nnspool-rejected-article-hook)
(defvar xemacs-codename)
;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
;;; as well include the Emacs version as well.
@ -539,7 +540,9 @@ If SILENT, don't prompt the user."
(substring emacs-version
(match-beginning 3)
(match-end 3))
"")))
"")
(if (boundp 'xemacs-codename)
(concat " - \"" xemacs-codename "\""))))
(t emacs-version))))
;; Written by "Mr. Per Persson" <pp@gnu.ai.mit.edu>.
@ -693,6 +696,8 @@ The current group name will be inserted at \"%s\".")
(message-goto-subject)
(re-search-forward " *$")
(replace-match " (crosspost notification)" t t)
(when (fboundp 'deactivate-mark)
(deactivate-mark))
(when (gnus-y-or-n-p "Send this complaint? ")
(message-send-and-exit)))))))

44
lisp/gnus/gnus-nocem.el
View file

@ -45,13 +45,13 @@
:type '(repeat (string :tag "Group")))
(defcustom gnus-nocem-issuers
'("AutoMoose-1" "Automoose-1" ; CancelMoose[tm]
"rbraver@ohww.norman.ok.us" ; Robert Braver
"clewis@ferret.ocunix.on.ca;" ; Chris Lewis
"jem@xpat.com;" ; Despammer from Korea
"snowhare@xmission.com" ; Benjamin "Snowhare" Franz
"red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM!
)
'("AutoMoose-1" "Automoose-1" ; CancelMoose[tm]
"rbraver@ohww.norman.ok.us" ; Robert Braver
"clewis@ferret.ocunix.on.ca" ; Chris Lewis
"jem@xpat.com" ; Despammer from Korea
"snowhare@xmission.com" ; Benjamin "Snowhare" Franz
"red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM!
)
"List of NoCeM issuers to pay attention to."
:group 'gnus-nocem
:type '(repeat string))
@ -98,6 +98,23 @@ matches an previously scanned and verified nocem message."
(defun gnus-nocem-cache-file ()
(concat (file-name-as-directory gnus-nocem-directory) "cache"))
;;
;; faster lookups for group names:
;;
(defvar gnus-nocem-real-group-hashtb nil
"Real-name mappings of subscribed groups.")
(defun gnus-fill-real-hashtb ()
"Fill up a hash table with the real-name mappings from the user's
active file."
(setq gnus-nocem-real-group-hashtb (gnus-make-hashtable
(length gnus-newsrc-alist)))
(mapcar (lambda (group)
(setq group (gnus-group-real-name (car group)))
(gnus-sethash group t gnus-nocem-real-group-hashtb))
gnus-newsrc-alist))
(defun gnus-nocem-scan-groups ()
"Scan all NoCeM groups for new NoCeM messages."
(interactive)
@ -107,6 +124,8 @@ matches an previously scanned and verified nocem message."
(gnus-make-directory gnus-nocem-directory)
;; Load any previous NoCeM headers.
(gnus-nocem-load-cache)
;; Get the group name mappings:
(gnus-fill-real-hashtb)
;; Read the active file if it hasn't been read yet.
(and (file-exists-p (gnus-nocem-active-file))
(not gnus-nocem-active)
@ -187,6 +206,8 @@ matches an previously scanned and verified nocem message."
(narrow-to-region b e)
(setq issuer (mail-fetch-field "issuer"))
(widen)
(or (member issuer gnus-nocem-issuers)
(message "invalid NoCeM issuer: %s" issuer))
(and (member issuer gnus-nocem-issuers) ; We like her....
(gnus-nocem-verify-issuer issuer) ; She is who she says she is...
(gnus-nocem-enter-article) ; We gobble the message..
@ -196,7 +217,8 @@ matches an previously scanned and verified nocem message."
(defun gnus-nocem-verify-issuer (person)
"Verify using PGP that the canceler is who she says she is."
(if (fboundp gnus-nocem-verifyer)
(funcall gnus-nocem-verifyer)
(ignore-errors
(funcall gnus-nocem-verifyer))
;; If we don't have Mailcrypt, then we use the message anyway.
t))
@ -223,7 +245,8 @@ matches an previously scanned and verified nocem message."
;; Make sure all entries in the hashtb are bound.
(set group nil))
(t
(when (gnus-gethash (symbol-name group) gnus-newsrc-hashtb)
(when (gnus-gethash (gnus-group-real-name (symbol-name group))
gnus-nocem-real-group-hashtb)
;; Valid group.
(beginning-of-line)
(while (= (following-char) ?\t)
@ -294,7 +317,8 @@ matches an previously scanned and verified nocem message."
gnus-nocem-hashtb nil
gnus-nocem-active nil
gnus-nocem-touched-alist nil
gnus-nocem-seen-message-ids nil))
gnus-nocem-seen-message-ids nil
gnus-nocem-real-group-hashtb nil))
(defun gnus-nocem-unwanted-article-p (id)
"Say whether article ID in the current group is wanted."

6
lisp/gnus/gnus-range.el
View file

@ -209,7 +209,7 @@ Note: LIST has to be sorted over `<'."
(setcar ranges (cons (car ranges)
(cadr ranges)))
(setcdr ranges (cddr ranges)))
(when (= (1+ (car ranges)) (car (cadr ranges)))
(when (= (1+ (car ranges)) (caadr ranges))
(setcar (cadr ranges) (car ranges))
(setcar ranges (cadr ranges))
(setcdr ranges (cddr ranges)))))
@ -218,8 +218,8 @@ Note: LIST has to be sorted over `<'."
(when (= (1+ (cdar ranges)) (cadr ranges))
(setcdr (car ranges) (cadr ranges))
(setcdr ranges (cddr ranges)))
(when (= (1+ (cdar ranges)) (car (cadr ranges)))
(setcdr (car ranges) (cdr (cadr ranges)))
(when (= (1+ (cdar ranges)) (caadr ranges))
(setcdr (car ranges) (cdadr ranges))
(setcdr ranges (cddr ranges))))))
(setq ranges (cdr ranges)))
out)))

108
lisp/gnus/gnus-salt.el
View file

@ -36,22 +36,32 @@
(defvar gnus-pick-mode nil
"Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
(defvar gnus-pick-display-summary nil
"*Display summary while reading.")
(defcustom gnus-pick-display-summary nil
"*Display summary while reading."
:type 'boolean
:group 'gnus-summary-pick)
(defvar gnus-pick-mode-hook nil
"Hook run in summary pick mode buffers.")
(defcustom gnus-pick-mode-hook nil
"Hook run in summary pick mode buffers."
:type 'hook
:group 'gnus-summary-pick)
(defvar gnus-mark-unpicked-articles-as-read nil
"*If non-nil, mark all unpicked articles as read.")
(defcustom gnus-mark-unpicked-articles-as-read nil
"*If non-nil, mark all unpicked articles as read."
:type 'boolean
:group 'gnus-summary-pick)
(defvar gnus-pick-elegant-flow t
"If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked.")
(defcustom gnus-pick-elegant-flow t
"If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked."
:type 'boolean
:group 'gnus-summary-pick)
(defvar gnus-summary-pick-line-format
(defcustom gnus-summary-pick-line-format
"%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
"*The format specification of the lines in pick buffers.
It accepts the same format specs that `gnus-summary-line-format' does.")
It accepts the same format specs that `gnus-summary-line-format' does."
:type 'string
:group 'gnus-summary-pick)
;;; Internal variables.
@ -122,11 +132,7 @@ It accepts the same format specs that `gnus-summary-line-format' does.")
;; Set up the menu.
(when (gnus-visual-p 'pick-menu 'menu)
(gnus-pick-make-menu-bar))
(unless (assq 'gnus-pick-mode minor-mode-alist)
(push '(gnus-pick-mode " Pick") minor-mode-alist))
(unless (assq 'gnus-pick-mode minor-mode-map-alist)
(push (cons 'gnus-pick-mode gnus-pick-mode-map)
minor-mode-map-alist))
(gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
(run-hooks 'gnus-pick-mode-hook))))
(defun gnus-pick-setup-message ()
@ -160,7 +166,7 @@ If given a prefix, mark all unpicked articles as read."
(if gnus-pick-elegant-flow
(progn
(when (or catch-up gnus-mark-unpicked-articles-as-read)
(gnus-summary-limit-mark-excluded-as-read))
(gnus-summary-catchup nil t))
(if (gnus-group-quit-config gnus-newsgroup-name)
(gnus-summary-exit)
(gnus-summary-next-group)))
@ -329,11 +335,7 @@ This must be bound to a button-down mouse event."
;; Set up the menu.
(when (gnus-visual-p 'binary-menu 'menu)
(gnus-binary-make-menu-bar))
(unless (assq 'gnus-binary-mode minor-mode-alist)
(push '(gnus-binary-mode " Binary") minor-mode-alist))
(unless (assq 'gnus-binary-mode minor-mode-map-alist)
(push (cons 'gnus-binary-mode gnus-binary-mode-map)
minor-mode-map-alist))
(gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
(run-hooks 'gnus-binary-mode-hook))))
(defun gnus-binary-display-article (article &optional all-header)
@ -352,16 +354,22 @@ This must be bound to a button-down mouse event."
;;; gnus-tree-mode
;;;
(defvar gnus-tree-line-format "%(%[%3,3n%]%)"
"Format of tree elements.")
(defcustom gnus-tree-line-format "%(%[%3,3n%]%)"
"Format of tree elements."
:type 'string
:group 'gnus-summary-tree)
(defvar gnus-tree-minimize-window t
(defcustom gnus-tree-minimize-window t
"If non-nil, minimize the tree buffer window.
If a number, never let the tree buffer grow taller than that number of
lines.")
lines."
:type 'boolean
:group 'gnus-summary-tree)
(defvar gnus-selected-tree-face 'modeline
"*Face used for highlighting selected articles in the thread tree.")
(defcustom gnus-selected-tree-face 'modeline
"*Face used for highlighting selected articles in the thread tree."
:type 'face
:group 'gnus-summary-tree)
(defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
(?\{ . ?\}) (?< . ?>))
@ -370,16 +378,24 @@ lines.")
(defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
"Characters used to connect parents with children.")
(defvar gnus-tree-mode-line-format "Gnus: %%b %S %Z"
"*The format specification for the tree mode line.")
(defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z"
"*The format specification for the tree mode line."
:type 'string
:group 'gnus-summary-tree)
(defvar gnus-generate-tree-function 'gnus-generate-vertical-tree
(defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree
"*Function for generating a thread tree.
Two predefined functions are available:
`gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'.")
`gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'."
:type '(radio (function-item gnus-generate-vertical-tree)
(function-item gnus-generate-horizontal-tree)
(function :tag "Other" nil))
:group 'gnus-summary-tree)
(defvar gnus-tree-mode-hook nil
"*Hook run in tree mode buffers.")
(defcustom gnus-tree-mode-hook nil
"*Hook run in tree mode buffers."
:type 'hook
:group 'gnus-summary-tree)
;;; Internal variables.
@ -412,6 +428,7 @@ Two predefined functions are available:
"\r" gnus-tree-select-article
gnus-mouse-2 gnus-tree-pick-article
"\C-?" gnus-tree-read-summary-keys
"h" gnus-tree-show-summary
"\C-c\C-i" gnus-info-find-node)
@ -462,6 +479,14 @@ Two predefined functions are available:
(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
(gnus-tree-minimize))))
(defun gnus-tree-show-summary ()
"Reconfigure windows to show summary buffer."
(interactive)
(if (not (gnus-buffer-live-p gnus-summary-buffer))
(error "There is no summary buffer for this tree buffer")
(gnus-configure-windows 'article)
(gnus-summary-goto-subject gnus-current-article)))
(defun gnus-tree-select-article (article)
"Select the article under point, if any."
(interactive (list (gnus-tree-article-number)))
@ -648,7 +673,9 @@ Two predefined functions are available:
"Generate a horizontal tree."
(let* ((dummy (stringp (car thread)))
(do (or dummy
(memq (mail-header-number (car thread)) gnus-tmp-limit)))
(and (car thread)
(memq (mail-header-number (car thread))
gnus-tmp-limit))))
col beg)
(if (not do)
;; We don't want this article.
@ -720,13 +747,12 @@ Two predefined functions are available:
(delete-char -1)
(insert (cadr gnus-tree-parent-child-edges))
(setq beg (point))
(forward-char -1)
;; Draw "-" lines leftwards.
(while (progn
(unless (bolp)
(forward-char -2))
(= (following-char) ? ))
(delete-char 1)
(insert (car gnus-tree-parent-child-edges)))
(while (= (char-after (1- (point))) ? )
(delete-char -1)
(insert (car gnus-tree-parent-child-edges))
(forward-char -1))
(goto-char beg)
(gnus-tree-forward-line 1)))
(setq dummyp nil)
@ -926,7 +952,7 @@ The following commands are available:
\\{gnus-carpal-mode-map}"
(interactive)
(kill-all-local-variables)
(setq mode-line-modified "-- ")
(setq mode-line-modified (cdr gnus-mode-line-modified))
(setq major-mode 'gnus-carpal-mode)
(setq mode-name "Gnus Carpal")
(setq mode-line-process nil)

97
lisp/gnus/gnus-score.el
View file

@ -1,4 +1,4 @@
;;; gnus-score.el --- scoring code for Gnus
1;;; gnus-score.el --- scoring code for Gnus
;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
@ -31,6 +31,7 @@
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
(require 'message)
(defcustom gnus-global-score-files nil
"List of global score files and directories.
@ -528,7 +529,8 @@ used as score."
(gnus-score-kill-help-buffer)
(unless (setq entry (assq (downcase hchar) char-to-header))
(if mimic (error "%c %c" prefix hchar) (error "")))
(if mimic (error "%c %c" prefix hchar)
(error "Illegal header type")))
(when (/= (downcase hchar) hchar)
;; This was a majuscule, so we end reading and set the defaults.
@ -536,36 +538,32 @@ used as score."
(setq tchar (or tchar ?s)
pchar (or pchar ?t)))
;; We continue reading - the type.
(while (not tchar)
(if mimic
(progn
(sit-for 1) (message "%c %c-" prefix hchar))
(message "%s header '%s' with match type (%s?): "
(if increase "Increase" "Lower")
(nth 1 entry)
(mapconcat (lambda (s)
(if (eq (nth 4 entry)
(nth 3 s))
(char-to-string (car s))
""))
char-to-type "")))
(setq tchar (read-char))
(when (or (= tchar ??) (= tchar ?\C-h))
(setq tchar nil)
(gnus-score-insert-help
"Match type"
(delq nil
(mapcar (lambda (s)
(if (eq (nth 4 entry)
(nth 3 s))
s nil))
char-to-type))
2)))
(let ((legal-types
(delq nil
(mapcar (lambda (s)
(if (eq (nth 4 entry)
(nth 3 s))
s nil))
char-to-type))))
;; We continue reading - the type.
(while (not tchar)
(if mimic
(progn
(sit-for 1) (message "%c %c-" prefix hchar))
(message "%s header '%s' with match type (%s?): "
(if increase "Increase" "Lower")
(nth 1 entry)
(mapconcat (lambda (s) (char-to-string (car s)))
legal-types "")))
(setq tchar (read-char))
(when (or (= tchar ??) (= tchar ?\C-h))
(setq tchar nil)
(gnus-score-insert-help "Match type" legal-types 2)))
(gnus-score-kill-help-buffer)
(unless (setq type (nth 1 (assq (downcase tchar) char-to-type)))
(if mimic (error "%c %c" prefix hchar) (error "")))
(gnus-score-kill-help-buffer)
(unless (setq type (nth 1 (assq (downcase tchar) legal-types)))
(if mimic (error "%c %c" prefix hchar)
(error "Illegal match type"))))
(when (/= (downcase tchar) tchar)
;; It was a majuscule, so we end reading and use the default.
@ -598,7 +596,7 @@ used as score."
(error "You rang?"))
(if mimic
(error "%c %c %c %c" prefix hchar tchar pchar)
(error ""))))
(error "Illegal match duration"))))
;; Always kill the score help buffer.
(gnus-score-kill-help-buffer))
@ -1005,6 +1003,7 @@ SCORE is the score to add."
(gnus-make-directory (file-name-directory file))
(setq gnus-score-edit-buffer (find-file-noselect file))
(gnus-configure-windows 'edit-score)
(select-window (get-buffer-window gnus-score-edit-buffer))
(gnus-score-mode)
(setq gnus-score-edit-exit-function 'gnus-score-edit-done)
(make-local-variable 'gnus-prev-winconf)
@ -1086,11 +1085,11 @@ SCORE is the score to add."
(decay (car (gnus-score-get 'decay alist)))
(eval (car (gnus-score-get 'eval alist))))
;; Perform possible decays.
(when (and gnus-decay-scores
(gnus-decay-scores
alist (or decay (gnus-time-to-day (current-time)))))
(gnus-score-set 'touched '(t) alist)
(gnus-score-set 'decay (list (gnus-time-to-day (current-time)))))
(when gnus-decay-scores
(when (or (not decay)
(gnus-decay-scores alist decay))
(gnus-score-set 'touched '(t) alist)
(gnus-score-set 'decay (list (gnus-time-to-day (current-time))))))
;; We do not respect eval and files atoms from global score
;; files.
(and files (not global)
@ -1280,8 +1279,7 @@ SCORE is the score to add."
(erase-buffer)
(let (emacs-lisp-mode-hook)
(if (string-match
(concat (regexp-quote gnus-adaptive-file-suffix)
"$")
(concat (regexp-quote gnus-adaptive-file-suffix) "$")
file)
;; This is an adaptive score file, so we do not run
;; it through `pp'. These files can get huge, and
@ -1364,6 +1362,7 @@ SCORE is the score to add."
(save-excursion
(set-buffer (get-buffer-create "*Headers*"))
(buffer-disable-undo (current-buffer))
(message-clone-locals gnus-summary-buffer)
;; Set the global variant of this variable.
(setq gnus-current-score-file current-score-file)
@ -2201,7 +2200,9 @@ SCORE is the score to add."
(gnus-add-current-to-buffer-list)
(while trace
(insert (format "%S -> %s\n" (cdar trace)
(file-name-nondirectory (caar trace))))
(if (caar trace)
(file-name-nondirectory (caar trace))
"(non-file rule)")))
(setq trace (cdr trace)))
(goto-char (point-min))
(gnus-configure-windows 'score-trace)))
@ -2457,8 +2458,8 @@ GROUP using BNews sys file syntax."
(if (looking-at "not.")
(progn
(setq not-match t)
(setq regexp (concat "^" (buffer-substring 5 (point-max)))))
(setq regexp (concat "^" (buffer-substring 1 (point-max))))
(setq regexp (concat "^" (buffer-substring 5 (point-max)) "$")))
(setq regexp (concat "^" (buffer-substring 1 (point-max)) "$"))
(setq not-match nil))
;; Finally - if this resulting regexp matches the group name,
;; we add this score file to the list of score files
@ -2730,11 +2731,11 @@ If ADAPT, return the home adaptive file instead."
;;;
(defun gnus-decay-score (score)
"Decay SCORE."
"Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
(floor
(- score
(* (if (< score 0) 1 -1)
(min score
(* (if (< score 0) -1 1)
(min (abs score)
(max gnus-score-decay-constant
(* (abs score)
gnus-score-decay-scale)))))))
@ -2750,11 +2751,13 @@ If ADAPT, return the home adaptive file instead."
(while (setq kill (pop entry))
(when (nth 2 kill)
(setq updated t)
(setq score (or (car kill) gnus-score-interactive-default-score)
(setq score (or (nth 1 kill)
gnus-score-interactive-default-score)
n times)
(while (natnump (decf n))
(setq score (funcall gnus-decay-score-function score)))
(setcar kill score))))))
(setcdr kill (cons score
(cdr (cdr kill)))))))))
;; Return whether this score file needs to be saved. By Je-haysuss!
updated))

4
lisp/gnus/gnus-soup.el
View file

@ -358,7 +358,7 @@ If NOT-ALL, don't pack ticked articles."
(call-process shell-file-name nil nil nil shell-command-switch
(concat "cd " dir " ; rm " files))
(gnus-message 4 "Packing...done" packer))
(error "Couldn't pack packet."))))
(error "Couldn't pack packet"))))
(defun gnus-soup-parse-areas (file)
"Parse soup area file FILE.
@ -523,7 +523,7 @@ Return whether the unpacking was successful."
(goto-char (point-min))
(while (not (eobp))
(unless (looking-at "#! *rnews +\\([0-9]+\\)")
(error "Bad header."))
(error "Bad header"))
(forward-line 1)
(setq beg (point)
end (+ (point) (string-to-int

12
lisp/gnus/gnus-srvr.el
View file

@ -505,6 +505,7 @@ The following commands are available:
"n" gnus-browse-next-group
"p" gnus-browse-prev-group
"\177" gnus-browse-prev-group
[delete] gnus-browse-prev-group
"N" gnus-browse-next-group
"P" gnus-browse-prev-group
"\M-n" gnus-browse-next-group
@ -552,7 +553,8 @@ The following commands are available:
(cond
((not (gnus-check-server method))
(gnus-message
1 "Unable to contact server: %s" (gnus-status-message method))
1 "Unable to contact server %s: %s" (nth 1 method)
(gnus-status-message method))
nil)
((not
(prog2
@ -663,7 +665,7 @@ buffer.
"(Un)subscribe to the next ARG groups."
(interactive "p")
(when (eobp)
(error "No group at current line."))
(error "No group at current line"))
(let ((ward (if (< arg 0) -1 1))
(arg (abs arg)))
(while (and (> arg 0)
@ -695,7 +697,9 @@ buffer.
;; If this group it killed, then we want to subscribe it.
(when (= (following-char) ?K)
(setq sub t))
(setq group (gnus-browse-group-name))
(when (gnus-gethash (setq group (gnus-browse-group-name))
gnus-newsrc-hashtb)
(error "Group already subscribed"))
;; Make sure the group has been properly removed before we
;; subscribe to it.
(gnus-kill-ephemeral-group group)
@ -745,6 +749,8 @@ buffer.
'request-regenerate (car (gnus-server-to-method server))))
(error "This backend doesn't support regeneration")
(gnus-message 5 "Requesting regeneration of %s..." server)
(unless (gnus-open-server server)
(error "Couldn't open server"))
(if (gnus-request-regenerate server)
(gnus-message 5 "Requesting regeneration of %s...done" server)
(gnus-message 5 "Couldn't regenerate %s" server)))))

79
lisp/gnus/gnus-start.el
View file

@ -79,7 +79,7 @@ saved will be used."
:group 'gnus-dribble-file
:type '(choice directory (const nil)))
(defcustom gnus-check-new-newsgroups t
(defcustom gnus-check-new-newsgroups 'ask-server
"*Non-nil means that Gnus will run gnus-find-new-newsgroups at startup.
This normally finds new newsgroups by comparing the active groups the
servers have already reported with those Gnus already knows, either alive
@ -123,7 +123,7 @@ check for bogus newsgroups with \\<gnus-group-mode-map>\\[gnus-group-check-bogus
:group 'gnus-start-server
:type 'boolean)
(defcustom gnus-read-active-file t
(defcustom gnus-read-active-file 'some
"*Non-nil means that Gnus will read the entire active file at startup.
If this variable is nil, Gnus will only know about the groups in your
`.newsrc' file.
@ -643,8 +643,8 @@ prompt the user for the name of an NNTP server to use."
(gnus-splash)
(gnus-clear-system)
(nnheader-init-server-buffer)
(gnus-read-init-file)
(setq gnus-slave slave)
(gnus-read-init-file)
(when (and (string-match "XEmacs" (emacs-version))
gnus-simple-splash)
@ -691,7 +691,7 @@ prompt the user for the name of an NNTP server to use."
"Unload all Gnus features."
(interactive)
(unless (boundp 'load-history)
(error "Sorry, `gnus-unload' is not implemented in this Emacs version."))
(error "Sorry, `gnus-unload' is not implemented in this Emacs version"))
(let ((history load-history)
feature)
(while history
@ -762,6 +762,7 @@ prompt the user for the name of an NNTP server to use."
;; Set the file modes to reflect the .newsrc file modes.
(save-buffer)
(when (and (file-exists-p gnus-current-startup-file)
(file-exists-p dribble-file)
(setq modes (file-modes gnus-current-startup-file)))
(set-file-modes dribble-file modes))
;; Possibly eval the file later.
@ -839,7 +840,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
;; done in `gnus-get-unread-articles'.
(and gnus-read-active-file
(not level)
(gnus-read-active-file))
(gnus-read-active-file nil dont-connect))
(unless gnus-active-hashtb
(setq gnus-active-hashtb (gnus-make-hashtable 4096)))
@ -861,7 +862,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
;; See whether we need to read the description file.
(when (and (boundp 'gnus-group-line-format)
(string-match "%[-,0-9]*D" gnus-group-line-format)
(let ((case-fold-search nil))
(string-match "%[-,0-9]*D" gnus-group-line-format))
(not gnus-description-hashtb)
(not dont-connect)
gnus-read-active-file)
@ -895,8 +897,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
"Search for new newsgroups and add them.
Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.'
The `-n' option line from .newsrc is respected.
If ARG (the prefix), use the `ask-server' method to query
the server for new groups."
If ARG (the prefix), use the `ask-server' method to query the server
for new groups."
(interactive "P")
(let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups)))
(null gnus-read-active-file)
@ -1050,7 +1052,8 @@ the server for new groups."
nil
(gnus-message 6 "First time user; subscribing you to default groups")
(unless (gnus-read-active-file-p)
(gnus-read-active-file))
(let ((gnus-read-active-file t))
(gnus-read-active-file)))
(setq gnus-newsrc-last-checked-date (current-time-string))
(let ((groups gnus-default-subscribed-newsgroups)
group)
@ -1209,7 +1212,8 @@ the server for new groups."
(format
"(gnus-group-set-info '%S)" info)))))
(when gnus-group-change-level-function
(funcall gnus-group-change-level-function group level oldlevel)))))
(funcall gnus-group-change-level-function
group level oldlevel previous)))))
(defun gnus-kill-newsgroup (newsgroup)
"Obsolete function. Kills a newsgroup."
@ -1282,12 +1286,11 @@ newsgroup."
"Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
(and cache-active
(< (car cache-active) (car active))
(setcar active (car cache-active)))
(and cache-active
(> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active)))))))
(when cache-active
(when (< (car cache-active) (car active))
(setcar active (car cache-active)))
(when (> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active))))))))
(defun gnus-activate-group (group &optional scan dont-check method)
;; Check whether a group has been activated or not.
@ -1307,9 +1310,18 @@ newsgroup."
(inline (gnus-request-group group dont-check method))
(error nil)
(quit nil))
(gnus-set-active group (setq active (gnus-parse-active)))
;; Return the new active info.
active)))
(setq active (gnus-parse-active))
;; If there are no articles in the group, the GROUP
;; command may have responded with the `(0 . 0)'. We
;; ignore this if we already have an active entry
;; for the group.
(if (and (zerop (car active))
(zerop (cdr active))
(gnus-active group))
(gnus-active group)
(gnus-set-active group active)
;; Return the new active info.
active))))
(defun gnus-get-unread-articles-in-group (info active &optional update)
(when active
@ -1552,11 +1564,12 @@ newsgroup."
(gnus-dribble-touch))
;; Get the active file(s) from the backend(s).
(defun gnus-read-active-file (&optional force)
(defun gnus-read-active-file (&optional force not-native)
(gnus-group-set-mode-line)
(let ((methods
(append
(if (gnus-check-server gnus-select-method)
(if (and (not not-native)
(gnus-check-server gnus-select-method))
;; The native server is available.
(cons gnus-select-method gnus-secondary-select-methods)
;; The native server is down, so we just do the
@ -1616,7 +1629,7 @@ newsgroup."
(t
(if (not (gnus-request-list method))
(unless (equal method gnus-message-archive-method)
(gnus-error 1 "Cannot read active file from %s server."
(gnus-error 1 "Cannot read active file from %s server"
(car method)))
(gnus-message 5 mesg)
(gnus-active-to-gnus-format method gnus-active-hashtb)
@ -1647,7 +1660,7 @@ newsgroup."
(gnus-make-hashtable
(count-lines (point-min) (point-max)))
(gnus-make-hashtable 4096)))))))
;; Delete unnecessary lines, cleaned up dmoore@ucsd.edu 31.10.1996
;; Delete unnecessary lines.
(goto-char (point-min))
(cond ((gnus-ignored-newsgroups-has-to-p)
(delete-matching-lines gnus-ignored-newsgroups))
@ -1659,21 +1672,20 @@ newsgroup."
;; Make the group names readable as a lisp expression even if they
;; contain special characters.
;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>.
(goto-char (point-max))
(while (re-search-backward "[][';?()#]" nil t)
(insert ?\\))
;; If these are groups from a foreign select method, we insert the
;; group prefix in front of the group names.
(and method (not (gnus-server-equal
(gnus-server-get-method nil method)
(gnus-server-get-method nil gnus-select-method)))
(let ((prefix (gnus-group-prefixed-name "" method)))
(goto-char (point-min))
(while (and (not (eobp))
(progn (insert prefix)
(zerop (forward-line 1)))))))
(when (not (gnus-server-equal
(gnus-server-get-method nil method)
(gnus-server-get-method nil gnus-select-method)))
(let ((prefix (gnus-group-prefixed-name "" method)))
(goto-char (point-min))
(while (and (not (eobp))
(progn (insert prefix)
(zerop (forward-line 1)))))))
;; Store the active file in a hash table.
(goto-char (point-min))
(let (group max min)
@ -2199,7 +2211,8 @@ If FORCE is non-nil, the .newsrc file is read."
(defun gnus-gnus-to-quick-newsrc-format ()
"Insert Gnus variables such as gnus-newsrc-alist in lisp format."
(let ((print-quoted t))
(let ((print-quoted t)
(print-escape-newlines t))
(insert ";; -*- emacs-lisp -*-\n")
(insert ";; Gnus startup file.\n")
(insert

107
lisp/gnus/gnus-sum.el
View file

@ -631,7 +631,7 @@ is not run if `gnus-visual' is nil."
:type 'function)
(defcustom gnus-parse-headers-hook
(list 'gnus-decode-rfc1522)
(list 'gnus-hack-decode-rfc1522 'gnus-decode-rfc1522)
"*A hook called before parsing the headers."
:group 'gnus-various
:type 'hook)
@ -1206,7 +1206,7 @@ increase the score of each group you read."
"j" gnus-summary-goto-article
"g" gnus-summary-goto-subject
"l" gnus-summary-goto-last-article
"p" gnus-summary-pop-article)
"o" gnus-summary-pop-article)
(gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map)
"k" gnus-summary-kill-thread
@ -2027,7 +2027,7 @@ The following commands are available:
(defmacro gnus-summary-article-sparse-p (article)
"Say whether this article is a sparse article or not."
` (memq ,article gnus-newsgroup-sparse))
`(memq ,article gnus-newsgroup-sparse))
(defmacro gnus-summary-article-ancient-p (article)
"Say whether this article is a sparse article or not."
@ -3061,8 +3061,9 @@ If NO-DISPLAY, don't generate a summary buffer."
"Return the headers of the GENERATIONeth parent of HEADERS."
(unless generation
(setq generation 1))
(let (references parent)
(while (and headers (not (zerop generation)))
(let ((parent t)
references)
(while (and parent headers (not (zerop generation)))
(setq references (mail-header-references headers))
(when (and references
(setq parent (gnus-parent-id references))
@ -3839,6 +3840,10 @@ If READ-ALL is non-nil, all articles in the group are selected."
(set var (delq article (symbol-value var))))))
;; Adjust assocs.
((memq mark uncompressed)
(when (not (listp (cdr (symbol-value var))))
(set var (list (symbol-value var))))
(when (not (listp (cdr articles)))
(setq articles (list articles)))
(while articles
(when (or (not (consp (setq article (pop articles))))
(< (car article) min)
@ -4214,7 +4219,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (read cur)))
(if (numberp (setq lines (ignore-errors (read cur))))
lines 0)
0))
;; Xref.
@ -4837,6 +4842,9 @@ The prefix argument ALL means to select all articles."
(not non-destructive))
(setq gnus-newsgroup-scored nil))
;; Set the new ranges of read articles.
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-undo-force-boundary))
(gnus-update-read-articles
group (append gnus-newsgroup-unreads gnus-newsgroup-unselected))
;; Set the current article marks.
@ -4873,6 +4881,7 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
(let* ((group gnus-newsgroup-name)
(quit-config (gnus-group-quit-config gnus-newsgroup-name))
(mode major-mode)
(group-point nil)
(buf (current-buffer)))
(run-hooks 'gnus-summary-prepare-exit-hook)
;; If we have several article buffers, we kill them at exit.
@ -4899,6 +4908,7 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
(run-hooks 'gnus-summary-exit-hook)
(unless quit-config
(gnus-group-next-unread-group 1))
(setq group-point (point))
(if temporary
nil ;Nothing to do.
;; If we have several article buffers, we kill them at exit.
@ -4928,8 +4938,7 @@ gnus-exit-group-hook is called with no arguments if that value is non-nil."
;; Clear the current group name.
(if (not quit-config)
(progn
(gnus-group-jump-to-group group)
(gnus-group-next-unread-group 1)
(goto-char group-point)
(gnus-configure-windows 'group 'force))
(gnus-handle-ephemeral-exit quit-config))
(unless quit-config
@ -5015,7 +5024,7 @@ which existed when entering the ephemeral is reset."
(suppress-keymap gnus-dead-summary-mode-map)
(substitute-key-definition
'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map)
(let ((keys '("\C-d" "\r" "\177")))
(let ((keys '("\C-d" "\r" "\177" [delete])))
(while keys
(define-key gnus-dead-summary-mode-map
(pop keys) 'gnus-summary-wake-up-the-dead))))
@ -5032,11 +5041,8 @@ which existed when entering the ephemeral is reset."
(if (null arg) (not gnus-dead-summary-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-dead-summary-mode
(unless (assq 'gnus-dead-summary-mode minor-mode-alist)
(push '(gnus-dead-summary-mode " Dead") minor-mode-alist))
(unless (assq 'gnus-dead-summary-mode minor-mode-map-alist)
(push (cons 'gnus-dead-summary-mode gnus-dead-summary-mode-map)
minor-mode-map-alist)))))
(gnus-add-minor-mode
'gnus-dead-summary-mode " Dead" gnus-dead-summary-mode-map))))
(defun gnus-deaden-summary ()
"Make the current summary buffer into a dead summary buffer."
@ -5101,7 +5107,8 @@ in."
(when current-prefix-arg
(completing-read
"Faq dir: " (and (listp gnus-group-faq-directory)
gnus-group-faq-directory)))))
(mapcar (lambda (file) (list file))
gnus-group-faq-directory))))))
(let (gnus-faq-buffer)
(when (setq gnus-faq-buffer
(gnus-group-fetch-faq gnus-newsgroup-name faq-dir))
@ -5163,7 +5170,8 @@ previous group instead."
(if (and (or (eq t unreads)
(and unreads (not (zerop unreads))))
(gnus-summary-read-group
target-group nil no-article current-buffer))
target-group nil no-article
(and (buffer-name current-buffer) current-buffer)))
(setq entered t)
(setq current-group target-group
target-group nil)))))))
@ -5311,7 +5319,7 @@ be displayed."
did)
(and (not pseudo)
(gnus-summary-article-pseudo-p article)
(error "This is a pseudo-article."))
(error "This is a pseudo-article"))
(prog1
(save-excursion
(set-buffer gnus-summary-buffer)
@ -5875,7 +5883,7 @@ If ALL, mark even excluded ticked and dormants as read."
'<)
(sort gnus-newsgroup-limit '<)))
article)
(setq gnus-newsgroup-unreads nil)
(setq gnus-newsgroup-unreads gnus-newsgroup-limit)
(if all
(setq gnus-newsgroup-dormant nil
gnus-newsgroup-marked nil
@ -5949,7 +5957,10 @@ If ALL, mark even excluded ticked and dormants as read."
(mail-header-number (car thread))))
(progn
(if (<= (length (cdr thread)) 1)
(setq thread (cadr thread))
(setq gnus-newsgroup-limit
(delq (mail-header-number (car thread))
gnus-newsgroup-limit)
thread (cadr thread))
(when (gnus-invisible-cut-children (cdr thread))
(let ((th (cdr thread)))
(while th
@ -5957,8 +5968,7 @@ If ALL, mark even excluded ticked and dormants as read."
gnus-newsgroup-limit)
(setq thread (car th)
th nil)
(setq th (cdr th)))))))))
))
(setq th (cdr th)))))))))))
thread)
(defun gnus-cut-threads (threads)
@ -6066,7 +6076,7 @@ fetch-old-headers verbiage, and so on."
(gnus-nocem-unwanted-article-p
(mail-header-id (car thread))))
(progn
(setq gnus-newsgroup-reads
(setq gnus-newsgroup-unreads
(delq number gnus-newsgroup-unreads))
t))))
;; Nope, invisible article.
@ -6174,12 +6184,17 @@ or `gnus-select-method', no matter what backend the article comes from."
(let* ((header (gnus-id-to-header message-id))
(sparse (and header
(gnus-summary-article-sparse-p
(mail-header-number header)))))
(if header
(mail-header-number header))
(memq (mail-header-number header)
gnus-newsgroup-limit))))
(if (and header
(or (not (gnus-summary-article-sparse-p
(mail-header-number header)))
sparse))
(prog1
;; The article is present in the buffer, to we just go to it.
;; The article is present in the buffer, so we just go to it.
(gnus-summary-goto-article
(mail-header-number header) nil header)
(mail-header-number header) nil t)
(when sparse
(gnus-summary-update-article (mail-header-number header))))
;; We fetch the article
@ -6342,11 +6357,15 @@ If BACKWARD, search backward instead."
"Search for an article containing REGEXP.
Optional argument BACKWARD means do search for backward.
`gnus-select-article-hook' is not called during the search."
;; We have to require this here to make sure that the following
;; dynamic binding isn't shadowed by autoloading.
(require 'gnus-async)
(let ((gnus-select-article-hook nil) ;Disable hook.
(gnus-article-display-hook nil)
(gnus-mark-article-hook nil) ;Inhibit marking as read.
(gnus-use-article-prefetch nil)
(gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay.
(gnus-use-trees nil) ;Inhibit updating tree buffer.
(sum (current-buffer))
(found nil)
point)
@ -6670,6 +6689,8 @@ and `request-accept' functions."
(cond
;; Move the article.
((eq action 'move)
;; Remove this article from future suppression.
(gnus-dup-unsuppress-article article)
(gnus-request-move-article
article ; Article to move
gnus-newsgroup-name ; From newsgroup
@ -6811,7 +6832,7 @@ and `request-accept' functions."
(save-excursion
(set-buffer gnus-group-buffer)
(when (gnus-group-goto-group (car to-groups) t)
(gnus-group-get-new-news-this-group 1))
(gnus-group-get-new-news-this-group 1 t))
(pop to-groups)))
(gnus-kill-buffer copy-buf)
@ -7004,7 +7025,7 @@ delete these instead."
(gnus-set-global-variables)
(unless (gnus-check-backend-function 'request-expire-articles
gnus-newsgroup-name)
(error "The current newsgroup does not support article deletion."))
(error "The current newsgroup does not support article deletion"))
;; Compute the list of articles to delete.
(let ((articles (gnus-summary-work-articles n))
not-deleted)
@ -7042,11 +7063,12 @@ groups."
(gnus-set-global-variables)
(when (and (not force)
(gnus-group-read-only-p))
(error "The current newsgroup does not support article editing."))
(error "The current newsgroup does not support article editing"))
;; Select article if needed.
(unless (eq (gnus-summary-article-number)
gnus-current-article)
(gnus-summary-select-article t))
(gnus-article-date-original)
(gnus-article-edit-article
`(lambda ()
(gnus-summary-edit-article-done
@ -7063,7 +7085,7 @@ groups."
(not (gnus-request-replace-article
(cdr gnus-article-current) (car gnus-article-current)
(current-buffer))))
(error "Couldn't replace article.")
(error "Couldn't replace article")
;; Update the summary buffer.
(if (and references
(equal (message-tokenize-header references " ")
@ -7711,7 +7733,7 @@ even ticked and dormant ones."
(setq scored (cdr scored)))
(if (not headers)
(when (not no-error)
(error "No expunged articles hidden."))
(error "No expunged articles hidden"))
(goto-char (point-min))
(gnus-summary-prepare-unthreaded (nreverse headers))
(goto-char (point-min))
@ -7742,7 +7764,9 @@ The number of articles marked as read is returned."
(if (and not-mark
(not gnus-newsgroup-adaptive)
(not gnus-newsgroup-auto-expire)
(not gnus-suppress-duplicates))
(not gnus-suppress-duplicates)
(or (not gnus-use-cache)
(not (eq gnus-use-cache 'passive))))
(progn
(when all
(setq gnus-newsgroup-marked nil
@ -7866,9 +7890,9 @@ Note that the re-threading will only work if `gnus-thread-ignore-subject'
is non-nil or the Subject: of both articles are the same."
(interactive)
(unless (not (gnus-group-read-only-p))
(error "The current newsgroup does not support article editing."))
(error "The current newsgroup does not support article editing"))
(unless (<= (length gnus-newsgroup-processable) 1)
(error "No more than one article may be marked."))
(error "No more than one article may be marked"))
(save-window-excursion
(let ((gnus-article-buffer " *reparent*")
(current-article (gnus-summary-article-number))
@ -7878,13 +7902,13 @@ is non-nil or the Subject: of both articles are the same."
(save-excursion
(if (eq (forward-line -1) 0)
(gnus-summary-article-number)
(error "Beginning of summary buffer."))))))
(error "Beginning of summary buffer"))))))
(unless (not (eq current-article parent-article))
(error "An article may not be self-referential."))
(error "An article may not be self-referential"))
(let ((message-id (mail-header-id
(gnus-summary-article-header parent-article))))
(unless (and message-id (not (equal message-id "")))
(error "No message-id in desired parent."))
(error "No message-id in desired parent"))
(gnus-summary-select-article t t nil current-article)
(set-buffer gnus-original-article-buffer)
(let ((buf (format "%s" (buffer-string))))
@ -7897,11 +7921,11 @@ is non-nil or the Subject: of both articles are the same."
(unless (gnus-request-replace-article
current-article (car gnus-article-current)
(current-buffer))
(error "Couldn't replace article."))))
(error "Couldn't replace article"))))
(set-buffer gnus-summary-buffer)
(gnus-summary-unmark-all-processable)
(gnus-summary-rethread-current)
(gnus-message 3 "Article %d is now the child of article %d."
(gnus-message 3 "Article %d is now the child of article %d"
current-article parent-article)))))
(defun gnus-summary-toggle-threads (&optional arg)
@ -8469,7 +8493,8 @@ save those articles instead."
(gnus-article-setup-buffer)
(set-buffer gnus-article-buffer)
(setq buffer-read-only nil)
(let ((command (if automatic command (read-string "Command: " command))))
(let ((command (if automatic command
(read-string "Command: " (cons command 0)))))
(erase-buffer)
(insert "$ " command "\n\n")
(if gnus-view-pseudo-asynchronously
@ -8701,6 +8726,8 @@ save those articles instead."
(lambda (buf) (switch-to-buffer buf) (gnus-summary-exit))
buffers)))))
(gnus-ems-redefine)
(provide 'gnus-sum)
(run-hooks 'gnus-sum-load-hook)

61
lisp/gnus/gnus-topic.el
View file

@ -79,7 +79,6 @@ with some simple extensions.
(defvar gnus-topic-killed-topics nil)
(defvar gnus-topic-inhibit-change-level nil)
(defvar gnus-topic-tallied-groups nil)
(defconst gnus-topic-line-format-alist
`((?n name ?s)
@ -364,8 +363,6 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(let ((buffer-read-only nil)
(lowest (or lowest 1)))
(setq gnus-topic-tallied-groups nil)
(when (or (not gnus-topic-alist)
(not gnus-topology-checked-p))
(gnus-topic-check-topology))
@ -441,10 +438,7 @@ articles in the topic and its subtopics."
(gnus-info-level info) (gnus-info-marks info)
(car entry) (gnus-info-method info)))))
(when (and (listp entry)
(numberp (car entry))
(not (member (gnus-info-group (setq info (nth 2 entry)))
gnus-topic-tallied-groups)))
(push (gnus-info-group info) gnus-topic-tallied-groups)
(numberp (car entry)))
(incf unread (car entry)))
(when (listp entry)
(setq tick t)))
@ -520,8 +514,7 @@ articles in the topic and its subtopics."
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(eval gnus-topic-line-format-spec)
(gnus-topic-remove-excess-properties)1)
(eval gnus-topic-line-format-spec))
(list 'gnus-topic (intern name)
'gnus-topic-level level
'gnus-topic-unread unread
@ -549,12 +542,14 @@ articles in the topic and its subtopics."
(when (and (eq major-mode 'gnus-group-mode)
gnus-topic-mode)
(let ((group (gnus-group-group-name))
(m (point-marker))
(buffer-read-only nil))
(when (and group
(gnus-get-info group)
(gnus-topic-goto-topic (gnus-current-topic)))
(gnus-topic-update-topic-line (gnus-group-topic-name))
(gnus-group-goto-group group)
(goto-char m)
(set-marker m nil)
(gnus-group-position-point)))))
(defun gnus-topic-goto-missing-group (group)
@ -648,7 +643,6 @@ articles in the topic and its subtopics."
(setq gnus-topic-active-topology nil
gnus-topic-active-alist nil
gnus-topic-killed-topics nil
gnus-topic-tallied-groups nil
gnus-topology-checked-p nil))
(defun gnus-topic-check-topology ()
@ -681,18 +675,20 @@ articles in the topic and its subtopics."
;; they belong to some topic.
(let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
gnus-topic-alist)))
(entry (assoc (caar gnus-topic-topology) gnus-topic-alist))
(entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
(newsrc (cdr gnus-newsrc-alist))
group)
(while newsrc
(unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
(setcdr entry (cons group (cdr entry))))))
(setcdr entry (list group))
(setq entry (cdr entry)))))
;; Go through all topics and make sure they contain only living groups.
(let ((alist gnus-topic-alist)
topic)
(while (setq topic (pop alist))
(while (cdr topic)
(if (gnus-gethash (cadr topic) gnus-newsrc-hashtb)
(if (and (cadr topic)
(gnus-gethash (cadr topic) gnus-newsrc-hashtb))
(setq topic (cdr topic))
(setcdr topic (cddr topic)))))))
@ -729,10 +725,11 @@ articles in the topic and its subtopics."
(push (cons topic-name (nreverse filtered-topic)) result)))
(setq gnus-topic-alist (nreverse result))))
(defun gnus-topic-change-level (group level oldlevel)
(defun gnus-topic-change-level (group level oldlevel &optional previous)
"Run when changing levels to enter/remove groups from topics."
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-goto-group (or (car (nth 2 previous)) group))
(when (and gnus-topic-mode
gnus-topic-alist
(not gnus-topic-inhibit-change-level))
@ -900,7 +897,9 @@ articles in the topic and its subtopics."
"\C-i" gnus-topic-indent
[tab] gnus-topic-indent
"r" gnus-topic-rename
"\177" gnus-topic-delete)
"\177" gnus-topic-delete
[delete] gnus-topic-delete
"h" gnus-topic-toggle-display-empty-topics)
(gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
"s" gnus-topic-sort-groups
@ -930,7 +929,9 @@ articles in the topic and its subtopics."
["Rename" gnus-topic-rename t]
["Create" gnus-topic-create-topic t]
["Mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t])
["Indent" gnus-topic-indent t]
["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
["Edit parameters" gnus-topic-edit-parameters t])
["List active" gnus-topic-list-active t]))))
(defun gnus-topic-mode (&optional arg redisplay)
@ -942,17 +943,14 @@ articles in the topic and its subtopics."
(if (null arg) (not gnus-topic-mode)
(> (prefix-numeric-value arg) 0)))
;; Infest Gnus with topics.
(when gnus-topic-mode
(if (not gnus-topic-mode)
(setq gnus-goto-missing-group-function nil)
(when (gnus-visual-p 'topic-menu 'menu)
(gnus-topic-make-menu-bar))
(setq gnus-topic-line-format-spec
(gnus-parse-format gnus-topic-line-format
gnus-topic-line-format-alist t))
(unless (assq 'gnus-topic-mode minor-mode-alist)
(push '(gnus-topic-mode " Topic") minor-mode-alist))
(unless (assq 'gnus-topic-mode minor-mode-map-alist)
(push (cons 'gnus-topic-mode gnus-topic-mode-map)
minor-mode-map-alist))
(gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
(add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
(add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
(set (make-local-variable 'gnus-group-prepare-function)
@ -1024,6 +1022,8 @@ If performed over a topic line, toggle folding the topic."
(gnus-group-read-group all no-article group)))
(defun gnus-topic-create-topic (topic parent &optional previous full-topic)
"Create a new TOPIC under PARENT.
When used interactively, PARENT will be the topic under point."
(interactive
(list
(read-string "New topic: ")
@ -1234,7 +1234,8 @@ If COPYP, copy the groups instead."
;; Remove from alist.
(setq gnus-topic-alist (delq entry gnus-topic-alist))
;; Remove from topology.
(gnus-topic-find-topology topic nil nil 'delete)))
(gnus-topic-find-topology topic nil nil 'delete)
(gnus-dribble-touch)))
(defun gnus-topic-rename (old-name new-name)
"Rename a topic."
@ -1303,6 +1304,16 @@ If FORCE, always re-read the active file."
gnus-killed-list gnus-zombie-list)
(gnus-group-list-groups 9 nil 1)))
(defun gnus-topic-toggle-display-empty-topics ()
"Show/hide topics that have no unread articles."
(interactive)
(setq gnus-topic-display-empty-topics
(not gnus-topic-display-empty-topics))
(gnus-group-list-groups)
(message "%s empty topics"
(if gnus-topic-display-empty-topics
"Showing" "Hiding")))
;;; Topic sorting functions
(defun gnus-topic-edit-parameters (group)
@ -1312,7 +1323,7 @@ If performed on a topic, edit the topic parameters instead."
(if group
(gnus-group-edit-group-parameters group)
(if (not (gnus-group-topic-p))
(error "Nothing to edit on the current line.")
(error "Nothing to edit on the current line")
(let ((topic (gnus-group-topic-name)))
(gnus-edit-form
(gnus-topic-parameters topic)

25
lisp/gnus/gnus-undo.el
View file

@ -73,15 +73,15 @@
"\M-\C-_" gnus-undo
"\C-_" gnus-undo
"\C-xu" gnus-undo
[(control /)] gnus-undo ; many people are used to type `C-/' on
; X terminals and get `C-_'.
))
;; many people are used to type `C-/' on X terminals and get `C-_'.
[(control /)] gnus-undo))
(defun gnus-undo-make-menu-bar ()
;; This is disabled for the time being.
(when nil
(define-key-after (current-local-map) [menu-bar file gnus-undo]
(cons "Undo" 'gnus-undo-actions)
[menu-bar file whatever])))
(define-key-after (current-local-map) [menu-bar file gnus-undo]
(cons "Undo" 'gnus-undo-actions)
[menu-bar file whatever])))
(defun gnus-undo-mode (&optional arg)
"Minor mode for providing `undo' in Gnus buffers.
@ -97,15 +97,9 @@
;; Set up the menu.
(when (gnus-visual-p 'undo-menu 'menu)
(gnus-undo-make-menu-bar))
;; Don't display anything in the mode line -- too annoying.
;;(unless (assq 'gnus-undo-mode minor-mode-alist)
;; (push '(gnus-undo-mode " Undo") minor-mode-alist))
(unless (assq 'gnus-undo-mode minor-mode-map-alist)
(push (cons 'gnus-undo-mode gnus-undo-mode-map)
minor-mode-map-alist))
(gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map)
(make-local-hook 'post-command-hook)
(add-hook 'post-command-hook 'gnus-undo-boundary nil t)
(add-hook 'gnus-summary-exit-hook 'gnus-undo-boundary)
(run-hooks 'gnus-undo-mode-hook)))
;;; Interface functions.
@ -124,6 +118,11 @@
(setq gnus-undo-boundary-inhibit nil)
(setq gnus-undo-boundary t)))
(defun gnus-undo-force-boundary ()
"Set Gnus undo boundary."
(setq gnus-undo-boundary-inhibit nil
gnus-undo-boundary t))
(defun gnus-undo-register (form)
"Register FORMS as something to be performed to undo a change.
FORMS may use backtick quote syntax."

5
lisp/gnus/gnus-util.el
View file

@ -255,7 +255,8 @@
(date (mapcar (lambda (d) (and d (string-to-int d))) parse))
(time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
(encode-time (caddr time) (cadr time) (car time)
(caddr date) (cadr date) (car date) (nth 4 date))))
(caddr date) (cadr date) (car date)
(* 60 (timezone-zone-to-minute (nth 4 date))))))
(defun gnus-time-minus (t1 t2)
"Subtract two internal times."
@ -530,7 +531,7 @@ Timezone package is used."
(unless gnus-xemacs
(let* ((overlayss (overlay-lists))
(buffer-read-only nil)
(overlays (nconc (car overlayss) (cdr overlayss))))
(overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
(while overlays
(delete-overlay (pop overlays))))))

73
lisp/gnus/gnus-uu.el
View file

@ -1388,7 +1388,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(if (not (looking-at gnus-uu-begin-string))
(setq state (list 'middle))
;; This is the beginning of an uuencoded article.
;; This is the beginning of a uuencoded article.
;; We replace certain characters that could make things messy.
(setq gnus-uu-file-name
(let ((nnheader-file-name-translation-alist
@ -1779,7 +1779,7 @@ post the entire file."
This may not be smart, as no other decoder I have seen are able to
follow threads when collecting uuencoded articles. (Well, I have seen
one package that does that - gnus-uu, but somehow, I don't think that
counts...) Default is nil."
counts...) The default is nil."
:group 'gnus-extract-post
:type 'boolean)
@ -1878,28 +1878,7 @@ If no file has been included, the user will be asked for a file."
(setq file-name gnus-uu-post-inserted-file-name)
(setq file-name (gnus-uu-post-insert-binary)))
(if gnus-uu-post-threaded
(let ((message-required-news-headers
(if (memq 'Message-ID message-required-news-headers)
message-required-news-headers
(cons 'Message-ID message-required-news-headers)))
gnus-inews-article-hook)
(setq gnus-inews-article-hook (if (listp gnus-inews-article-hook)
gnus-inews-article-hook
(list gnus-inews-article-hook)))
(push
'(lambda ()
(save-excursion
(goto-char (point-min))
(if (re-search-forward "^Message-ID: \\(.*\\)$" nil t)
(setq gnus-uu-post-message-id
(buffer-substring
(match-beginning 1) (match-end 1)))
(setq gnus-uu-post-message-id nil))))
gnus-inews-article-hook)
(gnus-uu-post-encoded file-name t))
(gnus-uu-post-encoded file-name nil)))
(gnus-uu-post-encoded file-name gnus-uu-post-threaded))
(setq gnus-uu-post-inserted-file-name nil)
(when gnus-uu-winconf-post-news
(set-window-configuration gnus-uu-winconf-post-news)))
@ -1966,12 +1945,12 @@ If no file has been included, the user will be asked for a file."
(goto-char (point-min))
(setq length (count-lines 1 (point-max)))
(setq parts (/ length gnus-uu-post-length))
(when (not (< (% length gnus-uu-post-length) 4))
(setq parts (1+ parts))))
(unless (< (% length gnus-uu-post-length) 4)
(incf parts)))
(when gnus-uu-post-separate-description
(forward-line -1))
(kill-region (point) (point-max))
(delete-region (point) (point-max))
(goto-char (point-min))
(re-search-forward
@ -1980,12 +1959,13 @@ If no file has been included, the user will be asked for a file."
(setq header (buffer-substring 1 (point)))
(goto-char (point-min))
(if (not gnus-uu-post-separate-description)
()
(when (and (not threaded) (re-search-forward "^Subject: " nil t))
(when gnus-uu-post-separate-description
(when (re-search-forward "^Subject: " nil t)
(end-of-line)
(insert (format " (0/%d)" parts)))
(message-send))
(save-excursion
(message-send))
(setq gnus-uu-post-message-id (message-fetch-field "message-id")))
(save-excursion
(setq i 1)
@ -1995,7 +1975,7 @@ If no file has been included, the user will be asked for a file."
(erase-buffer)
(insert header)
(when (and threaded gnus-uu-post-message-id)
(insert (format "References: %s\n" gnus-uu-post-message-id)))
(insert "References: " gnus-uu-post-message-id "\n"))
(insert separator)
(setq whole-len
(- 62 (length (format top-string "" file-name i parts ""))))
@ -2010,15 +1990,9 @@ If no file has been included, the user will be asked for a file."
(if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-)))
(goto-char (point-min))
(if (not (re-search-forward "^Subject: " nil t))
()
(if (not threaded)
(progn
(end-of-line)
(insert (format " (%d/%d)" i parts)))
(when (or (and (= i 2) gnus-uu-post-separate-description)
(and (= i 1) (not gnus-uu-post-separate-description)))
(replace-match "Subject: Re: "))))
(when (re-search-forward "^Subject: " nil t)
(end-of-line)
(insert (format " (%d/%d)" i parts)))
(goto-char (point-max))
(save-excursion
@ -2031,10 +2005,9 @@ If no file has been included, the user will be asked for a file."
(forward-line -4))
(setq end (point)))
(insert-buffer-substring uubuf beg end)
(insert beg-line)
(insert "\n")
(insert beg-line "\n")
(setq beg end)
(setq i (1+ i))
(incf i)
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$") nil t)
@ -2048,12 +2021,14 @@ If no file has been included, the user will be asked for a file."
(insert beg-line)
(insert "\n")
(let (message-sent-message-via)
(message-send))))
(save-excursion
(message-send))
(setq gnus-uu-post-message-id
(concat (message-fetch-field "references") " "
(message-fetch-field "message-id"))))))
(when (setq buf (get-buffer send-buffer-name))
(kill-buffer buf))
(when (setq buf (get-buffer encoded-buffer-name))
(kill-buffer buf))
(gnus-kill-buffer send-buffer-name)
(gnus-kill-buffer encoded-buffer-name)
(when (not gnus-uu-post-separate-description)
(set-buffer-modified-p nil)

1
lisp/gnus/gnus-win.el
View file

@ -184,6 +184,7 @@ See the Gnus manual for an explanation of the syntax used.")
(faq . gnus-faq-buffer)
(picons . "*Picons*")
(tree . gnus-tree-buffer)
(score-trace . "*Score Trace*")
(info . gnus-info-buffer)
(article-copy . gnus-article-copy)
(draft . gnus-draft-buffer))

53
lisp/gnus/gnus.el
View file

@ -145,6 +145,18 @@
:link '(custom-manual "(gnus)Various Summary Stuff")
:group 'gnus-summary)
(defgroup gnus-summary-pick nil
"Pick mode in the summary buffer."
:link '(custom-manual "(gnus)Pick and Read")
:prefix "gnus-pick-"
:group 'gnus-summary)
(defgroup gnus-summary-tree nil
"Tree display of threads in the summary buffer."
:link '(custom-manual "(gnus)Tree Display")
:prefix "gnus-tree-"
:group 'gnus-summary)
;; Belongs to gnus-uu.el
(defgroup gnus-extract-view nil
"Viewing extracted files."
@ -257,7 +269,6 @@ be set in `.emacs' instead."
(defalias 'gnus-extent-start-open 'ignore)
(defalias 'gnus-set-text-properties 'set-text-properties)
(defalias 'gnus-group-remove-excess-properties 'ignore)
(defalias 'gnus-topic-remove-excess-properties 'ignore)
(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
(defalias 'gnus-character-to-event 'identity)
@ -649,12 +660,13 @@ be set in `.emacs' instead."
(save-excursion
(save-restriction
(narrow-to-region start end)
(indent-rigidly start end arg)
;; We translate tabs into spaces -- not everybody uses
;; an 8-character tab.
(goto-char (point-min))
(while (search-forward "\t" nil t)
(replace-match " " t t)))))
(let ((tab-width 8))
(indent-rigidly start end arg)
;; We translate tabs into spaces -- not everybody uses
;; an 8-character tab.
(goto-char (point-min))
(while (search-forward "\t" nil t)
(replace-match " " t t))))))
(defvar gnus-simple-splash nil)
@ -781,7 +793,7 @@ used to 899, you would say something along these lines:
(when (and gnus-default-nntp-server
(not (string= gnus-default-nntp-server "")))
gnus-default-nntp-server)
(system-name)))
"news"))
(if (or (null gnus-nntp-service)
(equal gnus-nntp-service "nntp"))
nil
@ -1346,7 +1358,6 @@ want."
gnus-article-fill-cited-article
gnus-article-remove-cr
gnus-article-de-quoted-unreadable
gnus-article-display-x-face
gnus-summary-stop-page-breaking
;; gnus-summary-caesar-message
;; gnus-summary-verbose-headers
@ -1370,7 +1381,9 @@ want."
gnus-article-strip-leading-blank-lines
gnus-article-strip-multiple-blank-lines
gnus-article-strip-blank-lines
gnus-article-treat-overstrike))
gnus-article-treat-overstrike
gnus-article-display-x-face
gnus-smiley-display))
(defcustom gnus-article-save-directory gnus-directory
"*Name of the directory articles will be saved in (default \"~/News\")."
@ -1643,7 +1656,7 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-article-next-page gnus-article-prev-page
gnus-request-article-this-buffer gnus-article-mode
gnus-article-setup-buffer gnus-narrow-to-page
gnus-article-delete-invisible-text)
gnus-article-delete-invisible-text gnus-hack-decode-rfc1522)
("gnus-art" :interactive t
gnus-article-hide-headers gnus-article-hide-boring-headers
gnus-article-treat-overstrike gnus-article-word-wrap
@ -1910,6 +1923,20 @@ This restriction may disappear in later versions of Gnus."
;;; Gnus Utility Functions
;;;
(defmacro gnus-string-or (&rest strings)
"Return the first element of STRINGS that is a non-blank string.
STRINGS will be evaluated in normal `or' order."
`(gnus-string-or-1 ',strings))
(defun gnus-string-or-1 (strings)
(let (string)
(while strings
(setq string (eval (pop strings)))
(if (string-match "^[ \t]*$" string)
(setq string nil)
(setq strings nil)))
string))
;; Add the current buffer to the list of buffers to be killed on exit.
(defun gnus-add-current-to-buffer-list ()
(or (memq (current-buffer) gnus-buffer-list)
@ -2001,7 +2028,7 @@ that that variable is buffer-local to the summary buffers."
(string-match gnus-total-expirable-newsgroups group)))))
(defun gnus-group-auto-expirable-p (group)
"Check whether GROUP is total-expirable or not."
"Check whether GROUP is auto-expirable or not."
(let ((params (gnus-group-find-parameter group))
val)
(cond
@ -2064,7 +2091,7 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-simplify-mode-line ()
"Make mode lines a bit simpler."
(setq mode-line-modified "-- ")
(setq mode-line-modified (cdr gnus-mode-line-modified))
(when (listp mode-line-format)
(make-local-variable 'mode-line-format)
(setq mode-line-format (copy-sequence mode-line-format))

226
lisp/gnus/message.el
View file

@ -596,6 +596,25 @@ actually occur."
(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender)
"If non-nil, delete the deletable headers before feeding to mh.")
(defvar message-send-method-alist
'((news message-news-p message-send-via-news)
(mail message-mail-p message-send-via-mail))
"Alist of ways to send outgoing messages.
Each element has the form
\(TYPE PREDICATE FUNCTION)
where TYPE is a symbol that names the method; PREDICATE is a function
called without any parameters to determine whether the message is
a message of type TYPE; and FUNCTION is a function to be called if
PREDICATE returns non-nil. FUNCTION is called with one parameter --
the prefix.")
(defvar message-mail-alias-type 'abbrev
"*What alias expansion type to use in Message buffers.
The default is `abbrev', which uses mailabbrev. nil switches
mail aliases off.")
;;; Internal variables.
;;; Well, not really internal.
@ -725,19 +744,19 @@ Defaults to `text-mode-abbrev-table'.")
(let* ((cite-prefix "A-Za-z")
(cite-suffix (concat cite-prefix "0-9_.@-"))
(content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)"))
`((,(concat "^\\(To:\\)" content)
`((,(concat "^\\([Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-to-face nil t))
(,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^Reply-To:\\)" content)
(,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-cc-face nil t))
(,(concat "^\\(Subject:\\)" content)
(,(concat "^\\([Ss]ubject:\\)" content)
(1 'message-header-name-face)
(2 'message-header-subject-face nil t))
(,(concat "^\\(Newsgroups:\\|Followup-to:\\)" content)
(,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-newsgroups-face nil t))
(,(concat "^\\([^: \n\t]+:\\)" content)
(,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
(1 'message-header-name-face)
(2 'message-header-other-face nil t))
(,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
@ -1263,9 +1282,10 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)."
(easy-menu-add message-mode-menu message-mode-map)
(easy-menu-add message-mode-field-menu message-mode-map)
;; Allow mail alias things.
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
(funcall (intern "mail-aliases-setup")))
(when (eq message-mail-alias-type 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
(funcall (intern "mail-aliases-setup"))))
(run-hooks 'text-mode-hook 'message-mode-hook))
@ -1348,11 +1368,15 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)."
(defun message-insert-to ()
"Insert a To header that points to the author of the article being replied to."
(interactive)
(defun message-insert-to (&optional force)
"Insert a To header that points to the author of the article being replied to.
If the original author requested not to be sent mail, the function signals
an error.
With the prefix argument FORCE, insert the header anyway."
(interactive "P")
(let ((co (message-fetch-reply-field "mail-copies-to")))
(when (and co
(when (and (null force)
co
(equal (downcase co) "never"))
(error "The user has requested not to have copies sent via mail")))
(when (and (message-position-on-field "To")
@ -1733,30 +1757,43 @@ the user from the mailer."
(message-fix-before-sending)
(run-hooks 'message-send-hook)
(message "Sending...")
(when (and (or (not (message-news-p))
(and (or (not (memq 'news message-sent-message-via))
(y-or-n-p
"Already sent message via news; resend? "))
(funcall message-send-news-function arg)))
(or (not (message-mail-p))
(and (or (not (memq 'mail message-sent-message-via))
(y-or-n-p
"Already sent message via mail; resend? "))
(message-send-mail arg))))
(message-do-fcc)
;;(when (fboundp 'mail-hist-put-headers-into-history)
;; (mail-hist-put-headers-into-history))
(run-hooks 'message-sent-hook)
(message "Sending...done")
;; If buffer has no file, mark it as unmodified and delete autosave.
(unless buffer-file-name
(set-buffer-modified-p nil)
(delete-auto-save-file-if-necessary t))
;; Delete other mail buffers and stuff.
(message-do-send-housekeeping)
(message-do-actions message-send-actions)
;; Return success.
t)))
(let ((alist message-send-method-alist)
(success t)
elem sent)
(while (and success
(setq elem (pop alist)))
(when (and (or (not (funcall (cadr elem)))
(and (or (not (memq (car elem)
message-sent-message-via))
(y-or-n-p
(format
"Already sent message via %s; resend? "
(car elem))))
(setq success (funcall (caddr elem) arg)))))
(setq sent t)))
(when (and success sent)
(message-do-fcc)
;;(when (fboundp 'mail-hist-put-headers-into-history)
;; (mail-hist-put-headers-into-history))
(run-hooks 'message-sent-hook)
(message "Sending...done")
;; If buffer has no file, mark it as unmodified and delete autosave.
(unless buffer-file-name
(set-buffer-modified-p nil)
(delete-auto-save-file-if-necessary t))
;; Delete other mail buffers and stuff.
(message-do-send-housekeeping)
(message-do-actions message-send-actions)
;; Return success.
t))))
(defun message-send-via-mail (arg)
"Send the current message via mail."
(message-send-mail arg))
(defun message-send-via-news (arg)
"Send the current message via news."
(funcall message-send-news-function arg))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
@ -1926,10 +1963,10 @@ to find out how to use this."
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
(1 (error "qmail-inject reported permanent failure."))
(111 (error "qmail-inject reported transient failure."))
(1 (error "qmail-inject reported permanent failure"))
(111 (error "qmail-inject reported transient failure"))
;; should never happen
(t (error "qmail-inject reported unknown failure."))))
(t (error "qmail-inject reported unknown failure"))))
(defun message-send-mail-with-mh ()
"Send the prepared message buffer with mh."
@ -2007,7 +2044,8 @@ to find out how to use this."
(funcall (intern (format "%s-open-server" (car method)))
(cadr method) (cddr method))
(setq result
(funcall (intern (format "%s-request-post" (car method))))))
(funcall (intern (format "%s-request-post" (car method)))
(cadr method))))
(kill-buffer tembuf))
(set-buffer messbuf)
(if result
@ -2191,6 +2229,22 @@ to find out how to use this."
(y-or-n-p
(format "The %s header looks odd: \"%s\". Really post? "
(car headers) header)))))
(message-check 'repeated-newsgroups
(let ((case-fold-search t)
(headers '("Newsgroups" "Followup-To"))
header error groups group)
(while (and headers
(not error))
(when (setq header (mail-fetch-field (pop headers)))
(setq groups (message-tokenize-header header ","))
(while (setq group (pop groups))
(when (member group groups)
(setq error group
groups nil)))))
(if (not error)
t
(y-or-n-p
(format "Group %s is repeated in headers. Really post? " error)))))
;; Check the From header.
(message-check 'from
(let* ((case-fold-search t)
@ -2282,7 +2336,8 @@ to find out how to use this."
(concat "^" (regexp-quote mail-header-separator) "$"))
(while (not (eobp))
(when (not (looking-at "[ \t\n]"))
(setq sum (logxor (ash sum 1) (following-char))))
(setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
(following-char))))
(forward-char 1)))
sum))
@ -2373,16 +2428,21 @@ to find out how to use this."
(defun message-make-message-id ()
"Make a unique Message-ID."
(concat "<" (message-unique-id)
(let ((psubject (save-excursion (message-fetch-field "subject"))))
(if (and message-reply-headers
(mail-header-references message-reply-headers)
(mail-header-subject message-reply-headers)
psubject
(mail-header-subject message-reply-headers)
(not (string=
(message-strip-subject-re
(mail-header-subject message-reply-headers))
(message-strip-subject-re psubject))))
(let ((psubject (save-excursion (message-fetch-field "subject")))
(psupersedes
(save-excursion (message-fetch-field "supersedes"))))
(if (or
(and message-reply-headers
(mail-header-references message-reply-headers)
(mail-header-subject message-reply-headers)
psubject
(mail-header-subject message-reply-headers)
(not (string=
(message-strip-subject-re
(mail-header-subject message-reply-headers))
(message-strip-subject-re psubject))))
(and psupersedes
(string-match "_-_@" psupersedes)))
"_-_" ""))
"@" (message-make-fqdn) ">"))
@ -2468,9 +2528,10 @@ to find out how to use this."
(let ((stop-pos
(string-match " *at \\| *@ \\| *(\\| *<" from)))
(concat (if stop-pos (substring from 0 stop-pos) from)
"'s message of "
"'s message of \""
(if (or (not date) (string= date ""))
"(unknown date)" date)))))))
"(unknown date)" date)
"\""))))))
(defun message-make-distribution ()
"Make a Distribution header."
@ -2633,6 +2694,8 @@ Headers already prepared in the buffer are not modified."
header value elem)
;; First we remove any old generated headers.
(let ((headers message-deletable-headers))
(unless (buffer-modified-p)
(setq headers (delq 'Message-ID (copy-sequence headers))))
(while headers
(goto-char (point-min))
(and (re-search-forward
@ -2939,6 +3002,7 @@ Headers already prepared in the buffer are not modified."
(message-narrow-to-headers)
(run-hooks 'message-header-setup-hook))
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
(run-hooks 'message-setup-hook)
(message-position-point)
(undo-boundary))
@ -2951,7 +3015,11 @@ Headers already prepared in the buffer are not modified."
(let ((name (make-temp-name
(expand-file-name
(concat (file-name-as-directory message-autosave-directory)
"msg.")))))
"msg."
(nnheader-replace-chars-in-string
(nnheader-replace-chars-in-string
(buffer-name) ?* ?.)
?/ ?-))))))
(setq buffer-auto-save-file-name
(save-excursion
(prog1
@ -3246,9 +3314,10 @@ responses here are directed to other newsgroups."))
mail-header-separator "\n"
message-cancel-message)
(message "Canceling your article...")
(let ((message-syntax-checks 'dont-check-for-anything-just-trust-me))
(funcall message-send-news-function))
(message "Canceling your article...done")
(if (let ((message-syntax-checks
'dont-check-for-anything-just-trust-me))
(funcall message-send-news-function))
(message "Canceling your article...done"))
(kill-buffer buf)))))
;;;###autoload
@ -3576,14 +3645,15 @@ Do a `tab-to-tab-stop' if not in those headers."
(insert string)
(if (not comp)
(message "No matching groups")
(pop-to-buffer "*Completions*")
(buffer-disable-undo (current-buffer))
(let ((buffer-read-only nil))
(erase-buffer)
(let ((standard-output (current-buffer)))
(display-completion-list (sort completions 'string<)))
(goto-char (point-min))
(pop-to-buffer cur)))))))
(save-selected-window
(pop-to-buffer "*Completions*")
(buffer-disable-undo (current-buffer))
(let ((buffer-read-only nil))
(erase-buffer)
(let ((standard-output (current-buffer)))
(display-completion-list (sort completions 'string<)))
(goto-char (point-min))
(delete-region (point) (progn (forward-line 3) (point))))))))))
;;; Help stuff.
@ -3617,19 +3687,27 @@ The following arguments may contain lists of values."
Then clone the local variables and values from the old buffer to the
new one, cloning only the locals having a substring matching the
regexp varstr."
(let ((oldlocals (buffer-local-variables)))
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer (generate-new-buffer name))
(mapcar (lambda (dude)
(when (and (car dude)
(or (not varstr)
(string-match varstr (symbol-name (car dude)))))
(ignore-errors
(set (make-local-variable (car dude))
(cdr dude)))))
oldlocals)
(message-clone-locals oldbuf)
(current-buffer))))
(defun message-clone-locals (buffer)
"Clone the local variables from BUFFER to the current buffer."
(let ((locals (save-excursion
(set-buffer buffer)
(buffer-local-variables)))
(regexp "^gnus\\|^nn\\|^message"))
(mapcar
(lambda (local)
(when (and (car local)
(string-match regexp (symbol-name (car local))))
(ignore-errors
(set (make-local-variable (car local))
(cdr local)))))
locals)))
(run-hooks 'message-load-hook)
(provide 'message)

30
lisp/gnus/nnfolder.el
View file

@ -276,7 +276,8 @@ time saver for large mailboxes.")
(when group
(unless (assoc group nnfolder-group-alist)
(push (list group (cons 1 0)) nnfolder-group-alist)
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-read-folder group)))
t)
(deffoo nnfolder-request-list (&optional server)
@ -451,6 +452,11 @@ time saver for large mailboxes.")
(kill-buffer (current-buffer))
t))))
(defun nnfolder-request-regenerate (server)
(nnfolder-possibly-change-group nil server)
(nnfolder-generate-active-file)
t)
;;; Internal functions.
@ -503,8 +509,6 @@ time saver for large mailboxes.")
;; Change group.
(when (and group
(not (equal group nnfolder-current-group)))
;; 1997/8/14 by MORIOKA Tomohiko
;; for XEmacs/mule.
(let ((pathname-coding-system 'binary))
(nnmail-activate 'nnfolder)
(when (and (not (assoc group nnfolder-group-alist))
@ -513,16 +517,17 @@ time saver for large mailboxes.")
;; The group doesn't exist, so we create a new entry for it.
(push (list group (cons 1 0)) nnfolder-group-alist)
(nnmail-save-active nnfolder-group-alist nnfolder-active-file))
(if dont-check
(setq nnfolder-current-group group)
(setq nnfolder-current-group group
nnfolder-current-buffer nil)
(let (inf file)
;; If we have to change groups, see if we don't already have the
;; folder in memory. If we do, verify the modtime and destroy
;; the folder if needed so we can rescan it.
(when (setq inf (assoc group nnfolder-buffer-alist))
(setq nnfolder-current-buffer (nth 1 inf)))
(setq nnfolder-current-buffer
(nth 1 (assoc group nnfolder-buffer-alist)))
;; If the buffer is not live, make sure it isn't in the alist. If it
;; is live, verify that nobody else has touched the file since last
;; time.
@ -530,9 +535,9 @@ time saver for large mailboxes.")
(not (gnus-buffer-live-p nnfolder-current-buffer)))
(setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)
nnfolder-current-buffer nil))
(setq nnfolder-current-group group)
(when (or (not nnfolder-current-buffer)
(not (verify-visited-file-modtime nnfolder-current-buffer)))
(save-excursion
@ -758,9 +763,7 @@ time saver for large mailboxes.")
(defun nnfolder-group-pathname (group)
"Make pathname for GROUP."
;; 1997/8/14 by MORIOKA Tomohiko
;; encode file name for Emacs 20.
(setq group (encode-coding-string group nnmail-pathname-coding-system))
(setq group (gnus-encode-coding-string group nnmail-pathname-coding-system))
(let ((dir (file-name-as-directory (expand-file-name nnfolder-directory))))
;; If this file exists, we use it directly.
(if (or nnmail-use-long-file-names
@ -773,6 +776,7 @@ time saver for large mailboxes.")
"Save the buffer."
(when (buffer-modified-p)
(run-hooks 'nnfolder-save-buffer-hook)
(gnus-make-directory (file-name-directory (buffer-file-name)))
(save-buffer)))
(provide 'nnfolder)

4
lisp/gnus/nngateway.el
View file

@ -58,9 +58,11 @@ parameter -- the gateway address.")
(insert-buffer-substring buf)
(message-narrow-to-head)
(funcall nngateway-header-transformation nngateway-address)
(goto-char (point-max))
(insert mail-header-separator "\n")
(widen)
(let (message-required-mail-headers)
(message-send-mail))))))
(funcall message-send-mail-function))))))
;;; Internal functions

4
lisp/gnus/nnheader.el
View file

@ -683,9 +683,7 @@ without formatting."
(concat dir group "/")
;; If not, we translate dots into slashes.
(concat dir
;; 1997/8/10 by MORIOKA Tomohiko
;; encode file name for Emacs 20.
(encode-coding-string
(gnus-encode-coding-string
(nnheader-replace-chars-in-string group ?. ?/)
nnheader-pathname-coding-system)
"/")))

12
lisp/gnus/nnkiboze.el
View file

@ -154,7 +154,9 @@
(nnkiboze-possibly-change-group group)
(when force
(let ((files (list (nnkiboze-nov-file-name)
(concat nnkiboze-directory group ".newsrc")
(concat nnkiboze-directory
(nnheader-translate-file-chars
(concat group ".newsrc")))
(nnkiboze-score-file group))))
(while files
(and (file-exists-p (car files))
@ -205,8 +207,12 @@ Finds out what articles are to be part of the nnkiboze groups."
(defun nnkiboze-generate-group (group)
(let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
(newsrc-file (concat nnkiboze-directory group ".newsrc"))
(nov-file (concat nnkiboze-directory group ".nov"))
(newsrc-file (concat nnkiboze-directory
(nnheader-translate-file-chars
(concat group ".newsrc"))))
(nov-file (concat nnkiboze-directory
(nnheader-translate-file-chars
(concat group ".nov"))))
method nnkiboze-newsrc gname newsrc active
ginfo lowest glevel orig-info nov-buffer
;; Bind various things to nil to make group entry faster.

56
lisp/gnus/nnmail.el
View file

@ -113,7 +113,9 @@ If nil, the first match found will be used."
;; Added by gord@enci.ucalgary.ca (Gordon Matzigkeit).
(defcustom nnmail-keep-last-article nil
"If non-nil, nnmail will never delete the last expired article in a directory.
"If non-nil, nnmail will never delete/move a group's last article.
It can be marked expirable, so it will be deleted when it is no longer last.
You may need to set this variable if other programs are putting
new mail into folder numbers that Gnus has marked as expired."
:group 'nnmail-procmail
@ -396,7 +398,9 @@ Example:
'((any . "from\\|to\\|cc\\|sender\\|apparently-to\\|resent-from\\|resent-to\\|resent-cc")
(mail . "mailer-daemon\\|postmaster\\|uucp")
(to . "to\\|cc\\|apparently-to\\|resent-to\\|resent-cc")
(from . "from\\|sender\\|resent-from"))
(from . "from\\|sender\\|resent-from")
(nato . "to\\|cc\\|resent-to\\|resent-cc")
(naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc"))
"Alist of abbreviations allowed in `nnmail-split-fancy'."
:group 'nnmail-split
:type '(repeat (cons :format "%v" symbol regexp)))
@ -505,9 +509,7 @@ parameter. It should return nil, `warn' or `delete'."
(concat dir group "/")
;; If not, we translate dots into slashes.
(concat dir
;; 1997/8/10 by MORIOKA Tomohiko
;; encode file name for Emacs 20.
(encode-coding-string
(gnus-encode-coding-string
(nnheader-replace-chars-in-string group ?. ?/)
nnmail-pathname-coding-system)
"/")))
@ -559,18 +561,17 @@ parameter. It should return nil, `warn' or `delete'."
(defun nnmail-move-inbox (inbox)
"Move INBOX to `nnmail-crash-box'."
(if (not (file-writable-p nnmail-crash-box))
(gnus-error 1 "Can't write to crash box %s. Not moving mail."
(gnus-error 1 "Can't write to crash box %s. Not moving mail"
nnmail-crash-box)
;; If the crash box exists and is empty, we delete it.
(when (and (file-exists-p nnmail-crash-box)
(zerop (nnheader-file-size (file-truename nnmail-crash-box))))
(delete-file nnmail-crash-box))
(let ((inbox (file-truename (expand-file-name inbox)))
(tofile (file-truename (expand-file-name nnmail-crash-box)))
movemail popmail errors result)
(if (setq popmail (string-match
"^po:" (file-name-nondirectory inbox)))
(setq inbox (file-name-nondirectory inbox))
(let ((tofile (file-truename (expand-file-name nnmail-crash-box)))
(popmail (string-match "^po:" inbox))
movemail errors result)
(unless popmail
(setq inbox (file-truename (expand-file-name inbox)))
(setq movemail t)
;; On some systems, /usr/spool/mail/foo is a directory
;; and the actual inbox is /usr/spool/mail/foo/foo.
@ -590,7 +591,7 @@ parameter. It should return nil, `warn' or `delete'."
(nnmail-read-passwd
(format "Password for %s: "
(substring inbox (+ popmail 3))))))
(message "Getting mail from post office ..."))
(message "Getting mail from the post office..."))
(when (or (and (file-exists-p tofile)
(/= 0 (nnheader-file-size tofile)))
(and (file-exists-p inbox)
@ -831,7 +832,7 @@ is a spool. If not using procmail, return GROUP."
(= (following-char) ?\n)))
(save-excursion
(forward-line 1)
(while (looking-at ">From ")
(while (looking-at ">From \\|From ")
(forward-line 1))
(looking-at "[^ \n\t:]+[ \n\t]*:")))
(setq found 'yes)))))
@ -860,7 +861,7 @@ is a spool. If not using procmail, return GROUP."
(= (following-char) ?\n)))
(save-excursion
(forward-line 1)
(while (looking-at ">From ")
(while (looking-at ">From \\|From ")
(forward-line 1))
(looking-at "[^ \n\t:]+[ \n\t]*:")))
(setq found 'yes)))))
@ -1069,6 +1070,9 @@ FUNC will be called with the group name to determine the article number."
(fboundp nnmail-split-methods))
(let ((split
(condition-case nil
;; `nnmail-split-methods' is a function, so we
;; just call this function here and use the
;; result.
(or (funcall nnmail-split-methods)
'("bogus"))
(error
@ -1076,9 +1080,13 @@ FUNC will be called with the group name to determine the article number."
"Error in `nnmail-split-methods'; using `bogus' mail group")
(sit-for 1)
'("bogus")))))
(unless (equal split '(junk))
;; `nnmail-split-methods' is a function, so we just call
;; this function here and use the result.
;; The article may be "cross-posted" to `junk'. What
;; to do? Just remove the `junk' spec. Don't really
;; see anything else to do...
(let (elem)
(while (setq elem (car (memq 'junk split)))
(setq split (delq elem split))))
(when split
(setq group-art
(mapcar
(lambda (group) (cons group (funcall func group)))
@ -1109,7 +1117,13 @@ FUNC will be called with the group name to determine the article number."
;; See whether the split methods returned `junk'.
(if (equal group-art '(junk))
nil
(nreverse (delq 'junk group-art)))))))
;; The article may be "cross-posted" to `junk'. What
;; to do? Just remove the `junk' spec. Don't really
;; see anything else to do...
(let (elem)
(while (setq elem (car (memq 'junk group-art)))
(setq group-art (delq elem group-art)))
(nreverse group-art)))))))
(defun nnmail-insert-lines ()
"Insert how many lines there are in the body of the mail.
@ -1139,10 +1153,8 @@ Return the number of characters in the body."
(progn (forward-line 1) (point))))
(insert (format "Xref: %s" (system-name)))
(while group-alist
;; 1997/8/10 by MORIOKA Tomohiko
;; encode file name for Emacs 20.
(insert (format " %s:%d"
(encode-coding-string (caar group-alist)
(gnus-encode-coding-string (caar group-alist)
nnmail-pathname-coding-system)
(cdar group-alist)))
(setq group-alist (cdr group-alist)))

6
lisp/gnus/nnmh.el
View file

@ -190,11 +190,9 @@
(deffoo nnmh-request-list (&optional server dir)
(nnheader-insert "")
(let (;; 1997/8/14 by MORIOKA Tomohiko
;; for XEmacs/mule.
(pathname-coding-system 'binary)
(let ((pathname-coding-system 'binary)
(nnmh-toplev
(or dir (file-truename (file-name-as-directory nnmh-directory)))))
(file-truename (or dir (file-name-as-directory nnmh-directory)))))
(nnmh-request-list-1 nnmh-toplev))
(setq nnmh-group-alist (nnmail-get-active))
t)

21
lisp/gnus/nnml.el
View file

@ -38,7 +38,7 @@
(nnoo-declare nnml)
(defvoo nnml-directory message-directory
"Mail spool directory.")
"Spool directory for the nnml mail backend.")
(defvoo nnml-active-file
(concat (file-name-as-directory nnml-directory) "active")
@ -474,8 +474,15 @@ all. This may very well take some time.")
(defun nnml-article-to-file (article)
(nnml-update-file-alist)
(let (file)
(when (setq file (cdr (assq article nnml-article-file-alist)))
(concat nnml-current-directory file))))
(if (setq file (cdr (assq article nnml-article-file-alist)))
(concat nnml-current-directory file)
;; Just to make sure nothing went wrong when reading over NFS --
;; check once more.
(when (file-exists-p
(setq file (concat nnml-current-directory "/"
(number-to-string article))))
(nnml-update-file-alist t)
file))))
(defun nnml-deletable-article-p (group article)
"Say whether ARTICLE in GROUP can be deleted."
@ -769,8 +776,7 @@ all. This may very well take some time.")
(search-forward "\n\n" nil t)
(setq chars (- (point-max) (point)))
(max 1 (1- (point)))))
(when (and (not (= 0 chars)) ; none of them empty files...
(not (= (point-min) (point-max))))
(unless (zerop (buffer-size))
(goto-char (point-min))
(setq headers (nnml-parse-head chars (caar files)))
(save-excursion
@ -800,8 +806,9 @@ all. This may very well take some time.")
(setf (car active) num)))))))
t))
(defun nnml-update-file-alist ()
(unless nnml-article-file-alist
(defun nnml-update-file-alist (&optional force)
(when (or (not nnml-article-file-alist)
force)
(setq nnml-article-file-alist
(nnheader-article-to-file-alist nnml-current-directory))))

2
lisp/gnus/nnoo.el
View file

@ -143,7 +143,7 @@
(def (assq backend nnoo-definition-alist))
(parents (nth 1 def)))
(unless def
(error "%s belongs to a backend that hasn't been declared." var))
(error "%s belongs to a backend that hasn't been declared" var))
(setcar (nthcdr 2 def)
(delq (assq var (nth 2 def)) (nth 2 def)))
(setcar (nthcdr 2 def)

4
lisp/gnus/nnsoup.el
View file

@ -237,7 +237,7 @@ The SOUP packet file name will be inserted at the %s.")
(deffoo nnsoup-request-type (group &optional article)
(nnsoup-possibly-change-group group)
;; Try to guess the type based on the first articl ein the group.
;; Try to guess the type based on the first article in the group.
(when (not article)
(setq article
(cdaar (cddr (assoc group nnsoup-group-alist)))))
@ -623,7 +623,7 @@ The SOUP packet file name will be inserted at the %s.")
(nnsoup-write-replies)
;; Check whether there is anything here.
(when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
(error "No files to pack."))
(error "No files to pack"))
;; Pack all these files into a SOUP packet.
(gnus-soup-pack nnsoup-replies-directory nnsoup-packer))

44
lisp/gnus/nntp.el
View file

@ -73,10 +73,11 @@ It will be called with the buffer to output in.
Two pre-made functions are `nntp-open-network-stream', which is the
default, and simply connects to some port or other on the remote
system (see nntp-port-number). The other are `nntp-open-rlogin', which
does an rlogin on the remote system, and then does a telnet to the
NNTP server available there (see nntp-rlogin-parameters) and `nntp-open-telnet' which
telnets to a remote system, logs in and does the same")
system (see nntp-port-number). The other are `nntp-open-rlogin',
which does an rlogin on the remote system, and then does a telnet to
the NNTP server available there (see nntp-rlogin-parameters) and
`nntp-open-telnet' which telnets to a remote system, logs in and does
the same.")
(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp")
"*Parameters to `nntp-open-login'.
@ -98,6 +99,12 @@ via telnet.")
(defvoo nntp-telnet-passwd nil
"Password to use to log in via telnet with.")
(defvoo nntp-telnet-command "telnet"
"Command used to start telnet.")
(defvoo nntp-telnet-switches '("-8")
"Switches given to the telnet command.")
(defvoo nntp-end-of-line "\r\n"
"String to use on the end of lines when talking to the NNTP server.
This is \"\\r\\n\" by default, but should be \"\\n\" when
@ -122,7 +129,7 @@ The strings are tried in turn until a positive response is gotten. If
none of the commands are successful, nntp will just grab headers one
by one.")
(defvoo nntp-nov-gap 20
(defvoo nntp-nov-gap 5
"*Maximum allowed gap between two articles.
If the gap between two consecutive articles is bigger than this
variable, split the XOVER request into two requests.")
@ -187,7 +194,7 @@ server there that you can connect to. See also `nntp-open-connection-function'"
(save-excursion
(set-buffer (process-buffer process))
(goto-char (point-min))
(while (or (not (memq (following-char) '(?2 ?3 ?4 ?5)))
(while (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5)))
(looking-at "480"))
(when (looking-at "480")
(erase-buffer)
@ -568,20 +575,22 @@ server there that you can connect to. See also `nntp-open-connection-function'"
(when (nntp-send-command-and-decode
"\r?\n\\.\r?\n" "ARTICLE"
(if (numberp article) (int-to-string article) article))
(when (and buffer
(not (equal buffer nntp-server-buffer)))
(save-excursion
(set-buffer nntp-server-buffer)
(copy-to-buffer buffer (point-min) (point-max))
(nntp-find-group-and-number)))
(nntp-find-group-and-number)))
(if (and buffer
(not (equal buffer nntp-server-buffer)))
(save-excursion
(set-buffer nntp-server-buffer)
(copy-to-buffer buffer (point-min) (point-max))
(nntp-find-group-and-number))
(nntp-find-group-and-number))))
(deffoo nntp-request-head (article &optional group server)
(nntp-possibly-change-group group server)
(when (nntp-send-command-and-decode
(when (nntp-send-command
"\r?\n\\.\r?\n" "HEAD"
(if (numberp article) (int-to-string article) article))
(nntp-find-group-and-number)))
(prog1
(nntp-find-group-and-number)
(nntp-decode-text))))
(deffoo nntp-request-body (article &optional group server)
(nntp-possibly-change-group group server)
@ -1046,8 +1055,9 @@ This function is supposed to be called from `nntp-server-opened-hook'."
(save-excursion
(set-buffer buffer)
(erase-buffer)
(let ((proc (start-process
"nntpd" buffer "telnet" "-8"))
(let ((proc (apply
'start-process
"nntpd" buffer nntp-telnet-command nntp-telnet-switches))
(case-fold-search t))
(when (memq (process-status proc) '(open run))
(process-send-string proc "set escape \^X\n")

25
lisp/gnus/nnvirtual.el
View file

@ -374,22 +374,29 @@ to virtual article number.")
(insert "Xref: " system-name " " group ":")
(princ article (current-buffer))
(insert " ")
;; If there were existing xref lines, clean them up to have the correct
;; component server prefix.
(let ((xref-end (save-excursion
(search-forward "\t" (gnus-point-at-eol) 'move)
(point)))
(len (length prefix)))
(unless (= (point) xref-end)
(save-restriction
(narrow-to-region (point)
(or (search-forward "\t" (gnus-point-at-eol) t)
(gnus-point-at-eol)))
(goto-char (point-min))
(when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
(replace-match "" t t))
(goto-char (point-min))
(when (re-search-forward
(concat (gnus-group-real-name group) ":[0-9]+")
nil t)
(replace-match "" t t))
(unless (= (point) (point-max))
(insert " ")
(when (not (string= "" prefix))
(while (re-search-forward "[^ ]+:[0-9]+" xref-end t)
(while (re-search-forward "[^ ]+:[0-9]+" nil t)
(save-excursion
(goto-char (match-beginning 0))
(insert prefix))
(setq xref-end (+ xref-end len)))
)))
(insert prefix))))))
;; Ensure a trailing \t.
(end-of-line)

100
lisp/gnus/nnweb.el
View file

@ -288,9 +288,9 @@
(save-excursion
(set-buffer nnweb-buffer)
(erase-buffer)
(prog1
(url-insert-file-contents url)
(copy-to-buffer buf (point-min) (point-max)))))
(url-insert-file-contents url)
(copy-to-buffer buf (point-min) (point-max))
t))
(nnweb-url-retrieve-asynch
url 'nnweb-callback (current-buffer) nnheader-callback-function)
t)))
@ -344,7 +344,7 @@
(goto-char (point-min))
(while (re-search-forward "&\\([a-z]+\\);" nil t)
(replace-match (char-to-string (or (cdr (assq (intern (match-string 1))
w3-html-entities ))
w3-html-entities))
?#))
t t)))
@ -443,7 +443,10 @@
(replace-match "\\1 " t)
(forward-line 1))
(when (re-search-forward "\n\n+" nil t)
(replace-match "\n" t t))))
(replace-match "\n" t t))
(goto-char (point-min))
(when (search-forward "[More Headers]" nil t)
(replace-match "" t t))))
(defun nnweb-dejanews-search (search)
(nnweb-fetch-form
@ -564,35 +567,34 @@
(set-marker body nil))))
(defun nnweb-reference-search (search)
(prog1
(url-insert-file-contents
(concat
(nnweb-definition 'address)
"?"
(nnweb-encode-www-form-urlencoded
`(("search" . "advanced")
("querytext" . ,search)
("subj" . "")
("name" . "")
("login" . "")
("host" . "")
("organization" . "")
("groups" . "")
("keywords" . "")
("choice" . "Search")
("startmonth" . "Jul")
("startday" . "25")
("startyear" . "1996")
("endmonth" . "Aug")
("endday" . "24")
("endyear" . "1996")
("mode" . "Quick")
("verbosity" . "Verbose")
("ranking" . "Relevance")
("first" . "1")
("last" . "25")
("score" . "50")))))
(setq buffer-file-name nil))
(url-insert-file-contents
(concat
(nnweb-definition 'address)
"?"
(nnweb-encode-www-form-urlencoded
`(("search" . "advanced")
("querytext" . ,search)
("subj" . "")
("name" . "")
("login" . "")
("host" . "")
("organization" . "")
("groups" . "")
("keywords" . "")
("choice" . "Search")
("startmonth" . "Jul")
("startday" . "25")
("startyear" . "1996")
("endmonth" . "Aug")
("endday" . "24")
("endyear" . "1996")
("mode" . "Quick")
("verbosity" . "Verbose")
("ranking" . "Relevance")
("first" . "1")
("last" . "25")
("score" . "50")))))
(setq buffer-file-name nil)
t)
;;;
@ -670,21 +672,21 @@
(nnweb-remove-markup)))
(defun nnweb-altavista-search (search &optional part)
(prog1
(url-insert-file-contents
(concat
(nnweb-definition 'address)
"?"
(nnweb-encode-www-form-urlencoded
`(("pg" . "aq")
("what" . "news")
,@(when part `(("stq" . ,(int-to-string (* part 30)))))
("fmt" . "d")
("q" . ,search)
("r" . "")
("d0" . "")
("d1" . "")))))
(setq buffer-file-name nil)))
(url-insert-file-contents
(concat
(nnweb-definition 'address)
"?"
(nnweb-encode-www-form-urlencoded
`(("pg" . "aq")
("what" . "news")
,@(when part `(("stq" . ,(int-to-string (* part 30)))))
("fmt" . "d")
("q" . ,search)
("r" . "")
("d0" . "")
("d1" . "")))))
(setq buffer-file-name nil)
t)
(provide 'nnweb)

14
lisp/gnus/pop3.el
View file

@ -1,10 +1,10 @@
;;; pop3.el --- Post Office Protocol (RFC 1460) interface
;; Copyright (C) 1996, Free Software Foundation, Inc.
;; Copyright (C) 1996,1997 Free Software Foundation, Inc.
;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
;; Keywords: mail, pop3
;; Version: 1.3e
;; Version: 1.3g
;; This file is part of GNU Emacs.
@ -37,7 +37,7 @@
(require 'mail-utils)
(provide 'pop3)
(defconst pop3-version "1.3c")
(defconst pop3-version "1.3g")
(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil)
"*POP3 maildrop.")
@ -152,7 +152,7 @@ Return the response string if optional second argument is non-nil."
(set-buffer (process-buffer process))
(goto-char pop3-read-point)
(while (not (search-forward "\r\n" nil t))
(accept-process-output process)
(accept-process-output process 3)
(goto-char pop3-read-point))
(setq match-end (point))
(goto-char pop3-read-point)
@ -205,6 +205,7 @@ Return the response string if optional second argument is non-nil."
(defun pop3-munge-message-separator (start end)
"Check to see if a message separator exists. If not, generate one."
(if (not (fboundp 'message-make-date)) (autoload 'message-make-date "message"))
(save-excursion
(save-restriction
(narrow-to-region start end)
@ -214,7 +215,8 @@ Return the response string if optional second argument is non-nil."
(looking-at "BABYL OPTIONS:") ; Babyl
))
(let ((from (mail-strip-quoted-names (mail-fetch-field "From")))
(date (pop3-string-to-list (mail-fetch-field "Date")))
(date (pop3-string-to-list (or (mail-fetch-field "Date")
(message-make-date))))
(From_))
;; sample date formats I have seen
;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
@ -315,7 +317,7 @@ This function currently does nothing.")
(save-excursion
(set-buffer (process-buffer process))
(while (not (re-search-forward "^\\.\r\n" nil t))
(accept-process-output process)
(accept-process-output process 3)
;; bill@att.com ... to save wear and tear on the heap
(if (> (buffer-size) 20000) (sleep-for 1))
(if (> (buffer-size) 50000) (sleep-for 1))