mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-23 07:19:15 +00:00
Code Issues Releases Activity

Update to emacs-21-branch of the Gnus CVS repository.

Browse Source
This commit is contained in:
Gerd Moellmann 2000-09-19 13:37:09 +00:00
parent ce9ded5de2
commit 16409b0bb8
65 changed files with 10738 additions and 5960 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
lisp/gnus/earcon.el
View File

@ -1,7 +1,11 @@
;;; earcon.el --- Sound effects for messages
;; Copyright (C) 1996 Free Software Foundation
;; Copyright (C) 1996, 2000 Free Software Foundation
;; Author: Steven L. Baur <steve@miranova.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
@ -16,8 +20,10 @@
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; This file is part of GNU Emacs.
;;; Commentary:
;; This file provides access to sound effects in Gnus.
;;; Code:
@ -74,8 +80,6 @@
(defvar earcon-button-marker-list nil)
(make-variable-buffer-local 'earcon-button-marker-list)
;;; FIXME!! clone of code from gnus-vis.el FIXME!!
(defun earcon-article-push-button (event)
"Check text under the mouse pointer for a callback function.
@ -156,7 +160,6 @@ If N is negative, move backward instead."
(setq entry nil)))
entry))
(defun earcon-button-push (marker)
;; Push button starting at MARKER.
(save-excursion

758
lisp/gnus/gnus-agent.el
View File

File diff suppressed because it is too large Load Diff

2747
lisp/gnus/gnus-art.el
View File

File diff suppressed because it is too large Load Diff

168
lisp/gnus/gnus-async.el
View File

@ -1,5 +1,5 @@
;;; gnus-async.el --- asynchronous support for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +27,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-sum)
(require 'nntp)
@ -37,7 +35,7 @@
"Support for asynchronous operations."
:group 'gnus)
(defcustom gnus-asynchronous t
(defcustom gnus-asynchronous nil
"*If nil, inhibit all Gnus asynchronicity.
If non-nil, let the other asynch variables be heeded."
:group 'gnus-asynchronous
@ -49,8 +47,8 @@ If a number, prefetch only that many articles forward;
if t, prefetch as many articles as possible."
:group 'gnus-asynchronous
:type '(choice (const :tag "off" nil)
(integer :tag "some" 0)
(other :tag "all" t)))
(const :tag "all" t)
(integer :tag "some" 0)))
(defcustom gnus-prefetched-article-deletion-strategy '(read exit)
"List of symbols that say when to remove articles from the prefetch buffer.
@ -79,7 +77,10 @@ It should return non-nil if the article is to be prefetched."
(defvar gnus-async-article-alist nil)
(defvar gnus-async-article-semaphore '(nil))
(defvar gnus-async-fetch-list nil)
(defvar gnus-asynch-obarray nil)
(defvar gnus-async-hashtb nil)
(defvar gnus-async-current-prefetch-group nil)
(defvar gnus-async-current-prefetch-article nil)
(defvar gnus-async-timer nil)
(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*")
(defvar gnus-async-header-prefetched nil)
@ -108,8 +109,8 @@ It should return non-nil if the article is to be prefetched."
,@forms)
(gnus-async-release-semaphore 'gnus-async-article-semaphore)))
(put 'gnus-asynch-with-semaphore 'lisp-indent-function 0)
(put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body))
(put 'gnus-async-with-semaphore 'lisp-indent-function 0)
(put 'gnus-async-with-semaphore 'edebug-form-spec '(body))
;;;
;;; Article prefetch
@ -119,14 +120,14 @@ It should return non-nil if the article is to be prefetched."
(defun gnus-async-close ()
(gnus-kill-buffer gnus-async-prefetch-article-buffer)
(gnus-kill-buffer gnus-async-prefetch-headers-buffer)
(setq gnus-async-article-alist nil
(setq gnus-async-hashtb nil
gnus-async-article-alist nil
gnus-async-header-prefetched nil))
(defun gnus-async-set-buffer ()
(nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)
(unless gnus-asynch-obarray
(set (make-local-variable 'gnus-asynch-obarray)
(gnus-make-hashtable 1023))))
(unless gnus-async-hashtb
(setq gnus-async-hashtb (gnus-make-hashtable 1023))))
(defun gnus-async-halt-prefetch ()
"Stop prefetching."
@ -146,49 +147,54 @@ It should return non-nil if the article is to be prefetched."
;; do this, which leads to slightly slower article
;; buffer display.
(gnus-async-prefetch-article group next summary)
(run-with-idle-timer
0.1 nil 'gnus-async-prefetch-article group next summary)))))))
(when gnus-async-timer
(ignore-errors
(nnheader-cancel-timer 'gnus-async-timer)))
(setq gnus-async-timer
(run-with-idle-timer
0.1 nil 'gnus-async-prefetch-article
group next summary))))))))
(defun gnus-async-prefetch-article (group article summary &optional next)
"Possibly prefetch several articles starting with ARTICLE."
(if (not (gnus-buffer-live-p summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
(setq gnus-async-fetch-list nil))
(when (and gnus-asynchronous
(gnus-alive-p))
(when next
(gnus-async-with-semaphore
(pop gnus-async-fetch-list)))
(pop gnus-async-fetch-list)))
(let ((do-fetch next)
(do-message t)) ;(eq major-mode 'gnus-summary-mode)))
(do-message t)) ;(eq major-mode 'gnus-summary-mode)))
(when (and (gnus-group-asynchronous-p group)
(gnus-buffer-live-p summary)
(or (not next)
gnus-async-fetch-list))
(gnus-async-with-semaphore
(unless next
(setq do-fetch (not gnus-async-fetch-list))
;; Nix out any outstanding requests.
(setq gnus-async-fetch-list nil)
;; Fill in the new list.
(let ((n gnus-use-article-prefetch)
(data (gnus-data-find-list article))
d)
(while (and (setq d (pop data))
(if (numberp n)
(natnump (decf n))
n))
(unless (or (gnus-async-prefetched-article-entry
group (setq article (gnus-data-number d)))
(not (natnump article))
(not (funcall gnus-async-prefetch-article-p d)))
;; Not already fetched -- so we add it to the list.
(push article gnus-async-fetch-list)))
(setq gnus-async-fetch-list
(nreverse gnus-async-fetch-list))))
(unless next
(setq do-fetch (not gnus-async-fetch-list))
;; Nix out any outstanding requests.
(setq gnus-async-fetch-list nil)
;; Fill in the new list.
(let ((n gnus-use-article-prefetch)
(data (gnus-data-find-list article))
d)
(while (and (setq d (pop data))
(if (numberp n)
(natnump (decf n))
n))
(unless (or (gnus-async-prefetched-article-entry
group (setq article (gnus-data-number d)))
(not (natnump article))
(not (funcall gnus-async-prefetch-article-p d)))
;; Not already fetched -- so we add it to the list.
(push article gnus-async-fetch-list)))
(setq gnus-async-fetch-list
(nreverse gnus-async-fetch-list))))
(when do-fetch
(setq article (car gnus-async-fetch-list))))
(when do-fetch
(setq article (car gnus-async-fetch-list))))
(when (and do-fetch article)
;; We want to fetch some more articles.
@ -206,26 +212,33 @@ It should return non-nil if the article is to be prefetched."
(when do-message
(gnus-message 9 "Prefetching article %d in group %s"
article group))
(setq gnus-async-current-prefetch-group group)
(setq gnus-async-current-prefetch-article article)
(gnus-request-article article group))))))))))
(defun gnus-make-async-article-function (group article mark summary next)
"Return a callback function."
`(lambda (arg)
(save-excursion
(when arg
(gnus-async-set-buffer)
(gnus-async-with-semaphore
(setq
gnus-async-article-alist
(cons (list ',(intern (format "%s-%d" group article)
gnus-asynch-obarray)
,mark (set-marker (make-marker) (point-max))
,group ,article)
gnus-async-article-alist))))
(if (not (gnus-buffer-live-p ,summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
(gnus-async-prefetch-article ,group ,next ,summary t)))))
(gnus-async-article-callback arg ,group ,article ,mark ,summary ,next)))
(defun gnus-async-article-callback (arg group article mark summary next)
"Function called when an async article is done being fetched."
(save-excursion
(setq gnus-async-current-prefetch-article nil)
(when arg
(gnus-async-set-buffer)
(gnus-async-with-semaphore
(setq
gnus-async-article-alist
(cons (list (intern (format "%s-%d" group article)
gnus-async-hashtb)
mark (set-marker (make-marker) (point-max))
group article)
gnus-async-article-alist))))
(if (not (gnus-buffer-live-p summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
(gnus-async-prefetch-article group next summary t))))
(defun gnus-async-unread-p (data)
"Return non-nil if DATA represents an unread article."
@ -234,6 +247,9 @@ It should return non-nil if the article is to be prefetched."
(defun gnus-async-request-fetched-article (group article buffer)
"See whether we have ARTICLE from GROUP and put it in BUFFER."
(when (numberp article)
(when (and (equal group gnus-async-current-prefetch-group)
(eq article gnus-async-current-prefetch-article))
(gnus-async-wait-for-article article))
(let ((entry (gnus-async-prefetched-article-entry group article)))
(when entry
(save-excursion
@ -241,18 +257,48 @@ It should return non-nil if the article is to be prefetched."
(copy-to-buffer buffer (cadr entry) (caddr entry))
;; Remove the read article from the prefetch buffer.
(when (memq 'read gnus-prefetched-article-deletion-strategy)
(gnus-async-delete-prefected-entry entry))
(gnus-async-delete-prefetched-entry entry))
t)))))
(defun gnus-async-delete-prefected-entry (entry)
(defun gnus-async-wait-for-article (article)
"Wait until ARTICLE is no longer the currently-being-fetched article."
(save-excursion
(gnus-async-set-buffer)
(let ((proc (nntp-find-connection (current-buffer)))
(nntp-server-buffer (current-buffer))
(nntp-have-messaged nil)
(tries 0))
(condition-case nil
;; FIXME: we could stop waiting after some
;; timeout, but this is the wrong place to do it.
;; rather than checking time-spent-waiting, we
;; should check time-since-last-output, which
;; needs to be done in nntp.el.
(while (eq article gnus-async-current-prefetch-article)
(incf tries)
(when (nntp-accept-process-output proc 1)
(setq tries 0))
(when (and (not nntp-have-messaged) (eq 3 tries))
(gnus-message 5 "Waiting for async article...")
(setq nntp-have-messaged t)))
(quit
;; if the user interrupted on a slow/hung connection,
;; do something friendly.
(when (< 3 tries)
(setq gnus-async-current-prefetch-article nil))
(signal 'quit nil)))
(when nntp-have-messaged
(gnus-message 5 "")))))
(defun gnus-async-delete-prefetched-entry (entry)
"Delete ENTRY from buffer and alist."
(ignore-errors
(delete-region (cadr entry) (caddr entry))
(set-marker (cadr entry) nil)
(set-marker (caddr entry) nil))
(gnus-async-with-semaphore
(setq gnus-async-article-alist
(delq entry gnus-async-article-alist))))
(setq gnus-async-article-alist
(delq entry gnus-async-article-alist))))
(defun gnus-async-prefetch-remove-group (group)
"Remove all articles belonging to GROUP from the prefetch buffer."
@ -263,7 +309,7 @@ It should return non-nil if the article is to be prefetched."
(gnus-async-set-buffer)
(while alist
(when (equal group (nth 3 (car alist)))
(gnus-async-delete-prefected-entry (car alist)))
(gnus-async-delete-prefetched-entry (car alist)))
(pop alist))))))
(defun gnus-async-prefetched-article-entry (group article)
@ -271,7 +317,7 @@ It should return non-nil if the article is to be prefetched."
(let ((entry (save-excursion
(gnus-async-set-buffer)
(assq (intern (format "%s-%d" group article)
gnus-asynch-obarray)
gnus-async-hashtb)
gnus-async-article-alist))))
;; Perhaps something has emptied the buffer?
(if (and entry

70
lisp/gnus/gnus-audio.el
View File

@ -47,37 +47,37 @@
"Executable program for playing WAV files.")
;;; The following isn't implemented yet. Wait for Millennium Gnus.
;(defvar gnus-audio-effects-enabled t
; "When t, Gnus will use sound effects.")
;(defvar gnus-audio-enable-hooks nil
; "Functions run when enabling sound effects.")
;(defvar gnus-audio-disable-hooks nil
; "Functions run when disabling sound effects.")
;(defvar gnus-audio-theme-song nil
; "Theme song for Gnus.")
;(defvar gnus-audio-enter-group nil
; "Sound effect played when selecting a group.")
;(defvar gnus-audio-exit-group nil
; "Sound effect played when exiting a group.")
;(defvar gnus-audio-score-group nil
; "Sound effect played when scoring a group.")
;(defvar gnus-audio-busy-sound nil
; "Sound effect played when going into a ... sequence.")
;;(defvar gnus-audio-effects-enabled t
;; "When t, Gnus will use sound effects.")
;;(defvar gnus-audio-enable-hooks nil
;; "Functions run when enabling sound effects.")
;;(defvar gnus-audio-disable-hooks nil
;; "Functions run when disabling sound effects.")
;;(defvar gnus-audio-theme-song nil
;; "Theme song for Gnus.")
;;(defvar gnus-audio-enter-group nil
;; "Sound effect played when selecting a group.")
;;(defvar gnus-audio-exit-group nil
;; "Sound effect played when exiting a group.")
;;(defvar gnus-audio-score-group nil
;; "Sound effect played when scoring a group.")
;;(defvar gnus-audio-busy-sound nil
;; "Sound effect played when going into a ... sequence.")
;;;###autoload
;(defun gnus-audio-enable-sound ()
; "Enable Sound Effects for Gnus."
; (interactive)
; (setq gnus-audio-effects-enabled t)
; (gnus-run-hooks gnus-audio-enable-hooks))
;;(defun gnus-audio-enable-sound ()
;; "Enable Sound Effects for Gnus."
;; (interactive)
;; (setq gnus-audio-effects-enabled t)
;; (gnus-run-hooks gnus-audio-enable-hooks))
;;;###autoload
;(defun gnus-audio-disable-sound ()
; "Disable Sound Effects for Gnus."
; (interactive)
; (setq gnus-audio-effects-enabled nil)
; (gnus-run-hooks gnus-audio-disable-hooks))
;; "Disable Sound Effects for Gnus."
;; (interactive)
;; (setq gnus-audio-effects-enabled nil)
;; (gnus-run-hooks gnus-audio-disable-hooks))
;;;###autoload
(defun gnus-audio-play (file)
@ -104,16 +104,16 @@
;;; The following isn't implemented yet, wait for Red Gnus
;(defun gnus-audio-startrek-sounds ()
; "Enable sounds from Star Trek the original series."
; (interactive)
; (setq gnus-audio-busy-sound "working.au")
; (setq gnus-audio-enter-group "bulkhead_door.au")
; (setq gnus-audio-exit-group "bulkhead_door.au")
; (setq gnus-audio-score-group "ST_laser.au")
; (setq gnus-audio-theme-song "startrek.au")
; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group)
; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group))
;;(defun gnus-audio-startrek-sounds ()
;; "Enable sounds from Star Trek the original series."
;; (interactive)
;; (setq gnus-audio-busy-sound "working.au")
;; (setq gnus-audio-enter-group "bulkhead_door.au")
;; (setq gnus-audio-exit-group "bulkhead_door.au")
;; (setq gnus-audio-score-group "ST_laser.au")
;; (setq gnus-audio-theme-song "startrek.au")
;; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group)
;; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group))
;;;***
(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au"

22
lisp/gnus/gnus-bcklg.el
View File

@ -1,5 +1,5 @@
;;; gnus-bcklg.el --- backlog functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +27,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
;;;
@ -44,7 +42,7 @@
(or (get-buffer gnus-backlog-buffer)
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-backlog-buffer))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(setq buffer-read-only t)
(get-buffer gnus-backlog-buffer))))
@ -84,7 +82,9 @@
(setq b (point))
(insert-buffer-substring buffer)
;; Tag the beginning of the article with the ident.
(gnus-put-text-property b (1+ b) 'gnus-backlog ident))))))
(if (> (point-max) b)
(gnus-put-text-property b (1+ b) 'gnus-backlog ident)
(gnus-error 3 "Article %d is blank" number)))))))
(defun gnus-backlog-remove-oldest-article ()
(save-excursion
@ -126,7 +126,7 @@
t))
(setq gnus-backlog-articles (delq ident gnus-backlog-articles)))))))
(defun gnus-backlog-request-article (group number buffer)
(defun gnus-backlog-request-article (group number &optional buffer)
(when (numberp number)
(gnus-backlog-setup)
(let ((ident (intern (concat group ":" (int-to-string number))
@ -146,10 +146,12 @@
(setq end
(next-single-property-change
(1+ beg) 'gnus-backlog (current-buffer) (point-max)))))
(let ((buffer-read-only nil))
(erase-buffer)
(insert-buffer-substring gnus-backlog-buffer beg end)
t)))))
(save-excursion
(and buffer (set-buffer buffer))
(let ((buffer-read-only nil))
(erase-buffer)
(insert-buffer-substring gnus-backlog-buffer beg end)))
t))))
(provide 'gnus-bcklg)

94
lisp/gnus/gnus-cache.el
View File

@ -1,5 +1,6 @@
;;; gnus-cache.el --- cache interface for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-int)
(require 'gnus-range)
@ -62,7 +61,7 @@ If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
it's not cached."
:group 'gnus-cache
:type '(choice (const :tag "off" nil)
regexp))
regexp))
(defcustom gnus-uncacheable-groups nil
"*Groups that match this regexp will not be cached.
@ -79,6 +78,9 @@ it's not cached."
(defvar gnus-cache-overview-coding-system 'raw-text
"Coding system used on Gnus cache files.")
(defvar gnus-cache-coding-system 'raw-text
"Coding system used on Gnus cache files.")
;;; Internal variables.
@ -144,20 +146,17 @@ it's not cached."
(setq gnus-cache-buffer nil))))
(defun gnus-cache-possibly-enter-article
(group article headers ticked dormant unread &optional force)
(group article ticked dormant unread &optional force)
(when (and (or force (not (eq gnus-use-cache 'passive)))
(numberp article)
(> article 0)
(vectorp headers)) ; This might be a dummy article.
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
(gnus-group-real-name group) article)))
(setq group (car result)
headers (copy-sequence headers))
(mail-header-set-number headers (cdr result))))
(let ((number (mail-header-number headers))
file)
(> article 0)) ; This might be a dummy article.
(let ((number article) file headers)
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
(gnus-group-real-name group) article)))
(setq group (car result)
number (cdr result))))
(when (and number
(> number 0) ; Reffed article.
(or force
@ -177,10 +176,15 @@ it's not cached."
t ; The article already is saved.
(save-excursion
(set-buffer nntp-server-buffer)
(let ((gnus-use-cache nil))
(require 'gnus-art)
(let ((gnus-use-cache nil)
(gnus-article-decode-hook nil))
(gnus-request-article-this-buffer number group))
(when (> (buffer-size) 0)
(gnus-write-buffer file)
(let ((coding-system-for-write gnus-cache-coding-system))
(gnus-write-buffer file))
(setq headers (nnheader-parse-head t))
(mail-header-set-number headers number)
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-max))
@ -202,17 +206,7 @@ it's not cached."
(beginning-of-line))
(forward-line 1))
(beginning-of-line)
;; [number subject from date id references chars lines xref]
(insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
(mail-header-number headers)
(mail-header-subject headers)
(mail-header-from headers)
(mail-header-date headers)
(mail-header-id headers)
(or (mail-header-references headers) "")
(or (mail-header-chars headers) "")
(or (mail-header-lines headers) "")
(or (mail-header-xref headers) "")))
(nnheader-insert-nov headers)
;; Update the active info.
(set-buffer gnus-summary-buffer)
(gnus-cache-update-active group number)
@ -266,7 +260,8 @@ it's not cached."
(when (file-exists-p file)
(erase-buffer)
(gnus-kill-all-overlays)
(insert-file-contents file)
(let ((coding-system-for-read gnus-cache-coding-system))
(insert-file-contents file))
t)))
(defun gnus-cache-possibly-alter-active (group active)
@ -312,7 +307,9 @@ it's not cached."
;; unsuccessful), so we use the cached headers exclusively.
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-file-contents cache-file)
(let ((coding-system-for-read
gnus-cache-overview-coding-system))
(insert-file-contents cache-file))
'nov)
((eq type 'nov)
;; We have both cached and uncached NOV headers, so we
@ -337,7 +334,6 @@ Returns the list of articles entered."
(if (natnump article)
(when (gnus-cache-possibly-enter-article
gnus-newsgroup-name article
(gnus-summary-article-header article)
nil nil nil t)
(push article out))
(gnus-message 2 "Can't cache article %d" article))
@ -371,7 +367,7 @@ Returns the list of articles removed."
(defun gnus-summary-insert-cached-articles ()
"Insert all the articles cached for this group into the current buffer."
(interactive)
(let ((cached (sort (copy-sequence gnus-newsgroup-cached) '<))
(let ((cached (sort (copy-sequence gnus-newsgroup-cached) '>))
(gnus-verbose (max 6 gnus-verbose)))
(unless cached
(gnus-message 3 "No cached articles for this group"))
@ -397,7 +393,6 @@ Returns the list of articles removed."
(cons group
(set-buffer (gnus-get-buffer-create
" *gnus-cache-overview*"))))
(buffer-disable-undo (current-buffer))
;; Insert the contents of this group's cache overview.
(erase-buffer)
(let ((file (gnus-cache-file-name group ".overview")))
@ -420,7 +415,9 @@ Returns the list of articles removed."
(nnheader-translate-file-chars
(if (gnus-use-long-file-name 'not-cache)
group
(let ((group (nnheader-replace-chars-in-string group ?/ ?_)))
(let ((group (nnheader-replace-duplicate-chars-in-string
(nnheader-replace-chars-in-string group ?/ ?_)
?. ?_)))
;; Translate the first colon into a slash.
(when (string-match ":" group)
(aset group (match-beginning 0) ?/))
@ -431,10 +428,10 @@ Returns the list of articles removed."
(defun gnus-cache-update-article (group article)
"If ARTICLE is in the cache, remove it and re-enter it."
(gnus-cache-change-buffer group)
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(let ((gnus-use-cache nil))
(gnus-cache-possibly-enter-article
gnus-newsgroup-name article (gnus-summary-article-header article)
gnus-newsgroup-name article
nil nil nil t))))
(defun gnus-cache-possibly-remove-article (article ticked dormant unread
@ -489,9 +486,11 @@ Returns the list of articles removed."
(gnus-cache-save-buffers)
(save-excursion
(set-buffer cache-buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-file-contents (or file (gnus-cache-file-name group ".overview")))
(let ((coding-system-for-read
gnus-cache-overview-coding-system))
(insert-file-contents
(or file (gnus-cache-file-name group ".overview"))))
(goto-char (point-min))
(insert "\n")
(goto-char (point-min)))
@ -519,7 +518,6 @@ Returns the list of articles removed."
(let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
(save-excursion
(set-buffer cache-buf)
(buffer-disable-undo (current-buffer))
(erase-buffer))
(set-buffer nntp-server-buffer)
(goto-char (point-min))
@ -534,7 +532,9 @@ Returns the list of articles removed."
(save-excursion
(set-buffer cache-buf)
(erase-buffer)
(insert-file-contents (gnus-cache-file-name group (car cached)))
(let ((coding-system-for-read
gnus-cache-coding-system))
(insert-file-contents (gnus-cache-file-name group (car cached))))
(goto-char (point-min))
(insert "220 ")
(princ (car cached) (current-buffer))
@ -557,6 +557,7 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
(let ((gnus-mark-article-hook nil)
(gnus-expert-user t)
(nnmail-spool-file nil)
(mail-sources nil)
(gnus-use-dribble-file nil)
(gnus-novice-user nil)
(gnus-large-newsgroup nil))
@ -585,7 +586,7 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
;; We simply read the active file.
(save-excursion
(gnus-set-work-buffer)
(insert-file-contents gnus-cache-active-file)
(nnheader-insert-file-contents gnus-cache-active-file)
(gnus-active-to-gnus-format
nil (setq gnus-cache-active-hashtb
(gnus-make-hashtable
@ -597,14 +598,7 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
(when (or force
(and gnus-cache-active-hashtb
gnus-cache-active-altered))
(nnheader-temp-write gnus-cache-active-file
(mapatoms
(lambda (sym)
(when (and sym (boundp sym))
(insert (format "%s %d %d y\n"
(symbol-name sym) (cdr (symbol-value sym))
(car (symbol-value sym))))))
gnus-cache-active-hashtb))
(gnus-write-active-file gnus-cache-active-file gnus-cache-active-hashtb t)
;; Mark the active hashtb as unaltered.
(setq gnus-cache-active-altered nil)))

148
lisp/gnus/gnus-cite.el
View File

@ -1,7 +1,13 @@
;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Per Abhiddenware; you can redistribute it and/or modify
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Per Abhiddenware
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
@ -22,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-art)
(require 'gnus-range)
@ -44,10 +48,10 @@ article has citations."
:type 'string)
(defcustom gnus-cite-always-check nil
"Check article always for citations. Set it t to check all articles."
"Check article always for citations. Set it t to check all articles."
:group 'gnus-cite
:type '(choice (const :tag "no" nil)
(const :tag "yes" t)))
(const :tag "yes" t)))
(defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n"
"Format of opened cited text buttons."
@ -60,10 +64,13 @@ article has citations."
:type 'string)
(defcustom gnus-cited-lines-visible nil
"The number of lines of hidden cited text to remain visible."
"The number of lines of hidden cited text to remain visible.
Or a pair (cons) of numbers which are the number of lines at the top
and bottom of the text, respectively, to remain visible."
:group 'gnus-cite
:type '(choice (const :tag "none" nil)
integer))
integer
(cons :tag "Top and Bottom" integer integer)))
(defcustom gnus-cite-parse-max-size 25000
"Maximum article size (in bytes) where parsing citations is allowed.
@ -73,7 +80,7 @@ Set it to nil to parse all articles."
integer))
(defcustom gnus-cite-prefix-regexp
"^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
"^[]>»|:}+ ]*[]>»|:}+]\\(.*>»\\)?\\|^.*>"
"*Regexp matching the longest possible citation prefix on a line."
:group 'gnus-cite
:type 'regexp)
@ -103,13 +110,13 @@ The first regexp group should match the Supercite attribution."
:type 'integer)
(defcustom gnus-cite-attribution-prefix
"In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),"
"In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|-----Original Message-----"
"*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\\|>\\)\\(:\\|\\.\\.\\.\\)\\|-----Original Message-----\\)[ \t]*$"
"*Regexp matching the end of an attribution line.
The text matching the first grouping will be used as a button."
:group 'gnus-cite
@ -237,8 +244,8 @@ It is merged with the face for the cited text belonging to the attribution."
(defcustom gnus-cite-face-list
'(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4
gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8
gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11)
gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8
gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11)
"*List of faces used for highlighting citations.
When there are citations from multiple articles in the same message,
@ -342,7 +349,8 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
skip (gnus-cite-find-prefix number)
face (cdr (assoc prefix face-alist)))
;; Add attribution button.
(goto-line number)
(goto-char (point-min))
(forward-line (1- number))
(when (re-search-forward gnus-cite-attribution-suffix
(save-excursion (end-of-line 1) (point))
t)
@ -364,7 +372,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
"Dissect the article buffer looking for cited text."
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe)
(gnus-cite-parse-maybe nil t)
(let ((alist gnus-cite-prefix-alist)
prefix numbers number marks m)
;; Loop through citation prefixes.
@ -383,8 +391,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
(forward-line (1- number))
(push (cons (point-marker) prefix) marks)))
;; Skip to the beginning of the body.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(article-goto-body)
(push (cons (point-marker) "") marks)
;; Find the end of the body.
(goto-char (point-max))
@ -434,7 +441,6 @@ If WIDTH (the numerical prefix), use that text width when filling."
(fill-column (if width (prefix-numeric-value width) fill-column)))
(save-restriction
(while (cdr marks)
(widen)
(narrow-to-region (caar marks) (caadr marks))
(let ((adaptive-fill-regexp
(concat "^" (regexp-quote (cdar marks)) " *"))
@ -488,10 +494,18 @@ always hide."
;; Skip past lines we want to leave visible.
(when (and beg end gnus-cited-lines-visible)
(goto-char beg)
(forward-line gnus-cited-lines-visible)
(forward-line (if (consp gnus-cited-lines-visible)
(car gnus-cited-lines-visible)
gnus-cited-lines-visible))
(if (>= (point) end)
(setq beg nil)
(setq beg (point-marker))))
(setq beg (point-marker))
(when (consp gnus-cited-lines-visible)
(goto-char end)
(forward-line (- (cdr gnus-cited-lines-visible)))
(if (<= (point) beg)
(setq beg nil)
(setq end (point-marker))))))
(when (and beg end)
;; We use markers for the end-points to facilitate later
;; wrapping and mangling of text.
@ -517,17 +531,19 @@ always hide."
(defun gnus-article-toggle-cited-text (args)
"Toggle hiding the text in REGION."
(let* ((region (car args))
(beg (car region))
(end (cdr region))
(start (cadr args))
(hidden
(text-property-any
(car region) (1- (cdr region))
beg (1- end)
(car gnus-hidden-properties) (cadr gnus-hidden-properties)))
(inhibit-point-motion-hooks t)
buffer-read-only)
(funcall
(if hidden
'remove-text-properties 'gnus-add-text-properties)
(car region) (cdr region) gnus-hidden-properties)
beg end gnus-hidden-properties)
(save-excursion
(goto-char start)
(gnus-delete-line)
@ -560,8 +576,7 @@ See also the documentation for `gnus-article-highlight-citation'."
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(article-goto-body)
(let ((start (point))
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
@ -585,7 +600,8 @@ See also the documentation for `gnus-article-highlight-citation'."
(while total
(setq hidden (car total)
total (cdr total))
(goto-line hidden)
(goto-char (point-min))
(forward-line (1- hidden))
(unless (assq hidden gnus-cite-attribution-alist)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
@ -605,45 +621,42 @@ See also the documentation for `gnus-article-highlight-citation'."
;;; Internal functions:
(defun gnus-cite-parse-maybe (&optional force)
;; Parse if the buffer has changes since last time.
(if (and (not force)
(equal gnus-cite-article gnus-article-current))
(defun gnus-cite-parse-maybe (&optional force no-overlay)
"Always parse the buffer."
(gnus-cite-localize)
;;Reset parser information.
(setq gnus-cite-prefix-alist nil
gnus-cite-attribution-alist nil
gnus-cite-loose-prefix-alist nil
gnus-cite-loose-attribution-alist nil)
(unless no-overlay
(gnus-cite-delete-overlays))
;; Parse if not too large.
(if (and gnus-cite-parse-max-size
(> (buffer-size) gnus-cite-parse-max-size))
()
(gnus-cite-localize)
;;Reset parser information.
(setq gnus-cite-prefix-alist nil
gnus-cite-attribution-alist nil
gnus-cite-loose-prefix-alist nil
gnus-cite-loose-attribution-alist nil)
(while gnus-cite-overlay-list
(gnus-delete-overlay (pop gnus-cite-overlay-list)))
;; Parse if not too large.
(if (and (not force)
gnus-cite-parse-max-size
(> (buffer-size) gnus-cite-parse-max-size))
()
(setq gnus-cite-article (cons (car gnus-article-current)
(cdr gnus-article-current)))
(gnus-cite-parse-wrapper))))
(setq gnus-cite-article (cons (car gnus-article-current)
(cdr gnus-article-current)))
(gnus-cite-parse-wrapper)))
(defun gnus-cite-delete-overlays ()
(dolist (overlay gnus-cite-overlay-list)
(when (or (not (gnus-overlay-end overlay))
(and (>= (gnus-overlay-end overlay) (point-min))
(<= (gnus-overlay-end overlay) (point-max))))
(setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list))
(gnus-delete-overlay overlay))))
(defun gnus-cite-parse-wrapper ()
;; Wrap chopped gnus-cite-parse
(goto-char (point-min))
(unless (search-forward "\n\n" nil t)
(goto-char (point-max)))
(save-excursion
(gnus-cite-parse-attributions))
;; Try to avoid check citation if there is no reason to believe
;; that article has citations
(if (or gnus-cite-always-check
(save-excursion
(re-search-backward gnus-cite-reply-regexp nil t))
gnus-cite-loose-attribution-alist)
(progn (save-excursion
(gnus-cite-parse))
(save-excursion
(gnus-cite-connect-attributions)))))
;; Wrap chopped gnus-cite-parse.
(article-goto-body)
(let ((inhibit-point-motion-hooks t))
(save-excursion
(gnus-cite-parse-attributions))
(save-excursion
(gnus-cite-parse))
(save-excursion
(gnus-cite-connect-attributions))))
(defun gnus-cite-parse ()
;; Parse and connect citation prefixes and attribution lines.
@ -898,8 +911,8 @@ See also the documentation for `gnus-article-highlight-citation'."
(when face
(let ((inhibit-point-motion-hooks t)
from to overlay)
(goto-line number)
(unless (eobp) ; Sometimes things become confused.
(goto-char (point-min))
(when (zerop (forward-line (1- number)))
(forward-char (length prefix))
(skip-chars-forward " \t")
(setq from (point))
@ -914,7 +927,7 @@ See also the documentation for `gnus-article-highlight-citation'."
(defun gnus-cite-toggle (prefix)
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe)
(gnus-cite-parse-maybe nil t)
(let ((buffer-read-only nil)
(numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
(inhibit-point-motion-hooks t)
@ -922,7 +935,8 @@ See also the documentation for `gnus-article-highlight-citation'."
(while numbers
(setq number (car numbers)
numbers (cdr numbers))
(goto-line number)
(goto-char (point-min))
(forward-line (1- number))
(cond ((get-text-property (point) 'invisible)
(remove-text-properties (point) (progn (forward-line 1) (point))
gnus-hidden-properties))
@ -958,4 +972,8 @@ See also the documentation for `gnus-article-highlight-citation'."
(provide 'gnus-cite)
;; Local Variables:
;; coding: iso-8859-1
;; End:
;;; gnus-cite.el ends here

257
lisp/gnus/gnus-cus.el
View File

@ -1,6 +1,6 @@
;;; gnus-cus.el --- customization commands for Gnus
;;
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Copyright (C) 1996,1999, 2000 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: news
@ -28,6 +28,7 @@
(require 'wid-edit)
(require 'gnus-score)
(require 'gnus-topic)
;;; Widgets:
@ -51,6 +52,21 @@ if that value is non-nil."
(setq major-mode 'gnus-custom-mode
mode-name "Gnus Customize")
(use-local-map widget-keymap)
;; Emacs 21 stuff:
(when (and (facep 'custom-button-face)
(facep 'custom-button-pressed-face))
(set (make-local-variable 'widget-button-face)
'custom-button-face)
(set (make-local-variable 'widget-button-pressed-face)
'custom-button-pressed-face)
(set (make-local-variable 'widget-mouse-face)
'custom-button-pressed-face))
(when (and (boundp 'custom-raised-buttons)
(symbol-value 'custom-raised-buttons))
(set (make-local-variable 'widget-push-button-prefix) "")
(set (make-local-variable 'widget-push-button-suffix) "")
(set (make-local-variable 'widget-link-prefix) "")
(set (make-local-variable 'widget-link-suffix) ""))
(gnus-run-hooks 'gnus-custom-mode-hook))
;;; Group Customization:
@ -70,14 +86,63 @@ not. Let's say there's a group on the server that is called
`fa.4ad-l'. This is a real newsgroup, but the server has gotten the
articles from a mail-to-news gateway. Posting directly to this group
is therefore impossible--you have to send mail to the mailing list
address instead.")
address instead.
The gnus-group-split mail splitting mechanism will behave as if this
address was listed in gnus-group-split Addresses (see below).")
(to-list (gnus-email-address :tag "To List") "\
This address will be used when doing a `a' in the group.
It is totally ignored when doing a followup--except that if it is
present in a news group, you'll get mail group semantics when doing
`f'.")
`f'.
The gnus-group-split mail splitting mechanism will behave as if this
address was listed in gnus-group-split Addresses (see below).")
(extra-aliases (choice
:tag "Extra Aliases"
(list
:tag "List"
(editable-list
:inline t
(gnus-email-address :tag "Address")))
(gnus-email-address :tag "Address")) "\
Store messages posted from or to this address in this group.
You must be using gnus-group-split for this to work. The VALUE of the
nnmail-split-fancy SPLIT generated for this group will match these
addresses.")
(split-regexp (regexp :tag "gnus-group-split Regular Expression") "\
Like gnus-group-split Address, but expects a regular expression.")
(split-exclude (list :tag "gnus-group-split Restricts"
(editable-list
:inline t (regexp :tag "Restrict"))) "\
Regular expression that cancels gnus-group-split matches.
Each entry is added to the nnmail-split-fancy SPLIT as a separate
RESTRICT clause.")
(split-spec (choice :tag "gnus-group-split Overrider"
(sexp :tag "Fancy Split")
(const :tag "Catch All" catch-all)
(const :tag "Ignore" nil)) "\
Override all other gnus-group-split fields.
In `Fancy Split', you can enter any nnmail-split-fancy SPLIT. Note
that the name of this group won't be automatically assumed, you have
to add it to the SPLITs yourself. This means you can use such splits
to split messages to other groups too.
If you select `Catch All', this group will get postings for any
messages not matched in any other group. It overrides the variable
gnus-group-split-default-catch-all-group.
Selecting `Ignore' forces no SPLIT to be generated for this group,
disabling all other gnus-group-split fields.")
(broken-reply-to (const :tag "Broken Reply To" t) "\
Ignore `Reply-To' headers in this group.
@ -87,7 +152,7 @@ listserv has inserted `Reply-To' headers that point back to the
listserv itself. This is broken behavior. So there!")
(to-group (string :tag "To Group") "\
All posts will be send to the specified group.")
All posts will be sent to the specified group.")
(gcc-self (choice :tag "GCC"
:value t
@ -97,12 +162,18 @@ All posts will be send to the specified group.")
Specify default value for GCC header.
If this symbol is present in the group parameter list and set to `t',
new composed messages will be `Gcc''d to the current group. If it is
new composed messages will be `Gcc''d to the current group. If it is
present and set to `none', no `Gcc:' header will be generated, if it
is present and a string, this string will be inserted literally as a
`gcc' header (this symbol takes precedence over any default `Gcc'
rules as described later).")
(banner (choice :tag "Banner"
(const signature)
regexp
(const :tag "None" nil)) "\
Regular expression matching banners to be removed from articles.")
(auto-expire (const :tag "Automatic Expire" t) "\
All articles that are read will be marked as expirable.")
@ -121,10 +192,19 @@ Use with caution.")
When to expire.
Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function'
when expiring expirable messages. The value can either be a number of
when expiring expirable messages. The value can either be a number of
days (not necessarily an integer) or the symbols `never' or
`immediate'.")
(expiry-target (choice :tag "Expiry Target"
:value delete
(const delete)
(function :format "%v" nnmail-)
string) "\
Where expired messages end up.
Overrides `nnmail-expiry-target', which see.")
(score-file (file :tag "Score File") "\
Make the specified file into the current score file.
This means that all score commands you issue will end up in this file.")
@ -159,30 +239,78 @@ An arbitrary comment on the group.")
(visible (const :tag "Permanently visible" t) "\
Always display this group, even when there are no unread articles
in it.."))
"Alist of valid group parameters.
in it..")
(charset (symbol :tag "Charset") "\
The default charset to use in the group.")
(ignored-charsets
(choice :tag "Ignored charsets"
:value nil
(repeat (symbol))) "\
List of charsets that should be ignored.
When these charsets are used in the \"charset\" parameter, the
default charset will be used instead.")
(highlight-words
(choice :tag "Highlight words"
:value nil
(repeat (list (regexp :tag "Highlight regexp")
(number :tag "Group for entire word" 0)
(number :tag "Group for displayed part" 0)
(symbol :tag "Face"
gnus-emphasis-highlight-words))))
"highlight regexps.
See gnus-emphasis-alist."))
"Alist of valid group or topic parameters.
Each entry has the form (NAME TYPE DOC), where NAME is the parameter
itself (a symbol), TYPE is the parameters type (a sexp widget), and
DOC is a documentation string for the parameter.")
(defconst gnus-extra-topic-parameters
'((subscribe (regexp :tag "Subscribe") "\
If `gnus-subscribe-newsgroup-method' is set to
`gnus-subscribe-topics', new groups that matches this regexp will
automatically be subscribed to this topic"))
"Alist of topic parameters that are not also group parameters.
Each entry has the form (NAME TYPE DOC), where NAME is the parameter
itself (a symbol), TYPE is the parameters type (a sexp widget), and
DOC is a documentation string for the parameter.")
(defconst gnus-extra-group-parameters
'((uidvalidity (string :tag "IMAP uidvalidity") "\
Server-assigned value attached to IMAP groups, used to maintain consistency."))
"Alist of group parameters that are not also topic parameters.
Each entry has the form (NAME TYPE DOC), where NAME is the parameter
itself (a symbol), TYPE is the parameters type (a sexp widget), and
DOC is a documentation string for the parameter.")
(defvar gnus-custom-params)
(defvar gnus-custom-method)
(defvar gnus-custom-group)
(defvar gnus-custom-topic)
(defun gnus-group-customize (group)
"Edit the group on the current line."
(interactive (list (gnus-group-group-name)))
(defun gnus-group-customize (group &optional topic)
"Edit the group or topic on the current line."
(interactive (list (gnus-group-group-name) (gnus-group-topic-name)))
(let (info
(types (mapcar (lambda (entry)
`(cons :format "%v%h\n"
:doc ,(nth 2 entry)
(const :format "" ,(nth 0 entry))
,(nth 1 entry)))
gnus-group-parameters)))
(unless group
(append gnus-group-parameters
(if group
gnus-extra-group-parameters
gnus-extra-topic-parameters)))))
(unless (or group topic)
(error "No group on current line"))
(unless (setq info (gnus-get-info group))
(when (and group topic)
(error "Both a group an topic on current line"))
(unless (or topic (setq info (gnus-get-info group)))
(error "Killed group; can't be edited"))
;; Ready.
(kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
@ -190,13 +318,21 @@ DOC is a documentation string for the parameter.")
(gnus-custom-mode)
(make-local-variable 'gnus-custom-group)
(setq gnus-custom-group group)
(make-local-variable 'gnus-custom-topic)
(setq gnus-custom-topic topic)
(buffer-disable-undo)
(widget-insert "Customize the ")
(widget-create 'info-link
:help-echo "Push me to learn more."
:tag "group parameters"
"(gnus)Group Parameters")
(if group
(widget-create 'info-link
:help-echo "Push me to learn more."
:tag "group parameters"
"(gnus)Group Parameters")
(widget-create 'info-link
:help-echo "Push me to learn more."
:tag "topic parameters"
"(gnus)Topic Parameters"))
(widget-insert " for <")
(widget-insert group)
(widget-insert (gnus-group-decoded-name (or group topic)))
(widget-insert "> and press ")
(widget-create 'push-button
:tag "done"
@ -206,15 +342,17 @@ DOC is a documentation string for the parameter.")
(make-local-variable 'gnus-custom-params)
(setq gnus-custom-params
(widget-create 'group
:value (gnus-info-params info)
:value (if group
(gnus-info-params info)
(gnus-topic-parameters topic))
`(set :inline t
:greedy t
:tag "Parameters"
:format "%t:\n%h%v"
:doc "\
These special paramerters are recognized by Gnus.
Check the [ ] for the parameters you want to apply to this group, then
edit the value to suit your taste."
These special parameters are recognized by Gnus.
Check the [ ] for the parameters you want to apply to this group or
to the groups in this topic, then edit the value to suit your taste."
,@types)
'(repeat :inline t
:tag "Variables"
@ -232,34 +370,40 @@ like. If you want to hear a beep when you enter a group, you could
put something like `(dummy-variable (ding))' in the parameters of that
group. `dummy-variable' will be set to the result of the `(ding)'
form, but who cares?"
(group :value (nil nil)
(symbol :tag "Variable")
(sexp :tag
"Value")))
(list :format "%v" :value (nil nil)
(symbol :tag "Variable")
(sexp :tag
"Value")))
'(repeat :inline t
:tag "Unknown entries"
sexp)))
(widget-insert "\n\nYou can also edit the ")
(widget-create 'info-link
:tag "select method"
:help-echo "Push me to learn more about select methods."
"(gnus)Select Methods")
(widget-insert " for the group.\n")
(setq gnus-custom-method
(widget-create 'sexp
:tag "Method"
:value (gnus-info-method info)))
(when group
(widget-insert "\n\nYou can also edit the ")
(widget-create 'info-link
:tag "select method"
:help-echo "Push me to learn more about select methods."
"(gnus)Select Methods")
(widget-insert " for the group.\n")
(setq gnus-custom-method
(widget-create 'sexp
:tag "Method"
:value (gnus-info-method info))))
(use-local-map widget-keymap)
(widget-setup)))
(widget-setup)
(buffer-enable-undo)
(goto-char (point-min))))
(defun gnus-group-customize-done (&rest ignore)
"Apply changes and bury the buffer."
(interactive)
(gnus-group-edit-group-done 'params gnus-custom-group
(widget-value gnus-custom-params))
(gnus-group-edit-group-done 'method gnus-custom-group
(widget-value gnus-custom-method))
(if gnus-custom-topic
(gnus-topic-set-parameters gnus-custom-topic
(widget-value gnus-custom-params))
(gnus-group-edit-group-done 'params gnus-custom-group
(widget-value gnus-custom-params))
(gnus-group-edit-group-done 'method gnus-custom-group
(widget-value gnus-custom-method)))
(bury-buffer))
;;; Score Customization:
@ -375,9 +519,9 @@ documentation string for the parameter.")
(item `(const :format "" :value ,(downcase tag)))
(match '(string :tag "Match"))
(score '(choice :tag "Score"
(const :tag "default" nil)
(integer :format "%v"
:hide-front-space t)))
(const :tag "default" nil)
(integer :format "%v"
:hide-front-space t)))
(expire '(choice :tag "Expire"
(const :tag "off" nil)
(integer :format "%v"
@ -448,9 +592,9 @@ each score entry has four elements:
(item `(const :format "" :value ,(downcase tag)))
(match '(integer :tag "Match"))
(score '(choice :tag "Score"
(const :tag "default" nil)
(integer :format "%v"
:hide-front-space t)))
(const :tag "default" nil)
(integer :format "%v"
:hide-front-space t)))
(expire '(choice :tag "Expire"
(const :tag "off" nil)
(integer :format "%v"
@ -485,9 +629,9 @@ each score entry has four elements:
(item `(const :format "" :value ,(downcase tag)))
(match '(string :tag "Match"))
(score '(choice :tag "Score"
(const :tag "default" nil)
(integer :format "%v"
:hide-front-space t)))
(const :tag "default" nil)
(integer :format "%v"
:hide-front-space t)))
(expire '(choice :tag "Expire"
(const :tag "off" nil)
(integer :format "%v"
@ -537,11 +681,11 @@ eh?")))
(interactive (list gnus-current-score-file))
(let ((scores (gnus-score-load file))
(types (mapcar (lambda (entry)
`(group :format "%v%h\n"
:doc ,(nth 2 entry)
(const :format "" ,(nth 0 entry))
,(nth 1 entry)))
gnus-score-parameters)))
`(group :format "%v%h\n"
:doc ,(nth 2 entry)
(const :format "" ,(nth 0 entry))
,(nth 1 entry)))
gnus-score-parameters)))
;; Ready.
(kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
@ -580,6 +724,7 @@ if you do all your changes will be lost. ")
(gnus-score-string :tag "Subject")
(gnus-score-string :tag "References")
(gnus-score-string :tag "Xref")
(gnus-score-string :tag "Extra")
(gnus-score-string :tag "Message-ID")
(gnus-score-integer :tag "Lines")
(gnus-score-integer :tag "Chars")

35
lisp/gnus/gnus-demon.el
View File

@ -1,5 +1,5 @@
;;; gnus-demon.el --- daemonic Gnus behaviour
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +27,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-int)
(require 'nnheader)
@ -84,10 +82,6 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(defvar gnus-inhibit-demon nil
"*If non-nil, no daemonic function will be run.")
(eval-and-compile
(autoload 'timezone-parse-date "timezone")
(autoload 'timezone-make-arpa-date "timezone"))
;;; Functions.
(defun gnus-demon-add-handler (function time idle)
@ -121,8 +115,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(nth 2 handler)))
gnus-demon-handlers))
(setq gnus-demon-idle-time 0)
(setq gnus-demon-idle-has-been-called nil)
(setq gnus-use-demon t)))
(setq gnus-demon-idle-has-been-called nil)))
(gnus-add-shutdown 'gnus-demon-cancel 'gnus)
@ -132,7 +125,6 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(when gnus-demon-timer
(nnheader-cancel-timer gnus-demon-timer))
(setq gnus-demon-timer nil
gnus-use-demon nil
gnus-demon-idle-has-been-called nil)
(condition-case ()
(nnheader-cancel-function-timers 'gnus-demon)
@ -157,17 +149,17 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
time
(let* ((now (current-time))
;; obtain NOW as discrete components -- make a vector for speed
(nowParts (apply 'vector (decode-time now)))
(nowParts (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)))
(thenParts (parse-time-string time))
(thenHour (elt thenParts 0))
(thenMin (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
;; same time tomorrow. Doc for encode-time
;; says that this is OK.
(+ (elt nowParts 3)
(if (or (< thenHour (elt nowParts 2))
@ -199,6 +191,10 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
;; sufficiently ripe.
(let ((handlers gnus-demon-handler-state)
(gnus-inhibit-demon t)
;; Try to avoid dialog boxes, e.g. by Mailcrypt.
;; Unfortunately, Emacs 20's `message-or-box...' doesn't
;; obey `use-dialog-box'.
use-dialog-box (last-nonmenu-event 10)
handler time idle)
(while handlers
(setq handler (pop handlers))
@ -266,12 +262,11 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
"Add daemonic nntp server disconnection to Gnus.
If no commands have gone out via nntp during the last five
minutes, the connection is closed."
(gnus-demon-add-handler 'gnus-demon-close-connections 5 nil))
(gnus-demon-add-handler 'gnus-demon-nntp-close-connections 5 nil))
(defun gnus-demon-nntp-close-connection ()
(save-window-excursion
(when (nnmail-time-less '(0 300)
(nnmail-time-since nntp-last-command-time))
(when (time-less-p '(0 300) (time-since nntp-last-command-time))
(nntp-close-server))))
(defun gnus-demon-add-scanmail ()
@ -281,8 +276,8 @@ minutes, the connection is closed."
(defun gnus-demon-scan-mail ()
(save-window-excursion
(let ((servers gnus-opened-servers)
server)
(gnus-clear-inboxes-moved)
server
(nnmail-fetched-sources (list t)))
(while (setq server (car (pop servers)))
(and (gnus-check-backend-function 'request-scan (car server))
(or (gnus-server-opened server)

60
lisp/gnus/gnus-draft.el
View File

@ -1,5 +1,6 @@
;;; gnus-draft.el --- draft message support for Gnus
;; Copyright (C) 1997,98 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -67,12 +68,13 @@
(interactive "P")
(when (eq major-mode 'gnus-summary-mode)
(when (set (make-local-variable 'gnus-draft-mode)
(if (null arg) (not gnus-draft-mode)
(> (prefix-numeric-value arg) 0)))
(if (null arg) (not gnus-draft-mode)
(> (prefix-numeric-value arg) 0)))
;; Set up the menu.
(when (gnus-visual-p 'draft-menu 'menu)
(gnus-draft-make-menu-bar))
(gnus-add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map)
(mml-mode)
(gnus-run-hooks 'gnus-draft-mode-hook))))
;;; Commands
@ -94,9 +96,11 @@
(interactive)
(let ((article (gnus-summary-article-number)))
(gnus-summary-mark-as-read article gnus-canceled-mark)
(gnus-draft-setup article gnus-newsgroup-name)
(gnus-draft-setup article gnus-newsgroup-name t)
(set-buffer-modified-p t)
(save-buffer)
(let ((gnus-verbose-backends nil))
(gnus-request-expire-articles (list article) gnus-newsgroup-name t))
(push
`((lambda ()
(when (gnus-buffer-exists-p ,gnus-summary-buffer)
@ -113,14 +117,22 @@
(while (setq article (pop articles))
(gnus-summary-remove-process-mark article)
(unless (memq article gnus-newsgroup-unsendable)
(gnus-draft-send article gnus-newsgroup-name)
(gnus-draft-send article gnus-newsgroup-name t)
(gnus-summary-mark-article article gnus-canceled-mark)))))
(defun gnus-draft-send (article &optional group)
(defun gnus-draft-send (article &optional group interactive)
"Send message ARTICLE."
(gnus-draft-setup article (or group "nndraft:queue"))
(let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)
message-send-hook type method)
(let ((message-syntax-checks (if interactive nil
'dont-check-for-anything-just-trust-me))
(message-inhibit-body-encoding (or (not group)
(equal group "nndraft:queue")
message-inhibit-body-encoding))
(message-send-hook (and group (not (equal group "nndraft:queue"))
message-send-hook))
(message-setup-hook (and group (not (equal group "nndraft:queue"))
message-setup-hook))
type method)
(gnus-draft-setup article (or group "nndraft:queue"))
;; We read the meta-information that says how and where
;; this message is to be sent.
(save-restriction
@ -176,20 +188,22 @@
;;;!!!but for the time being, we'll just run this tiny function uncompiled.
(progn
(defun gnus-draft-setup (narticle group)
(gnus-setup-message 'forward
(let ((article narticle))
(message-mail)
(erase-buffer)
(if (not (gnus-request-restore-buffer article group))
(error "Couldn't restore the article")
;; Insert the separator.
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(insert mail-header-separator)
(forward-line 1)
(message-set-auto-save-file-name))))))
(defun gnus-draft-setup (narticle group &optional restore)
(gnus-setup-message 'forward
(let ((article narticle))
(message-mail)
(erase-buffer)
(if (not (gnus-request-restore-buffer article group))
(error "Couldn't restore the article")
(if (and restore (equal group "nndraft:queue"))
(mime-to-mml))
;; Insert the separator.
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(insert mail-header-separator)
(forward-line 1)
(message-set-auto-save-file-name))))))
(defun gnus-draft-article-sendable-p (article)
"Say whether ARTICLE is sendable."

15
lisp/gnus/gnus-dup.el
View File

@ -1,5 +1,6 @@
;;; gnus-dup.el --- suppression of duplicate articles in Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -32,8 +33,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-art)
@ -100,7 +99,7 @@ seen in the same session."
"Save the duplicate suppression list."
(when (and gnus-save-duplicate-list
gnus-dup-list-dirty)
(nnheader-temp-write gnus-duplicate-file
(with-temp-file gnus-duplicate-file
(gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list))))
(setq gnus-dup-list-dirty nil))
@ -138,6 +137,8 @@ seen in the same session."
(gnus-dup-open))
(gnus-message 6 "Suppressing duplicates...")
(let ((headers gnus-newsgroup-headers)
(auto (and gnus-newsgroup-auto-expire
(memq gnus-duplicate-mark gnus-auto-expirable-marks)))
number header)
(while (setq header (pop headers))
(when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
@ -145,8 +146,10 @@ seen in the same session."
(setq gnus-newsgroup-unreads
(delq (setq number (mail-header-number header))
gnus-newsgroup-unreads))
(push (cons number gnus-duplicate-mark)
gnus-newsgroup-reads))))
(if (not auto)
(push (cons number gnus-duplicate-mark) gnus-newsgroup-reads)
(push number gnus-newsgroup-expirable)
(push (cons number gnus-expirable-mark) gnus-newsgroup-reads)))))
(gnus-message 6 "Suppressing duplicates...done"))
(defun gnus-dup-unsuppress-article (article)

6
lisp/gnus/gnus-eform.el
View File

@ -1,5 +1,6 @@
;;; gnus-eform.el --- a mode for editing forms for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -53,7 +54,8 @@
(defvar gnus-edit-form-mode-map nil)
(unless gnus-edit-form-mode-map
(setq gnus-edit-form-mode-map (copy-keymap emacs-lisp-mode-map))
(setq gnus-edit-form-mode-map (make-sparse-keymap))
(set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map)
(gnus-define-keys gnus-edit-form-mode-map
"\C-c\C-c" gnus-edit-form-done
"\C-c\C-k" gnus-edit-form-exit))

228
lisp/gnus/gnus-ems.el
View File

@ -1,5 +1,6 @@
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -29,11 +30,14 @@
;;; Function aliases later to be redefined for XEmacs usage.
(defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
"Non-nil if running under XEmacs.")
(eval-and-compile
(defvar gnus-xemacs (featurep 'xemacs)
"Non-nil if running under XEmacs."))
(defvar gnus-mouse-2 [mouse-2])
(defvar gnus-down-mouse-3 [down-mouse-3])
(defvar gnus-down-mouse-2 [down-mouse-2])
(defvar gnus-widget-button-keymap nil)
(defvar gnus-mode-line-modified
(if (or gnus-xemacs
(< emacs-major-version 20))
@ -45,103 +49,42 @@
(autoload 'gnus-xmas-redefine "gnus-xmas")
(autoload 'appt-select-lowest-window "appt"))
(or (fboundp 'mail-file-babyl-p)
(fset 'mail-file-babyl-p 'rmail-file-p))
;;; Mule functions.
(defun gnus-mule-cite-add-face (number prefix face)
;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
(when face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(unless (eobp) ; Sometimes things become confused (broken).
(if (boundp 'MULE)
(forward-char (chars-in-string prefix))
(forward-char (length prefix)))
(skip-chars-forward " \t")
(setq from (point))
(end-of-line 1)
(skip-chars-backward " \t")
(setq to (point))
(when (< from to)
(push (setq overlay (gnus-make-overlay from to))
gnus-cite-overlay-list)
(gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
(defun gnus-mule-max-width-function (el max-width)
(` (let* ((val (eval (, el)))
(valstr (if (numberp val)
(int-to-string val) val)))
(if (> (length valstr) (, max-width))
(truncate-string valstr (, max-width))
valstr))))
(defun gnus-encode-coding-string (string system)
string)
(defun gnus-decode-coding-string (string system)
string)
(defun gnus-encode-coding-string (string system)
string)
`(let* ((val (eval (, el)))
(valstr (if (numberp val)
(int-to-string val) val)))
(if (> (length valstr) ,max-width)
(truncate-string-to-width valstr ,max-width)
valstr)))
(eval-and-compile
(if (string-match "XEmacs\\|Lucid" emacs-version)
nil
(if gnus-xemacs
(gnus-xmas-define)
(defvar gnus-mouse-face-prop 'mouse-face
"Property used for highlighting mouse regions."))
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
(gnus-xmas-define))
((or (not (boundp 'emacs-minor-version))
(and (< emacs-major-version 20)
(< emacs-minor-version 30)))
;; Remove the `intangible' prop.
(let ((props (and (boundp 'gnus-hidden-properties)
gnus-hidden-properties)))
(while (and props (not (eq (car (cdr props)) 'intangible)))
(setq props (cdr props)))
(when props
(setcdr props (cdr (cdr (cdr props))))))
(unless (fboundp 'buffer-substring-no-properties)
(defun buffer-substring-no-properties (beg end)
(format "%s" (buffer-substring beg end)))))
((boundp 'MULE)
(provide 'gnusutil))))
"Property used for highlighting mouse regions.")))
(eval-and-compile
(cond
((not window-system)
(defun gnus-dummy-func (&rest args))
(let ((funcs '(mouse-set-point set-face-foreground
set-face-background x-popup-menu)))
(while funcs
(unless (fboundp (car funcs))
(fset (car funcs) 'gnus-dummy-func))
(setq funcs (cdr funcs))))))
(unless (fboundp 'file-regular-p)
(defun file-regular-p (file)
(and (not (file-directory-p file))
(not (file-symlink-p file))
(file-exists-p file))))
(unless (fboundp 'face-list)
(defun face-list (&rest args))))
(defalias (car funcs) 'ignore))
(setq funcs (cdr funcs)))))))
(eval-and-compile
(let ((case-fold-search t))
(cond
((string-match "windows-nt\\|os/2\\|emx\\|cygwin"
((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
(symbol-name system-type))
(setq nnheader-file-name-translation-alist
(append nnheader-file-name-translation-alist
'((?: . ?_)
(?+ . ?-))))))))
(mapcar (lambda (c) (cons c ?_))
'(?: ?* ?\" ?< ?> ??))
'((?+ . ?-))))))))
(defvar gnus-tmp-unread)
(defvar gnus-tmp-replied)
@ -155,37 +98,31 @@
(defun gnus-ems-redefine ()
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
(gnus-xemacs
(gnus-xmas-redefine))
((featurep 'mule)
;; Mule and new Emacs definitions
;; [Note] Now there are three kinds of mule implementations,
;; original MULE, XEmacs/mule and beta version of Emacs including
;; some mule features. Unfortunately these API are different. In
;; original MULE, XEmacs/mule and Emacs 20+ including
;; MULE features. Unfortunately these API are different. In
;; particular, Emacs (including original MULE) and XEmacs are
;; quite different.
;; quite different. Howvere, this version of Gnus doesn't support
;; anything other than XEmacs 20+ and Emacs 20.3+.
;; Predicates to check are following:
;; (boundp 'MULE) is t only if MULE (original; anything older than
;; Mule 2.3) is running.
;; (featurep 'mule) is t when every mule variants are running.
;; These implementations may be able to share between original
;; MULE and beta version of new Emacs. In addition, it is able to
;; detect XEmacs/mule by (featurep 'mule) and to check variable
;; `emacs-version'. In this case, implementation for XEmacs/mule
;; may be able to share between XEmacs and XEmacs/mule.
(defalias 'gnus-truncate-string 'truncate-string)
;; It is possible to detect XEmacs/mule by (featurep 'mule) and
;; checking `emacs-version'. In this case, the implementation for
;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
(defvar gnus-summary-display-table nil
"Display table used in summary mode buffers.")
(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 (lambda ()))
(fset 'gnus-encode-coding-string 'encode-coding-string)
(fset 'gnus-decode-coding-string 'decode-coding-string)
(defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
(when (boundp 'gnus-check-before-posting)
(setq gnus-check-before-posting
@ -203,18 +140,12 @@
(format "%4d: %-20s"
gnus-tmp-lines
(if (> (length gnus-tmp-name) 20)
(truncate-string gnus-tmp-name 20)
(truncate-string-to-width gnus-tmp-name 20)
gnus-tmp-name))
gnus-tmp-closing-bracket)
(point))
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject-or-nil "\n"))
(when (and (boundp 'enable-multibyte-characters)
enable-multibyte-characters)
(require 'gnus-mule)
(gnus-mule-initialize))
)))
(insert " " gnus-tmp-subject-or-nil "\n")))))
(defun gnus-region-active-p ()
"Say whether the region is active."
@ -223,9 +154,9 @@
(boundp 'mark-active)
mark-active))
(defun gnus-add-minor-mode (mode name map)
(if (fboundp 'add-minor-mode)
(add-minor-mode mode name map)
(if (fboundp 'add-minor-mode)
(defalias 'gnus-add-minor-mode 'add-minor-mode)
(defun gnus-add-minor-mode (mode name map &rest rest)
(set (make-local-variable mode) t)
(unless (assq mode minor-mode-alist)
(push `(,mode ,name) minor-mode-alist))
@ -242,41 +173,90 @@
(let ((buffer-read-only nil))
(erase-buffer)
(when (and dir
(file-exists-p (setq file (concat dir "x-splash"))))
(nnheader-temp-write nil
(file-exists-p (setq file
(expand-file-name "x-splash" dir))))
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(ignore-errors
(setq pixmap (read (current-buffer))))))
(when pixmap
(erase-buffer)
(unless (facep 'gnus-splash)
(make-face 'gnus-splash))
(make-face 'gnus-splash)
(setq height (/ (car pixmap) (frame-char-height))
width (/ (cadr pixmap) (frame-char-width)))
(set-face-foreground 'gnus-splash "ForestGreen")
(set-face-foreground 'gnus-splash "Brown")
(set-face-stipple 'gnus-splash pixmap)
(insert-char ?\n (* (/ (window-height) 2 height) height))
(setq i height)
(while (> i 0)
(insert-char ? (* (+ (/ (window-width) 2 width) 1) width))
(insert-char ?\ (* (/ (window-width) 2 width) width))
(setq beg (point))
(insert-char ? width)
(insert-char ?\ width)
(set-text-properties beg (point) '(face gnus-splash))
(insert "\n")
(insert ?\n)
(decf i))
(goto-char (point-min))
(sit-for 0))))))
(if (fboundp 'split-string)
(fset 'gnus-split-string 'split-string)
(defun gnus-split-string (string pattern)
"Return a list of substrings of STRING which are separated by PATTERN."
(let (parts (start 0))
(while (string-match pattern string start)
(setq parts (cons (substring string start (match-beginning 0)) parts)
start (match-end 0)))
(nreverse (cons (substring string start) parts)))))
(defvar gnus-article-xface-ring-internal nil
"Cache for face data.")
;; Worth customizing?
(defvar gnus-article-xface-ring-size 6
"Length of the ring used for `gnus-article-xface-ring-internal'.")
(defun gnus-article-display-xface (beg end)
"Display an XFace header from between BEG and END in the current article.
Requires support for images in your Emacs and the external programs
`uncompface', `icontopbm' and `ppmtoxbm'. On a GNU/Linux system these
might be in packages with names like `compface' or `faces-xface' and
`netpbm' or `libgr-progs', for instance.
This function is for Emacs 21+. See `gnus-xmas-article-display-xface'
for XEmacs."
;; It might be worth converting uncompface's output in Lisp.
(unless gnus-article-xface-ring-internal ; Only load ring when needed.
(setq gnus-article-xface-ring-internal
(make-ring gnus-article-xface-ring-size)))
(save-excursion
(let* ((cur (current-buffer))
(data (buffer-substring beg end))
(image (cdr-safe (assoc data (ring-elements
gnus-article-xface-ring-internal)))))
(when (if (fboundp 'display-graphic-p)
(display-graphic-p))
(unless image
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(with-temp-buffer
(insert data)
(and (eq 0 (call-process-region (point-min) (point-max)
"uncompface"
'delete '(t nil)))
(goto-char (point-min))
(progn (insert "/* Width=48, Height=48 */\n") t)
(eq 0 (call-process-region (point-min) (point-max)
"icontopbm"
'delete '(t nil)))
(eq 0 (call-process-region (point-min) (point-max)
"pbmtoxbm"
'delete '(t nil)))
;; Miles Bader says that faces don't look right as
;; light on dark.
(if (eq 'dark (cdr-safe (assq 'background-mode
(frame-parameters))))
(setq image (create-image (buffer-string) 'xbm t
:ascent 'center
:foreground "black"
:background "white"))
(setq image (create-image (buffer-string) 'xbm t
:ascent 'center))))))
(ring-insert gnus-article-xface-ring-internal (cons data image))))
(when image
(goto-char (point-min))
(re-search-forward "^From:" nil 'move)
(insert-image image)))))
(provide 'gnus-ems)

36
lisp/gnus/gnus-gl.el
View File

@ -1,5 +1,7 @@
;;; gnus-gl.el --- an interface to GroupLens for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Brad Miller <bmiller@cs.umn.edu>
;; Keywords: news, score
@ -137,10 +139,10 @@
This pseudonym is obtained during the registration process")
(defvar grouplens-bbb-host "grouplens.cs.umn.edu"
"Host where the bbbd is running" )
"Host where the bbbd is running.")
(defvar grouplens-bbb-port 9000
"Port where the bbbd is listening" )
"Port where the bbbd is listening.")
(defvar grouplens-newsgroups
'("comp.groupware" "comp.human-factors" "comp.lang.c++"
@ -194,19 +196,19 @@ GroupLens scores can be combined with gnus scores in one of three ways.
;;;; Program global variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar grouplens-bbb-token nil
"Current session token number")
"Current session token number.")
(defvar grouplens-bbb-process nil
"Process Id of current bbbd network stream process")
"Process Id of current bbbd network stream process.")
(defvar grouplens-bbb-buffer nil
"Buffer associated with the BBBD process")
"Buffer associated with the BBBD process.")
(defvar grouplens-rating-alist nil
"Current set of message-id rating pairs")
"Current set of message-id rating pairs.")
(defvar grouplens-current-hashtable nil
"A hashtable to hold predictions from the BBB")
"A hashtable to hold predictions from the BBB.")
(defvar grouplens-current-group nil)
@ -312,7 +314,7 @@ If this times out we give up and assume that something has died..." )
(concat "login " grouplens-pseudonym))
(if (bbb-read-response bbb-process)
(setq grouplens-bbb-token (bbb-extract-token-number))
(gnus-message 3 "Error: GroupLens login failed")))))
(gnus-message 3 "Error: GroupLens login failed")))))
(gnus-message 3 "Error: you must set a pseudonym"))
grouplens-bbb-token)
@ -406,7 +408,7 @@ recommend using both scores and grouplens predictions together."
pred (bbb-get-pred))
(push `(,mid ,pred nil s) resp)
(gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh))
grouplens-current-hashtable)
grouplens-current-hashtable)
(forward-line 1)
t)
((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)")
@ -765,7 +767,7 @@ If prefix argument ALL is non-nil, all articles are marked as read."
(defun gnus-gl-get-trace ()
"Insert the contents of the BBBD trace buffer."
(when grouplens-bbb-buffer
(insert-buffer grouplens-bbb-buffer)))
(insert-buffer-substring grouplens-bbb-buffer)))
;;
;; GroupLens minor mode
@ -779,12 +781,12 @@ If prefix argument ALL is non-nil, all articles are marked as read."
(unless gnus-grouplens-mode-map
(setq gnus-grouplens-mode-map (make-keymap))
(gnus-define-keys
gnus-grouplens-mode-map
"n" grouplens-next-unread-article
"r" bbb-summary-rate-article
"k" grouplens-score-thread
"c" grouplens-summary-catchup-and-exit
"," grouplens-best-unread-article))
gnus-grouplens-mode-map
"n" grouplens-next-unread-article
"r" bbb-summary-rate-article
"k" grouplens-score-thread
"c" grouplens-summary-catchup-and-exit
"," grouplens-best-unread-article))
(defun gnus-grouplens-make-menu-bar ()
(unless (boundp 'gnus-grouplens-menu)

820
lisp/gnus/gnus-group.el
View File

File diff suppressed because it is too large Load Diff

66
lisp/gnus/gnus-int.el
View File

@ -1,5 +1,6 @@
;;; gnus-int.el --- backend interface functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(defcustom gnus-open-server-hook nil
@ -93,6 +92,7 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server."
;; gnus-open-server-hook might have opened it
(gnus-server-opened gnus-select-method)
(gnus-open-server gnus-select-method)
gnus-batch-mode
(gnus-y-or-n-p
(format
"%s (%s) open error: '%s'. Continue? "
@ -220,10 +220,12 @@ If it is down, start it up (again)."
(defun gnus-server-opened (gnus-command-method)
"Check whether a connection to GNUS-COMMAND-METHOD has been opened."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
(funcall (inline (gnus-get-function gnus-command-method 'server-opened))
(nth 1 gnus-command-method)))
(unless (eq (gnus-server-status gnus-command-method)
'denied)
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
(funcall (inline (gnus-get-function gnus-command-method 'server-opened))
(nth 1 gnus-command-method))))
(defun gnus-status-message (gnus-command-method)
"Return the status message from GNUS-COMMAND-METHOD.
@ -270,6 +272,14 @@ this group uses will be queried."
(funcall (gnus-get-function gnus-command-method func)
(gnus-group-real-name group) (nth 1 gnus-command-method)))))
(defun gnus-request-group-articles (group)
"Request a list of existing articles in GROUP."
(let ((gnus-command-method (gnus-find-method-for-group group))
(func 'request-group-articles))
(when (gnus-check-backend-function func group)
(funcall (gnus-get-function gnus-command-method func)
(gnus-group-real-name group) (nth 1 gnus-command-method)))))
(defun gnus-close-group (group)
"Request the GROUP be closed."
(let ((gnus-command-method (inline (gnus-find-method-for-group group))))
@ -309,6 +319,16 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
(funcall (gnus-get-function gnus-command-method 'request-type)
(gnus-group-real-name group) article))))
(defun gnus-request-set-mark (group action)
"Set marks on articles in the backend."
(let ((gnus-command-method (gnus-find-method-for-group group)))
(if (not (gnus-check-backend-function
'request-set-mark (car gnus-command-method)))
action
(funcall (gnus-get-function gnus-command-method 'request-set-mark)
(gnus-group-real-name group) action
(nth 1 gnus-command-method)))))
(defun gnus-request-update-mark (group article mark)
"Allow the backend to change the mark the user tries to put on an article."
(let ((gnus-command-method (gnus-find-method-for-group group)))
@ -394,13 +414,14 @@ If BUFFER, insert the article in that group."
(defun gnus-request-scan (group gnus-command-method)
"Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(when gnus-plugged
(let ((gnus-command-method
(if group (gnus-find-method-for-group group) gnus-command-method))
(gnus-inhibit-demon t))
(funcall (gnus-get-function gnus-command-method 'request-scan)
(and group (gnus-group-real-name group))
(nth 1 gnus-command-method)))))
(let ((gnus-command-method
(if group (gnus-find-method-for-group group) gnus-command-method))
(gnus-inhibit-demon t)
(mail-source-plugged gnus-plugged))
(if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method)))
(funcall (gnus-get-function gnus-command-method 'request-scan)
(and group (gnus-group-real-name group))
(nth 1 gnus-command-method)))))
(defsubst gnus-request-update-info (info gnus-command-method)
"Request that GNUS-COMMAND-METHOD update INFO."
@ -425,7 +446,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
article (gnus-group-real-name group)
(nth 1 gnus-command-method) accept-function last)))
(defun gnus-request-accept-article (group &optional gnus-command-method last)
(defun gnus-request-accept-article (group &optional gnus-command-method last
no-encode)
;; Make sure there's a newline at the end of the article.
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
@ -435,6 +457,12 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
(unless no-encode
(save-restriction
(message-narrow-to-head)
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body))
(let ((func (car (or gnus-command-method
(gnus-find-method-for-group group)))))
(funcall (intern (format "%s-request-accept-article" func))
@ -442,7 +470,13 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(cadr gnus-command-method)
last)))
(defun gnus-request-replace-article (article group buffer)
(defun gnus-request-replace-article (article group buffer &optional no-encode)
(unless no-encode
(save-restriction
(message-narrow-to-head)
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body))
(let ((func (car (gnus-group-name-to-method group))))
(funcall (intern (format "%s-request-replace-article" func))
article (gnus-group-real-name group) buffer)))

22
lisp/gnus/gnus-kill.el
View File

@ -1,5 +1,6 @@
;;; gnus-kill.el --- kill commands for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -28,8 +29,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-art)
(require 'gnus-range)
@ -51,7 +50,8 @@
:type 'boolean)
(defcustom gnus-winconf-kill-file nil
"What does this do, Lars?"
"What does this do, Lars?
I don't know, Per."
:group 'gnus-score-kill
:type 'sexp)
@ -431,7 +431,7 @@ Returns the number of articles marked as read."
(defun gnus-score-insert-help (string alist idx)
(save-excursion
(pop-to-buffer "*Score Help*")
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
(insert string ":\n\n")
(while alist
@ -446,7 +446,7 @@ Returns the number of articles marked as read."
(setq beg (point))
(setq form (ignore-errors (read (current-buffer)))))
(unless (listp form)
(error "Illegal kill entry (possibly rn kill file?): %s" form))
(error "Invalid kill entry (possibly rn kill file?): %s" form))
(if (or (eq (car form) 'gnus-kill)
(eq (car form) 'gnus-raise)
(eq (car form) 'gnus-lower))
@ -526,7 +526,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
;; It's on the form (regexp . date).
(if (zerop (gnus-execute field (car kill-list)
command nil (not all)))
(when (> (gnus-days-between date (cdr kill-list))
(when (> (days-between date (cdr kill-list))
gnus-kill-expiry-days)
(setq regexp nil))
(setcdr kill-list date))
@ -537,7 +537,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(setq kdate (cdr kill))
(if (zerop (gnus-execute
field (car kill) command nil (not all)))
(when (> (gnus-days-between date kdate)
(when (> (days-between date kdate)
gnus-kill-expiry-days)
;; Time limit has been exceeded, so we
;; remove the match.
@ -568,7 +568,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(concat "\n" (gnus-prin1-to-string object))
(save-excursion
(set-buffer (gnus-get-buffer-create "*Gnus PP*"))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
(insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
(let ((klist (cadr (nth 2 object)))
@ -685,6 +685,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
(mapconcat 'identity command-line-args-left " "))))
(gnus-expert-user t)
(nnmail-spool-file nil)
(mail-sources nil)
(gnus-use-dribble-file nil)
(gnus-batch-mode t)
info group newsrc entry
@ -704,7 +705,8 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
(and (car entry)
(or (eq (car entry) t)
(not (zerop (car entry))))))
(gnus-summary-read-group group nil t nil t)
(ignore-errors
(gnus-summary-read-group group nil t nil t))
(when (eq (current-buffer) (get-buffer gnus-summary-buffer))
(gnus-summary-exit))))
;; Exit Emacs.

11
lisp/gnus/gnus-logic.el
View File

@ -1,5 +1,6 @@
;;; gnus-logic.el --- advanced scoring code for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-score)
(require 'gnus-util)
@ -173,9 +172,9 @@
((eq type 'at)
(equal date match))
((eq type 'before)
(gnus-time-less match date))
(time-less-p match date))
((eq type 'after)
(gnus-time-less date match))
(time-less-p date match))
(t
(error "No such date score type: %s" type)))))
@ -220,7 +219,7 @@
((memq type '(s S string String))
'search-forward)
(t
(error "Illegal match type: %s" type)))))
(error "Invalid match type: %s" type)))))
(goto-char (point-min))
(prog1
(funcall search-func match nil t)

7
lisp/gnus/gnus-mh.el
View File

@ -1,5 +1,6 @@
;;; gnus-mh.el --- mh-e interface for Gnus
;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -66,8 +67,8 @@ Optional argument FOLDER specifies folder name."
t))))
(errbuf (gnus-get-buffer-create " *Gnus rcvstore*"))
;; Find the rcvstore program.
(exec-path (if mh-lib-progs (cons mh-lib-progs exec-path) exec-path)))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(exec-path (if mh-lib (cons mh-lib exec-path) exec-path)))
(with-current-buffer gnus-original-article-buffer
(save-restriction
(widen)
(unwind-protect

8
lisp/gnus/gnus-move.el
View File

@ -1,5 +1,6 @@
;;; gnus-move.el --- commands for moving Gnus from one server to another
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-start)
(require 'gnus-int)
@ -47,6 +46,7 @@ Update the .newsrc.eld file to reflect the change of nntp server."
;; First start Gnus.
(let ((gnus-activate-level 0)
(mail-sources nil)
(nnmail-spool-file nil))
(gnus))
@ -92,6 +92,8 @@ Update the .newsrc.eld file to reflect the change of nntp server."
;; Then we read the headers from the `from-server'.
(when (and (gnus-request-group group nil from-server)
(gnus-active group)
(gnus-uncompress-range
(gnus-active group))
(setq type (gnus-retrieve-headers
(gnus-uncompress-range
(gnus-active group))

514
lisp/gnus/gnus-msg.el
View File

@ -1,5 +1,6 @@
;;; gnus-msg.el --- mail and post interface for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -28,26 +29,24 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-ems)
(require 'message)
(require 'gnus-art)
(defcustom gnus-post-method nil
(defcustom gnus-post-method 'current
"*Preferred method for posting USENET news.
If this variable is `current', Gnus will use the \"current\" select
method when posting. If it is nil (which is the default), Gnus will
use the native posting method of the server.
use the native select method when posting.
This method will not be used in mail groups and the like, only in
\"real\" newsgroups.
If not nil nor `native', the value must be a valid method as discussed
in the documentation of `gnus-select-method'. It can also be a list of
methods. If that is the case, the user will be queried for what select
in the documentation of `gnus-select-method'. It can also be a list of
methods. If that is the case, the user will be queried for what select
method to use when posting."
:group 'gnus-group-foreign
:type `(choice (const nil)
@ -102,13 +101,37 @@ the second with the current group name.")
(defvar gnus-posting-styles nil
"*Alist of styles to use when posting.")
(defvar gnus-posting-style-alist
'((organization . message-user-organization)
(signature . message-signature)
(signature-file . message-signature-file)
(address . user-mail-address)
(name . user-full-name))
"*Mapping from style parameters to variables.")
(defcustom gnus-group-posting-charset-alist
'(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
(message-this-is-mail nil nil)
(message-this-is-news nil t))
"Alist of regexps and permitted unencoded charsets for posting.
Each element of the alist has the form (TEST HEADER BODY-LIST), where
TEST is either a regular expression matching the newsgroup header or a
variable to query,
HEADER is the charset which may be left unencoded in the header (nil
means encode all charsets),
BODY-LIST is a list of charsets which may be encoded using 8bit
content-transfer encoding in the body, or one of the special values
nil (always encode using quoted-printable) or t (always use 8bit).
Note that any value other than nil for HEADER infringes some RFCs, so
use this option with care."
:type '(repeat (list :tag "Permitted unencoded charsets"
(choice :tag "Where"
(regexp :tag "Group")
(const :tag "Mail message" :value message-this-is-mail)
(const :tag "News article" :value message-this-is-news))
(choice :tag "Header"
(const :tag "None" nil)
(symbol :tag "Charset"))
(choice :tag "Body"
(const :tag "Any" :value t)
(const :tag "None" :value nil)
(repeat :tag "Charsets"
(symbol :tag "Charset")))))
:group 'gnus-charset)
;;; Internal variables.
@ -127,9 +150,10 @@ the second with the current group name.")
The buffer below is a mail buffer. When you press `C-c C-c', it will
be sent to the Gnus Bug Exterminators.
At the bottom of the buffer you'll see lots of variable settings.
Please do not delete those. They will tell the Bug People what your
environment is, so that it will be easier to locate the bugs.
The thing near the bottom of the buffer is how the environment
settings will be included in the mail. Please do not delete that.
They will tell the Bug People what your environment is, so that it
will be easier to locate the bugs.
If you have found a bug that makes Emacs go \"beep\", set
debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
@ -159,6 +183,7 @@ Thank you for your help in stamping out bugs.
"c" gnus-summary-cancel-article
"s" gnus-summary-supersede-article
"r" gnus-summary-reply
"y" gnus-summary-yank-message
"R" gnus-summary-reply-with-original
"w" gnus-summary-wide-reply
"W" gnus-summary-wide-reply-with-original
@ -177,6 +202,20 @@ Thank you for your help in stamping out bugs.
;; "c" gnus-summary-send-draft
"r" gnus-summary-resend-message)
;;;###autoload
(defun gnus-msg-mail (&rest args)
"Start editing a mail message to be sent.
Like `message-mail', but with Gnus paraphernalia, particularly the
the Gcc: header for archiving purposes."
(interactive)
(gnus-setup-message 'message
(apply 'message-mail args)))
;;;###autoload
(define-mail-user-agent 'gnus-user-agent
'gnus-msg-mail 'message-send-and-exit
'message-kill-buffer 'message-send-hook)
;;; Internal functions.
(defvar gnus-article-reply nil)
@ -191,7 +230,9 @@ Thank you for your help in stamping out bugs.
(,group gnus-newsgroup-name)
(message-header-setup-hook
(copy-sequence message-header-setup-hook))
(mbl mml-buffer-list)
(message-mode-hook (copy-sequence message-mode-hook)))
(setq mml-buffer-list nil)
(add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
(add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
(add-hook 'message-mode-hook 'gnus-configure-posting-styles)
@ -202,12 +243,37 @@ Thank you for your help in stamping out bugs.
(setq gnus-message-buffer (current-buffer))
(set (make-local-variable 'gnus-message-group-art)
(cons ,group ,article))
(make-local-variable 'gnus-newsgroup-name)
(gnus-run-hooks 'gnus-message-setup-hook))
(set (make-local-variable 'gnus-newsgroup-name) ,group)
(gnus-run-hooks 'gnus-message-setup-hook)
(if (eq major-mode 'message-mode)
;; Make mml-buffer-list local.
;; Restore global mml-buffer-list value as mbl.
;; What a hack! -- Shenghuo
(let ((mml-buffer-list mml-buffer-list))
(setq mml-buffer-list mbl)
(make-local-variable 'mml-buffer-list)
(add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
(mml-destroy-buffers)
(setq mml-buffer-list mbl)))
(gnus-add-buffer)
(gnus-configure-windows ,config t)
(set-buffer-modified-p nil))))
(defun gnus-setup-posting-charset (group)
(let ((alist gnus-group-posting-charset-alist)
(group (or group ""))
elem)
(when group
(catch 'found
(while (setq elem (pop alist))
(when (or (and (stringp (car elem))
(string-match (car elem) group))
(and (gnus-functionp (car elem))
(funcall (car elem) group))
(and (symbolp (car elem))
(symbol-value (car elem))))
(throw 'found (cons (cadr elem) (caddr elem)))))))))
(defun gnus-inews-add-send-actions (winconf buffer article)
(make-local-hook 'message-sent-hook)
(add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
@ -230,11 +296,29 @@ Thank you for your help in stamping out bugs.
;;; Post news commands of Gnus group mode and summary mode
(defun gnus-group-mail ()
"Start composing a mail."
(interactive)
(gnus-setup-message 'message
(message-mail)))
(defun gnus-group-mail (&optional arg)
"Start composing a mail.
If ARG, use the group under the point to find a posting style.
If ARG is 1, prompt for a group name to find the posting style."
(interactive "P")
;; We can't `let' gnus-newsgroup-name here, since that leads
;; to local variables leaking.
(let ((group gnus-newsgroup-name)
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Use posting style of group: "
gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
(gnus-setup-message 'message (message-mail)))
(save-excursion
(set-buffer buffer)
(setq gnus-newsgroup-name group)))))
(defun gnus-group-post-news (&optional arg)
"Start composing a news message.
@ -355,7 +439,9 @@ header line with the old Message-ID."
;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
;; this buffer should be passed to all mail/news reply/post routines.
(setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
(buffer-disable-undo gnus-article-copy)
(save-excursion
(set-buffer gnus-article-copy)
(mm-enable-multibyte))
(let ((article-buffer (or article-buffer gnus-article-buffer))
end beg)
(if (not (and (get-buffer article-buffer)
@ -374,7 +460,7 @@ header line with the old Message-ID."
(gnus-remove-text-with-property 'gnus-next)
(insert
(prog1
(format "%s" (buffer-string))
(buffer-substring-no-properties (point-min) (point-max))
(erase-buffer)))
;; Find the original headers.
(set-buffer gnus-original-article-buffer)
@ -386,10 +472,10 @@ header line with the old Message-ID."
;; Delete the headers from the displayed articles.
(set-buffer gnus-article-copy)
(delete-region (goto-char (point-min))
(or (search-forward "\n\n" nil t) (point)))
(or (search-forward "\n\n" nil t) (point-max)))
;; Insert the original article headers.
(insert-buffer-substring gnus-original-article-buffer beg end)
(gnus-article-decode-rfc1522)))
(article-decode-encoded-words)))
gnus-article-copy)))
(defun gnus-post-news (post &optional group header article-buffer yank subject
@ -402,6 +488,7 @@ header line with the old Message-ID."
(article-buffer 'reply)
(t 'message))
(let* ((group (or group gnus-newsgroup-name))
(charset (gnus-group-name-charset nil group))
(pgroup group)
to-address to-group mailing-list to-list
newsgroup-p)
@ -412,7 +499,8 @@ header line with the old Message-ID."
newsgroup-p (gnus-group-find-parameter group 'newsgroup)
mailing-list (when gnus-mailing-list-groups
(string-match gnus-mailing-list-groups group))
group (gnus-group-real-name group)))
group (gnus-group-name-decode (gnus-group-real-name group)
charset)))
(if (or (and to-group
(gnus-news-group-p to-group))
newsgroup-p
@ -464,7 +552,7 @@ If SILENT, don't prompt the user."
;; the default method.
((null group-method)
(or (and (null (eq gnus-post-method 'active)) gnus-post-method)
gnus-select-method message-post-method))
gnus-select-method message-post-method))
;; We want the inverse of the default
((and arg (not (eq arg 0)))
(if (eq gnus-post-method 'active)
@ -485,14 +573,16 @@ If SILENT, don't prompt the user."
(list gnus-post-method)))
gnus-secondary-select-methods
(mapcar 'cdr gnus-server-alist)
(mapcar 'car gnus-opened-servers)
(list gnus-select-method)
(list group-method)))
method-alist post-methods method)
;; Weed out all mail methods.
(while methods
(setq method (gnus-server-get-method "" (pop methods)))
(when (or (gnus-method-option-p method 'post)
(gnus-method-option-p method 'post-mail))
(when (and (or (gnus-method-option-p method 'post)
(gnus-method-option-p method 'post-mail))
(not (member method post-methods)))
(push method post-methods)))
;; Create a name-method alist.
(setq method-alist
@ -515,8 +605,9 @@ If SILENT, don't prompt the user."
;; Override normal method.
((and (eq gnus-post-method 'current)
(not (eq (car group-method) 'nndraft))
(gnus-get-function group-method 'request-post t)
(not arg))
group-method)
group-method)
((and gnus-post-method
(not (eq gnus-post-method 'current)))
gnus-post-method)
@ -525,69 +616,32 @@ If SILENT, don't prompt the user."
;; Dummy to avoid byte-compile warning.
;; Dummies 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.
;;; The following function works with later GNU Emacs, and XEmacs.
(defun gnus-extended-version ()
"Stringified Gnus version and Emacs version."
(interactive)
(concat
gnus-version
"/"
"Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)
" (" gnus-version ")"
" "
(cond
((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version)
(concat "Emacs " (substring emacs-version
(match-beginning 1)
(match-end 1))))
((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
(concat "Emacs/" (match-string 1 emacs-version)))
((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
emacs-version)
(concat (substring emacs-version
(match-beginning 1)
(match-end 1))
(format " %d.%d" emacs-major-version emacs-minor-version)
(concat (match-string 1 emacs-version)
(format "/%d.%d" emacs-major-version emacs-minor-version)
(if (match-beginning 3)
(substring emacs-version
(match-beginning 3)
(match-end 3))
(match-string 3 emacs-version)
"")
(if (boundp 'xemacs-codename)
(concat " - \"" xemacs-codename "\""))))
(concat " (" xemacs-codename ")")
"")))
(t emacs-version))))
;; Written by "Mr. Per Persson" <pp@gnu.org>.
(defun gnus-inews-insert-mime-headers ()
"Insert MIME headers.
Assumes ISO-Latin-1 is used iff 8-bit characters are present."
(goto-char (point-min))
(let ((mail-header-separator
(progn
(goto-char (point-min))
(if (and (search-forward (concat "\n" mail-header-separator "\n")
nil t)
(not (search-backward "\n\n" nil t)))
mail-header-separator
""))))
(or (mail-position-on-field "Mime-Version")
(insert "1.0")
(cond ((save-restriction
(widen)
(goto-char (point-min))
(re-search-forward "[^\000-\177]" nil t))
(or (mail-position-on-field "Content-Type")
(insert "text/plain; charset=ISO-8859-1"))
(or (mail-position-on-field "Content-Transfer-Encoding")
(insert "8bit")))
(t (or (mail-position-on-field "Content-Type")
(insert "text/plain; charset=US-ASCII"))
(or (mail-position-on-field "Content-Transfer-Encoding")
(insert "7bit")))))))
(custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers)
;;;
;;; Gnus Mail Functions
@ -610,6 +664,10 @@ automatically."
(gnus-summary-select-article)
(set-buffer (gnus-copy-article-buffer))
(gnus-msg-treat-broken-reply-to)
(save-restriction
(message-narrow-to-head)
(goto-char (point-max)))
(mml-quote-region (point) (point-max))
(message-reply nil wide)
(when yank
(gnus-inews-yank-articles yank)))))
@ -635,16 +693,51 @@ The original article will be yanked."
(interactive "P")
(gnus-summary-reply-with-original n t))
(defun gnus-summary-mail-forward (&optional full-headers post)
"Forward the current message to another user.
If FULL-HEADERS (the prefix), include full headers when forwarding."
(defun gnus-summary-mail-forward (&optional arg post)
"Forward the current message to another user.
If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
if ARG is 1, decode the message and forward directly inline;
if ARG is 2, foward message as an rfc822 MIME section;
if ARG is 3, decode message and forward as an rfc822 MIME section;
if ARG is 4, foward message directly inline;
otherwise, use flipped `message-forward-as-mime'.
If POST, post instead of mail."
(interactive "P")
(gnus-setup-message 'forward
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
(let ((message-included-forward-headers
(if full-headers "" message-included-forward-headers)))
(message-forward post))))
(let ((message-forward-as-mime message-forward-as-mime)
(message-forward-show-mml message-forward-show-mml))
(cond
((null arg))
((eq arg 1) (setq message-forward-as-mime nil
message-forward-show-mml t))
((eq arg 2) (setq message-forward-as-mime t
message-forward-show-mml nil))
((eq arg 3) (setq message-forward-as-mime t
message-forward-show-mml t))
((eq arg 4) (setq message-forward-as-mime nil
message-forward-show-mml nil))
(t (setq message-forward-as-mime (not message-forward-as-mime))))
(gnus-setup-message 'forward
(gnus-summary-select-article)
(let ((mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
text)
(save-excursion
(set-buffer gnus-original-article-buffer)
(mm-with-unibyte-current-buffer
(setq text (buffer-string))))
(set-buffer
(gnus-get-buffer-create
(generate-new-buffer-name " *Gnus forward*")))
(erase-buffer)
(mm-disable-multibyte)
(insert text)
(goto-char (point-min))
(when (looking-at "From ")
(replace-match "X-From-Line: ") )
(when message-forward-show-mml
(mm-enable-multibyte)
(mime-to-mml))
(message-forward post)))))
(defun gnus-summary-resend-message (address n)
"Resend the current article to ADDRESS."
@ -657,11 +750,11 @@ If FULL-HEADERS (the prefix), include full headers when forwarding."
(set-buffer gnus-original-article-buffer)
(message-resend address)))))
(defun gnus-summary-post-forward (&optional full-headers)
(defun gnus-summary-post-forward (&optional arg)
"Forward the current article to a newsgroup.
If FULL-HEADERS (the prefix), include full headers when forwarding."
See `gnus-summary-mail-forward' for ARG."
(interactive "P")
(gnus-summary-mail-forward full-headers t))
(gnus-summary-mail-forward arg t))
(defvar gnus-nastygram-message
"The following article was inappropriately posted to %s.\n\n"
@ -694,7 +787,8 @@ The current group name will be inserted at \"%s\".")
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
(if (and (<= (length (message-tokenize-header
(setq newsgroups (mail-fetch-field "newsgroups"))
(setq newsgroups
(mail-fetch-field "newsgroups"))
", "))
1)
(or (not (setq followup-to (mail-fetch-field "followup-to")))
@ -833,7 +927,12 @@ If YANK is non-nil, include the original article."
(stringp nntp-server-type))
(insert nntp-server-type))
(insert "\n\n\n\n\n")
(gnus-debug)
(let (text)
(save-excursion
(set-buffer (gnus-get-buffer-create " *gnus environment info*"))
(gnus-debug)
(setq text (buffer-string)))
(insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
(goto-char (point-min))
(search-forward "Subject: " nil t)
(message "")))
@ -842,6 +941,19 @@ If YANK is non-nil, include the original article."
(when (get-buffer "*Gnus Help Bug*")
(kill-buffer "*Gnus Help Bug*")))
(defun gnus-summary-yank-message (buffer n)
"Yank the current article into a composed message."
(interactive
(list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
current-prefix-arg))
(gnus-summary-iterate n
(let ((gnus-display-mime-function nil)
(gnus-inhibit-treatment t))
(gnus-summary-select-article))
(save-excursion
(set-buffer buffer)
(message-yank-buffer gnus-article-buffer))))
(defun gnus-debug ()
"Attempts to go through the Gnus source file and report what variables have been changed.
The source file has to be in the Emacs load path."
@ -857,7 +969,6 @@ The source file has to be in the Emacs load path."
;; Go through all the files looking for non-default values for variables.
(save-excursion
(set-buffer (gnus-get-buffer-create " *gnus bug info*"))
(buffer-disable-undo (current-buffer))
(while files
(erase-buffer)
(when (and (setq file (locate-library (pop files)))
@ -940,7 +1051,8 @@ this is a reply."
(when gcc
(message-remove-header "gcc")
(widen)
(setq groups (message-tokenize-header gcc " ,"))
(setq groups (message-unquote-tokens
(message-tokenize-header gcc " ,")))
;; Copy the article over to some group(s).
(while (setq group (pop groups))
(gnus-check-server
@ -964,12 +1076,20 @@ this is a reply."
(save-excursion
(nnheader-set-temp-buffer " *acc*")
(insert-buffer-substring cur)
(message-encode-message-body)
(save-restriction
(message-narrow-to-headers)
(let ((mail-parse-charset message-default-charset)
(rfc2047-header-encoding-alist
(cons '("Newsgroups" . default)
rfc2047-header-encoding-alist)))
(mail-encode-encoded-word-buffer)))
(goto-char (point-min))
(when (re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$")
nil t)
(replace-match "" t t ))
(unless (gnus-request-accept-article group method t)
(unless (gnus-request-accept-article group method t t)
(gnus-message 1 "Couldn't store article in group %s: %s"
group (gnus-status-message method))
(sit-for 2))
@ -998,9 +1118,10 @@ this is a reply."
(group (or group gnus-newsgroup-name ""))
(gcc-self-val
(and gnus-newsgroup-name
(not (equal gnus-newsgroup-name ""))
(gnus-group-find-parameter
gnus-newsgroup-name 'gcc-self)))
result
result
(groups
(cond
((null gnus-message-archive-method)
@ -1068,86 +1189,131 @@ this is a reply."
;;; Posting styles.
(defvar gnus-message-style-insertions nil)
(defun gnus-configure-posting-styles ()
"Configure posting styles according to `gnus-posting-styles'."
(unless gnus-inhibit-posting-styles
(let ((styles gnus-posting-styles)
(gnus-newsgroup-name (or gnus-newsgroup-name ""))
style match variable attribute value value-value)
(make-local-variable 'gnus-message-style-insertions)
(let ((group (or gnus-newsgroup-name ""))
(styles gnus-posting-styles)
style match variable attribute value v results
filep name address element)
;; If the group has a posting-style parameter, add it at the end with a
;; regexp matching everything, to be sure it takes precedence over all
;; the others.
(when gnus-newsgroup-name
(let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
(when tmp-style
(setq styles (append styles (list (cons ".*" tmp-style)))))))
;; Go through all styles and look for matches.
(while styles
(setq style (pop styles)
match (pop style))
(when (cond ((stringp match)
;; Regexp string match on the group name.
(string-match match gnus-newsgroup-name))
((or (symbolp match)
(gnus-functionp match))
(cond ((gnus-functionp match)
;; Function to be called.
(funcall match))
((boundp match)
;; Variable to be checked.
(symbol-value match))))
((listp match)
;; This is a form to be evaled.
(eval match)))
(dolist (style styles)
(setq match (pop style))
(goto-char (point-min))
(when (cond
((stringp match)
;; Regexp string match on the group name.
(string-match match group))
((eq match 'header)
(let ((header (message-fetch-field (pop style))))
(and header
(string-match (pop style) header))))
((or (symbolp match)
(gnus-functionp match))
(cond
((gnus-functionp match)
;; Function to be called.
(funcall match))
((boundp match)
;; Variable to be checked.
(symbol-value match))))
((listp match)
;; This is a form to be evaled.
(eval match)))
;; We have a match, so we set the variables.
(while style
(setq attribute (pop style)
value (cadr attribute)
variable nil)
;; We find the variable that is to be modified.
(if (and (not (stringp (car attribute)))
(not (eq 'body (car attribute)))
(not (setq variable
(cdr (assq (car attribute)
gnus-posting-style-alist)))))
(message "Couldn't find attribute %s" (car attribute))
;; We get the value.
(setq value-value
(cond ((stringp value)
value)
((or (symbolp value)
(gnus-functionp value))
(cond ((gnus-functionp value)
(funcall value))
((boundp value)
(symbol-value value))))
((listp value)
(eval value))))
(if variable
;; This is an ordinary variable.
(set (make-local-variable variable) value-value)
;; This is either a body or a header to be inserted in the
;; message.
(when value-value
(let ((attr (car attribute)))
(make-local-variable 'message-setup-hook)
(if (eq 'body attr)
(add-hook 'message-setup-hook
`(lambda ()
(save-excursion
(message-goto-body)
(insert ,value-value))))
(add-hook 'message-setup-hook
'gnus-message-insert-stylings)
(push (cons (if (stringp attr) attr
(symbol-name attr))
value-value)
gnus-message-style-insertions))))))))))))
(defun gnus-message-insert-stylings ()
(let (val)
(save-excursion
(message-goto-eoh)
(while (setq val (pop gnus-message-style-insertions))
(when (cdr val)
(insert (car val) ": " (cdr val) "\n"))
(gnus-pull (car val) gnus-message-style-insertions)))))
(dolist (attribute style)
(setq element (pop attribute)
variable nil
filep nil)
(setq value
(cond
((eq (car attribute) :file)
(setq filep t)
(cadr attribute))
((eq (car attribute) :value)
(cadr attribute))
(t
(car attribute))))
;; We get the value.
(setq v
(cond
((stringp value)
value)
((or (symbolp value)
(gnus-functionp value))
(cond ((gnus-functionp value)
(funcall value))
((boundp value)
(symbol-value value))))
((listp value)
(eval value))))
;; Translate obsolescent value.
(when (eq element 'signature-file)
(setq element 'signature
filep t))
;; Get the contents of file elems.
(when (and filep v)
(setq v (with-temp-buffer
(insert-file-contents v)
(buffer-string))))
(setq results (delq (assoc element results) results))
(push (cons element v) results))))
;; Now we have all the styles, so we insert them.
(setq name (assq 'name results)
address (assq 'address results))
(setq results (delq name (delq address results)))
(make-local-variable 'message-setup-hook)
(dolist (result results)
(add-hook 'message-setup-hook
(cond
((eq 'eval (car result))
'ignore)
((eq 'body (car result))
`(lambda ()
(save-excursion
(message-goto-body)
(insert ,(cdr result)))))
((eq 'signature (car result))
(set (make-local-variable 'message-signature) nil)
(set (make-local-variable 'message-signature-file) nil)
(if (not (cdr result))
'ignore
`(lambda ()
(save-excursion
(let ((message-signature ,(cdr result)))
(when message-signature
(message-insert-signature)))))))
(t
(let ((header
(if (symbolp (car result))
(capitalize (symbol-name (car result)))
(car result))))
`(lambda ()
(save-excursion
(message-remove-header ,header)
(let ((value ,(cdr result)))
(when value
(message-goto-eoh)
(insert ,header ": " value "\n"))))))))))
(when (or name address)
(add-hook 'message-setup-hook
`(lambda ()
(set (make-local-variable 'user-mail-address)
,(or (cdr address) user-mail-address))
(let ((user-full-name ,(or (cdr name) (user-full-name)))
(user-mail-address
,(or (cdr address) user-mail-address)))
(save-excursion
(message-remove-header "From")
(message-goto-eoh)
(insert "From: " (message-make-from) "\n")))))))))
;;; Allow redefinition of functions.

41
lisp/gnus/gnus-nocem.el
View File

@ -1,5 +1,6 @@
;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'nnmail)
(require 'gnus-art)
@ -52,8 +51,7 @@
"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!
)
"red@redpoll.mrfs.oh.us (Richard E. Depew)") ; ARMM! ARMM!
"*List of NoCeM issuers to pay attention to.
This can also be a list of `(ISSUER CONDITIONS)' elements."
@ -123,7 +121,7 @@ matches an previously scanned and verified nocem message."
(interactive)
(let ((groups gnus-nocem-groups)
(gnus-inhibit-demon t)
group active gactive articles)
group active gactive articles check-headers)
(gnus-make-directory gnus-nocem-directory)
;; Load any previous NoCeM headers.
(gnus-nocem-load-cache)
@ -148,7 +146,7 @@ matches an previously scanned and verified nocem message."
(save-excursion
(let ((dependencies (make-vector 10 nil))
headers header)
(nnheader-temp-write nil
(with-temp-buffer
(setq headers
(if (eq 'nov
(gnus-retrieve-headers
@ -175,7 +173,14 @@ matches an previously scanned and verified nocem message."
(null (mail-header-references header)))
(not (member (mail-header-message-id header)
gnus-nocem-seen-message-ids))))
(gnus-nocem-check-article group header)))))))
(push header check-headers)))
(let ((i 0)
(len (length check-headers)))
(dolist (h check-headers)
(gnus-message
7 "Checking article %d in %s for NoCeM (%d of %d)..."
(mail-header-number h) group (incf i) len)
(gnus-nocem-check-article group h)))))))
(setq gnus-nocem-active
(cons (list group gactive)
(delq (assoc group gnus-nocem-active)
@ -187,14 +192,12 @@ matches an previously scanned and verified nocem message."
(defun gnus-nocem-check-article (group header)
"Check whether the current article is an NCM article and that we want it."
;; Get the article.
(gnus-message 7 "Checking article %d in %s for NoCeM..."
(mail-header-number header) group)
(let ((date (mail-header-date header))
issuer b e type)
(when (or (not date)
(nnmail-time-less
(nnmail-time-since (nnmail-date-to-time date))
(nnmail-days-to-time gnus-nocem-expiry-wait)))
(time-less-p
(time-since (date-to-time date))
(days-to-time gnus-nocem-expiry-wait)))
(gnus-request-article-this-buffer (mail-header-number header) group)
(goto-char (point-min))
(when (re-search-forward "-----BEGIN PGP MESSAGE-----" nil t)
@ -273,7 +276,7 @@ matches an previously scanned and verified nocem message."
gnus-nocem-real-group-hashtb)
;; Valid group.
(beginning-of-line)
(while (= (following-char) ?\t)
(while (eq (char-after) ?\t)
(forward-line -1))
(setq id (buffer-substring (point) (1- (search-forward "\t"))))
(unless (gnus-gethash id gnus-nocem-hashtb)
@ -281,7 +284,7 @@ matches an previously scanned and verified nocem message."
(gnus-sethash id t gnus-nocem-hashtb)
(push id ncm))
(forward-line 1)
(while (= (following-char) ?\t)
(while (eq (char-after) ?\t)
(forward-line 1))))))
(when ncm
(setq gnus-nocem-touched-alist t)
@ -304,13 +307,13 @@ matches an previously scanned and verified nocem message."
"Save the NoCeM cache."
(when (and gnus-nocem-alist
gnus-nocem-touched-alist)
(nnheader-temp-write (gnus-nocem-cache-file)
(with-temp-file (gnus-nocem-cache-file)
(gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
(setq gnus-nocem-touched-alist nil)))
(defun gnus-nocem-save-active ()
"Save the NoCeM active file."
(nnheader-temp-write (gnus-nocem-active-file)
(with-temp-file (gnus-nocem-active-file)
(gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
(defun gnus-nocem-alist-to-hashtb ()
@ -318,11 +321,11 @@ matches an previously scanned and verified nocem message."
(let* ((alist gnus-nocem-alist)
(pprev (cons nil alist))
(prev pprev)
(expiry (nnmail-days-to-time gnus-nocem-expiry-wait))
(expiry (days-to-time gnus-nocem-expiry-wait))
entry)
(setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51)))
(while (setq entry (car alist))
(if (not (nnmail-time-less (nnmail-time-since (car entry)) expiry))
(if (not (time-less-p (time-since (car entry)) expiry))
;; This entry has expired, so we remove it.
(setcdr prev (cdr alist))
(setq prev alist)

153
lisp/gnus/gnus-range.el
View File

@ -1,5 +1,6 @@
;;; gnus-range.el --- range and sequence functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
;;; List and range functions
(defun gnus-last-element (list)
@ -226,13 +225,81 @@ Note: LIST has to be sorted over `<'."
(setq ranges (cdr ranges)))
out)))
(defun gnus-remove-from-range (ranges list)
"Return a list of ranges that has all articles from LIST removed from RANGES.
Note: LIST has to be sorted over `<'."
;; !!! This function shouldn't look like this, but I've got a headache.
(gnus-compress-sequence
(gnus-sorted-complement
(gnus-uncompress-range ranges) list)))
(defun gnus-remove-from-range (range1 range2)
"Return a range that has all articles from RANGE2 removed from RANGE1.
The returned range is always a list. RANGE2 can also be a unsorted
list of articles. RANGE1 is modified by side effects, RANGE2 is not
modified."
(if (or (null range1) (null range2))
range1
(let (out r1 r2 r1_min r1_max r2_min r2_max
(range2 (gnus-copy-sequence range2)))
(setq range1 (if (listp (cdr range1)) range1 (list range1))
range2 (sort (if (listp (cdr range2)) range2 (list range2))
(lambda (e1 e2)
(< (if (consp e1) (car e1) e1)
(if (consp e2) (car e2) e2))))
r1 (car range1)
r2 (car range2)
r1_min (if (consp r1) (car r1) r1)
r1_max (if (consp r1) (cdr r1) r1)
r2_min (if (consp r2) (car r2) r2)
r2_max (if (consp r2) (cdr r2) r2))
(while (and range1 range2)
(cond ((< r2_max r1_min) ; r2 < r1
(pop range2)
(setq r2 (car range2)
r2_min (if (consp r2) (car r2) r2)
r2_max (if (consp r2) (cdr r2) r2)))
((and (<= r2_min r1_min) (<= r1_max r2_max)) ; r2 overlap r1
(pop range1)
(setq r1 (car range1)
r1_min (if (consp r1) (car r1) r1)
r1_max (if (consp r1) (cdr r1) r1)))
((and (<= r2_min r1_min) (<= r2_max r1_max)) ; r2 overlap min r1
(pop range2)
(setq r1_min (1+ r2_max)
r2 (car range2)
r2_min (if (consp r2) (car r2) r2)
r2_max (if (consp r2) (cdr r2) r2)))
((and (<= r1_min r2_min) (<= r2_max r1_max)) ; r2 contained in r1
(if (eq r1_min (1- r2_min))
(push r1_min out)
(push (cons r1_min (1- r2_min)) out))
(pop range2)
(if (< r2_max r1_max) ; finished with r1?
(setq r1_min (1+ r2_max))
(pop range1)
(setq r1 (car range1)
r1_min (if (consp r1) (car r1) r1)
r1_max (if (consp r1) (cdr r1) r1)))
(setq r2 (car range2)
r2_min (if (consp r2) (car r2) r2)
r2_max (if (consp r2) (cdr r2) r2)))
((and (<= r2_min r1_max) (<= r1_max r2_max)) ; r2 overlap max r1
(if (eq r1_min (1- r2_min))
(push r1_min out)
(push (cons r1_min (1- r2_min)) out))
(pop range1)
(setq r1 (car range1)
r1_min (if (consp r1) (car r1) r1)
r1_max (if (consp r1) (cdr r1) r1)))
((< r1_max r2_min) ; r2 > r1
(pop range1)
(if (eq r1_min r1_max)
(push r1_min out)
(push (cons r1_min r1_max) out))
(setq r1 (car range1)
r1_min (if (consp r1) (car r1) r1)
r1_max (if (consp r1) (cdr r1) r1)))))
(when r1
(if (eq r1_min r1_max)
(push r1_min out)
(push (cons r1_min r1_max) out))
(pop range1))
(while range1
(push (pop range1) out))
(nreverse out))))
(defun gnus-member-of-range (number ranges)
(if (not (listp (cdr ranges)))
@ -266,19 +333,59 @@ Note: LIST has to be sorted over `<'."
sublistp))
(defun gnus-range-add (range1 range2)
"Add RANGE2 to RANGE1 destructively."
(cond
;; If either are nil, then the job is quite easy.
((or (null range1) (null range2))
(or range1 range2))
(t
;; I don't like thinking.
(gnus-compress-sequence
(sort
(nconc
(gnus-uncompress-range range1)
(gnus-uncompress-range range2))
'<)))))
"Add RANGE2 to RANGE1 (nondestructively)."
(unless (listp (cdr range1))
(setq range1 (list range1)))
(unless (listp (cdr range2))
(setq range2 (list range2)))
(let ((item1 (pop range1))
(item2 (pop range2))
range item selector)
(while (or item1 item2)
(setq selector
(cond
((null item1) nil)
((null item2) t)
((and (numberp item1) (numberp item2)) (< item1 item2))
((numberp item1) (< item1 (car item2)))
((numberp item2) (< (car item1) item2))
(t (< (car item1) (car item2)))))
(setq item
(or
(let ((tmp1 item) (tmp2 (if selector item1 item2)))
(cond
((null tmp1) tmp2)
((null tmp2) tmp1)
((and (numberp tmp1) (numberp tmp2))
(cond
((eq tmp1 tmp2) tmp1)
((eq (1+ tmp1) tmp2) (cons tmp1 tmp2))
((eq (1+ tmp2) tmp1) (cons tmp2 tmp1))
(t nil)))
((numberp tmp1)
(cond
((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2)
((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2)))
((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1))
(t nil)))
((numberp tmp2)
(cond
((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1)
((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1)))
((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2))
(t nil)))
((< (1+ (cdr tmp1)) (car tmp2)) nil)
((< (1+ (cdr tmp2)) (car tmp1)) nil)
(t (cons (min (car tmp1) (car tmp2))
(max (cdr tmp1) (cdr tmp2))))))
(progn
(if item (push item range))
(if selector item1 item2))))
(if selector
(setq item1 (pop range1))
(setq item2 (pop range2))))
(if item (push item range))
(reverse range)))
(provide 'gnus-range)

172
lisp/gnus/gnus-salt.el
View File

@ -1,5 +1,6 @@
;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-sum)
@ -55,7 +54,7 @@
:group 'gnus-summary-pick)
(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."
"If non-nil, `gnus-pick-start-reading' runs `gnus-summary-next-group' when no articles have been picked."
:type 'boolean
:group 'gnus-summary-pick)
@ -78,8 +77,7 @@ It accepts the same format specs that `gnus-summary-line-format' does."
"u" gnus-pick-unmark-article-or-thread
"." gnus-pick-article-or-thread
gnus-down-mouse-2 gnus-pick-mouse-pick-region
"\r" gnus-pick-start-reading
))
"\r" gnus-pick-start-reading))
(defun gnus-pick-make-menu-bar ()
(unless (boundp 'gnus-pick-menu)
@ -123,7 +121,8 @@ 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))
(gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
(gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map
nil 'gnus-pick-mode)
(gnus-run-hooks 'gnus-pick-mode-hook))))
(defun gnus-pick-setup-message ()
@ -133,7 +132,8 @@ It accepts the same format specs that `gnus-summary-line-format' does."
(set-buffer gnus-summary-buffer)
gnus-pick-mode))
(message-add-action
'(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill)))
'(gnus-configure-windows ,gnus-current-window-configuration t)
'send 'exit 'postpone 'kill)))
(defvar gnus-pick-line-number 1)
(defun gnus-pick-line-number ()
@ -164,8 +164,8 @@ If given a prefix, mark all unpicked articles as read."
(error "No articles have been picked"))))
(defun gnus-pick-goto-article (arg)
"Go to the article number indicated by ARG. If ARG is an invalid
article number, then stay on current line."
"Go to the article number indicated by ARG.
If ARG is an invalid article number, then stay on current line."
(let (pos)
(save-excursion
(goto-char (point-min))
@ -174,9 +174,9 @@ article number, then stay on current line."
(if (not pos)
(gnus-error 2 "No such line: %s" arg)
(goto-char pos))))
(defun gnus-pick-article (&optional arg)
"Pick the article on the current line.
"Pick the article on the current line.
If ARG, pick the article on that line instead."
(interactive "P")
(when arg
@ -184,27 +184,31 @@ If ARG, pick the article on that line instead."
(gnus-summary-mark-as-processable 1))
(defun gnus-pick-article-or-thread (&optional arg)
"If gnus-thread-hide-subtree is t, then pick the thread on the current line.
"If `gnus-thread-hide-subtree' is t, then pick the thread on the current line.
Otherwise pick the article on the current line.
If ARG, pick the article/thread on that line instead."
(interactive "P")
(when arg
(gnus-pick-goto-article arg))
(if gnus-thread-hide-subtree
(gnus-uu-mark-thread)
(progn
(save-excursion
(gnus-uu-mark-thread))
(forward-line 1))
(gnus-summary-mark-as-processable 1)))
(defun gnus-pick-unmark-article-or-thread (&optional arg)
"If gnus-thread-hide-subtree is t, then unmark the thread on current line.
"If `gnus-thread-hide-subtree' is t, then unmark the thread on current line.
Otherwise unmark the article on current line.
If ARG, unmark thread/article on that line instead."
(interactive "P")
(when arg
(gnus-pick-goto-article arg))
(if gnus-thread-hide-subtree
(gnus-uu-unmark-thread)
(save-excursion
(gnus-uu-unmark-thread))
(gnus-summary-unmark-as-processable 1)))
(defun gnus-pick-mouse-pick (e)
(interactive "e")
(mouse-set-point e)
@ -242,46 +246,46 @@ This must be bound to a button-down mouse event."
;; (but not outside the window where the drag started).
(let (event end end-point (end-of-range (point)))
(track-mouse
(while (progn
(setq event (cdr (gnus-read-event-char)))
(or (mouse-movement-p event)
(eq (car-safe event) 'switch-frame)))
(if (eq (car-safe event) 'switch-frame)
nil
(setq end (event-end event)
end-point (posn-point end))
(while (progn
(setq event (cdr (gnus-read-event-char)))
(or (mouse-movement-p event)
(eq (car-safe event) 'switch-frame)))
(if (eq (car-safe event) 'switch-frame)
nil
(setq end (event-end event)
end-point (posn-point end))
(cond
;; Are we moving within the original window?
((and (eq (posn-window end) start-window)
(integer-or-marker-p end-point))
;; Go to START-POINT first, so that when we move to END-POINT,
;; if it's in the middle of intangible text,
;; point jumps in the direction away from START-POINT.
(goto-char start-point)
(goto-char end-point)
(gnus-pick-article)
;; In case the user moved his mouse really fast, pick
;; articles on the line between this one and the last one.
(let* ((this-line (1+ (count-lines 1 end-point)))
(min-line (min this-line start-line))
(max-line (max this-line start-line)))
(while (< min-line max-line)
(goto-line min-line)
(gnus-pick-article)
(setq min-line (1+ min-line)))
(setq start-line this-line))
(when (zerop (% click-count 3))
(setq end-of-range (point))))
(t
(let ((mouse-row (cdr (cdr (mouse-position)))))
(cond
((null mouse-row))
((< mouse-row top)
(mouse-scroll-subr start-window (- mouse-row top)))
((>= mouse-row bottom)
(mouse-scroll-subr start-window
(1+ (- mouse-row bottom)))))))))))
(cond
;; Are we moving within the original window?
((and (eq (posn-window end) start-window)
(integer-or-marker-p end-point))
;; Go to START-POINT first, so that when we move to END-POINT,
;; if it's in the middle of intangible text,
;; point jumps in the direction away from START-POINT.
(goto-char start-point)
(goto-char end-point)
(gnus-pick-article)
;; In case the user moved his mouse really fast, pick
;; articles on the line between this one and the last one.
(let* ((this-line (1+ (count-lines 1 end-point)))
(min-line (min this-line start-line))
(max-line (max this-line start-line)))
(while (< min-line max-line)
(goto-line min-line)
(gnus-pick-article)
(setq min-line (1+ min-line)))
(setq start-line this-line))
(when (zerop (% click-count 3))
(setq end-of-range (point))))
(t
(let ((mouse-row (cdr (cdr (mouse-position)))))
(cond
((null mouse-row))
((< mouse-row top)
(mouse-scroll-subr start-window (- mouse-row top)))
((>= mouse-row bottom)
(mouse-scroll-subr start-window
(1+ (- mouse-row bottom)))))))))))
(when (consp event)
(let ((fun (key-binding (vector (car event)))))
;; Run the binding of the terminating up-event, if possible.
@ -323,8 +327,8 @@ This must be bound to a button-down mouse event."
(setq gnus-binary-mode-map (make-sparse-keymap))
(gnus-define-keys
gnus-binary-mode-map
"g" gnus-binary-show-article))
gnus-binary-mode-map
"g" gnus-binary-show-article))
(defun gnus-binary-make-menu-bar ()
(unless (boundp 'gnus-binary-menu)
@ -350,7 +354,8 @@ 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))
(gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
(gnus-add-minor-mode 'gnus-binary-mode " Binary"
gnus-binary-mode-map nil 'gnus-binary-mode-map)
(gnus-run-hooks 'gnus-binary-mode-hook))))
(defun gnus-binary-display-article (article &optional all-header)
@ -432,6 +437,7 @@ Two predefined functions are available:
(defvar gnus-selected-tree-overlay nil)
(defvar gnus-tree-displayed-thread nil)
(defvar gnus-tree-inhibit nil)
(defvar gnus-tree-mode-map nil)
(put 'gnus-tree-mode 'mode-class 'special)
@ -440,13 +446,13 @@ Two predefined functions are available:
(setq gnus-tree-mode-map (make-keymap))
(suppress-keymap gnus-tree-mode-map)
(gnus-define-keys
gnus-tree-mode-map
"\r" gnus-tree-select-article
gnus-mouse-2 gnus-tree-pick-article
"\C-?" gnus-tree-read-summary-keys
"h" gnus-tree-show-summary
gnus-tree-mode-map
"\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)
"\C-c\C-i" gnus-info-find-node)
(substitute-key-definition
'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
@ -470,7 +476,7 @@ Two predefined functions are available:
(setq mode-name "Tree")
(setq major-mode 'gnus-tree-mode)
(use-local-map gnus-tree-mode-map)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(setq buffer-read-only t)
(setq truncate-lines t)
(save-excursion
@ -482,15 +488,17 @@ Two predefined functions are available:
(defun gnus-tree-read-summary-keys (&optional arg)
"Read a summary buffer key sequence and execute it."
(interactive "P")
(let ((buf (current-buffer))
win)
(set-buffer gnus-article-buffer)
(gnus-article-read-summary-keys arg nil t)
(when (setq win (get-buffer-window buf))
(select-window win)
(when gnus-selected-tree-overlay
(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
(gnus-tree-minimize))))
(unless gnus-tree-inhibit
(let ((buf (current-buffer))
(gnus-tree-inhibit t)
win)
(set-buffer gnus-article-buffer)
(gnus-article-read-summary-keys arg nil t)
(when (setq win (get-buffer-window buf))
(select-window win)
(when gnus-selected-tree-overlay
(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."
@ -521,12 +529,14 @@ Two predefined functions are available:
(defun gnus-tree-article-region (article)
"Return a cons with BEG and END of the article region."
(let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
(let ((pos (text-property-any
(point-min) (point-max) 'gnus-number article)))
(when pos
(cons pos (next-single-property-change pos 'gnus-number)))))
(defun gnus-tree-goto-article (article)
(let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
(let ((pos (text-property-any
(point-min) (point-max) 'gnus-number article)))
(when pos
(goto-char pos))))
@ -704,7 +714,7 @@ Two predefined functions are available:
(while (progn
(forward-line -1)
(forward-char col)
(= (following-char) ? ))
(eq (char-after) ? ))
(delete-char 1)
(insert (caddr gnus-tree-parent-child-edges)))
(goto-char beg)))
@ -762,7 +772,7 @@ Two predefined functions are available:
(forward-char -1)
;; Draw "-" lines leftwards.
(while (and (> (point) 1)
(= (char-after (1- (point))) ? ))
(eq (char-after (1- (point))) ? ))
(delete-char -1)
(insert (car gnus-tree-parent-child-edges))
(forward-char -1))
@ -969,7 +979,7 @@ The following commands are available:
(setq mode-name "Gnus Carpal")
(setq mode-line-process nil)
(use-local-map gnus-carpal-mode-map)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(setq buffer-read-only t)
(make-local-variable 'gnus-carpal-attached-buffer)
(gnus-run-hooks 'gnus-carpal-mode-hook))

370
lisp/gnus/gnus-score.el
View File

@ -1,5 +1,6 @@
;;; gnus-score.el --- scoring code for Gnus
;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -28,8 +29,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
@ -109,8 +108,8 @@ gnus-score-find-bnews: Apply score files whose names matches.
See the documentation to these functions for more information.
This variable can also be a list of functions to be called. Each
function should either return a list of score files, or a list of
score alists.
function is given the group name as argument and should either return
a list of score files, or a list of score alists.
If functions other than these pre-defined functions are used,
the `a' symbolic prefix to the score commands will always use
@ -119,13 +118,17 @@ the `a' symbolic prefix to the score commands will always use
:type '(radio (function-item gnus-score-find-single)
(function-item gnus-score-find-hierarchical)
(function-item gnus-score-find-bnews)
(function :tag "Other")))
(repeat :tag "List of functions"
(choice (function :tag "Other" :value 'ignore)
(function-item gnus-score-find-single)
(function-item gnus-score-find-hierarchical)
(function-item gnus-score-find-bnews)))
(function :tag "Other" :value 'ignore)))
(defcustom gnus-score-interactive-default-score 1000
"*Scoring commands will raise/lower the score with this number as the default."
:group 'gnus-score-default
:type '(choice (const nil)
integer))
:type 'integer)
(defcustom gnus-score-expiry-days 7
"*Number of days before unused score file entries are expired.
@ -141,12 +144,6 @@ will be expired along with non-matching score entries."
:group 'gnus-score-expire
:type 'boolean)
(defcustom gnus-orphan-score nil
"*All orphans get this score added. Set in the score file."
:group 'gnus-score-default
:type '(choice (const nil)
integer))
(defcustom gnus-decay-scores nil
"*If non-nil, decay non-permanent scores."
:group 'gnus-score-decay
@ -204,6 +201,8 @@ It can be:
(repeat (choice string
(cons regexp (repeat file))
(function :value fun)))
(function-item gnus-hierarchial-home-score-file)
(function-item gnus-current-home-score-file)
(function :value fun)))
(defcustom gnus-home-adapt-file nil
@ -224,14 +223,14 @@ This variable allows the same syntax as `gnus-home-score-file'."
(gnus-catchup-mark (subject -10))
(gnus-killed-mark (from -1) (subject -20))
(gnus-del-mark (from -2) (subject -15)))
"*Alist of marks and scores."
:group 'gnus-score-adapt
:type '(repeat (cons (symbol :tag "Mark")
(repeat (list (choice :tag "Header"
(const from)
(const subject)
(symbol :tag "other"))
(integer :tag "Score"))))))
"*Alist of marks and scores."
:group 'gnus-score-adapt
:type '(repeat (cons (symbol :tag "Mark")
(repeat (list (choice :tag "Header"
(const from)
(const subject)
(symbol :tag "other"))
(integer :tag "Score"))))))
(defcustom gnus-ignored-adaptive-words nil
"List of words to be ignored when doing adaptive word scoring."
@ -262,10 +261,10 @@ This variable allows the same syntax as `gnus-home-score-file'."
(,gnus-catchup-mark . -10)
(,gnus-killed-mark . -20)
(,gnus-del-mark . -15))
"*Alist of marks and scores."
:group 'gnus-score-adapt
:type '(repeat (cons (character :tag "Mark")
(integer :tag "Score"))))
"*Alist of marks and scores."
:group 'gnus-score-adapt
:type '(repeat (cons (character :tag "Mark")
(integer :tag "Score"))))
(defcustom gnus-adaptive-word-minimum nil
"If a number, this is the minimum score value that can be assigned to a word."
@ -311,6 +310,7 @@ Should be one of the following symbols.
i: message-id
t: references
x: xref
e: `extra' (non-standard overview)
l: lines
d: date
f: followup
@ -324,6 +324,7 @@ If nil, the user will be asked for a header."
(const :tag "message-id" i)
(const :tag "references" t)
(const :tag "xref" x)
(const :tag "extra" e)
(const :tag "lines" l)
(const :tag "date" d)
(const :tag "followup" f)
@ -388,7 +389,7 @@ If nil, the user will be asked for a duration."
(defcustom gnus-score-thread-simplify nil
"If non-nil, subjects will simplified as in threading."
:group 'gnus-score-various
:type 'boolean)
:type 'boolean)
@ -447,6 +448,7 @@ of the last successful match.")
("chars" 6 gnus-score-integer)
("lines" 7 gnus-score-integer)
("xref" 8 gnus-score-string)
("extra" 9 gnus-score-string)
("head" -1 gnus-score-body)
("body" -1 gnus-score-body)
("all" -1 gnus-score-body)
@ -480,7 +482,7 @@ The user will be prompted for header to score on, match type,
permanence, and the string to be used. The numerical prefix will be
used as score."
(interactive (gnus-interactive "P\ny"))
(gnus-summary-increase-score (- (gnus-score-default score)) symp))
(gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))
(defun gnus-score-kill-help-buffer ()
(when (get-buffer "*Score Help*")
@ -494,7 +496,7 @@ The user will be prompted for header to score on, match type,
permanence, and the string to be used. The numerical prefix will be
used as score."
(interactive (gnus-interactive "P\ny"))
(let* ((nscore (gnus-score-default score))
(let* ((nscore (gnus-score-delta-default score))
(prefix (if (< nscore 0) ?L ?I))
(increase (> nscore 0))
(char-to-header
@ -502,9 +504,10 @@ used as score."
(?s "subject" nil nil string)
(?b "body" "" nil body-string)
(?h "head" "" nil body-string)
(?i "message-id" nil t string)
(?i "message-id" nil nil string)
(?r "references" "message-id" nil string)
(?x "xref" nil nil string)
(?e "extra" nil nil string)
(?l "lines" nil nil number)
(?d "date" nil nil date)
(?f "followup" nil nil string)
@ -533,7 +536,7 @@ used as score."
(aref (symbol-name gnus-score-default-type) 0)))
(pchar (and gnus-score-default-duration
(aref (symbol-name gnus-score-default-duration) 0)))
entry temporary type match)
entry temporary type match extra)
(unwind-protect
(progn
@ -555,7 +558,7 @@ 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 "Illegal header type")))
(error "Invalid header type")))
(when (/= (downcase hchar) hchar)
;; This was a majuscule, so we end reading and set the defaults.
@ -588,7 +591,7 @@ used as score."
(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"))))
(error "Invalid match type"))))
(when (/= (downcase tchar) tchar)
;; It was a majuscule, so we end reading and use the default.
@ -616,18 +619,35 @@ used as score."
;; Deal with der(r)ided superannuated paradigms.
(when (and (eq (1+ prefix) 77)
(eq (+ hchar 12) 109)
(eq tchar 114)
(eq (1- tchar) 113)
(eq (- pchar 4) 111))
(error "You rang?"))
(if mimic
(error "%c %c %c %c" prefix hchar tchar pchar)
(error "Illegal match duration"))))
(error "Invalid match duration"))))
;; Always kill the score help buffer.
(gnus-score-kill-help-buffer))
;; If scoring an extra (non-standard overview) header,
;; we must find out which header is in question.
(setq extra
(and gnus-extra-headers
(equal (nth 1 entry) "extra")
(intern ; need symbol
(gnus-completing-read
(symbol-name (car gnus-extra-headers)) ; default response
"Score extra header:" ; prompt
(mapcar (lambda (x) ; completion list
(cons (symbol-name x) x))
gnus-extra-headers)
nil ; no completion limit
t)))) ; require match
;; extra is now nil or a symbol.
;; We have all the data, so we enter this score.
(setq match (if (string= (nth 2 entry) "") ""
(gnus-summary-header (or (nth 2 entry) (nth 1 entry)))))
(gnus-summary-header (or (nth 2 entry) (nth 1 entry))
nil extra)))
;; Modify the match, perhaps.
(cond
@ -654,7 +674,7 @@ used as score."
current-score-file)
(t
(gnus-score-file-name "all"))))))
(gnus-summary-score-entry
(nth 1 entry) ; Header
match ; Match
@ -663,7 +683,9 @@ used as score."
(if (eq temporary 'perm) ; Temp
nil
temporary)
(not (nth 3 entry))) ; Prompt
(not (nth 3 entry)) ; Prompt
nil ; not silent
extra) ; non-standard overview.
(when (eq symp 'a)
;; We change the score file back to the previous one.
@ -675,7 +697,7 @@ used as score."
(setq gnus-score-help-winconf (current-window-configuration))
(save-excursion
(set-buffer (gnus-get-buffer-create "*Score Help*"))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(delete-windows-on (current-buffer))
(erase-buffer)
(insert string ":\n\n")
@ -710,16 +732,18 @@ used as score."
(pop-to-buffer "*Score Help*")
(let ((window-min-height 1))
(shrink-window-if-larger-than-buffer))
(select-window (get-buffer-window gnus-summary-buffer))))
(select-window (get-buffer-window gnus-summary-buffer t))))
(defun gnus-summary-header (header &optional no-err)
(defun gnus-summary-header (header &optional no-err extra)
;; Return HEADER for current articles, or error.
(let ((article (gnus-summary-article-number))
headers)
(if article
(if (and (setq headers (gnus-summary-article-header article))
(vectorp headers))
(aref headers (nth 1 (assoc header gnus-header-index)))
(if extra ; `header' must be "extra"
(or (cdr (assq extra (mail-header-extra headers))) "")
(aref headers (nth 1 (assoc header gnus-header-index))))
(if no-err
nil
(error "Pseudo-articles can't be scored")))
@ -745,7 +769,7 @@ used as score."
(gnus-newsgroup-score-alist)))))
(defun gnus-summary-score-entry (header match type score date
&optional prompt silent)
&optional prompt silent extra)
"Enter score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
@ -753,7 +777,8 @@ TYPE is the match type: substring, regexp, exact, fuzzy.
SCORE is the score to add.
DATE is the expire date, or nil for no expire, or 'now for immediate expire.
If optional argument `PROMPT' is non-nil, allow user to edit match.
If optional argument `SILENT' is nil, show effect of score entry."
If optional argument `SILENT' is nil, show effect of score entry.
If optional argument `EXTRA' is non-nil, it's a non-standard overview header."
;; Regexp is the default type.
(when (eq type t)
(setq type 'r))
@ -762,9 +787,10 @@ If optional argument `SILENT' is nil, show effect of score entry."
(setq match (if match (gnus-simplify-subject-re match) "")))
((eq type 'f)
(setq match (gnus-simplify-subject-fuzzy match))))
(let ((score (gnus-score-default score))
(header (format "%s" (downcase header)))
(let ((score (gnus-score-delta-default score))
(header (downcase header))
new)
(set-text-properties 0 (length header) nil header)
(when prompt
(setq match (read-string
(format "Match %s on %s, %s: "
@ -779,8 +805,7 @@ If optional argument `SILENT' is nil, show effect of score entry."
(int-to-string match)
match))))
;; Get rid of string props.
(setq match (format "%s" match))
(set-text-properties 0 (length match) nil match)
;; If this is an integer comparison, we transform from string to int.
(when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
@ -794,12 +819,17 @@ If optional argument `SILENT' is nil, show effect of score entry."
elem)
(setq new
(cond
(extra
(list match score
(and date (if (numberp date) date
(date-to-day date)))
type (symbol-name extra)))
(type
(list match score
(and date (if (numberp date) date
(gnus-day-number date)))
(date-to-day date)))
type))
(date (list match score (gnus-day-number date)))
(date (list match score (date-to-day date)))
(score (list match score))
(t (list match))))
;; We see whether we can collapse some score entries.
@ -824,18 +854,19 @@ If optional argument `SILENT' is nil, show effect of score entry."
(if (and (>= (nth 1 (assoc header gnus-header-index)) 0)
(eq (nth 2 (assoc header gnus-header-index))
'gnus-score-string))
(gnus-summary-score-effect header match type score)
(gnus-summary-score-effect header match type score extra)
(gnus-summary-rescore)))
;; Return the new scoring rule.
new))
(defun gnus-summary-score-effect (header match type score)
(defun gnus-summary-score-effect (header match type score extra)
"Simulate the effect of a score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
TYPE is the score type.
SCORE is the score to add."
SCORE is the score to add.
EXTRA is the possible non-standard header."
(interactive (list (completing-read "Header: "
gnus-header-index
(lambda (x) (fboundp (nth 2 x)))
@ -856,7 +887,7 @@ SCORE is the score to add."
(t
(regexp-quote match)))))
(while (not (eobp))
(let ((content (gnus-summary-header header 'noerr))
(let ((content (gnus-summary-header header 'noerr extra))
(case-fold-search t))
(and content
(when (if (eq type 'f)
@ -939,7 +970,7 @@ SCORE is the score to add."
(defun gnus-score-followup-article (&optional score)
"Add SCORE to all followups to the article in the current buffer."
(interactive "P")
(setq score (gnus-score-default score))
(setq score (gnus-score-delta-default score))
(when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
(save-restriction
@ -954,7 +985,7 @@ SCORE is the score to add."
(defun gnus-score-followup-thread (&optional score)
"Add SCORE to all later articles in the thread the current buffer is part of."
(interactive "P")
(setq score (gnus-score-default score))
(setq score (gnus-score-delta-default score))
(when (gnus-buffer-live-p gnus-summary-buffer)
(save-excursion
(save-restriction
@ -999,7 +1030,7 @@ SCORE is the score to add."
(let ((buffer-read-only nil))
;; Set score.
(gnus-summary-update-mark
(if (= n (or gnus-summary-default-score 0)) ?
(if (= n (or gnus-summary-default-score 0)) ? ;Whitespace
(if (< n (or gnus-summary-default-score 0))
gnus-score-below-mark gnus-score-over-mark))
'score))
@ -1124,7 +1155,7 @@ SCORE is the score to add."
(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))) alist))
(gnus-score-set 'decay (list (time-to-days (current-time))) alist))
;; We do not respect eval and files atoms from global score
;; files.
(when (and files (not global))
@ -1205,9 +1236,9 @@ SCORE is the score to add."
;; Couldn't read file.
(setq gnus-score-alist nil)
;; Read file.
(save-excursion
(gnus-set-work-buffer)
(insert-file-contents file)
(with-temp-buffer
(let ((coding-system-for-read score-mode-coding-system))
(insert-file-contents file))
(goto-char (point-min))
;; Only do the loading if the score file isn't empty.
(when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
@ -1247,11 +1278,11 @@ SCORE is the score to add."
err
(cond
((not (listp (car a)))
(format "Illegal score element %s in %s" (car a) file))
(format "Invalid score element %s in %s" (car a) file))
((stringp (caar a))
(cond
((not (listp (setq sr (cdar a))))
(format "Illegal header match %s in %s" (nth 1 (car a)) file))
(format "Invalid header match %s in %s" (nth 1 (car a)) file))
(t
(setq type (caar a))
(while (and sr (not err))
@ -1262,7 +1293,7 @@ SCORE is the score to add."
((if (member (downcase type) '("lines" "chars"))
(not (numberp (car s)))
(not (stringp (car s))))
(format "Illegal match %s in %s" (car s) file))
(format "Invalid match %s in %s" (car s) file))
((and (cadr s) (not (integerp (cadr s))))
(format "Non-integer score %s in %s" (cadr s) file))
((and (caddr s) (not (integerp (caddr s))))
@ -1293,7 +1324,7 @@ SCORE is the score to add."
(setcar scor
(list (caar scor) (nth 2 (car scor))
(and (nth 3 (car scor))
(gnus-day-number (nth 3 (car scor))))
(date-to-day (nth 3 (car scor))))
(if (nth 1 (car scor)) 'r 's)))
(setq scor (cdr scor))))
(push (if (not (listp (cdr entry)))
@ -1313,7 +1344,7 @@ SCORE is the score to add."
(while cache
(current-buffer)
(setq entry (pop cache)
file (car entry)
file (nnheader-translate-file-chars (car entry) t)
score (cdr entry))
(if (or (not (equal (gnus-score-get 'touched score) '(t)))
(gnus-score-get 'read-only score)
@ -1340,7 +1371,8 @@ SCORE is the score to add."
(delete-file file)
;; There are scores, so we write the file.
(when (file-writable-p file)
(gnus-write-buffer file)
(let ((coding-system-for-write score-mode-coding-system))
(gnus-write-buffer file))
(when gnus-score-after-write-file-function
(funcall gnus-score-after-write-file-function file)))))
(and gnus-score-uncacheable-files
@ -1388,7 +1420,7 @@ SCORE is the score to add."
(when (and gnus-summary-default-score
scores)
(let* ((entries gnus-header-index)
(now (gnus-day-number (current-time-string)))
(now (date-to-day (current-time-string)))
(expire (and gnus-score-expiry-days
(- now gnus-score-expiry-days)))
(headers gnus-newsgroup-headers)
@ -1407,7 +1439,7 @@ SCORE is the score to add."
(save-excursion
(set-buffer (gnus-get-buffer-create "*Headers*"))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(when (gnus-buffer-live-p gnus-summary-buffer)
(message-clone-locals gnus-summary-buffer))
@ -1431,6 +1463,10 @@ SCORE is the score to add."
(when (setq new (funcall (nth 2 entry) scores header
now expire trace))
(push new news))))
(when (gnus-buffer-live-p gnus-summary-buffer)
(let ((scored gnus-newsgroup-scored))
(with-current-buffer gnus-summary-buffer
(setq gnus-newsgroup-scored scored))))
;; Remove the buffer.
(kill-buffer (current-buffer)))
@ -1447,85 +1483,56 @@ SCORE is the score to add."
(let (score)
(while (setq score (pop scores))
(while score
(when (listp (caar score))
(when (consp (caar score))
(gnus-score-advanced (car score) trace))
(pop score))))
(gnus-message 5 "Scoring...done"))))))
(defun gnus-score-lower-thread (thread score-adjust)
"Lower the socre on THREAD with SCORE-ADJUST.
THREAD is expected to contain a list of the form `(PARENT [CHILD1
CHILD2 ...])' where PARENT is a header array and each CHILD is a list
of the same form as THREAD. The empty list `nil' is valid. For each
article in the tree, the score of the corresponding entry in
GNUS-NEWSGROUP-SCORED is adjusted by SCORE-ADJUST."
(while thread
(let ((head (car thread)))
(if (listp head)
;; handle a child and its descendants
(gnus-score-lower-thread head score-adjust)
;; handle the parent
(let* ((article (mail-header-number head))
(score (assq article gnus-newsgroup-scored)))
(if score (setcdr score (+ (cdr score) score-adjust))
(push (cons article score-adjust) gnus-newsgroup-scored)))))
(setq thread (cdr thread))))
(defun gnus-get-new-thread-ids (articles)
(let ((index (nth 1 (assoc "message-id" gnus-header-index)))
(refind gnus-score-index)
id-list art this tref)
(while articles
(setq art (car articles)
this (aref (car art) index)
tref (aref (car art) refind)
articles (cdr articles))
(when (string-equal tref "") ;no references line
(push this id-list)))
id-list))
;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
(defun gnus-score-orphans (score)
(let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
alike articles art arts this last this-id)
(setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
articles gnus-scores-articles)
;;more or less the same as in gnus-score-string
(erase-buffer)
(while articles
(setq art (car articles)
this (aref (car art) gnus-score-index)
articles (cdr articles))
;;completely skip if this is empty (not a child, so not an orphan)
(when (not (string= this ""))
(if (equal last this)
;; O(N*H) cons-cells used here, where H is the number of
;; headers.
(push art alike)
(when last
;; Insert the line, with a text property on the
;; terminating newline referring to the articles with
;; this line.
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike))
(setq alike (list art)
last this))))
(when last ; Bwadr, duplicate code.
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike))
;; PLM: now delete those lines that contain an entry from new-thread-ids
(while new-thread-ids
(setq this-id (car new-thread-ids)
new-thread-ids (cdr new-thread-ids))
(goto-char (point-min))
(while (search-forward this-id nil t)
;; found a match. remove this line
(beginning-of-line)
(kill-line 1)))
;; now for each line: update its articles with score by moving to
;; every end-of-line in the buffer and read the articles property
(goto-char (point-min))
(while (eq 0 (progn
(end-of-line)
(setq arts (get-text-property (point) 'articles))
(while arts
(setq art (car arts)
arts (cdr arts))
(setcdr art (+ score (cdr art))))
(forward-line))))))
"Score orphans.
A root is an article with no references. An orphan is an article
which has references, but is not connected via its references to a
root article. This function finds all the orphans, and adjusts their
score in GNUS-NEWSGROUP-SCORED by SCORE."
(let ((threads (gnus-make-threads)))
;; gnus-make-threads produces a list, where each entry is a "thread"
;; as described in the gnus-score-lower-thread docs. This function
;; will be called again (after limiting has been done) if the display
;; is threaded. It would be nice to somehow save this info and use
;; it later.
(while threads
(let* ((thread (car threads))
(id (aref (car thread) gnus-score-index)))
;; If the parent of the thread is not a root, lower the score of
;; it and its descendants. Note that some roots seem to satisfy
;; (eq id nil) and some (eq id ""); not sure why.
(if (and id (not (string= id "")))
(gnus-score-lower-thread thread score)))
(setq threads (cdr threads)))))
(defun gnus-score-integer (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
entries alist)
;; Find matches.
(while scores
(setq alist (car scores)
@ -1542,7 +1549,7 @@ SCORE is the score to add."
(match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
(eq type '>=) (eq type '=))
type
(error "Illegal match type: %s" type)))
(error "Invalid match type: %s" type)))
(articles gnus-scores-articles))
;; Instead of doing all the clever stuff that
;; `gnus-score-string' does to minimize searches and stuff,
@ -1574,7 +1581,6 @@ SCORE is the score to add."
(defun gnus-score-date (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
entries alist match match-func article)
;; Find matches.
(while scores
(setq alist (car scores)
@ -1602,7 +1608,7 @@ SCORE is the score to add."
((eq type 'regexp)
(setq match-func 'string-match
match (nth 0 kill)))
(t (error "Illegal match type: %s" type)))
(t (error "Invalid match type: %s" type)))
;; Instead of doing all the clever stuff that
;; `gnus-score-string' does to minimize searches and stuff,
;; I will assume that people generally will put so few
@ -1661,8 +1667,8 @@ SCORE is the score to add."
(while articles
(setq article (mail-header-number (caar articles)))
(gnus-message 7 "Scoring article %s of %s..." article last)
(widen)
(when (funcall request-func article gnus-newsgroup-name)
(widen)
(goto-char (point-min))
;; If just parts of the article is to be searched, but the
;; backend didn't support partial fetching, we just narrow
@ -1700,7 +1706,7 @@ SCORE is the score to add."
(eq type 'string) (eq type 'String))
'search-forward)
(t
(error "Illegal match type: %s" type)))))
(error "Invalid match type: %s" type)))))
(goto-char (point-min))
(when (funcall search-func match nil t)
;; Found a match, update scores.
@ -1786,7 +1792,7 @@ SCORE is the score to add."
(search-func
(cond ((= dmt ?r) 're-search-forward)
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
(t (error "Illegal match type: %s" type))))
(t (error "Invalid match type: %s" type))))
arts art)
(goto-char (point-min))
(if (= dmt ?e)
@ -1867,12 +1873,23 @@ SCORE is the score to add."
;; and U is the number of unique headers. It is assumed (but
;; untested) this will be a net win because of the large constant
;; factor involved with string matching.
(setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
(setq gnus-scores-articles
;; We cannot string-sort the extra headers list. *sigh*
(if (= gnus-score-index 9)
gnus-scores-articles
(sort gnus-scores-articles 'gnus-score-string<))
articles gnus-scores-articles)
(erase-buffer)
(while (setq art (pop articles))
(setq this (aref (car art) gnus-score-index))
;; If we're working with non-standard headers, we are stuck
;; with working on them as a group. What a hassle.
;; Just wait 'til you see what horrors we commit against `match'...
(if (= gnus-score-index 9)
(setq this (prin1-to-string this))) ; ick.
(if simplify
(setq this (gnus-map-function gnus-simplify-subject-functions this)))
(if (equal last this)
@ -1903,11 +1920,12 @@ SCORE is the score to add."
(type (or (nth 3 kill) 's))
(score (or (nth 1 kill) gnus-score-interactive-default-score))
(date (nth 2 kill))
(extra (nth 4 kill)) ; non-standard header; string.
(found nil)
(mt (aref (symbol-name type) 0))
(case-fold-search (not (memq mt '(?R ?S ?E ?F))))
(dmt (downcase mt))
; Assume user already simplified regexp and fuzzies
;; Assume user already simplified regexp and fuzzies
(match (if (and simplify (not (memq dmt '(?f ?r))))
(gnus-map-function
gnus-simplify-subject-functions
@ -1917,7 +1935,14 @@ SCORE is the score to add."
(cond ((= dmt ?r) 're-search-forward)
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
((= dmt ?w) nil)
(t (error "Illegal match type: %s" type)))))
(t (error "Invalid match type: %s" type)))))
;; Evil hackery to make match usable in non-standard headers.
(when extra
(setq match (concat "[ (](" extra " \\. \"[^)]*"
match "[^(]*\")[ )]")
search-func 're-search-forward)) ; XXX danger?!?
(cond
;; Fuzzy matches. We save these for later.
((= dmt ?f)
@ -2044,6 +2069,7 @@ SCORE is the score to add."
(cond
;; Permanent.
((null date)
;; Do nothing.
)
;; Match, update date.
((and found gnus-update-score-entry-dates)
@ -2082,6 +2108,7 @@ SCORE is the score to add."
(cond
;; Permanent.
((null date)
;; Do nothing.
)
;; Match, update date.
((and found gnus-update-score-entry-dates)
@ -2212,9 +2239,9 @@ SCORE is the score to add."
;; Perform adaptive word scoring.
(when (and (listp gnus-newsgroup-adaptive)
(memq 'word gnus-newsgroup-adaptive))
(nnheader-temp-write nil
(with-temp-buffer
(let* ((hashtb (gnus-make-hashtable 1000))
(date (gnus-day-number (current-time-string)))
(date (date-to-day (current-time-string)))
(data gnus-newsgroup-data)
(syntab (syntax-table))
word d score val)
@ -2250,7 +2277,7 @@ SCORE is the score to add."
(let ((ignored (append gnus-ignored-adaptive-words
(if gnus-adaptive-word-no-group-words
(message-tokenize-header
(gnus-group-real-name
(gnus-group-real-name
gnus-newsgroup-name)
"."))
gnus-default-ignored-adaptive-words)))
@ -2292,11 +2319,10 @@ SCORE is the score to add."
1 "No score rules apply to the current article (default score %d)."
gnus-summary-default-score)
(set-buffer "*Score Trace*")
(setq truncate-lines t)
(while trace
(insert (format "%S -> %s\n" (cdar trace)
(if (caar trace)
(file-name-nondirectory (caar trace))
"(non-file rule)")))
(or (caar trace) "(non-file rule)")))
(setq trace (cdr trace)))
(goto-char (point-min))
(gnus-configure-windows 'score-trace)))
@ -2389,14 +2415,14 @@ SCORE is the score to add."
(gnus-summary-raise-score score))
(gnus-summary-next-subject 1 t)))
(defun gnus-score-default (level)
(defun gnus-score-delta-default (level)
(if level (prefix-numeric-value level)
gnus-score-interactive-default-score))
(defun gnus-summary-raise-thread (&optional score)
"Raise the score of the articles in the current thread with SCORE."
(interactive "P")
(setq score (gnus-score-default score))
(setq score (gnus-score-delta-default score))
(let (e)
(save-excursion
(let ((articles (gnus-summary-articles-in-thread)))
@ -2425,7 +2451,7 @@ SCORE is the score to add."
(defun gnus-summary-lower-thread (&optional score)
"Lower score of articles in the current thread with SCORE."
(interactive "P")
(gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
(gnus-summary-raise-thread (- (1- (gnus-score-delta-default score)))))
;;; Finding score files.
@ -2474,8 +2500,8 @@ SCORE is the score to add."
seen out file)
(while (setq file (pop files))
(cond
;; Ignore "." and "..".
((member (file-name-nondirectory file) '("." ".."))
;; Ignore files that start with a dot.
((string-match "^\\." (file-name-nondirectory file))
nil)
;; Add subtrees of directory to also be searched.
((and (file-directory-p file)
@ -2505,10 +2531,11 @@ GROUP using BNews sys file syntax."
(klen (length kill-dir))
(score-regexp (gnus-score-file-regexp))
(trans (cdr (assq ?: nnheader-file-name-translation-alist)))
(group-trans (nnheader-translate-file-chars group t))
ofiles not-match regexp)
(save-excursion
(set-buffer (gnus-get-buffer-create "*gnus score files*"))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
;; Go through all score file names and create regexp with them
;; as the source.
(while sfiles
@ -2551,16 +2578,18 @@ 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 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
;; applicable to this group.
(when (or (and not-match
(not (string-match regexp group)))
(and (not not-match)
(string-match regexp group)))
(ignore-errors
(not (string-match regexp group-trans))))
(and (not not-match)
(ignore-errors (string-match regexp group-trans))))
(push (car sfiles) ofiles)))
(setq sfiles (cdr sfiles)))
(kill-buffer (current-buffer))
@ -2628,7 +2657,7 @@ Destroys the current buffer."
(defun gnus-sort-score-files (files)
"Sort FILES so that the most general files come first."
(nnheader-temp-write nil
(with-temp-buffer
(let ((alist
(mapcar
(lambda (file)
@ -2797,12 +2826,14 @@ If ADAPT, return the home adaptive file instead."
;; Function.
((gnus-functionp elem)
(funcall elem group))
;; Regexp-file cons
;; Regexp-file cons.
((consp elem)
(when (string-match (gnus-globalify-regexp (car elem)) group)
(replace-match (cadr elem) t nil group ))))))
(replace-match (cadr elem) t nil group))))))
(when found
(nnheader-concat gnus-kill-files-directory found))))
(if (file-name-absolute-p found)
found
(nnheader-concat gnus-kill-files-directory found)))))
(defun gnus-hierarchial-home-score-file (group)
"Return the score file of the top-level hierarchy of GROUP."
@ -2840,7 +2871,7 @@ If ADAPT, return the home adaptive file instead."
(defun gnus-decay-scores (alist day)
"Decay non-permanent scores in ALIST."
(let ((times (- (gnus-time-to-day (current-time)) day))
(let ((times (- (time-to-days (current-time)) day))
kill entry updated score n)
(unless (zerop times) ;Done decays today already?
(while (setq entry (pop alist))
@ -2854,7 +2885,7 @@ If ADAPT, return the home adaptive file instead."
n times)
(while (natnump (decf n))
(setq score (funcall gnus-decay-score-function score)))
(setcdr kill (cons score
(setcdr kill (cons score
(cdr (cdr kill)))))))))
;; Return whether this score file needs to be saved. By Je-haysuss!
updated))
@ -2913,8 +2944,7 @@ See `(Gnus)Scoring Tips' for examples of good regular expressions."
(cond
(bad (cons 'bad bad))
(new (cons 'new new))
;; or nil
)))))
(t nil))))))
(provide 'gnus-score)

32
lisp/gnus/gnus-setup.el
View File

@ -1,5 +1,6 @@
;;; gnus-setup.el --- Initialization & Setup for Gnus 5
;; Copyright (C) 1995, 96 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc.
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news
@ -65,22 +66,20 @@
"site-lisp/bbdb-1.51/")
"Directory where Big Brother Database is found.")
(defvar gnus-use-tm running-xemacs
"Set this if you want MIME support for Gnus")
(defvar gnus-use-mhe nil
"Set this if you want to use MH-E for mail reading")
"Set this if you want to use MH-E for mail reading.")
(defvar gnus-use-rmail nil
"Set this if you want to use RMAIL for mail reading")
"Set this if you want to use RMAIL for mail reading.")
(defvar gnus-use-sendmail t
"Set this if you want to use SENDMAIL for mail reading")
"Set this if you want to use SENDMAIL for mail reading.")
(defvar gnus-use-vm nil
"Set this if you want to use the VM package for mail reading")
"Set this if you want to use the VM package for mail reading.")
(defvar gnus-use-sc nil
"Set this if you want to use Supercite")
"Set this if you want to use Supercite.")
(defvar gnus-use-mailcrypt t
"Set this if you want to use Mailcrypt for dealing with PGP messages")
"Set this if you want to use Mailcrypt for dealing with PGP messages.")
(defvar gnus-use-bbdb nil
"Set this if you want to use the Big Brother DataBase")
"Set this if you want to use the Big Brother DataBase.")
(when (and (not gnus-use-installed-gnus)
(null (member gnus-gnus-lisp-directory load-path)))
@ -89,19 +88,6 @@
;;; We can't do this until we know where Gnus is.
(require 'message)
;;; Tools for MIME by
;;; UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
;;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(when gnus-use-tm
(when (and (not gnus-use-installed-tm)
(null (member gnus-tm-lisp-directory load-path)))
(setq load-path (cons gnus-tm-lisp-directory load-path)))
;; tm may or may not be dumped with XEmacs. In Sunpro it is, otherwise
;; it isn't.
(unless (featurep 'mime-setup)
(load "mime-setup")))
;;; Mailcrypt by
;;; Jin Choi <jin@atype.com>
;;; Patrick LoPresti <patl@lcs.mit.edu>

71
lisp/gnus/gnus-soup.el
View File

@ -1,5 +1,7 @@
;;; gnus-soup.el --- SOUP packet writing support for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -28,8 +30,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-art)
(require 'message)
@ -69,9 +69,9 @@ The SOUP packet file name will be inserted at the %s.")
;;; Internal Variables:
(defvar gnus-soup-encoding-type ?n
(defvar gnus-soup-encoding-type ?u
"*Soup encoding type.
`n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
`u' is USENET news format, `m' is Unix mbox format, and `M' is MMDF mailbox
format.")
(defvar gnus-soup-index-type ?c
@ -142,21 +142,19 @@ move those articles instead."
(buffer-disable-undo tmp-buf)
(save-excursion
(while articles
;; Find the header of the article.
(set-buffer gnus-summary-buffer)
(when (setq headers (gnus-summary-article-header (car articles)))
;; Put the article in a buffer.
(set-buffer tmp-buf)
(when (gnus-request-article-this-buffer
(car articles) gnus-newsgroup-name)
(save-restriction
(message-narrow-to-head)
(message-remove-header gnus-soup-ignored-headers t))
(gnus-soup-store gnus-soup-directory prefix headers
gnus-soup-encoding-type
gnus-soup-index-type)
(gnus-soup-area-set-number
area (1+ (or (gnus-soup-area-number area) 0)))))
;; Put the article in a buffer.
(set-buffer tmp-buf)
(when (gnus-request-article-this-buffer
(car articles) gnus-newsgroup-name)
(setq headers (nnheader-parse-head t))
(save-restriction
(message-narrow-to-head)
(message-remove-header gnus-soup-ignored-headers t))
(gnus-soup-store gnus-soup-directory prefix headers
gnus-soup-encoding-type
gnus-soup-index-type)
(gnus-soup-area-set-number
area (1+ (or (gnus-soup-area-number area) 0))))
;; Mark article as read.
(set-buffer gnus-summary-buffer)
(gnus-summary-remove-process-mark (car articles))
@ -170,11 +168,11 @@ move those articles instead."
"Make a SOUP packet from the SOUP areas."
(interactive)
(gnus-soup-read-areas)
(unless (file-exists-p gnus-soup-directory)
(message "No such directory: %s" gnus-soup-directory))
(when (null (directory-files gnus-soup-directory nil "\\.MSG$"))
(message "No files to pack."))
(gnus-soup-pack gnus-soup-directory gnus-soup-packer))
(if (file-exists-p gnus-soup-directory)
(if (directory-files gnus-soup-directory nil "\\.MSG$")
(gnus-soup-pack gnus-soup-directory gnus-soup-packer)
(message "No files to pack."))
(message "No such directory: %s" gnus-soup-directory)))
(defun gnus-group-brew-soup (n)
"Make a soup packet from the current group.
@ -249,7 +247,8 @@ Note -- this function hasn't been implemented yet."
;; a soup header.
(setq head-line
(cond
((= gnus-soup-encoding-type ?n)
((or (= gnus-soup-encoding-type ?u)
(= gnus-soup-encoding-type ?n)) ;;Gnus back compatibility.
(format "#! rnews %d\n" (buffer-size)))
((= gnus-soup-encoding-type ?m)
(while (search-forward "\nFrom " nil t)
@ -339,7 +338,8 @@ If NOT-ALL, don't pack ticked articles."
(while (setq prefix (pop prefixes))
(erase-buffer)
(insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix)))
(gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file))))))
(let ((coding-system-for-write mm-text-coding-system))
(gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))))
(defun gnus-soup-pack (dir packer)
(let* ((files (mapconcat 'identity
@ -376,7 +376,7 @@ though the two last may be nil if they are missing."
(when (file-exists-p file)
(save-excursion
(set-buffer (nnheader-find-file-noselect file 'force))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(goto-char (point-min))
(while (not (eobp))
(push (vector (gnus-soup-field)
@ -399,7 +399,7 @@ file. The vector contain three strings, [prefix name encoding]."
(let (replies)
(save-excursion
(set-buffer (nnheader-find-file-noselect file))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(goto-char (point-min))
(while (not (eobp))
(push (vector (gnus-soup-field) (gnus-soup-field)
@ -424,7 +424,7 @@ file. The vector contain three strings, [prefix name encoding]."
"Write the AREAS file."
(interactive)
(when gnus-soup-areas
(nnheader-temp-write (concat gnus-soup-directory "AREAS")
(with-temp-file (concat gnus-soup-directory "AREAS")
(let ((areas gnus-soup-areas)
area)
(while (setq area (pop areas))
@ -445,7 +445,7 @@ file. The vector contain three strings, [prefix name encoding]."
(defun gnus-soup-write-replies (dir areas)
"Write a REPLIES file in DIR containing AREAS."
(nnheader-temp-write (concat dir "REPLIES")
(with-temp-file (concat dir "REPLIES")
(let (area)
(while (setq area (pop areas))
(insert (format "%s\t%s\t%s\n"
@ -517,9 +517,12 @@ Return whether the unpacking was successful."
(tmp-buf (gnus-get-buffer-create " *soup send*"))
beg end)
(cond
((/= (gnus-soup-encoding-format
(gnus-soup-reply-encoding (car replies)))
?n)
((and (/= (gnus-soup-encoding-format
(gnus-soup-reply-encoding (car replies)))
?u)
(/= (gnus-soup-encoding-format
(gnus-soup-reply-encoding (car replies)))
?n)) ;; Gnus back compatibility.
(error "Unsupported encoding"))
((null msg-buf)
t)

40
lisp/gnus/gnus-spec.el
View File

@ -1,5 +1,6 @@
;;; gnus-spec.el --- format spec functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
;;; Internal variables.
@ -203,9 +202,7 @@
(gnus-parse-format
new-format
(symbol-value
(intern (format "gnus-%s-line-format-alist"
(if (eq type 'article-mode)
'summary-mode type))))
(intern (format "gnus-%s-line-format-alist" type)))
(not (string-match "mode$" (symbol-name type))))))
;; Enter the new format spec into the list.
(if entry
@ -243,6 +240,12 @@
(point) (progn ,@form (point))
'(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
(defun gnus-balloon-face-function (form type)
`(gnus-put-text-property
(point) (progn ,@form (point))
'balloon-help
,(intern (format "gnus-balloon-face-%d" type))))
(defun gnus-tilde-max-form (el max-width)
"Return a form that limits EL to MAX-WIDTH."
(let ((max (abs max-width)))
@ -289,8 +292,10 @@
;; SPEC-ALIST and returns a list that can be eval'ed to return the
;; string. If the FORMAT string contains the specifiers %( and %)
;; the text between them will have the mouse-face text property.
;; If the FORMAT string contains the specifiers %[ and %], the text between
;; them will have the balloon-help text property.
(if (string-match
"\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'"
"\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
format)
(gnus-parse-complex-format format spec-alist)
;; This is a simple format.
@ -305,13 +310,17 @@
(replace-match "\\\"" nil t))
(goto-char (point-min))
(insert "(\"")
(while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t)
(while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
(let ((number (if (match-beginning 1)
(match-string 1) "0"))
(delim (aref (match-string 2) 0)))
(if (or (= delim ?\()
(= delim ?\{))
(replace-match (concat "\"(" (if (= delim ?\() "mouse" "face")
(= delim ?\{)
(= delim ?\«))
(replace-match (concat "\"("
(cond ((= delim ?\() "mouse")
((= delim ?\{) "face")
(t "balloon"))
" " number " \""))
(replace-match "\")\""))))
(goto-char (point-max))
@ -392,9 +401,9 @@
(t
nil)))
;; User-defined spec -- find the spec name.
(when (= (setq spec (following-char)) ?u)
(when (eq (setq spec (char-after)) ?u)
(forward-char 1)
(setq user-defined (following-char)))
(setq user-defined (char-after)))
(forward-char 1)
(delete-region spec-beg (point))
@ -521,7 +530,7 @@ If PROPS, insert the result."
(not (eq 'byte-code (car form)))
;; Under XEmacs, it's (funcall #<compiled-function ...>)
(not (and (eq 'funcall (car form))
(compiled-function-p (cadr form)))))
(byte-code-function-p (cadr form)))))
(fset 'gnus-tmp-func `(lambda () ,form))
(byte-compile 'gnus-tmp-func)
(setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
@ -537,8 +546,11 @@ If PROPS, insert the result."
(symbol-value (intern (format "gnus-%s-line-format" type)))
(symbol-value (intern (format "gnus-%s-line-format-alist" type)))
insertable)))
(provide 'gnus-spec)
;; Local Variables:
;; coding: iso-8859-1
;; End:
;;; gnus-spec.el ends here

142
lisp/gnus/gnus-srvr.el
View File

@ -1,5 +1,6 @@
;;; gnus-srvr.el --- virtual server support for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-spec)
(require 'gnus-group)
@ -137,6 +136,9 @@ The following specs are understood:
"D" gnus-server-deny-server
"R" gnus-server-remove-denials
"n" next-line
"p" previous-line
"g" gnus-server-regenerate-server
"\C-c\C-i" gnus-info-find-node
@ -163,7 +165,7 @@ The following commands are available:
(gnus-set-default-directory)
(setq mode-line-process nil)
(use-local-map gnus-server-mode-map)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
(gnus-run-hooks 'gnus-server-mode-hook))
@ -173,12 +175,12 @@ The following commands are available:
(gnus-tmp-where (nth 1 method))
(elem (assoc method gnus-opened-servers))
(gnus-tmp-status (cond ((eq (nth 1 elem) 'denied)
"(denied)")
((or (gnus-server-opened method)
(eq (nth 1 elem) 'ok))
"(opened)")
(t
"(closed)"))))
"(denied)")
((or (gnus-server-opened method)
(eq (nth 1 elem) 'ok))
"(opened)")
(t
"(closed)"))))
(beginning-of-line)
(gnus-add-text-properties
(point)
@ -295,6 +297,18 @@ The following commands are available:
(push (assoc server gnus-server-alist) gnus-server-killed-servers)
(setq gnus-server-alist (delq (car gnus-server-killed-servers)
gnus-server-alist))
(let ((groups (gnus-groups-from-server server)))
(when (and groups
(gnus-yes-or-no-p
(format "Kill all %s groups from this server? "
(length groups))))
(dolist (group groups)
(setq gnus-newsrc-alist
(delq (assoc group gnus-newsrc-alist)
gnus-newsrc-alist))
(when gnus-group-change-level-function
(funcall gnus-group-change-level-function
group gnus-level-killed 3)))))
(gnus-server-position-point))
(defun gnus-server-yank-server ()
@ -508,28 +522,28 @@ The following commands are available:
(suppress-keymap gnus-browse-mode-map)
(gnus-define-keys
gnus-browse-mode-map
" " gnus-browse-read-group
"=" gnus-browse-select-group
"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
"\M-p" gnus-browse-prev-group
"\r" gnus-browse-select-group
"u" gnus-browse-unsubscribe-current-group
"l" gnus-browse-exit
"L" gnus-browse-exit
"q" gnus-browse-exit
"Q" gnus-browse-exit
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
gnus-browse-mode-map
" " gnus-browse-read-group
"=" gnus-browse-select-group
"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
"\M-p" gnus-browse-prev-group
"\r" gnus-browse-select-group
"u" gnus-browse-unsubscribe-current-group
"l" gnus-browse-exit
"L" gnus-browse-exit
"q" gnus-browse-exit
"Q" gnus-browse-exit
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
(defun gnus-browse-make-menu-bar ()
(gnus-turn-off-edit-menu 'browse)
@ -552,9 +566,9 @@ The following commands are available:
(defun gnus-browse-foreign-server (server &optional return-buffer)
"Browse the server SERVER."
(setq gnus-browse-current-method server)
(setq gnus-browse-current-method (gnus-server-to-method server))
(setq gnus-browse-return-buffer return-buffer)
(let* ((method (gnus-server-to-method server))
(let* ((method gnus-browse-current-method)
(gnus-select-method method)
groups group)
(gnus-message 5 "Connecting to %s..." (nth 1 method))
@ -577,7 +591,7 @@ The following commands are available:
(when gnus-carpal
(gnus-carpal-setup-buffer 'browse))
(gnus-configure-windows 'browse)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(let ((buffer-read-only nil))
(erase-buffer))
(gnus-browse-mode)
@ -591,22 +605,38 @@ The following commands are available:
(goto-char (point-min))
(unless (string= gnus-ignored-newsgroups "")
(delete-matching-lines gnus-ignored-newsgroups))
(while (re-search-forward
"\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
(goto-char (match-end 1))
(condition-case ()
(push (cons (match-string 1)
(max 0 (- (1+ (read cur)) (read cur))))
groups)
(error nil)))))
(while (not (eobp))
(ignore-errors
(push (cons
(if (eq (char-after) ?\")
(read cur)
(let ((p (point)) (name ""))
(skip-chars-forward "^ \t\\\\")
(setq name (buffer-substring p (point)))
(while (eq (char-after) ?\\)
(setq p (1+ (point)))
(forward-char 2)
(skip-chars-forward "^ \t\\\\")
(setq name (concat name (buffer-substring
p (point)))))
name))
(max 0 (- (1+ (read cur)) (read cur))))
groups))
(forward-line))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
(let ((buffer-read-only nil))
(let ((buffer-read-only nil) charset)
(while groups
(setq group (car groups))
(insert
(format "K%7d: %s\n" (cdr group) (car group)))
(setq charset (gnus-group-name-charset method group))
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(insert
(format "K%7d: %s\n" (cdr group)
(gnus-group-name-decode (car group) charset))))
(list 'gnus-group (car group)))
(setq groups (cdr groups))))
(switch-to-buffer (current-buffer))
(goto-char (point-min))
@ -638,7 +668,7 @@ buffer.
(setq mode-name "Browse Server")
(setq mode-line-process nil)
(use-local-map gnus-browse-mode-map)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(setq truncate-lines t)
(gnus-set-default-directory)
(setq buffer-read-only t)
@ -651,12 +681,12 @@ buffer.
(if (or (not (gnus-get-info group))
(gnus-ephemeral-group-p group))
(unless (gnus-group-read-ephemeral-group
group gnus-browse-current-method nil
(gnus-group-real-name group) gnus-browse-current-method nil
(cons (current-buffer) 'browse))
(error "Couldn't enter %s" group))
(unless (gnus-group-read-group nil no-article group)
(error "Couldn't enter %s" group)))))
(defun gnus-browse-select-group ()
"Select the current group."
(interactive)
@ -694,11 +724,12 @@ buffer.
(defun gnus-browse-group-name ()
(save-excursion
(beginning-of-line)
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
(gnus-group-prefixed-name
;; Remove text props.
(format "%s" (match-string 1))
gnus-browse-current-method))))
(let ((name (get-text-property (point) 'gnus-group)))
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
(gnus-group-prefixed-name
(or name
(match-string-no-properties 1))
gnus-browse-current-method)))))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
@ -708,7 +739,7 @@ buffer.
(save-excursion
(beginning-of-line)
;; If this group it killed, then we want to subscribe it.
(when (= (following-char) ?K)
(when (eq (char-after) ?K)
(setq sub t))
(setq group (gnus-browse-group-name))
(when (and sub
@ -725,7 +756,8 @@ buffer.
nil nil (if (gnus-server-equal
gnus-browse-current-method "native")
nil
gnus-browse-current-method))
(gnus-method-simplify
gnus-browse-current-method)))
gnus-level-default-subscribed gnus-level-killed
(and (car (nth 1 gnus-newsrc-alist))
(gnus-gethash (car (nth 1 gnus-newsrc-alist))

577
lisp/gnus/gnus-start.el
View File

@ -1,5 +1,6 @@
;;; gnus-start.el --- startup functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -52,7 +53,7 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead."
(directory-file-name installation-directory))
"site-lisp/gnus-init")
(error nil))
"*The site-wide Gnus Emacs-Lisp startup file name, or nil if none.
"The site-wide Gnus Emacs-Lisp startup file name, or nil if none.
If a file with the `.el' or `.elc' suffixes exists, it will be read instead."
:group 'gnus-start
:type '(choice file (const nil)))
@ -142,27 +143,19 @@ properly with all servers."
(const some)
(const t)))
(defcustom gnus-level-subscribed 5
"*Groups with levels less than or equal to this variable are subscribed."
:group 'gnus-group-levels
:type 'integer)
(defconst gnus-level-subscribed 5
"Groups with levels less than or equal to this variable are subscribed.")
(defcustom gnus-level-unsubscribed 7
"*Groups with levels less than or equal to this variable are unsubscribed.
(defconst gnus-level-unsubscribed 7
"Groups with levels less than or equal to this variable are unsubscribed.
Groups with levels less than `gnus-level-subscribed', which should be
less than this variable, are subscribed."
:group 'gnus-group-levels
:type 'integer)
less than this variable, are subscribed.")
(defcustom gnus-level-zombie 8
"*Groups with this level are zombie groups."
:group 'gnus-group-levels
:type 'integer)
(defconst gnus-level-zombie 8
"Groups with this level are zombie groups.")
(defcustom gnus-level-killed 9
"*Groups with this level are killed."
:group 'gnus-group-levels
:type 'integer)
(defconst gnus-level-killed 9
"Groups with this level are killed.")
(defcustom gnus-level-default-subscribed 3
"*New subscribed groups will be subscribed at this level."
@ -197,6 +190,16 @@ groups."
:type '(choice integer
(const :tag "none" nil)))
(defcustom gnus-read-newsrc-file t
"*Non-nil means that Gnus will read the `.newsrc' file.
Gnus always reads its own startup file, which is called
\".newsrc.eld\". The file called \".newsrc\" is in a format that can
be readily understood by other newsreaders. If you don't plan on
using other newsreaders, set this variable to nil to save some time on
entry."
:group 'gnus-newsrc
:type 'boolean)
(defcustom gnus-save-newsrc-file t
"*Non-nil means that Gnus will save the `.newsrc' file.
Gnus always saves its own startup file, which is called
@ -223,12 +226,12 @@ not match this regexp will be removed before saving the list."
:type 'boolean)
(defcustom gnus-ignored-newsgroups
(purecopy (mapconcat 'identity
'("^to\\." ; not "real" groups
"^[0-9. \t]+ " ; all digits in name
"[][\"#'()]" ; bogus characters
)
"\\|"))
(mapconcat 'identity
'("^to\\." ; not "real" groups
"^[0-9. \t]+ " ; all digits in name
"^[\"][]\"[#'()]" ; bogus characters
)
"\\|")
"*A regexp to match uninteresting newsgroups in the active file.
Any lines in the active file matching this regular expression are
removed from the newsgroup list before anything else is done to it,
@ -244,7 +247,9 @@ inserts new groups at the beginning of the list of groups;
alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
for your decision; `gnus-subscribe-killed' kills all new groups;
`gnus-subscribe-zombies' will make all new groups into zombies."
`gnus-subscribe-zombies' will make all new groups into zombies;
`gnus-subscribe-topics' will enter groups into the topics that
claim them."
:group 'gnus-group-new
:type '(radio (function-item gnus-subscribe-randomly)
(function-item gnus-subscribe-alphabetically)
@ -252,6 +257,7 @@ for your decision; `gnus-subscribe-killed' kills all new groups;
(function-item gnus-subscribe-interactively)
(function-item gnus-subscribe-killed)
(function-item gnus-subscribe-zombies)
(function-item gnus-subscribe-topics)
function))
(defcustom gnus-subscribe-options-newsgroup-method
@ -360,7 +366,7 @@ This hook is called as the first thing when Gnus is started."
(defcustom gnus-after-getting-new-news-hook
(when (gnus-boundp 'display-time-timer)
'(display-time-event-handler))
"*A hook run after Gnus checks for new news."
"*A hook run after Gnus checks for new news when Gnus is already running."
:group 'gnus-group-new
:type 'hook)
@ -382,16 +388,13 @@ Can be used to turn version control on or off."
:type 'hook)
(defcustom gnus-always-read-dribble-file nil
"Uncoditionally read the dribble file."
"Unconditionally read the dribble file."
:group 'gnus-newsrc
:type 'boolean)
(defvar gnus-startup-file-coding-system 'binary
"*Coding system for startup file.")
(defvar gnus-startup-file-coding-system 'binary
"*Coding system for startup file.")
;;; Internal variables
(defvar gnus-newsrc-file-version nil)
@ -618,6 +621,7 @@ the first newsgroup."
gnus-newsgroup-unreads nil
nnoo-state-alist nil
gnus-current-select-method nil
nnmail-split-history nil
gnus-ephemeral-servers nil)
(gnus-shutdown 'gnus)
;; Kill the startup file.
@ -729,17 +733,14 @@ prompt the user for the name of an NNTP server to use."
;;;###autoload
(defun gnus-unload ()
"Unload all Gnus features."
"Unload all Gnus features.
\(For some value of `all' or `Gnus'.) Currently, features whose names
have prefixes `gnus-', `nn', `mm-' or `rfc' are unloaded. Use
cautiously -- unloading may cause trouble."
(interactive)
(unless (boundp 'load-history)
(error "Sorry, `gnus-unload' is not implemented in this Emacs version"))
(let ((history load-history)
feature)
(while history
(and (string-match "^\\(gnus\\|nn\\)" (caar history))
(setq feature (cdr (assq 'provide (car history))))
(unload-feature feature 'force))
(setq history (cdr history)))))
(dolist (feature features)
(if (string-match "^\\(gnus-\\|nn\\|mm-\\|rfc\\)" (symbol-name feature))
(unload-feature feature 'force))))
;;;
@ -788,7 +789,7 @@ prompt the user for the name of an NNTP server to use."
(erase-buffer)
(setq buffer-file-name dribble-file)
(auto-save-mode t)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(bury-buffer (current-buffer))
(set-buffer-modified-p nil)
(let ((auto (make-auto-save-file-name))
@ -858,7 +859,11 @@ prompt the user for the name of an NNTP server to use."
"Setup news information.
If RAWFILE is non-nil, the .newsrc file will also be read.
If LEVEL is non-nil, the news will be set up at level LEVEL."
(let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile)))))
(require 'nnmail)
(let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile))))
;; Binding this variable will inhibit multiple fetchings
;; of the same mail source.
(nnmail-fetched-sources (list t)))
(when init
;; Clear some variables to re-initialize news information.
@ -942,7 +947,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(defun gnus-find-new-newsgroups (&optional arg)
"Search for new newsgroups and add them.
Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.'
Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method'.
The `-n' option line from .newsrc is respected.
With 1 C-u, use the `ask-server' method to query the server for new
@ -953,16 +958,16 @@ for new groups, and subscribe the new groups as zombies."
(let* ((gnus-subscribe-newsgroup-method
gnus-subscribe-newsgroup-method)
(check (cond
((or (and (= (or arg 1) 4)
(not (listp gnus-check-new-newsgroups)))
(null gnus-read-active-file)
(eq gnus-read-active-file 'some))
'ask-server)
((= (or arg 1) 16)
(setq gnus-subscribe-newsgroup-method
'gnus-subscribe-zombies)
t)
(t gnus-check-new-newsgroups))))
((or (and (= (or arg 1) 4)
(not (listp gnus-check-new-newsgroups)))
(null gnus-read-active-file)
(eq gnus-read-active-file 'some))
'ask-server)
((= (or arg 1) 16)
(setq gnus-subscribe-newsgroup-method
'gnus-subscribe-zombies)
t)
(t gnus-check-new-newsgroups))))
(unless (gnus-check-first-time-used)
(if (or (consp check)
(eq check 'ask-server))
@ -1097,34 +1102,40 @@ for new groups, and subscribe the new groups as zombies."
hashtb))
(when new-newsgroups
(gnus-subscribe-hierarchical-interactive new-newsgroups)))
(if (> groups 0)
(gnus-message 5 "%d new newsgroup%s arrived"
groups (if (> groups 1) "s have" " has"))
(gnus-message 5 "No new newsgroups"))
(if (> groups 0)
(gnus-message 5 "%d new newsgroup%s arrived"
groups (if (> groups 1) "s have" " has"))
(gnus-message 5 "No new newsgroups"))
(when got-new
(setq gnus-newsrc-last-checked-date new-date))
got-new))
(defun gnus-check-first-time-used ()
(if (or (> (length gnus-newsrc-alist) 1)
(file-exists-p gnus-startup-file)
(file-exists-p (concat gnus-startup-file ".el"))
(file-exists-p (concat gnus-startup-file ".eld")))
nil
(catch 'ended
;; First check if any of the following files exist. If they do,
;; it's not the first time the user has used Gnus.
(dolist (file (list gnus-current-startup-file
(concat gnus-current-startup-file ".el")
(concat gnus-current-startup-file ".eld")
gnus-startup-file
(concat gnus-startup-file ".el")
(concat gnus-startup-file ".eld")))
(when (file-exists-p file)
(throw 'ended nil)))
(gnus-message 6 "First time user; subscribing you to default groups")
(unless (gnus-read-active-file-p)
(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)
;; Subscribe to the default newsgroups.
(let ((groups (or gnus-default-subscribed-newsgroups
gnus-backup-default-subscribed-newsgroups))
group)
(if (eq groups t)
nil
(setq groups (or groups gnus-backup-default-subscribed-newsgroups))
(when (eq groups t)
;; If t, we subscribe (or not) all groups as if they were new.
(mapatoms
(lambda (sym)
(if (null (setq group (symbol-name sym)))
()
(when (setq group (symbol-name sym))
(let ((do-sub (gnus-matches-options-n group)))
(cond
((eq do-sub 'subscribe)
@ -1135,23 +1146,25 @@ for new groups, and subscribe the new groups as zombies."
(t
(push group gnus-killed-list))))))
gnus-active-hashtb)
(while groups
(when (gnus-active (car groups))
(dolist (group groups)
;; Only subscribe the default groups that are activated.
(when (gnus-active group)
(gnus-group-change-level
(car groups) gnus-level-default-subscribed gnus-level-killed))
(setq groups (cdr groups)))
group gnus-level-default-subscribed gnus-level-killed)))
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-make-help-group))
(when gnus-novice-user
(gnus-message 7 "`A k' to list killed groups"))))))
(defun gnus-subscribe-group (group previous &optional method)
(defun gnus-subscribe-group (group &optional previous method)
"Subcribe GROUP and put it after PREVIOUS."
(gnus-group-change-level
(if method
(list t group gnus-level-default-subscribed nil nil method)
group)
gnus-level-default-subscribed gnus-level-killed previous t))
gnus-level-default-subscribed gnus-level-killed previous t)
t)
;; `gnus-group-change-level' is the fundamental function for changing
;; subscription levels of newsgroups. This might mean just changing
@ -1246,14 +1259,14 @@ for new groups, and subscribe the new groups as zombies."
(setq active (gnus-active group))
(setq num
(if active (- (1+ (cdr active)) (car active)) t))
;; Check whether the group is foreign. If so, the
;; foreign select method has to be entered into the
;; info.
(let ((method (or gnus-override-subscribe-method
(gnus-group-method group))))
(if (eq method gnus-select-method)
(setq info (list group level nil))
(setq info (list group level nil nil method)))))
;; Shorten the select method if possible, if we need to
;; store it at all (native groups).
(let ((method (gnus-method-simplify
(or gnus-override-subscribe-method
(gnus-group-method group)))))
(if method
(setq info (list group level nil nil method))
(setq info (list group level nil)))))
(unless previous
(setq previous
(let ((p gnus-newsrc-alist))
@ -1371,7 +1384,7 @@ newsgroup."
t)
(condition-case ()
(inline (gnus-request-group group dont-check method))
(error nil)
;;(error nil)
(quit nil))
(setq active (gnus-parse-active))
;; If there are no articles in the group, the GROUP
@ -1443,7 +1456,7 @@ newsgroup."
;; Then we want to peel off any elements that are higher
;; than the upper active limit.
(let ((srange range))
;; Go past all legal elements.
;; Go past all valid elements.
(while (and (cdr srange)
(<= (or (and (atom (cadr srange))
(cadr srange))
@ -1451,7 +1464,7 @@ newsgroup."
(cdr active)))
(setq srange (cdr srange)))
(when (cdr srange)
;; Nuke all remaining illegal elements.
;; Nuke all remaining invalid elements.
(setcdr srange nil))
;; Adjust the final element.
@ -1485,7 +1498,7 @@ newsgroup."
gnus-activate-foreign-newsgroups)
(t 0))
level))
info group active method)
scanned-methods info group active method retrievegroups)
(gnus-message 5 "Checking new news...")
(while newsrc
@ -1497,6 +1510,13 @@ newsgroup."
;; be reached) we just set the number of unread articles in this
;; newsgroup to t. This means that Gnus thinks that there are
;; unread articles, but it has no idea how many.
;; To be more explicit:
;; >0 for an active group with messages
;; 0 for an active group with no unread messages
;; nil for non-foreign groups that the user has requested not be checked
;; t for unchecked foreign groups or bogus groups, or groups that can't
;; be checked, for one reason or other.
(if (and (setq method (gnus-info-method info))
(not (inline
(gnus-server-equal
@ -1504,8 +1524,8 @@ newsgroup."
(setq method (gnus-server-get-method nil method)))))
(not (gnus-secondary-method-p method)))
;; These groups are foreign. Check the level.
(when (<= (gnus-info-level info) foreign-level)
(setq active (gnus-activate-group group 'scan))
(when (and (<= (gnus-info-level info) foreign-level)
(setq active (gnus-activate-group group 'scan)))
;; Let the Gnus agent save the active file.
(when (and gnus-agent gnus-plugged active)
(gnus-agent-save-group-info
@ -1516,18 +1536,76 @@ newsgroup."
"-request-update-info")))
(inline (gnus-request-update-info info method))))
;; These groups are native or secondary.
(when (and (<= (gnus-info-level info) level)
(not gnus-read-active-file))
(setq active (gnus-activate-group group 'scan))
(inline (gnus-close-group group))))
(cond
;; We don't want these groups.
((> (gnus-info-level info) level)
(setq active 'ignore))
;; Activate groups.
((not gnus-read-active-file)
(if (gnus-check-backend-function 'retrieve-groups group)
;; if server support gnus-retrieve-groups we push
;; the group onto retrievegroups for later checking
(if (assoc method retrievegroups)
(setcdr (assoc method retrievegroups)
(cons group (cdr (assoc method retrievegroups))))
(push (list method group) retrievegroups))
;; hack: `nnmail-get-new-mail' changes the mail-source depending
;; on the group, so we must perform a scan for every group
;; if the users has any directory mail sources.
;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil,
;; for it scan all spool files even when the groups are
;; not required.
(if (and
(or nnmail-scan-directory-mail-source-once
(null (assq 'directory
(or mail-sources
(if (listp nnmail-spool-file)
nnmail-spool-file
(list nnmail-spool-file))))))
(member method scanned-methods))
(setq active (gnus-activate-group group))
(setq active (gnus-activate-group group 'scan))
(push method scanned-methods))
(when active
(gnus-close-group group))))))
;; Get the number of unread articles in the group.
(if active
(inline (gnus-get-unread-articles-in-group info active t))
(cond
((eq active 'ignore)
;; Don't do anything.
)
(active
(inline (gnus-get-unread-articles-in-group info active t)))
(t
;; The group couldn't be reached, so we nix out the number of
;; unread articles and stuff.
(gnus-set-active group nil)
(setcar (gnus-gethash group gnus-newsrc-hashtb) t)))
(let ((tmp (gnus-gethash group gnus-newsrc-hashtb)))
(if tmp (setcar tmp t))))))
;; iterate through groups on methods which support gnus-retrieve-groups
;; and fetch a partial active file and use it to find new news.
(while retrievegroups
(let* ((mg (pop retrievegroups))
(method (or (car mg) gnus-select-method))
(groups (cdr mg)))
(when (gnus-check-server method)
;; Request that the backend scan its incoming messages.
(when (gnus-check-backend-function 'request-scan (car method))
(gnus-request-scan nil method))
(gnus-read-active-file-2 (mapcar (lambda (group)
(gnus-group-real-name group))
groups) method)
(dolist (group groups)
(cond
((setq active (gnus-active (gnus-info-group
(setq info (gnus-get-info group)))))
(inline (gnus-get-unread-articles-in-group info active t)))
(t
;; The group couldn't be reached, so we nix out the number of
;; unread articles and stuff.
(gnus-set-active group nil)
(setcar (gnus-gethash group gnus-newsrc-hashtb) t)))))))
(gnus-message 5 "Checking new news...done")))
@ -1635,85 +1713,90 @@ newsgroup."
(defun gnus-read-active-file (&optional force not-native)
(gnus-group-set-mode-line)
(let ((methods
(append
(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
;; secondary ones.
gnus-secondary-select-methods)
;; Also read from the archive server.
(when (gnus-archive-server-wanted-p)
(list "archive"))))
list-type)
(mapcar
(lambda (m) (if (stringp m) (gnus-server-get-method nil m) m))
(append
(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
;; secondary ones.
gnus-secondary-select-methods)
;; Also read from the archive server.
(when (gnus-archive-server-wanted-p)
(list "archive")))))
method)
(setq gnus-have-read-active-file nil)
(save-excursion
(set-buffer nntp-server-buffer)
(while methods
(let* ((method (if (stringp (car methods))
(gnus-server-get-method nil (car methods))
(car methods)))
(where (nth 1 method))
(mesg (format "Reading active file%s via %s..."
(if (and where (not (zerop (length where))))
(concat " from " where) "")
(car method))))
(while (setq method (pop methods))
;; Only do each method once, in case the methods appear more
;; than once in this list.
(unless (member method methods)
(condition-case ()
(gnus-read-active-file-1 method force)
;; We catch C-g so that we can continue past servers
;; that do not respond.
(quit nil)))))))
(defun gnus-read-active-file-1 (method force)
(let (where mesg)
(setq where (nth 1 method)
mesg (format "Reading active file%s via %s..."
(if (and where (not (zerop (length where))))
(concat " from " where) "")
(car method)))
(gnus-message 5 mesg)
(when (gnus-check-server method)
;; Request that the backend scan its incoming messages.
(when (gnus-check-backend-function 'request-scan (car method))
(gnus-request-scan nil method))
(cond
((and (eq gnus-read-active-file 'some)
(gnus-check-backend-function 'retrieve-groups (car method))
(not force))
(let ((newsrc (cdr gnus-newsrc-alist))
(gmethod (gnus-server-get-method nil method))
groups info)
(while (setq info (pop newsrc))
(when (inline
(gnus-server-equal
(inline
(gnus-find-method-for-group
(gnus-info-group info) info))
gmethod))
(push (gnus-group-real-name (gnus-info-group info))
groups)))
(gnus-read-active-file-2 groups method)))
((null method)
t)
(t
(if (not (gnus-request-list method))
(unless (equal method gnus-message-archive-method)
(gnus-error 1 "Cannot read active file from %s server"
(car method)))
(gnus-message 5 mesg)
(when (gnus-check-server method)
;; Request that the backend scan its incoming messages.
(when (gnus-check-backend-function 'request-scan (car method))
(gnus-request-scan nil method))
(cond
((and (eq gnus-read-active-file 'some)
(gnus-check-backend-function 'retrieve-groups (car method))
(not force))
(let ((newsrc (cdr gnus-newsrc-alist))
(gmethod (gnus-server-get-method nil method))
groups info)
(while (setq info (pop newsrc))
(when (inline
(gnus-server-equal
(inline
(gnus-find-method-for-group
(gnus-info-group info) info))
gmethod))
(push (gnus-group-real-name (gnus-info-group info))
groups)))
(when groups
(gnus-check-server method)
(setq list-type (gnus-retrieve-groups groups method))
(cond
((not list-type)
(gnus-error
1.2 "Cannot read partial active file from %s server."
(car method)))
((eq list-type 'active)
(gnus-active-to-gnus-format
method gnus-active-hashtb nil t))
(t
(gnus-groups-to-gnus-format
method gnus-active-hashtb t))))))
((null method)
t)
(t
(if (not (gnus-request-list method))
(unless (equal method gnus-message-archive-method)
(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 nil t)
;; We mark this active file as read.
(push method gnus-have-read-active-file)
(gnus-message 5 "%sdone" mesg))))))
(setq methods (cdr methods))))))
(gnus-active-to-gnus-format method gnus-active-hashtb nil t)
;; We mark this active file as read.
(push method gnus-have-read-active-file)
(gnus-message 5 "%sdone" mesg)))))))
(defun gnus-ignored-newsgroups-has-to-p ()
"Non-nil iff gnus-ignored-newsgroups includes \"^to\\\\.\" as an element."
;; note this regexp is the same as:
;; (concat (regexp-quote "^to\\.") "\\($\\|" (regexp-quote "\\|") "\\)")
(string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" gnus-ignored-newsgroups))
(defun gnus-read-active-file-2 (groups method)
"Read an active file for GROUPS in METHOD using gnus-retrieve-groups."
(when groups
(save-excursion
(set-buffer nntp-server-buffer)
(gnus-check-server method)
(let ((list-type (gnus-retrieve-groups groups method)))
(cond ((not list-type)
(gnus-error
1.2 "Cannot read partial active file from %s server."
(car method)))
((eq list-type 'active)
(gnus-active-to-gnus-format method gnus-active-hashtb nil t))
(t
(gnus-groups-to-gnus-format method gnus-active-hashtb t)))))))
;; Read an active file and place the results in `gnus-active-hashtb'.
(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors
@ -1732,22 +1815,22 @@ newsgroup."
(gnus-make-hashtable 4096)))))))
;; Delete unnecessary lines.
(goto-char (point-min))
(cond ((gnus-ignored-newsgroups-has-to-p)
(delete-matching-lines gnus-ignored-newsgroups))
((string= gnus-ignored-newsgroups "")
(delete-matching-lines "^to\\."))
(t
(delete-matching-lines (concat "^to\\.\\|"
gnus-ignored-newsgroups))))
(cond
((string= gnus-ignored-newsgroups "")
(delete-matching-lines "^to\\."))
(t
(delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups))))
;; Make the group names readable as a lisp expression even if they
;; contain special characters.
(goto-char (point-max))
(while (re-search-backward "[][';?()#]" nil t)
(insert ?\\))
(goto-char (point-min))
(unless (re-search-forward "[\\\"]" nil t)
;; Make the group names readable as a lisp expression even if they
;; contain special characters.
(goto-char (point-max))
(while (re-search-backward "[][';?()#]" nil t)
(insert ?\\)))
;; Let the Gnus agent save the active file.
(when (and gnus-agent real-active)
(when (and gnus-agent real-active gnus-plugged)
(gnus-agent-save-active method))
;; If these are groups from a foreign select method, we insert the
@ -1758,30 +1841,37 @@ newsgroup."
(let ((prefix (gnus-group-prefixed-name "" method)))
(goto-char (point-min))
(while (and (not (eobp))
(progn (insert prefix)
(zerop (forward-line 1)))))))
(progn
(when (= (following-char) ?\")
(forward-char 1))
(insert prefix)
(zerop (forward-line 1)))))))
;; Store the active file in a hash table.
(goto-char (point-min))
(let (group max min)
(while (not (eobp))
(condition-case ()
(condition-case err
(progn
(narrow-to-region (point) (gnus-point-at-eol))
;; group gets set to a symbol interned in the hash table
;; (what a hack!!) - jwz
(setq group (let ((obarray hashtb)) (read cur)))
;; ### The extended group name scheme makes
;; the previous optimization strategy sort of pointless...
(when (stringp group)
(setq group (intern group hashtb)))
(if (and (numberp (setq max (read cur)))
(numberp (setq min (read cur)))
(progn
(skip-chars-forward " \t")
(not
(or (= (following-char) ?=)
(= (following-char) ?x)
(= (following-char) ?j)))))
(or (eq (char-after) ?=)
(eq (char-after) ?x)
(eq (char-after) ?j)))))
(progn
(set group (cons min max))
;; if group is moderated, stick in moderation table
(when (= (following-char) ?m)
(when (eq (char-after) ?m)
(unless gnus-moderated-hashtb
(setq gnus-moderated-hashtb (gnus-make-hashtable)))
(gnus-sethash (symbol-name group) t
@ -1792,7 +1882,7 @@ newsgroup."
(symbolp group)
(set group nil))
(unless ignore-errors
(gnus-message 3 "Warning - illegal active: %s"
(gnus-message 3 "Warning - invalid active: %s"
(buffer-substring
(gnus-point-at-bol) (gnus-point-at-eol))))))
(widen)
@ -1814,39 +1904,44 @@ newsgroup."
(gnus-group-prefixed-name "" method))))
;; Let the Gnus agent save the active file.
(when (and gnus-agent real-active)
(gnus-agent-save-groups method))
(goto-char (point-min))
;; We split this into to separate loops, one with the prefix
;; and one without to speed the reading up somewhat.
(if prefix
(let (min max opoint group)
(if (and gnus-agent
real-active
gnus-plugged
(gnus-agent-method-p method))
(progn
(gnus-agent-save-groups method)
(gnus-active-to-gnus-format method hashtb nil real-active))
(goto-char (point-min))
;; We split this into to separate loops, one with the prefix
;; and one without to speed the reading up somewhat.
(if prefix
(let (min max opoint group)
(while (not (eobp))
(condition-case ()
(progn
(read cur) (read cur)
(setq min (read cur)
max (read cur)
opoint (point))
(skip-chars-forward " \t")
(insert prefix)
(goto-char opoint)
(set (let ((obarray hashtb)) (read cur))
(cons min max)))
(error (and group (symbolp group) (set group nil))))
(forward-line 1)))
(let (min max group)
(while (not (eobp))
(condition-case ()
(progn
(when (eq (char-after) ?2)
(read cur) (read cur)
(setq min (read cur)
max (read cur)
opoint (point))
(skip-chars-forward " \t")
(insert prefix)
(goto-char opoint)
(set (let ((obarray hashtb)) (read cur))
max (read cur))
(set (setq group (let ((obarray hashtb)) (read cur)))
(cons min max)))
(error (and group (symbolp group) (set group nil))))
(forward-line 1)))
(let (min max group)
(while (not (eobp))
(condition-case ()
(when (= (following-char) ?2)
(read cur) (read cur)
(setq min (read cur)
max (read cur))
(set (setq group (let ((obarray hashtb)) (read cur)))
(cons min max)))
(error (and group (symbolp group) (set group nil))))
(forward-line 1))))))
(forward-line 1)))))))
(defun gnus-read-newsrc-file (&optional force)
"Read startup file.
@ -1864,7 +1959,8 @@ If FORCE is non-nil, the .newsrc file is read."
;; file (ticked articles, killed groups, foreign methods, etc.)
(gnus-read-newsrc-el-file quick-file)
(when (and (file-exists-p gnus-current-startup-file)
(when (and gnus-read-newsrc-file
(file-exists-p gnus-current-startup-file)
(or force
(and (file-newer-than-file-p newsrc-file quick-file)
(file-newer-than-file-p newsrc-file
@ -1880,7 +1976,7 @@ If FORCE is non-nil, the .newsrc file is read."
(save-excursion
(gnus-message 5 "Reading %s..." newsrc-file)
(set-buffer (nnheader-find-file-noselect newsrc-file))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(gnus-newsrc-to-gnus-format)
(kill-buffer (current-buffer))
(gnus-message 5 "Reading %s...done" newsrc-file)))
@ -2056,7 +2152,7 @@ If FORCE is non-nil, the .newsrc file is read."
(unless (boundp symbol)
(set symbol nil))
;; It was a group name.
(setq subscribed (= (following-char) ?:)
(setq subscribed (eq (char-after) ?:)
group (symbol-name symbol)
reads nil)
(if (eolp)
@ -2080,7 +2176,7 @@ If FORCE is non-nil, the .newsrc file is read."
(read buf)))
(widen)
;; If the next character is a dash, then this is a range.
(if (= (following-char) ?-)
(if (eq (char-after) ?-)
(progn
;; We read the upper bound of the range.
(forward-char 1)
@ -2102,8 +2198,8 @@ If FORCE is non-nil, the .newsrc file is read."
(push num1 reads))
;; If the next char in ?\n, then we have reached the end
;; of the line and return nil.
(/= (following-char) ?\n))
((= (following-char) ?\n)
(not (eq (char-after) ?\n)))
((eq (char-after) ?\n)
;; End of line, so we end.
nil)
(t
@ -2117,7 +2213,7 @@ If FORCE is non-nil, the .newsrc file is read."
(buffer-substring (gnus-point-at-bol)
(gnus-point-at-eol))))
nil))
;; Skip past ", ". Spaces are illegal in these ranges, but
;; Skip past ", ". Spaces are invalid in these ranges, but
;; we allow them, because it's a common mistake to put a
;; space after the comma.
(skip-chars-forward ", "))
@ -2229,7 +2325,7 @@ If FORCE is non-nil, the .newsrc file is read."
(gnus-point-at-eol)))
;; Search for all "words"...
(while (re-search-forward "[^ \t,\n]+" eol t)
(if (= (char-after (match-beginning 0)) ?!)
(if (eq (char-after (match-beginning 0)) ?!)
;; If the word begins with a bang (!), this is a "not"
;; spec. We put this spec (minus the bang) and the
;; symbol `ignore' into the list.
@ -2277,7 +2373,7 @@ If FORCE is non-nil, the .newsrc file is read."
(setq buffer-file-name
(concat gnus-current-startup-file ".eld"))
(setq default-directory (file-name-directory buffer-file-name))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
(gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
(gnus-gnus-to-quick-newsrc-format)
@ -2294,6 +2390,7 @@ If FORCE is non-nil, the .newsrc file is read."
"Insert Gnus variables such as gnus-newsrc-alist in lisp format."
(let ((print-quoted t)
(print-escape-newlines t))
(insert ";; -*- emacs-lisp -*-\n")
(insert ";; Gnus startup file.\n")
(insert "\
@ -2341,7 +2438,7 @@ If FORCE is non-nil, the .newsrc file is read."
info ranges range method)
(setq buffer-file-name gnus-current-startup-file)
(setq default-directory (file-name-directory buffer-file-name))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
;; Write options.
(when gnus-newsrc-options
@ -2404,12 +2501,13 @@ If FORCE is non-nil, the .newsrc file is read."
(save-excursion
(set-buffer gnus-dribble-buffer)
(let ((slave-name
(make-temp-file (concat gnus-current-startup-file "-slave-")))
(make-temp-name (concat gnus-current-startup-file "-slave-")))
(modes (ignore-errors
(file-modes (concat gnus-current-startup-file ".eld")))))
(let ((coding-system-for-write gnus-startup-file-coding-system))
(gnus-write-buffer slave-name))
(when modes
(set-file-modes slave-name modes))
(gnus-write-buffer slave-name))))
(set-file-modes slave-name modes)))))
(defun gnus-master-read-slave-newsrc ()
(let ((slave-files
@ -2427,7 +2525,6 @@ If FORCE is non-nil, the .newsrc file is read."
(gnus-message 7 "Reading slave newsrcs...")
(save-excursion
(set-buffer (gnus-get-buffer-create " *gnus slave*"))
(buffer-disable-undo (current-buffer))
(setq slave-files
(sort (mapcar (lambda (file)
(list (nth 5 (file-attributes file)) file))
@ -2438,7 +2535,7 @@ If FORCE is non-nil, the .newsrc file is read."
(while slave-files
(erase-buffer)
(setq file (nth 1 (car slave-files)))
(insert-file-contents file)
(nnheader-insert-file-contents file)
(when (condition-case ()
(progn
(eval-buffer (current-buffer))
@ -2485,6 +2582,8 @@ If FORCE is non-nil, the .newsrc file is read."
(gnus-message 5 "Reading descriptions file via %s..." (car method))
(cond
((null (gnus-get-function method 'request-list-newsgroups t))
t)
((not (gnus-check-server method))
(gnus-message 1 "Couldn't open server")
nil)
@ -2529,12 +2628,13 @@ If FORCE is non-nil, the .newsrc file is read."
(let ((str (buffer-substring
(point) (progn (end-of-line) (point))))
(coding
(and (boundp 'enable-multibyte-characters)
enable-multibyte-characters
(and (or gnus-xemacs
(and (boundp 'enable-multibyte-characters)
enable-multibyte-characters))
(fboundp 'gnus-mule-get-coding-system)
(gnus-mule-get-coding-system (symbol-name group)))))
(if coding
(setq str (gnus-decode-coding-string str (car coding))))
(when coding
(setq str (mm-decode-coding-string str (car coding))))
(set group str)))
(forward-line 1))))
(gnus-message 5 "Reading descriptions file...done")
@ -2554,7 +2654,8 @@ If FORCE is non-nil, the .newsrc file is read."
"Declare backend NAME with ABILITIES as a Gnus backend."
(setq gnus-valid-select-methods
(nconc gnus-valid-select-methods
(list (apply 'list name abilities)))))
(list (apply 'list name abilities))))
(gnus-redefine-select-method-widget))
(defun gnus-set-default-directory ()
"Set the default directory in the current buffer to `gnus-default-directory'.

1797
lisp/gnus/gnus-sum.el
View File

File diff suppressed because it is too large Load Diff

290
lisp/gnus/gnus-topic.el
View File

@ -1,5 +1,6 @@
;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Ilja Weis <kult@uni-paderborn.de>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -28,8 +29,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-group)
(require 'gnus-start)
@ -151,11 +150,20 @@ with some simple extensions.
(gnus-group-topic group))))
(defun gnus-topic-goto-topic (topic)
"Go to TOPIC."
(when topic
(gnus-goto-char (text-property-any (point-min) (point-max)
'gnus-topic (intern topic)))))
(defun gnus-topic-jump-to-topic (topic)
"Go to TOPIC."
(interactive
(list (completing-read "Go to topic: "
(mapcar 'list (gnus-topic-list))
nil t)))
(dolist (topic (gnus-current-topics topic))
(gnus-topic-fold t))
(gnus-topic-goto-topic topic))
(defun gnus-current-topic ()
"Return the name of the current topic."
(let ((result
@ -205,16 +213,17 @@ If TOPIC, start with that topic."
(if (member group gnus-zombie-list)
gnus-level-zombie gnus-level-killed))))
(and
unread ; nil means that the group is dead.
info ; nil means that the group is dead.
(<= clevel level)
(>= clevel lowest) ; Is inside the level we want.
(or all
(if (eq unread t)
(if (or (eq unread t)
(eq unread nil))
gnus-group-list-inactive-groups
(> unread 0))
(and gnus-list-groups-with-ticked-articles
(cdr (assq 'tick (gnus-info-marks info))))
; Has right readedness.
;; Has right readedness.
;; Check for permanent visibility.
(and gnus-permanently-visible-groups
(string-match gnus-permanently-visible-groups group))
@ -363,7 +372,8 @@ If TOPIC, start with that topic."
;;; Generating group buffers
(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
(defun gnus-group-prepare-topics (level &optional all lowest
regexp list-topic topic-level)
"List all newsgroups with unread articles of level LEVEL or lower.
Use the `gnus-group-topics' to sort the groups.
If ALL is non-nil, list groups that have no unread articles.
@ -418,7 +428,7 @@ articles in the topic and its subtopics."
(entries (gnus-topic-find-groups
(car type) list-level
(or all
(cdr (assq 'visible
(cdr (assq 'visible
(gnus-topic-hierarchical-parameters
(car type)))))
lowest))
@ -446,7 +456,8 @@ articles in the topic and its subtopics."
(if (stringp entry)
;; Dead groups.
(gnus-group-insert-group-line
entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed)
entry (if (member entry gnus-zombie-list)
gnus-level-zombie gnus-level-killed)
nil (- (1+ (cdr (setq active (gnus-active entry))))
(car active))
nil)
@ -494,7 +505,7 @@ articles in the topic and its subtopics."
(let ((data (cadr (gnus-topic-find-topology topic))))
(setcdr data
(list (if insert 'visible 'invisible)
(if hide 'hide nil)
(caddr data)
(cadddr data))))
(if total-remove
(setq gnus-topic-alist
@ -507,9 +518,9 @@ articles in the topic and its subtopics."
(car gnus-group-list-mode) (cdr gnus-group-list-mode)
nil nil topic level))
(defun gnus-topic-fold (&optional insert)
(defun gnus-topic-fold (&optional insert topic)
"Remove/insert the current topic."
(let ((topic (gnus-group-topic-name)))
(let ((topic (or topic (gnus-group-topic-name))))
(when topic
(save-excursion
(if (not (gnus-group-active-topic-p))
@ -533,15 +544,16 @@ articles in the topic and its subtopics."
(gnus-topic-update-unreads name unread)
(beginning-of-line)
;; Insert the text.
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(eval gnus-topic-line-format-spec))
(list 'gnus-topic (intern name)
'gnus-topic-level level
'gnus-topic-unread unread
'gnus-active active-topic
'gnus-topic-visible visiblep))))
(if shownp
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(eval gnus-topic-line-format-spec))
(list 'gnus-topic (intern name)
'gnus-topic-level level
'gnus-topic-unread unread
'gnus-active active-topic
'gnus-topic-visible visiblep)))))
(defun gnus-topic-update-unreads (topic unreads)
(setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
@ -584,7 +596,8 @@ articles in the topic and its subtopics."
(let* ((topic (gnus-group-topic group))
(groups (cdr (assoc topic gnus-topic-alist)))
(g (cdr (member group groups)))
(unfound t))
(unfound t)
entry)
;; Try to jump to a visible group.
(while (and g (not (gnus-group-goto-group (car g) t)))
(pop g))
@ -598,8 +611,20 @@ articles in the topic and its subtopics."
(when (and unfound
topic
(not (gnus-topic-goto-missing-topic topic)))
(gnus-topic-insert-topic-line
topic t t (car (gnus-topic-find-topology topic)) nil 0)))))
(let* ((top (gnus-topic-find-topology topic))
(children (cddr top))
(type (cadr top))
(unread 0)
(entries (gnus-topic-find-groups
(car type) (car gnus-group-list-mode)
(cdr gnus-group-list-mode))))
(while children
(incf unread (gnus-topic-unread (caar (pop children)))))
(while (setq entry (pop entries))
(when (numberp (car entry))
(incf unread (car entry))))
(gnus-topic-insert-topic-line
topic t t (car (gnus-topic-find-topology topic)) nil unread))))))
(defun gnus-topic-goto-missing-topic (topic)
(if (gnus-topic-goto-topic topic)
@ -608,15 +633,18 @@ articles in the topic and its subtopics."
(let* ((top (gnus-topic-find-topology
(gnus-topic-parent-topic topic)))
(tp (reverse (cddr top))))
(while (not (equal (caaar tp) topic))
(setq tp (cdr tp)))
(pop tp)
(while (and tp
(not (gnus-topic-goto-topic (caaar tp))))
(pop tp))
(if tp
(gnus-topic-forward-topic 1)
(gnus-topic-goto-missing-topic (caadr top))))
(if (not top)
(gnus-topic-insert-topic-line
topic t t (car (gnus-topic-find-topology topic)) nil 0)
(while (not (equal (caaar tp) topic))
(setq tp (cdr tp)))
(pop tp)
(while (and tp
(not (gnus-topic-goto-topic (caaar tp))))
(pop tp))
(if tp
(gnus-topic-forward-topic 1)
(gnus-topic-goto-missing-topic (caadr top)))))
nil))
(defun gnus-topic-update-topic-line (topic-name &optional reads)
@ -908,6 +936,7 @@ articles in the topic and its subtopics."
"=" gnus-topic-select-group
"\r" gnus-topic-select-group
" " gnus-topic-read-group
"\C-c\C-x" gnus-topic-expire-articles
"\C-k" gnus-topic-kill-group
"\C-y" gnus-topic-yank-group
"\M-g" gnus-topic-get-new-news-this-topic
@ -931,6 +960,7 @@ articles in the topic and its subtopics."
"c" gnus-topic-copy-group
"h" gnus-topic-hide-topic
"s" gnus-topic-show-topic
"j" gnus-topic-jump-to-topic
"M" gnus-topic-move-matching
"C" gnus-topic-copy-matching
"\C-i" gnus-topic-indent
@ -962,6 +992,7 @@ articles in the topic and its subtopics."
["Copy matching" gnus-topic-copy-matching t]
["Move matching" gnus-topic-move-matching t])
("Topics"
["Goto" gnus-topic-jump-to-topic t]
["Show" gnus-topic-show-topic t]
["Hide" gnus-topic-hide-topic t]
["Delete" gnus-topic-delete t]
@ -969,6 +1000,7 @@ articles in the topic and its subtopics."
["Create" gnus-topic-create-topic t]
["Mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t]
["Sort" gnus-topic-sort-topics 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]))))
@ -982,12 +1014,15 @@ articles in the topic and its subtopics."
(if (null arg) (not gnus-topic-mode)
(> (prefix-numeric-value arg) 0)))
;; Infest Gnus with topics.
(if (not 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))
(gnus-set-format 'topic t)
(gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
(gnus-add-minor-mode 'gnus-topic-mode " Topic"
gnus-topic-mode-map nil (lambda (&rest junk)
(interactive)
(gnus-topic-mode nil t)))
(add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
(set (make-local-variable 'gnus-group-prepare-function)
'gnus-group-prepare-topics)
@ -1032,7 +1067,8 @@ If performed over a topic line, toggle folding the topic."
(if (gnus-group-topic-p)
(let ((gnus-group-list-mode
(if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
(gnus-topic-fold all))
(gnus-topic-fold all)
(gnus-dribble-touch))
(gnus-group-select-group all)))
(defun gnus-mouse-pick-topic (e)
@ -1041,6 +1077,19 @@ If performed over a topic line, toggle folding the topic."
(mouse-set-point e)
(gnus-topic-read-group nil))
(defun gnus-topic-expire-articles (topic)
"Expire articles in this topic or group."
(interactive (list (gnus-group-topic-name)))
(if (not topic)
(call-interactively 'gnus-group-expire-articles)
(save-excursion
(gnus-message 5 "Expiring groups in %s..." topic)
(let ((gnus-group-marked
(mapcar (lambda (entry) (car (nth 2 entry)))
(gnus-topic-find-groups topic gnus-level-killed t))))
(gnus-group-expire-articles nil))
(gnus-message 5 "Expiring groups in %s...done" topic))))
(defun gnus-topic-read-group (&optional all no-article group)
"Read news in this newsgroup.
If the prefix argument ALL is non-nil, already read articles become
@ -1086,44 +1135,60 @@ When used interactively, PARENT will be the topic under point."
(gnus-group-list-groups)
(gnus-topic-goto-topic topic))
;; FIXME:
;; 1. When the marked groups are overlapped with the process
;; region, the behavior of move or remove is not right.
;; 2. Can't process on several marked groups with a same name,
;; because gnus-group-marked only keeps one copy.
(defun gnus-topic-move-group (n topic &optional copyp)
"Move the next N groups to TOPIC.
If COPYP, copy the groups instead."
(interactive
(list current-prefix-arg
(completing-read "Move to topic: " gnus-topic-alist nil t)))
(let ((groups (gnus-group-process-prefix n))
(let ((use-marked (and (not n) (not (gnus-region-active-p))
gnus-group-marked t))
(groups (gnus-group-process-prefix n))
(topicl (assoc topic gnus-topic-alist))
(start-group (progn (forward-line 1) (gnus-group-group-name)))
(start-topic (gnus-group-topic-name))
(start-group (progn (forward-line 1) (gnus-group-group-name)))
entry)
(mapcar
(lambda (g)
(gnus-group-remove-mark g)
(when (and
(setq entry (assoc (gnus-current-topic) gnus-topic-alist))
(not copyp))
(setcdr entry (gnus-delete-first g (cdr entry))))
(nconc topicl (list g)))
groups)
(gnus-topic-enter-dribble)
(if start-group
(gnus-group-goto-group start-group)
(gnus-topic-goto-topic start-topic))
(gnus-group-list-groups)))
(if (and (not groups) (not copyp) start-topic)
(gnus-topic-move start-topic topic)
(mapcar
(lambda (g)
(gnus-group-remove-mark g use-marked)
(when (and
(setq entry (assoc (gnus-current-topic) gnus-topic-alist))
(not copyp))
(setcdr entry (gnus-delete-first g (cdr entry))))
(nconc topicl (list g)))
groups)
(gnus-topic-enter-dribble)
(if start-group
(gnus-group-goto-group start-group)
(gnus-topic-goto-topic start-topic))
(gnus-group-list-groups))))
(defun gnus-topic-remove-group (&optional arg)
(defun gnus-topic-remove-group (&optional n)
"Remove the current group from the topic."
(interactive "P")
(gnus-group-iterate arg
(lambda (group)
(let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
(buffer-read-only nil))
(when (and topicl group)
(gnus-delete-line)
(gnus-delete-first group topicl))
(gnus-topic-update-topic)
(gnus-group-position-point)))))
(let ((use-marked (and (not n) (not (gnus-region-active-p))
gnus-group-marked t))
(groups (gnus-group-process-prefix n)))
(mapcar
(lambda (group)
(gnus-group-remove-mark group use-marked)
(let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
(buffer-read-only nil))
(when (and topicl group)
(gnus-delete-line)
(gnus-delete-first group topicl))
(gnus-topic-update-topic)))
groups)
(gnus-topic-enter-dribble)
(gnus-group-position-point)))
(defun gnus-topic-copy-group (n topic)
"Copy the current group to a topic."
@ -1145,7 +1210,12 @@ If COPYP, copy the groups instead."
(gnus-topic-find-topology topic nil nil gnus-topic-topology)
(gnus-topic-enter-dribble))
(gnus-group-kill-group n discard)
(gnus-topic-update-topic)))
(if (not (gnus-group-topic-p))
(gnus-topic-update-topic)
;; Move up one line so that we update the right topic.
(forward-line -1)
(gnus-topic-update-topic)
(forward-line 1))))
(defun gnus-topic-yank-group (&optional arg)
"Yank the last topic."
@ -1195,18 +1265,32 @@ If COPYP, copy the groups instead."
(setq alist (cdr alist))))))
(gnus-topic-update-topic)))
(defun gnus-topic-hide-topic ()
"Hide the current topic."
(interactive)
(defun gnus-topic-hide-topic (&optional permanent)
"Hide the current topic.
If PERMANENT, make it stay hidden in subsequent sessions as well."
(interactive "P")
(when (gnus-current-topic)
(gnus-topic-goto-topic (gnus-current-topic))
(gnus-topic-remove-topic nil nil 'hidden)))
(if permanent
(setcar (cddr
(cadr
(gnus-topic-find-topology (gnus-current-topic))))
'hidden))
(gnus-topic-remove-topic nil nil)))
(defun gnus-topic-show-topic ()
"Show the hidden topic."
(interactive)
(defun gnus-topic-show-topic (&optional permanent)
"Show the hidden topic.
If PERMANENT, make it stay shown in subsequent sessions as well."
(interactive "P")
(when (gnus-group-topic-p)
(gnus-topic-remove-topic t nil 'shown)))
(if (not permanent)
(gnus-topic-remove-topic t nil)
(let ((topic
(gnus-topic-find-topology
(completing-read "Show topic: " gnus-topic-alist nil t))))
(setcar (cddr (cadr topic)) nil)
(setcar (cdr (cadr topic)) 'visible)
(gnus-group-list-groups)))))
(defun gnus-topic-mark-topic (topic &optional unmark)
"Mark all groups in the topic with the process mark."
@ -1450,6 +1534,68 @@ If REVERSE, sort in reverse order."
(interactive "P")
(gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
(defun gnus-topic-sort-topics-1 (top reverse)
(if (cdr top)
(let ((subtop
(mapcar `(lambda (top)
(gnus-topic-sort-topics-1 top ,reverse))
(sort (cdr top)
'(lambda (t1 t2)
(string-lessp (caar t1) (caar t2)))))))
(setcdr top (if reverse (reverse subtop) subtop))))
top)
(defun gnus-topic-sort-topics (&optional topic reverse)
"Sort topics in TOPIC alphabeticaly by topic name.
If REVERSE, reverse the sorting order."
(interactive
(list (completing-read "Sort topics in : " gnus-topic-alist nil t
(gnus-current-topic))
current-prefix-arg))
(let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
gnus-topic-topology)))
(gnus-topic-sort-topics-1 topic-topology reverse)
(gnus-topic-enter-dribble)
(gnus-group-list-groups)
(gnus-topic-goto-topic topic)))
(defun gnus-topic-move (current to)
"Move the CURRENT topic to TO."
(interactive
(list
(gnus-group-topic-name)
(completing-read "Move to topic: " gnus-topic-alist nil t)))
(unless (and current to)
(error "Can't find topic"))
(let ((current-top (cdr (gnus-topic-find-topology current)))
(to-top (cdr (gnus-topic-find-topology to))))
(unless current-top
(error "Can't find topic `%s'" current))
(unless to-top
(error "Can't find topic `%s'" to))
(if (gnus-topic-find-topology to current-top 0);; Don't care the level
(error "Can't move `%s' to its sub-level" current))
(gnus-topic-find-topology current nil nil 'delete)
(while (cdr to-top)
(setq to-top (cdr to-top)))
(setcdr to-top (list current-top))
(gnus-topic-enter-dribble)
(gnus-group-list-groups)
(gnus-topic-goto-topic current)))
(defun gnus-subscribe-topics (newsgroup)
(catch 'end
(let (match gnus-group-change-level-function)
(dolist (topic (gnus-topic-list))
(when (and (setq match (cdr (assq 'subscribe
(gnus-topic-parameters topic))))
(string-match match newsgroup))
;; Just subscribe the group.
(gnus-subscribe-alphabetically newsgroup)
;; Add the group to the topic.
(nconc (assoc topic gnus-topic-alist) (list newsgroup))
(throw 'end t))))))
(provide 'gnus-topic)
;;; gnus-topic.el ends here

16
lisp/gnus/gnus-undo.el
View File

@ -1,5 +1,7 @@
;;; gnus-undo.el --- minor mode for undoing in Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -46,8 +48,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus-util)
(require 'gnus)
(require 'custom)
@ -86,11 +86,11 @@
(setq gnus-undo-mode-map (make-sparse-keymap))
(gnus-define-keys gnus-undo-mode-map
"\M-\C-_" gnus-undo
"\C-_" gnus-undo
"\C-xu" gnus-undo
;; many people are used to type `C-/' on X terminals and get `C-_'.
[(control /)] gnus-undo))
"\M-\C-_" gnus-undo
"\C-_" gnus-undo
"\C-xu" gnus-undo
;; 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.

377
lisp/gnus/gnus-util.el
View File

@ -1,5 +1,6 @@
;;; gnus-util.el --- utility functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -33,12 +34,10 @@
(require 'custom)
(eval-when-compile (require 'cl))
(require 'nnheader)
(require 'timezone)
(require 'message)
(eval-when-compile (require 'rmail))
(require 'time-date)
(eval-and-compile
(autoload 'nnmail-date-to-time "nnmail")
(autoload 'rmail-insert-rmail-file-header "rmail")
(autoload 'rmail-count-new-messages "rmail")
(autoload 'rmail-show-message "rmail"))
@ -76,9 +75,6 @@
(set symbol nil))
symbol))
(defun gnus-truncate-string (str width)
(substring str 0 width))
;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
;; to limit the length of a string. This function is necessary since
;; `(substr "abc" 0 30)' pukes with "Args out of range".
@ -107,25 +103,15 @@
(when (gnus-buffer-exists-p buf)
(kill-buffer buf))))
(if (fboundp 'point-at-bol)
(fset 'gnus-point-at-bol 'point-at-bol)
(defun gnus-point-at-bol ()
"Return point at the beginning of the line."
(let ((p (point)))
(beginning-of-line)
(prog1
(point)
(goto-char p)))))
(defalias 'gnus-point-at-bol
(if (fboundp 'point-at-bol)
'point-at-bol
'line-beginning-position))
(if (fboundp 'point-at-eol)
(fset 'gnus-point-at-eol 'point-at-eol)
(defun gnus-point-at-eol ()
"Return point at the end of the line."
(let ((p (point)))
(end-of-line)
(prog1
(point)
(goto-char p)))))
(defalias 'gnus-point-at-eol
(if (fboundp 'point-at-eol)
'point-at-eol
'line-end-position))
(defun gnus-delete-first (elt list)
"Delete by side effect the first occurrence of ELT as a member of LIST."
@ -179,8 +165,8 @@
(and (string-match "(.*" from)
(setq name (substring from (1+ (match-beginning 0))
(match-end 0)))))
;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
(list (or name from) (or address from))))
(list (if (string= name "") nil name) (or address from))))
(defun gnus-fetch-field (field)
"Return the value of the header FIELD of current article."
@ -232,43 +218,6 @@
;;; Time functions.
(defun gnus-days-between (date1 date2)
;; Return the number of days between date1 and date2.
(- (gnus-day-number date1) (gnus-day-number date2)))
(defun gnus-day-number (date)
(let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
(timezone-parse-date date))))
(timezone-absolute-from-gregorian
(nth 1 dat) (nth 2 dat) (car dat))))
(defun gnus-time-to-day (time)
"Convert TIME to day number."
(let ((tim (decode-time time)))
(timezone-absolute-from-gregorian
(nth 4 tim) (nth 3 tim) (nth 5 tim))))
(defun gnus-encode-date (date)
"Convert DATE to internal time."
(let* ((parse (timezone-parse-date date))
(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)
(* 60 (timezone-zone-to-minute (nth 4 date))))))
(defun gnus-time-minus (t1 t2)
"Subtract two internal times."
(let ((borrow (< (cadr t1) (cadr t2))))
(list (- (car t1) (car t2) (if borrow 1 0))
(- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
(defun gnus-time-less (t1 t2)
"Say whether time T1 is less than time T2."
(or (< (car t1) (car t2))
(and (= (car t1) (car t2))
(< (nth 1 t1) (nth 1 t2)))))
(defun gnus-file-newer-than (file date)
(let ((fdate (nth 5 (file-attributes file))))
(or (> (car fdate) (car date))
@ -343,20 +292,9 @@
(defun gnus-dd-mmm (messy-date)
"Return a string like DD-MMM from a big messy string."
(let ((datevec (ignore-errors (timezone-parse-date messy-date))))
(if (or (not datevec)
(string-equal "0" (aref datevec 1)))
"??-???"
(format "%2s-%s"
(condition-case ()
;; Make sure leading zeroes are stripped.
(number-to-string (string-to-number (aref datevec 2)))
(error "??"))
(capitalize
(or (car
(nth (1- (string-to-number (aref datevec 1)))
timezone-months-assoc))
"???"))))))
(condition-case ()
(format-time-string "%d-%b" (safe-date-to-time messy-date))
(error " - ")))
(defmacro gnus-date-get-time (date)
"Convert DATE string to Emacs time.
@ -367,7 +305,7 @@ Cache the result as a text property stored in DATE."
'(0 0)
(or (get-text-property 0 'gnus-time d)
;; or compute the value...
(let ((time (nnmail-date-to-time d)))
(let ((time (safe-date-to-time d)))
;; and store it back in the string.
(put-text-property 0 1 'gnus-time time d)
time)))))
@ -451,12 +389,14 @@ jabbering all the time."
ids))
(nreverse ids)))
(defun gnus-parent-id (references &optional n)
(defsubst gnus-parent-id (references &optional n)
"Return the last Message-ID in REFERENCES.
If N, return the Nth ancestor instead."
(when references
(let ((ids (inline (gnus-split-references references))))
(car (last ids (or n 1))))))
(while (nthcdr (or n 1) ids)
(setq ids (cdr ids)))
(car ids))))
(defsubst gnus-buffer-live-p (buffer)
"Say whether BUFFER is alive or not."
@ -496,20 +436,8 @@ If N, return the Nth ancestor instead."
(cons (and (numberp event) event) event)))
(defun gnus-sortable-date (date)
"Make sortable string by string-lessp from DATE.
Timezone package is used."
(condition-case ()
(progn
(setq date (inline (timezone-fix-time
date nil
(aref (inline (timezone-parse-date date)) 4))))
(inline
(timezone-make-sortable-date
(aref date 0) (aref date 1) (aref date 2)
(inline
(timezone-make-time-string
(aref date 3) (aref date 4) (aref date 5))))))
(error "")))
"Make string suitable for sorting from DATE."
(gnus-time-iso8601 (date-to-time date)))
(defun gnus-copy-file (file &optional to)
"Copy FILE to TO."
@ -541,7 +469,7 @@ Timezone package is used."
(erase-buffer))
(set-buffer (gnus-get-buffer-create gnus-work-buffer))
(kill-all-local-variables)
(buffer-disable-undo (current-buffer))))
(mm-enable-multibyte)))
(defmacro gnus-group-real-name (group)
"Find the real name of a foreign newsgroup."
@ -553,21 +481,41 @@ Timezone package is used."
(defun gnus-make-sort-function (funs)
"Return a composite sort condition based on the functions in FUNC."
(cond
((not (listp funs)) funs)
;; Just a simple function.
((gnus-functionp funs) funs)
;; No functions at all.
((null funs) funs)
((cdr funs)
;; A list of functions.
((or (cdr funs)
(listp (car funs)))
`(lambda (t1 t2)
,(gnus-make-sort-function-1 (reverse funs))))
;; A list containing just one function.
(t
(car funs))))
(defun gnus-make-sort-function-1 (funs)
"Return a composite sort condition based on the functions in FUNC."
(if (cdr funs)
`(or (,(car funs) t1 t2)
(and (not (,(car funs) t2 t1))
,(gnus-make-sort-function-1 (cdr funs))))
`(,(car funs) t1 t2)))
(let ((function (car funs))
(first 't1)
(last 't2))
(when (consp function)
(cond
;; Reversed spec.
((eq (car function) 'not)
(setq function (cadr function)
first 't2
last 't1))
((gnus-functionp function)
;; Do nothing.
)
(t
(error "Invalid sort spec: %s" function))))
(if (cdr funs)
`(or (,function ,first ,last)
(and (not (,function ,last ,first))
,(gnus-make-sort-function-1 (cdr funs))))
`(,function ,first ,last))))
(defun gnus-turn-off-edit-menu (type)
"Turn off edit menu in `gnus-TYPE-mode-map'."
@ -591,17 +539,19 @@ Bind `print-quoted' and `print-readably' to t while printing."
(defun gnus-make-directory (directory)
"Make DIRECTORY (and all its parents) if it doesn't exist."
(when (and directory
(not (file-exists-p directory)))
(make-directory directory t))
(let ((file-name-coding-system nnmail-pathname-coding-system))
(when (and directory
(not (file-exists-p directory)))
(make-directory directory t)))
t)
(defun gnus-write-buffer (file)
"Write the current buffer's contents to FILE."
;; Make sure the directory exists.
(gnus-make-directory (file-name-directory file))
;; Write the buffer.
(write-region (point-min) (point-max) file nil 'quietly))
(let ((file-name-coding-system nnmail-pathname-coding-system))
;; Write the buffer.
(write-region (point-min) (point-max) file nil 'quietly)))
(defun gnus-delete-file (file)
"Delete FILE if it exists."
@ -614,13 +564,13 @@ Bind `print-quoted' and `print-readably' to t while printing."
(setq string (replace-match "" t t string)))
string)
(defun gnus-put-text-property-excluding-newlines (beg end prop val)
(defsubst gnus-put-text-property-excluding-newlines (beg end prop val)
"The same as `put-text-property', but don't put this prop on any newlines in the region."
(save-match-data
(save-excursion
(save-restriction
(goto-char beg)
(while (re-search-forward "[ \t]*\n" end 'move)
(while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
(gnus-put-text-property beg (match-beginning 0) prop val)
(setq beg (point)))
(gnus-put-text-property beg (point) prop val)))))
@ -733,7 +683,8 @@ with potentially long computations."
(save-excursion
(set-buffer file-buffer)
(rmail-insert-rmail-file-header)
(let ((require-final-newline nil))
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(kill-buffer file-buffer))
(error "Output file does not exist")))
@ -744,7 +695,7 @@ with potentially long computations."
;; Decide whether to append to a file or to an Emacs buffer.
(let ((outbuf (get-file-buffer filename)))
(if (not outbuf)
(append-to-file (point-min) (point-max) filename)
(mm-append-to-file (point-min) (point-max) filename)
;; File has been visited, in buffer OUTBUF.
(set-buffer outbuf)
(let ((buffer-read-only nil)
@ -784,7 +735,8 @@ with potentially long computations."
(let ((file-buffer (create-file-buffer filename)))
(save-excursion
(set-buffer file-buffer)
(let ((require-final-newline nil))
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(kill-buffer file-buffer))
(error "Output file does not exist")))
@ -812,7 +764,7 @@ with potentially long computations."
(insert "\n"))
(insert "\n"))
(goto-char (point-max))
(append-to-file (point-min) (point-max) filename)))
(mm-append-to-file (point-min) (point-max) filename)))
;; File has been visited, in buffer OUTBUF.
(set-buffer outbuf)
(let ((buffer-read-only nil))
@ -853,84 +805,84 @@ ARG is passed to the first function."
;;; .netrc and .authinforc parsing
;;;
(defvar gnus-netrc-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?@ "w" table)
(modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?_ "w" table)
(modify-syntax-entry ?! "w" table)
(modify-syntax-entry ?. "w" table)
(modify-syntax-entry ?, "w" table)
(modify-syntax-entry ?: "w" table)
(modify-syntax-entry ?\; "w" table)
(modify-syntax-entry ?% "w" table)
(modify-syntax-entry ?) "w" table)
(modify-syntax-entry ?( "w" table)
table)
"Syntax table when parsing .netrc files.")
(defun gnus-parse-netrc (file)
"Parse FILE and return an list of all entries in the file."
(if (not (file-exists-p file))
()
(save-excursion
(when (file-exists-p file)
(with-temp-buffer
(let ((tokens '("machine" "default" "login"
"password" "account" "macdef" "force"))
"password" "account" "macdef" "force"
"port"))
alist elem result pair)
(nnheader-set-temp-buffer " *netrc*")
(unwind-protect
(progn
(set-syntax-table gnus-netrc-syntax-table)
(insert-file-contents file)
(goto-char (point-min))
;; Go through the file, line by line.
(while (not (eobp))
(narrow-to-region (point) (gnus-point-at-eol))
;; For each line, get the tokens and values.
(while (not (eobp))
(skip-chars-forward "\t ")
(unless (eobp)
(setq elem (buffer-substring
(point) (progn (forward-sexp 1) (point))))
(cond
((equal elem "macdef")
;; We skip past the macro definition.
(widen)
(while (and (zerop (forward-line 1))
(looking-at "$")))
(narrow-to-region (point) (point)))
((member elem tokens)
;; Tokens that don't have a following value are ignored,
;; except "default".
(when (and pair (or (cdr pair)
(equal (car pair) "default")))
(push pair alist))
(setq pair (list elem)))
(t
;; Values that haven't got a preceding token are ignored.
(when pair
(setcdr pair elem)
(push pair alist)
(setq pair nil))))))
(if alist
(push (nreverse alist) result))
(setq alist nil
pair nil)
(widen)
(forward-line 1))
(nreverse result))
(kill-buffer " *netrc*"))))))
(insert-file-contents file)
(goto-char (point-min))
;; Go through the file, line by line.
(while (not (eobp))
(narrow-to-region (point) (gnus-point-at-eol))
;; For each line, get the tokens and values.
(while (not (eobp))
(skip-chars-forward "\t ")
;; Skip lines that begin with a "#".
(if (eq (char-after) ?#)
(goto-char (point-max))
(unless (eobp)
(setq elem
(if (= (following-char) ?\")
(read (current-buffer))
(buffer-substring
(point) (progn (skip-chars-forward "^\t ")
(point)))))
(cond
((equal elem "macdef")
;; We skip past the macro definition.
(widen)
(while (and (zerop (forward-line 1))
(looking-at "$")))
(narrow-to-region (point) (point)))
((member elem tokens)
;; Tokens that don't have a following value are ignored,
;; except "default".
(when (and pair (or (cdr pair)
(equal (car pair) "default")))
(push pair alist))
(setq pair (list elem)))
(t
;; Values that haven't got a preceding token are ignored.
(when pair
(setcdr pair elem)
(push pair alist)
(setq pair nil)))))))
(when alist
(push (nreverse alist) result))
(setq alist nil
pair nil)
(widen)
(forward-line 1))
(nreverse result)))))
(defun gnus-netrc-machine (list machine)
"Return the netrc values from LIST for MACHINE or for the default entry."
(let ((rest list))
(while (and list
(not (equal (cdr (assoc "machine" (car list))) machine)))
(defun gnus-netrc-machine (list machine &optional port defaultport)
"Return the netrc values from LIST for MACHINE or for the default entry.
If PORT specified, only return entries with matching port tokens.
Entries without port tokens default to DEFAULTPORT."
(let ((rest list)
result)
(while list
(when (equal (cdr (assoc "machine" (car list))) machine)
(push (car list) result))
(pop list))
(car (or list
(progn (while (and rest (not (assoc "default" (car rest))))
(pop rest))
rest)))))
(unless result
;; No machine name matches, so we look for default entries.
(while rest
(when (assoc "default" (car rest))
(push (car rest) result))
(pop rest)))
(when result
(setq result (nreverse result))
(while (and result
(not (equal (or port defaultport "nntp")
(or (gnus-netrc-get (car result) "port")
defaultport "nntp"))))
(pop result))
(car result))))
(defun gnus-netrc-get (alist type)
"Return the value of token TYPE from ALIST."
@ -938,7 +890,7 @@ ARG is passed to the first function."
;;; Various
(defvar gnus-group-buffer) ; Compiler directive
(defvar gnus-group-buffer) ; Compiler directive
(defun gnus-alive-p ()
"Say whether Gnus is running or not."
(and (boundp 'gnus-group-buffer)
@ -971,11 +923,12 @@ ARG is passed to the first function."
(setq alist (delq entry alist)))
alist))
(defmacro gnus-pull (key alist)
(defmacro gnus-pull (key alist &optional assoc-p)
"Modify ALIST to be without KEY."
(unless (symbolp alist)
(error "Not a symbol: %s" alist))
`(setq ,alist (delq (assq ,key ,alist) ,alist)))
(let ((fun (if assoc-p 'assoc 'assq)))
`(setq ,alist (delq (,fun ,key ,alist) ,alist))))
(defun gnus-globalify-regexp (re)
"Returns a regexp that matches a whole line, iff RE matches a part of it."
@ -983,6 +936,52 @@ ARG is passed to the first function."
re
(unless (string-match "\\$$" re) ".*$")))
(defun gnus-set-window-start (&optional point)
"Set the window start to POINT, or (point) if nil."
(let ((win (get-buffer-window (current-buffer) t)))
(when win
(set-window-start win (or point (point))))))
(defun gnus-annotation-in-region-p (b e)
(if (= b e)
(eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
(text-property-any b e 'gnus-undeletable t)))
(defun gnus-or (&rest elems)
"Return non-nil if any of the elements are non-nil."
(catch 'found
(while elems
(when (pop elems)
(throw 'found t)))))
(defun gnus-and (&rest elems)
"Return non-nil if all of the elements are non-nil."
(catch 'found
(while elems
(unless (pop elems)
(throw 'found nil)))
t))
(defun gnus-write-active-file (file hashtb &optional full-names)
(let ((coding-system-for-write nnmail-active-file-coding-system))
(with-temp-file file
(mapatoms
(lambda (sym)
(when (and sym
(boundp sym)
(symbol-value sym))
(insert (format "%S %d %d y\n"
(if full-names
sym
(intern (gnus-group-real-name (symbol-name sym))))
(or (cdr (symbol-value sym))
(car (symbol-value sym)))
(car (symbol-value sym))))))
hashtb)
(goto-char (point-max))
(while (search-backward "\\." nil t)
(delete-char 1)))))
(provide 'gnus-util)
;;; gnus-util.el ends here

284
lisp/gnus/gnus-uu.el
View File

@ -1,5 +1,6 @@
;;; gnus-uu.el --- extract (uu)encoded files in Gnus
;; Copyright (C) 1985,86,87,93,94,95,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Created: 2 Oct 1993
@ -28,12 +29,11 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-art)
(require 'message)
(require 'gnus-msg)
(require 'mm-decode)
(defgroup gnus-extract nil
"Extracting encoded files."
@ -217,9 +217,12 @@ Note that this variable can be used in conjunction with the
;; Various variables users may set
(defcustom gnus-uu-tmp-dir temporary-file-directory
(defcustom gnus-uu-tmp-dir
(cond ((fboundp 'temp-directory) (temp-directory))
((boundp 'temporary-file-directory) temporary-file-directory)
("/tmp/"))
"*Variable saying where gnus-uu is to do its work.
Defaults to `temporary-file-directory'."
Default is \"/tmp/\"."
:group 'gnus-extract
:type 'directory)
@ -292,7 +295,9 @@ so I simply dropped them."
(defcustom gnus-uu-digest-headers
'("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:"
"^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:")
"^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:"
"^MIME-Version:" "^Content-Disposition:" "^Content-Description:"
"^Content-ID:")
"*List of regexps to match headers included in digested messages.
The headers will be included in the sequence they are matched."
:group 'gnus-extract
@ -330,7 +335,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defvar gnus-uu-shar-begin-string "^#! */bin/sh")
(defvar gnus-uu-shar-file-name nil)
(defvar gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)")
(defvar gnus-uu-shar-name-marker
"begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)")
(defvar gnus-uu-postscript-begin-string "^%!PS-")
(defvar gnus-uu-postscript-end-string "^%%EOF$")
@ -345,6 +351,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defvar gnus-uu-default-dir gnus-article-save-directory)
(defvar gnus-uu-digest-from-subject nil)
(defvar gnus-uu-digest-buffer nil)
;; Keymaps
@ -370,7 +377,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map)
;;"x" gnus-uu-extract-any
;;"m" gnus-uu-extract-mime
"m" gnus-summary-save-parts
"u" gnus-uu-decode-uu
"U" gnus-uu-decode-uu-and-save
"s" gnus-uu-decode-unshar
@ -383,17 +390,17 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
"P" gnus-uu-decode-postscript-and-save)
(gnus-define-keys
(gnus-uu-extract-view-map "v" gnus-uu-extract-map)
"u" gnus-uu-decode-uu-view
"U" gnus-uu-decode-uu-and-save-view
"s" gnus-uu-decode-unshar-view
"S" gnus-uu-decode-unshar-and-save-view
"o" gnus-uu-decode-save-view
"O" gnus-uu-decode-save-view
"b" gnus-uu-decode-binhex-view
"B" gnus-uu-decode-binhex-view
"p" gnus-uu-decode-postscript-view
"P" gnus-uu-decode-postscript-and-save-view)
(gnus-uu-extract-view-map "v" gnus-uu-extract-map)
"u" gnus-uu-decode-uu-view
"U" gnus-uu-decode-uu-and-save-view
"s" gnus-uu-decode-unshar-view
"S" gnus-uu-decode-unshar-and-save-view
"o" gnus-uu-decode-save-view
"O" gnus-uu-decode-save-view
"b" gnus-uu-decode-binhex-view
"B" gnus-uu-decode-binhex-view
"p" gnus-uu-decode-postscript-view
"P" gnus-uu-decode-postscript-and-save-view)
;; Commands.
@ -450,7 +457,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
gnus-uu-default-dir
gnus-uu-default-dir))))
(setq gnus-uu-binhex-article-name
(make-temp-file (concat gnus-uu-work-dir "binhex")))
(make-temp-name (concat gnus-uu-work-dir "binhex")))
(gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir))
(defun gnus-uu-decode-uu-view (&optional n)
@ -490,7 +497,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(interactive
(list current-prefix-arg
(read-file-name (if gnus-uu-save-separate-articles
"Save articles in dir: "
"Save articles is dir: "
"Save articles in file: ")
gnus-uu-default-dir gnus-uu-default-dir)))
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
@ -503,7 +510,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(read-file-name "Unbinhex, view and save in dir: "
gnus-uu-default-dir gnus-uu-default-dir)))
(setq gnus-uu-binhex-article-name
(make-temp-file (concat gnus-uu-work-dir "binhex")))
(make-temp-name (concat gnus-uu-work-dir "binhex")))
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-binhex n file)))
@ -514,15 +521,20 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
"Digests and forwards all articles in this series."
(interactive "P")
(let ((gnus-uu-save-in-digest t)
(file (make-temp-file (nnheader-concat gnus-uu-tmp-dir "forward")))
buf subject from)
(file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward")))
(message-forward-as-mime message-forward-as-mime)
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
gnus-uu-digest-buffer subject from)
(if (and n (not (numberp n)))
(setq message-forward-as-mime (not message-forward-as-mime)
n nil))
(gnus-setup-message 'forward
(setq gnus-uu-digest-from-subject nil)
(setq gnus-uu-digest-buffer
(gnus-get-buffer-create " *gnus-uu-forward*"))
(gnus-uu-decode-save n file)
(setq buf (switch-to-buffer
(gnus-get-buffer-create " *gnus-uu-forward*")))
(erase-buffer)
(insert-file file)
(switch-to-buffer gnus-uu-digest-buffer)
(let ((fs gnus-uu-digest-from-subject))
(when fs
(setq from (caar fs)
@ -552,9 +564,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(when (re-search-forward "^From: ")
(delete-region (point) (gnus-point-at-eol))
(insert from))
(message-forward post))
(delete-file file)
(kill-buffer buf)
(message-forward post t))
(setq gnus-uu-digest-from-subject nil)))
(defun gnus-uu-digest-post-forward (&optional n)
@ -565,8 +575,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
;; Process marking.
(defun gnus-uu-mark-by-regexp (regexp &optional unmark)
"Ask for a regular expression and set the process mark on all articles that match."
(interactive (list (read-from-minibuffer "Mark (regexp): ")))
"Set the process mark on articles whose subjects match REGEXP.
When called interactively, prompt for REGEXP.
Optional UNMARK non-nil means unmark instead of mark."
(interactive "sMark (regexp): \nP")
(let ((articles (gnus-uu-find-articles-matching regexp)))
(while articles
(if unmark
@ -575,9 +587,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(message ""))
(gnus-summary-position-point))
(defun gnus-uu-unmark-by-regexp (regexp &optional unmark)
"Ask for a regular expression and remove the process mark on all articles that match."
(interactive (list (read-from-minibuffer "Mark (regexp): ")))
(defun gnus-uu-unmark-by-regexp (regexp)
"Remove the process mark from articles whose subjects match REGEXP.
When called interactively, prompt for REGEXP."
(interactive "sUnmark (regexp): ")
(gnus-uu-mark-by-regexp regexp t))
(defun gnus-uu-mark-series ()
@ -620,10 +633,12 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defun gnus-uu-mark-thread ()
"Marks all articles downwards in this thread."
(interactive)
(let ((level (gnus-summary-thread-level)))
(while (and (gnus-summary-set-process-mark (gnus-summary-article-number))
(zerop (gnus-summary-next-subject 1))
(> (gnus-summary-thread-level) level))))
(gnus-save-hidden-threads
(let ((level (gnus-summary-thread-level)))
(while (and (gnus-summary-set-process-mark
(gnus-summary-article-number))
(zerop (gnus-summary-next-subject 1 nil t))
(> (gnus-summary-thread-level) level)))))
(gnus-summary-position-point))
(defun gnus-uu-unmark-thread ()
@ -652,7 +667,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defun gnus-uu-mark-over (&optional score)
"Mark all articles with a score over SCORE (the prefix)."
(interactive "P")
(let ((score (gnus-score-default score))
(let ((score (or score gnus-summary-default-score 0))
(data gnus-newsgroup-data))
(save-excursion
(while data
@ -808,8 +823,9 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(gnus-uu-save-separate-articles
(save-excursion
(set-buffer buffer)
(gnus-write-buffer
(concat gnus-uu-saved-article-name gnus-current-article))
(let ((coding-system-for-write mm-text-coding-system))
(gnus-write-buffer
(concat gnus-uu-saved-article-name gnus-current-article)))
(cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
((eq in-state 'first-and-last) (list gnus-uu-saved-article-name
'begin 'end))
@ -835,14 +851,20 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(eq in-state 'first-and-last))
(progn
(setq state (list 'begin))
(save-excursion (set-buffer (gnus-get-buffer-create "*gnus-uu-body*"))
(erase-buffer))
(save-excursion
(set-buffer (gnus-get-buffer-create "*gnus-uu-body*"))
(erase-buffer))
(save-excursion
(set-buffer (gnus-get-buffer-create "*gnus-uu-pre*"))
(erase-buffer)
(insert (format
"Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n"
(current-time-string) name name))))
"Date: %s\nFrom: %s\nSubject: %s Digest\n\n"
(current-time-string) name name))
(when (and message-forward-as-mime gnus-uu-digest-buffer)
;; The default part in multipart/digest is message/rfc822.
;; Subject is a fake head.
(insert "<#part type=text/plain>\nSubject: Topics\n\n"))
(insert "Topics:\n")))
(when (not (eq in-state 'end))
(setq state (list 'middle))))
(save-excursion
@ -856,14 +878,20 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
;; These two are necessary for XEmacs 19.12 fascism.
(put-text-property (point-min) (point-max) 'invisible nil)
(put-text-property (point-min) (point-max) 'intangible nil))
(when (and message-forward-as-mime
message-forward-show-mml
gnus-uu-digest-buffer)
(mm-enable-multibyte)
(mime-to-mml))
(goto-char (point-min))
(re-search-forward "\n\n")
;; Quote all 30-dash lines.
(save-excursion
(while (re-search-forward "^-" nil t)
(beginning-of-line)
(delete-char 1)
(insert "- ")))
(unless (and message-forward-as-mime gnus-uu-digest-buffer)
;; Quote all 30-dash lines.
(save-excursion
(while (re-search-forward "^-" nil t)
(beginning-of-line)
(delete-char 1)
(insert "- "))))
(setq body (buffer-substring (1- (point)) (point-max)))
(narrow-to-region (point-min) (point))
(if (not (setq headers gnus-uu-digest-headers))
@ -881,30 +909,66 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(1- (point)))
(progn (forward-line 1) (point)))))))))
(widen)))
(insert sorthead) (goto-char (point-max))
(insert body) (goto-char (point-max))
(insert (concat "\n" (make-string 30 ?-) "\n\n"))
(if (and message-forward-as-mime gnus-uu-digest-buffer)
(if message-forward-show-mml
(progn
(insert "\n<#mml type=message/rfc822>\n")
(insert sorthead) (goto-char (point-max))
(insert body) (goto-char (point-max))
(insert "\n<#/mml>\n"))
(let ((buf (mml-generate-new-buffer " *mml*")))
(with-current-buffer buf
(insert sorthead)
(goto-char (point-min))
(when (re-search-forward "^Subject: \\(.*\\)$" nil t)
(setq subj (buffer-substring (match-beginning 1)
(match-end 1))))
(goto-char (point-max))
(insert body))
(insert "\n<#part type=message/rfc822"
" buffer=\"" (buffer-name buf) "\">\n")))
(insert sorthead) (goto-char (point-max))
(insert body) (goto-char (point-max))
(insert (concat "\n" (make-string 30 ?-) "\n\n")))
(goto-char beg)
(when (re-search-forward "^Subject: \\(.*\\)$" nil t)
(setq subj (buffer-substring (match-beginning 1) (match-end 1)))
(setq subj (buffer-substring (match-beginning 1) (match-end 1))))
(when subj
(save-excursion
(set-buffer "*gnus-uu-pre*")
(insert (format " %s\n" subj)))))
(when (or (eq in-state 'last)
(eq in-state 'first-and-last))
(save-excursion
(set-buffer "*gnus-uu-pre*")
(insert (format "\n\n%s\n\n" (make-string 70 ?-)))
(gnus-write-buffer gnus-uu-saved-article-name))
(save-excursion
(set-buffer "*gnus-uu-body*")
(goto-char (point-max))
(insert
(concat (setq end-string (format "End of %s Digest" name))
"\n"))
(insert (concat (make-string (length end-string) ?*) "\n"))
(write-region
(point-min) (point-max) gnus-uu-saved-article-name t))
(if (and message-forward-as-mime gnus-uu-digest-buffer)
(with-current-buffer gnus-uu-digest-buffer
(erase-buffer)
(insert-buffer "*gnus-uu-pre*")
(goto-char (point-max))
(insert-buffer "*gnus-uu-body*"))
(save-excursion
(set-buffer "*gnus-uu-pre*")
(insert (format "\n\n%s\n\n" (make-string 70 ?-)))
(if gnus-uu-digest-buffer
(with-current-buffer gnus-uu-digest-buffer
(erase-buffer)
(insert-buffer "*gnus-uu-pre*"))
(let ((coding-system-for-write mm-text-coding-system))
(gnus-write-buffer gnus-uu-saved-article-name))))
(save-excursion
(set-buffer "*gnus-uu-body*")
(goto-char (point-max))
(insert
(concat (setq end-string (format "End of %s Digest" name))
"\n"))
(insert (concat (make-string (length end-string) ?*) "\n"))
(if gnus-uu-digest-buffer
(with-current-buffer gnus-uu-digest-buffer
(goto-char (point-max))
(insert-buffer "*gnus-uu-body*"))
(let ((coding-system-for-write mm-text-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
(write-region
(point-min) (point-max) gnus-uu-saved-article-name t)))))
(gnus-kill-buffer "*gnus-uu-pre*")
(gnus-kill-buffer "*gnus-uu-body*")
(push 'end state))
@ -951,7 +1015,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(beginning-of-line)
(forward-line 1)
(when (file-exists-p gnus-uu-binhex-article-name)
(append-to-file start-char (point) gnus-uu-binhex-article-name))))
(mm-append-to-file start-char (point) gnus-uu-binhex-article-name))))
(if (memq 'begin state)
(cons gnus-uu-binhex-article-name state)
state)))
@ -1026,7 +1090,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
;; finally just replaces the next to last number with "[0-9]+".
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
(insert (regexp-quote string))
@ -1126,7 +1190,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
string)
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(while string-list
(erase-buffer)
(insert (caar string-list))
@ -1201,9 +1265,10 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
&optional sloppy limit no-errors)
(let ((state 'first)
(gnus-asynchronous nil)
(gnus-inhibit-treatment t)
has-been-begin article result-file result-files process-state
gnus-summary-display-article-function
gnus-article-display-hook gnus-article-prepare-hook
gnus-article-prepare-hook gnus-display-mime-function
article-series files)
(while (and articles
@ -1394,7 +1459,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
;; We replace certain characters that could make things messy.
(setq gnus-uu-file-name
(let ((nnheader-file-name-translation-alist
'((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
'((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
(nnheader-translate-file-chars (match-string 1))))
(replace-match (concat "begin 644 " gnus-uu-file-name) t t)
@ -1471,6 +1536,21 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(cons (if (= (length files) 1) (car files) files) state)
state))))
(defvar gnus-uu-unshar-warning
"*** WARNING ***
Shell archives are an archaic method of bundling files for distribution
across computer networks. During the unpacking process, arbitrary commands
are executed on your system, and all kinds of nasty things can happen.
Please examine the archive very carefully before you instruct Emacs to
unpack it. You can browse the archive buffer using \\[scroll-other-window].
If you are unsure what to do, please answer \"no\"."
"Text of warning message displayed by `gnus-uu-unshar-article'.
Make sure that this text consists only of few text lines. Otherwise,
Gnus might fail to display all of it.")
;; This function is used by `gnus-uu-grab-articles' to treat
;; a shared article.
(defun gnus-uu-unshar-article (process-buffer in-state)
@ -1481,14 +1561,31 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(goto-char (point-min))
(if (not (re-search-forward gnus-uu-shar-begin-string nil t))
(setq state (list 'wrong-type))
(beginning-of-line)
(setq start-char (point))
(call-process-region
start-char (point-max) shell-file-name nil
(gnus-get-buffer-create gnus-uu-output-buffer-name) nil
shell-command-switch
(concat "cd " gnus-uu-work-dir " "
gnus-shell-command-separator " sh"))))
(save-window-excursion
(save-excursion
(switch-to-buffer (current-buffer))
(delete-other-windows)
(let ((buffer (get-buffer-create (generate-new-buffer-name
"*Warning*"))))
(unless
(unwind-protect
(with-current-buffer buffer
(insert (substitute-command-keys
gnus-uu-unshar-warning))
(goto-char (point-min))
(display-buffer buffer)
(yes-or-no-p "This is a shell archive, unshar it? "))
(kill-buffer buffer))
(setq state (list 'error))))))
(unless (memq 'error state)
(beginning-of-line)
(setq start-char (point))
(call-process-region
start-char (point-max) shell-file-name nil
(gnus-get-buffer-create gnus-uu-output-buffer-name) nil
shell-command-switch
(concat "cd " gnus-uu-work-dir " "
gnus-shell-command-separator " sh")))))
state))
;; Returns the name of what the shar file is going to unpack.
@ -1678,7 +1775,8 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
gnus-uu-tmp-dir)))
(setq gnus-uu-work-dir
(make-temp-file (concat gnus-uu-tmp-dir "gnus") t))
(make-temp-name (concat gnus-uu-tmp-dir "gnus")))
(gnus-make-directory gnus-uu-work-dir)
(set-file-modes gnus-uu-work-dir 448)
(setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))
(push (cons gnus-newsgroup-name gnus-uu-work-dir)
@ -1695,23 +1793,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(when (setq buf (get-buffer gnus-uu-output-buffer-name))
(kill-buffer buf))))
(defun gnus-quote-arg-for-sh-or-csh (arg)
(let ((pos 0) new-pos accum)
;; *** bug: we don't handle newline characters properly
(while (setq new-pos (string-match "[;!`\"$\\& \t{}]" arg pos))
(push (substring arg pos new-pos) accum)
(push "\\" accum)
(push (list (aref arg new-pos)) accum)
(setq pos (1+ new-pos)))
(if (= pos 0)
arg
(apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
;; Inputs an action and a filename and returns a full command, making sure
;; that the filename will be treated as a single argument when the shell
;; executes the command.
(defun gnus-uu-command (action file)
(let ((quoted-file (gnus-quote-arg-for-sh-or-csh file)))
(let ((quoted-file (mm-quote-arg file)))
(if (string-match "%s" action)
(format action quoted-file)
(concat action " " quoted-file))))
@ -1807,7 +1893,9 @@ is t."
(gnus-summary-post-news)
(use-local-map (copy-keymap (current-local-map)))
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (current-local-map))
(use-local-map map))
(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
(local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews)
(local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews)

16
lisp/gnus/gnus-vm.el
View File

@ -1,7 +1,9 @@
;;; gnus-vm.el --- vm interface for Gnus
;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc.
;; Author: Per Persson <pp@gnu.org>
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Per Persson <pp@gnu.ai.mit.edu>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
@ -36,6 +38,7 @@
(require 'gnus-msg)
(eval-when-compile
(require 'cl)
(autoload 'vm-mode "vm")
(autoload 'vm-save-message "vm")
(autoload 'vm-forward-message "vm")
@ -46,11 +49,10 @@
"Inhibit loading `win-vm' if using a window-system.
Has to be set before gnus-vm is loaded.")
(or gnus-vm-inhibit-window-system
(condition-case nil
(when window-system
(require 'win-vm))
(error nil)))
(unless gnus-vm-inhibit-window-system
(ignore-errors
(when window-system
(require 'win-vm))))
(when (not (featurep 'vm))
(load "vm"))

103
lisp/gnus/gnus-win.el
View File

@ -1,5 +1,6 @@
;;; gnus-win.el --- window configuration functions for Gnus
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -27,8 +28,6 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'gnus)
(defgroup gnus-windows nil
@ -87,9 +86,9 @@
(article 1.0)))
(t
'(vertical 1.0
(summary 0.25 point)
(if gnus-carpal '(summary-carpal 4))
(article 1.0)))))
(summary 0.25 point)
(if gnus-carpal '(summary-carpal 4))
(article 1.0)))))
(server
(vertical 1.0
(server 1.0 point)
@ -288,7 +287,7 @@ See the Gnus manual for an explanation of the syntax used.")
(defun gnus-configure-frame (split &optional window)
"Split WINDOW according to SPLIT."
(unless window
(setq window (get-buffer-window (current-buffer))))
(setq window (or (get-buffer-window (current-buffer)) (selected-window))))
(select-window window)
;; This might be an old-stylee buffer config.
(when (vectorp split)
@ -320,9 +319,11 @@ See the Gnus manual for an explanation of the syntax used.")
(let ((buffer (cond ((stringp type) type)
(t (cdr (assq type gnus-window-to-buffer))))))
(unless buffer
(error "Illegal buffer type: %s" type))
(switch-to-buffer (gnus-get-buffer-create
(gnus-window-to-buffer-helper buffer)))
(error "Invalid buffer type: %s" type))
(let ((buf (gnus-get-buffer-create
(gnus-window-to-buffer-helper buffer))))
(if (eq buf (window-buffer (selected-window))) (set-buffer buf)
(switch-to-buffer buf)))
(when (memq 'frame-focus split)
(setq gnus-window-frame-focus window))
;; We return the window if it has the `point' spec.
@ -375,7 +376,7 @@ See the Gnus manual for an explanation of the syntax used.")
((integerp size)
(setq s size))
(t
(error "Illegal size: %s" size)))
(error "Invalid size: %s" size)))
;; Try to make sure that we are inside the safe limits.
(cond ((zerop s))
((eq type 'horizontal)
@ -410,48 +411,50 @@ See the Gnus manual for an explanation of the syntax used.")
(defvar gnus-frame-split-p nil)
(defun gnus-configure-windows (setting &optional force)
(setq gnus-current-window-configuration setting)
(setq force (or force gnus-always-force-window-configuration))
(setq setting (gnus-windows-old-to-new setting))
(let ((split (if (symbolp setting)
(cadr (assq setting gnus-buffer-configuration))
setting))
all-visible)
(if (window-configuration-p setting)
(set-window-configuration setting)
(setq gnus-current-window-configuration setting)
(setq force (or force gnus-always-force-window-configuration))
(setq setting (gnus-windows-old-to-new setting))
(let ((split (if (symbolp setting)
(cadr (assq setting gnus-buffer-configuration))
setting))
all-visible)
(setq gnus-frame-split-p nil)
(setq gnus-frame-split-p nil)
(unless split
(error "No such setting: %s" setting))
(unless split
(error "No such setting in `gnus-buffer-configuration': %s" setting))
(if (and (setq all-visible (gnus-all-windows-visible-p split))
(not force))
;; All the windows mentioned are already visible, so we just
;; put point in the assigned buffer, and do not touch the
;; winconf.
(select-window all-visible)
(if (and (setq all-visible (gnus-all-windows-visible-p split))
(not force))
;; All the windows mentioned are already visible, so we just
;; put point in the assigned buffer, and do not touch the
;; winconf.
(select-window all-visible)
;; Either remove all windows or just remove all Gnus windows.
(let ((frame (selected-frame)))
(unwind-protect
(if gnus-use-full-window
;; We want to remove all other windows.
(if (not gnus-frame-split-p)
;; This is not a `frame' split, so we ignore the
;; other frames.
(delete-other-windows)
;; This is a `frame' split, so we delete all windows
;; on all frames.
(gnus-delete-windows-in-gnusey-frames))
;; Just remove some windows.
(gnus-remove-some-windows)
(switch-to-buffer nntp-server-buffer))
(select-frame frame)))
;; Either remove all windows or just remove all Gnus windows.
(let ((frame (selected-frame)))
(unwind-protect
(if gnus-use-full-window
;; We want to remove all other windows.
(if (not gnus-frame-split-p)
;; This is not a `frame' split, so we ignore the
;; other frames.
(delete-other-windows)
;; This is a `frame' split, so we delete all windows
;; on all frames.
(gnus-delete-windows-in-gnusey-frames))
;; Just remove some windows.
(gnus-remove-some-windows)
(switch-to-buffer nntp-server-buffer))
(select-frame frame)))
(switch-to-buffer nntp-server-buffer)
(let (gnus-window-frame-focus)
(gnus-configure-frame split (get-buffer-window (current-buffer)))
(when gnus-window-frame-focus
(select-frame (window-frame gnus-window-frame-focus)))))))
(let (gnus-window-frame-focus)
(switch-to-buffer nntp-server-buffer)
(gnus-configure-frame split)
(when gnus-window-frame-focus
(select-frame (window-frame gnus-window-frame-focus))))))))
(defun gnus-delete-windows-in-gnusey-frames ()
"Do a `delete-other-windows' in all frames that have Gnus windows."
@ -502,11 +505,11 @@ should have point."
(setq buffer (cond ((stringp type) type)
(t (cdr (assq type gnus-window-to-buffer)))))
(unless buffer
(error "Illegal buffer type: %s" type))
(error "Invalid buffer type: %s" type))
(if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
(setq win (get-buffer-window buf t)))
(if (memq 'point split)
(setq all-visible win))
(setq all-visible win))
(setq all-visible nil)))
(t
(when (eq type 'frame)

625
lisp/gnus/gnus.el
View File

@ -1,5 +1,6 @@
;;; gnus.el --- a newsreader for GNU Emacs
;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
;; 1997, 1998, 2000 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -29,13 +30,8 @@
(eval '(run-hooks 'gnus-load-hook))
(eval-when-compile (require 'cl))
(require 'mm-util)
(eval-when-compile (require 'cl))
(require 'custom)
(eval-and-compile
(if (< emacs-major-version 20)
(require 'gnus-load)))
(require 'message)
(defgroup gnus nil
@ -43,6 +39,12 @@
:group 'news
:group 'mail)
(defgroup gnus-charset nil
"Group character set issues."
:link '(custom-manual "(gnus)Charsets")
:version "21.1"
:group 'gnus)
(defgroup gnus-cache nil
"Cache interface."
:group 'gnus)
@ -247,12 +249,16 @@ is restarted, and sometimes reloaded."
:link '(custom-manual "(gnus)Various Various")
:group 'gnus)
(defgroup gnus-mime nil
"Variables for controlling the Gnus MIME interface."
:group 'gnus)
(defgroup gnus-exit nil
"Exiting gnus."
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
(defconst gnus-version-number "5.7"
(defconst gnus-version-number "5.8.8"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Gnus v%s" gnus-version-number)
@ -270,8 +276,6 @@ be set in `.emacs' instead."
:group 'gnus-start
:type 'boolean)
;;; Kludges to help the transition from the old `custom.el'.
(unless (featurep 'gnus-xmas)
(defalias 'gnus-make-overlay 'make-overlay)
(defalias 'gnus-delete-overlay 'delete-overlay)
@ -287,11 +291,33 @@ be set in `.emacs' instead."
(defalias 'gnus-character-to-event 'identity)
(defalias 'gnus-add-text-properties 'add-text-properties)
(defalias 'gnus-put-text-property 'put-text-property)
(defalias 'gnus-mode-line-buffer-identification 'identity)
(defvar gnus-mode-line-image-cache t)
(if (fboundp 'find-image)
(defun gnus-mode-line-buffer-identification (line)
(let ((str (car-safe line)))
(if (and (stringp str)
(string-match "^Gnus:" str))
(progn (add-text-properties
0 5
(list 'display
(if (eq t gnus-mode-line-image-cache)
(setq gnus-mode-line-image-cache
(find-image
'((:type xpm :file "gnus-pointer.xpm"
:ascent 100)
(:type xbm :file "gnus-pointer.xbm"
:ascent 100))))
gnus-mode-line-image-cache)
'help-echo "This is Gnus")
str)
(list str))
line)))
(defalias 'gnus-mode-line-buffer-identification 'identity))
(defalias 'gnus-characterp 'numberp)
(defalias 'gnus-deactivate-mark 'deactivate-mark)
(defalias 'gnus-window-edges 'window-edges)
(defalias 'gnus-key-press-event-p 'numberp))
(defalias 'gnus-key-press-event-p 'numberp)
(defalias 'gnus-decode-rfc1522 'ignore))
;; We define these group faces here to avoid the display
;; update forced when creating new faces.
@ -362,6 +388,72 @@ be set in `.emacs' instead."
()))
"Level 3 empty newsgroup face.")
(defface gnus-group-news-4-face
'((((class color)
(background dark))
(:bold t))
(((class color)
(background light))
(:bold t))
(t
()))
"Level 4 newsgroup face.")
(defface gnus-group-news-4-empty-face
'((((class color)
(background dark))
())
(((class color)
(background light))
())
(t
()))
"Level 4 empty newsgroup face.")
(defface gnus-group-news-5-face
'((((class color)
(background dark))
(:bold t))
(((class color)
(background light))
(:bold t))
(t
()))
"Level 5 newsgroup face.")
(defface gnus-group-news-5-empty-face
'((((class color)
(background dark))
())
(((class color)
(background light))
())
(t
()))
"Level 5 empty newsgroup face.")
(defface gnus-group-news-6-face
'((((class color)
(background dark))
(:bold t))
(((class color)
(background light))
(:bold t))
(t
()))
"Level 6 newsgroup face.")
(defface gnus-group-news-6-empty-face
'((((class color)
(background dark))
())
(((class color)
(background light))
())
(t
()))
"Level 6 empty newsgroup face.")
(defface gnus-group-news-low-face
'((((class color)
(background dark))
@ -639,13 +731,13 @@ be set in `.emacs' instead."
(defface gnus-splash-face
'((((class color)
(background dark))
(:foreground "ForestGreen"))
(:foreground "Brown"))
(((class color)
(background light))
(:foreground "ForestGreen"))
(:foreground "Brown"))
(t
()))
"Level 1 newsgroup face.")
"Face of the splash screen.")
(defun gnus-splash ()
(save-excursion
@ -677,8 +769,28 @@ be set in `.emacs' instead."
"Insert startup message in current buffer."
;; Insert the message.
(erase-buffer)
(insert
(format " %s
(cond
((and
(fboundp 'find-image)
(display-graphic-p)
(let ((image (find-image
`((:type xpm :file "gnus.xpm")
(:type xbm :file "gnus.xbm"
;; Account for the xbm's blackground.
:background ,(face-foreground 'gnus-splash-face)
:foreground ,(face-background 'default))))))
(when image
(let ((size (image-size image)))
(insert-char ?\n (max 0 (round (- (window-height)
(or y (cdr size)) 1) 2)))
(insert-char ?\ (max 0 (round (- (window-width)
(or x (car size))) 2)))
(insert-image image))
(setq gnus-simple-splash nil)
t))))
(t
(insert
(format " %s
_ ___ _ _
_ ___ __ ___ __ _ ___
__ _ ___ __ ___
@ -698,21 +810,21 @@ be set in `.emacs' instead."
__
"
""))
;; And then hack it.
(gnus-indent-rigidly (point-min) (point-max)
(/ (max (- (window-width) (or x 46)) 0) 2))
(goto-char (point-min))
(forward-line 1)
(let* ((pheight (count-lines (point-min) (point-max)))
(wheight (window-height))
(rest (- wheight pheight)))
(insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
;; Fontify some.
(put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
""))
;; And then hack it.
(gnus-indent-rigidly (point-min) (point-max)
(/ (max (- (window-width) (or x 46)) 0) 2))
(goto-char (point-min))
(forward-line 1)
(let* ((pheight (count-lines (point-min) (point-max)))
(wheight (window-height))
(rest (- wheight pheight)))
(insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
;; Fontify some.
(put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
(setq gnus-simple-splash t)))
(goto-char (point-min))
(setq mode-line-buffer-identification (concat " " gnus-version))
(setq gnus-simple-splash t)
(set-buffer-modified-p t))
(eval-when (load)
@ -784,31 +896,30 @@ used to 899, you would say something along these lines:
(and (file-readable-p gnus-nntpserver-file)
(save-excursion
(set-buffer (gnus-get-buffer-create " *gnus nntp*"))
(buffer-disable-undo (current-buffer))
(insert-file-contents gnus-nntpserver-file)
(let ((name (buffer-string)))
(prog1
(if (string-match "^[ \t\n]*$" name)
(if (string-match "\\'[ \t\n]*$" name)
nil
name)
(kill-buffer (current-buffer))))))))
(defcustom gnus-select-method
(condition-case nil
(nconc
(list 'nntp (or (condition-case nil
(gnus-getenv-nntpserver)
(error nil))
(when (and gnus-default-nntp-server
(not (string= gnus-default-nntp-server "")))
gnus-default-nntp-server)
"news"))
(if (or (null gnus-nntp-service)
(equal gnus-nntp-service "nntp"))
nil
(list gnus-nntp-service)))
(nconc
(list 'nntp (or (condition-case nil
(gnus-getenv-nntpserver)
(error nil))
(when (and gnus-default-nntp-server
(not (string= gnus-default-nntp-server "")))
gnus-default-nntp-server)
"news"))
(if (or (null gnus-nntp-service)
(equal gnus-nntp-service "nntp"))
nil
(list gnus-nntp-service)))
(error nil))
"*Default method for selecting a newsgroup.
"Default method for selecting a newsgroup.
This variable should be a list, where the first element is how the
news is to be fetched, the second is the address.
@ -839,7 +950,7 @@ see the manual for details."
"*Method used for archiving messages you've sent.
This should be a mail method.
It's probably not a very effective to change this variable once you've
It's probably not very effective to change this variable once you've
run Gnus once. After doing that, you must edit this server from the
server buffer."
:group 'gnus-server
@ -868,6 +979,7 @@ that case, just return a fully prefixed name of the group --
\"nnml+private:mail.misc\", for instance."
:group 'gnus-message
:type '(choice (const :tag "none" nil)
function
sexp
string))
@ -895,8 +1007,8 @@ If, for instance, you want to read your mail with the nnml backend,
you could set this variable:
\(setq gnus-secondary-select-methods '((nnml \"\")))"
:group 'gnus-server
:type '(repeat gnus-select-method))
:group 'gnus-server
:type '(repeat gnus-select-method))
(defvar gnus-backup-default-subscribed-newsgroups
'("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus")
@ -925,10 +1037,23 @@ articles by Message-ID is painfully slow. By setting this method to an
nntp method, you might get acceptable results.
The value of this variable must be a valid select method as discussed
in the documentation of `gnus-select-method'."
in the documentation of `gnus-select-method'.
It can also be a list of select methods, as well as the special symbol
`current', which means to use the current select method. If it is a
list, Gnus will try all the methods in the list until it finds a match."
:group 'gnus-server
:type '(choice (const :tag "default" nil)
gnus-select-method))
(const :tag "DejaNews" (nnweb "refer" (nnweb-type dejanews)))
gnus-select-method
(repeat :menu-tag "Try multiple"
:tag "Multiple"
:value (current (nnweb "refer" (nnweb-type dejanews)))
(choice :tag "Method"
(const current)
(const :tag "DejaNews"
(nnweb "refer" (nnweb-type dejanews)))
gnus-select-method))))
(defcustom gnus-group-faq-directory
'("/ftp@mirrors.aol.com:/pub/rtfm/usenet/"
@ -987,11 +1112,6 @@ newsgroups."
:group 'gnus-summary-marks
:type 'character)
(defcustom gnus-asynchronous nil
"*If non-nil, Gnus will supply backends with data needed for async article fetching."
:group 'gnus-asynchronous
:type 'boolean)
(defcustom gnus-large-newsgroup 200
"*The number of articles which indicates a large newsgroup.
If the number of articles in a newsgroup is greater than this value,
@ -1083,18 +1203,13 @@ articles. This is not a good idea."
:group 'gnus-meta
:type 'boolean)
(defcustom gnus-use-demon nil
"If non-nil, Gnus might use some demons."
:group 'gnus-meta
:type 'boolean)
(defcustom gnus-use-scoring t
"*If non-nil, enable scoring."
:group 'gnus-meta
:type 'boolean)
(defcustom gnus-use-picons nil
"*If non-nil, display picons."
"*If non-nil, display picons in a frame of their own."
:group 'gnus-meta
:type 'boolean)
@ -1167,8 +1282,12 @@ slower."
("nnfolder" mail respool address)
("nngateway" post-mail address prompt-address physical-address)
("nnweb" none)
("nnslashdot" post)
("nnultimate" none)
("nnwarchive" none)
("nnlistserv" none)
("nnagent" post-mail))
("nnagent" post-mail)
("nnimap" post-mail address prompt-address physical-address))
"*An alist of valid select methods.
The first element of each list lists should be a string with the name
of the select method. The other elements may be the category of
@ -1189,18 +1308,28 @@ this variable. I think."
(const :format "%v " virtual)
(const respool)))))
(define-widget 'gnus-select-method 'list
"Widget for entering a select method."
:args `((choice :tag "Method"
,@(mapcar (lambda (entry)
(list 'const :format "%v\n"
(intern (car entry))))
gnus-valid-select-methods))
(string :tag "Address")
(editable-list :inline t
(list :format "%v"
variable
(sexp :tag "Value")))))
(defun gnus-redefine-select-method-widget ()
"Recomputes the select-method widget based on the value of
`gnus-valid-select-methods'."
(define-widget 'gnus-select-method 'list
"Widget for entering a select method."
:value '(nntp "")
:tag "Select Method"
:args `((choice :tag "Method"
,@(mapcar (lambda (entry)
(list 'const :format "%v\n"
(intern (car entry))))
gnus-valid-select-methods)
(symbol :tag "other"))
(string :tag "Address")
(repeat :tag "Options"
:inline t
(list :format "%v"
variable
(sexp :tag "Value"))))
))
(gnus-redefine-select-method-widget)
(defcustom gnus-updated-mode-lines '(group article summary tree)
"List of buffers that should update their mode lines.
@ -1283,7 +1412,7 @@ following hook:
(defcustom gnus-group-change-level-function nil
"Function run when a group level is changed.
It is called with three parameters -- GROUP, LEVEL and OLDLEVEL."
:group 'gnus-group-level
:group 'gnus-group-levels
:type 'function)
;;; Face thingies.
@ -1345,60 +1474,6 @@ face."
:group 'gnus-visual
:type 'face)
(defcustom gnus-article-display-hook
(if (and (string-match "XEmacs" emacs-version)
(featurep 'xface))
'(gnus-article-hide-headers-if-wanted
gnus-article-hide-boring-headers
gnus-article-treat-overstrike
gnus-article-maybe-highlight
gnus-article-display-x-face)
'(gnus-article-hide-headers-if-wanted
gnus-article-hide-boring-headers
gnus-article-treat-overstrike
gnus-article-maybe-highlight))
"*Controls how the article buffer will look.
If you leave the list empty, the article will appear exactly as it is
stored on the disk. The list entries will hide or highlight various
parts of the article, making it easier to find the information you
want."
:group 'gnus-article-highlight
:group 'gnus-visual
:type 'hook
:options '(gnus-article-add-buttons
gnus-article-add-buttons-to-head
gnus-article-emphasize
gnus-article-fill-cited-article
gnus-article-remove-cr
gnus-article-de-quoted-unreadable
gnus-summary-stop-page-breaking
;; gnus-summary-caesar-message
;; gnus-summary-verbose-headers
gnus-summary-toggle-mime
gnus-article-hide
gnus-article-hide-headers
gnus-article-hide-boring-headers
gnus-article-hide-signature
gnus-article-hide-citation
gnus-article-hide-pgp
gnus-article-hide-pem
gnus-article-highlight
gnus-article-highlight-headers
gnus-article-highlight-citation
gnus-article-highlight-signature
gnus-article-date-ut
gnus-article-date-local
gnus-article-date-lapsed
gnus-article-date-original
gnus-article-remove-trailing-blank-lines
gnus-article-strip-leading-blank-lines
gnus-article-strip-multiple-blank-lines
gnus-article-strip-blank-lines
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\")."
:group 'gnus-article-saving
@ -1407,9 +1482,27 @@ want."
(defvar gnus-plugged t
"Whether Gnus is plugged or not.")
(defcustom gnus-default-charset 'iso-8859-1
"Default charset assumed to be used when viewing non-ASCII characters.
This variable is overridden on a group-to-group basis by the
gnus-group-charset-alist variable and is only used on groups not
covered by that variable."
:type 'symbol
:group 'gnus-charset)
(defcustom gnus-default-posting-charset nil
"Default charset assumed to be used when posting non-ASCII characters.
This variable is overridden on a group-to-group basis by the
gnus-group-posting-charset-alist variable and is only used on groups not
covered by that variable.
If nil, no default charset is assumed when posting."
:type 'symbol
:group 'gnus-charset)
;;; Internal variables
(defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information")
(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter)
(defvar gnus-original-article-buffer " *Original Article*")
(defvar gnus-newsgroup-name nil)
@ -1457,7 +1550,7 @@ want."
,(nnheader-concat gnus-cache-directory "active"))))
"List of predefined (convenience) servers.")
(defvar gnus-topic-indentation "") ;; Obsolete variable.
(defvar gnus-topic-indentation "");; Obsolete variable.
(defconst gnus-article-mark-lists
'((marked . tick) (replied . reply)
@ -1485,7 +1578,6 @@ want."
'((gnus-group-mode "(gnus)The Group Buffer")
(gnus-summary-mode "(gnus)The Summary Buffer")
(gnus-article-mode "(gnus)The Article Buffer")
(mime/viewer-mode "(gnus)The Article Buffer")
(gnus-server-mode "(gnus)The Server Buffer")
(gnus-browse-mode "(gnus)Browse Foreign Server")
(gnus-tree-mode "(gnus)Tree Display"))
@ -1504,11 +1596,11 @@ want."
(defvar gnus-variable-list
'(gnus-newsrc-options gnus-newsrc-options-n
gnus-newsrc-last-checked-date
gnus-newsrc-alist gnus-server-alist
gnus-killed-list gnus-zombie-list
gnus-topic-topology gnus-topic-alist
gnus-format-specs)
gnus-newsrc-last-checked-date
gnus-newsrc-alist gnus-server-alist
gnus-killed-list gnus-zombie-list
gnus-topic-topology gnus-topic-alist
gnus-format-specs)
"Gnus variables saved in the quick startup file.")
(defvar gnus-newsrc-alist nil
@ -1549,6 +1641,9 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
(defvar gnus-dead-summary nil)
(defvar gnus-invalid-group-regexp "[: `'\"/]\\|^$"
"Regexp matching invalid groups.")
;;; End of variables.
;; Define some autoload functions Gnus might use.
@ -1565,24 +1660,22 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
(when (consp function)
(setq keymap (car (memq 'keymap function)))
(setq function (car function)))
(autoload function (car package) nil interactive keymap)))
(unless (fboundp function)
(autoload function (car package) nil interactive keymap))))
(if (eq (nth 1 package) ':interactive)
(cdddr package)
(nthcdr 3 package)
(cdr package)))))
'(("metamail" metamail-buffer)
("info" Info-goto-node)
("hexl" hexl-hex-string-to-integer)
'(("info" :interactive t Info-goto-node)
("pp" pp pp-to-string pp-eval-expression)
("qp" quoted-printable-decode-region quoted-printable-decode-string)
("ps-print" ps-print-preprint)
("mail-extr" mail-extract-address-components)
("browse-url" browse-url)
("browse-url" :interactive t browse-url)
("message" :interactive t
message-send-and-exit message-yank-original)
("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time)
("babel" babel-as-string)
("nnmail" nnmail-split-fancy nnmail-article-group)
("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers)
("timezone" timezone-make-date-arpa-standard timezone-fix-time
timezone-make-sortable-date timezone-make-time-string)
("rmailout" rmail-output)
("rmailout" rmail-output rmail-output-to-rmail-file)
("rmail" rmail-insert-rmail-file-header rmail-count-new-messages
rmail-show-message rmail-summary-exists
rmail-select-summary rmail-update-summary)
@ -1615,35 +1708,36 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-article-hide-citation-in-followups)
("gnus-kill" gnus-kill gnus-apply-kill-file-internal
gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author
gnus-execute gnus-expunge)
gnus-execute gnus-expunge gnus-batch-kill gnus-batch-score)
("gnus-cache" gnus-cache-possibly-enter-article gnus-cache-save-buffers
gnus-cache-possibly-remove-articles gnus-cache-request-article
gnus-cache-retrieve-headers gnus-cache-possibly-alter-active
gnus-cache-enter-remove-article gnus-cached-article-p
gnus-cache-open gnus-cache-close gnus-cache-update-article)
("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
gnus-cache-remove-article gnus-summary-insert-cached-articles)
("gnus-score" :interactive t
gnus-summary-increase-score gnus-summary-set-score
gnus-summary-raise-thread gnus-summary-raise-same-subject
gnus-summary-raise-score gnus-summary-raise-same-subject-and-select
gnus-summary-lower-thread gnus-summary-lower-same-subject
gnus-summary-lower-score gnus-summary-lower-same-subject-and-select
gnus-summary-current-score gnus-score-default
gnus-score-flush-cache gnus-score-close
gnus-possibly-score-headers gnus-score-followup-article
gnus-score-followup-thread)
("gnus-score"
(gnus-summary-score-map keymap) gnus-score-save gnus-score-headers
gnus-cache-open gnus-cache-close gnus-cache-update-article
gnus-cache-articles-in-group)
("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
gnus-cache-remove-article gnus-summary-insert-cached-articles)
("gnus-score" :interactive t
gnus-summary-increase-score gnus-summary-set-score
gnus-summary-raise-thread gnus-summary-raise-same-subject
gnus-summary-raise-score gnus-summary-raise-same-subject-and-select
gnus-summary-lower-thread gnus-summary-lower-same-subject
gnus-summary-lower-score gnus-summary-lower-same-subject-and-select
gnus-summary-current-score gnus-score-delta-default
gnus-score-flush-cache gnus-score-close
gnus-possibly-score-headers gnus-score-followup-article
gnus-score-followup-thread)
("gnus-score"
(gnus-summary-score-map keymap) gnus-score-save gnus-score-headers
gnus-current-score-file-nondirectory gnus-score-adaptive
gnus-score-find-trace gnus-score-file-name)
("gnus-cus" :interactive t gnus-group-customize gnus-score-customize)
("gnus-topic" :interactive t gnus-topic-mode)
("gnus-topic" gnus-topic-remove-group gnus-topic-set-parameters)
("gnus-topic" gnus-topic-remove-group gnus-topic-set-parameters
gnus-subscribe-topics)
("gnus-salt" :interactive t gnus-pick-mode gnus-binary-mode)
("gnus-uu" (gnus-uu-extract-map keymap) (gnus-uu-mark-map keymap))
("gnus-uu" :interactive t
gnus-uu-post-news
gnus-uu-digest-mail-forward gnus-uu-digest-post-forward
gnus-uu-mark-series gnus-uu-mark-region gnus-uu-mark-buffer
gnus-uu-mark-by-regexp gnus-uu-mark-all
@ -1654,17 +1748,11 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view
gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view
gnus-uu-decode-binhex-view gnus-uu-unmark-thread
gnus-uu-mark-over gnus-uu-post-news gnus-uu-post-news)
("gnus-uu" gnus-uu-delete-work-dir gnus-quote-arg-for-sh-or-csh
gnus-uu-unmark-thread)
gnus-uu-mark-over gnus-uu-post-news)
("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread)
("gnus-msg" (gnus-summary-send-map keymap)
gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
("gnus-msg" :interactive t
gnus-summary-wide-reply
gnus-summary-wide-reply-with-original
gnus-summary-followup-to-mail
gnus-summary-followup-to-mail-with-original
gnus-summary-post-forward
gnus-group-post-news gnus-group-mail gnus-summary-post-news
gnus-summary-followup gnus-summary-followup-with-original
gnus-summary-cancel-article gnus-summary-supersede-article
@ -1679,6 +1767,7 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
("gnus-picon" :interactive t gnus-article-display-picons
gnus-group-display-picons gnus-picons-article-display-x-face
gnus-picons-display-x-face)
("gnus-picon" gnus-picons-buffer-name)
("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p
gnus-grouplens-mode)
("smiley" :interactive t gnus-smiley-display)
@ -1694,8 +1783,7 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc
gnus-group-setup-buffer gnus-group-get-new-news
gnus-group-make-help-group gnus-group-update-group
gnus-clear-inboxes-moved gnus-group-iterate
gnus-group-group-name)
gnus-group-iterate gnus-group-group-name)
("gnus-bcklg" gnus-backlog-request-article gnus-backlog-enter-article
gnus-backlog-remove-article)
("gnus-art" gnus-article-read-summary-keys gnus-article-save
@ -1703,20 +1791,24 @@ 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-hack-decode-rfc1522)
gnus-article-delete-invisible-text gnus-treat-article)
("gnus-art" :interactive t
gnus-article-hide-headers gnus-article-hide-boring-headers
gnus-article-treat-overstrike gnus-article-word-wrap
gnus-article-treat-overstrike
gnus-article-remove-cr gnus-article-remove-trailing-blank-lines
gnus-article-display-x-face gnus-article-de-quoted-unreadable
gnus-article-mime-decode-quoted-printable gnus-article-hide-pgp
gnus-article-de-base64-unreadable
gnus-article-decode-HZ
gnus-article-wash-html
gnus-article-hide-pgp
gnus-article-hide-pem gnus-article-hide-signature
gnus-article-strip-leading-blank-lines gnus-article-date-local
gnus-article-date-original gnus-article-date-lapsed
gnus-article-show-all-headers
gnus-article-edit-mode gnus-article-edit-article
gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522
gnus-start-date-timer gnus-stop-date-timer)
gnus-article-edit-done gnus-article-decode-encoded-words
gnus-start-date-timer gnus-stop-date-timer
gnus-mime-view-all-parts)
("gnus-int" gnus-request-type)
("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1
gnus-dribble-enter gnus-read-init-file gnus-dribble-touch)
@ -1739,7 +1831,10 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-unplugged gnus-agentize gnus-agent-batch)
("gnus-vm" :interactive t gnus-summary-save-in-vm
gnus-summary-save-article-vm)
("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts))))
("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts)
("gnus-mlspl" gnus-group-split gnus-group-split-fancy)
("gnus-mlspl" :interactive t gnus-group-split-setup
gnus-group-split-update))))
;;; gnus-sum.el thingies
@ -1757,6 +1852,7 @@ with some simple extensions.
%a Extracted name of the poster (string)
%A Extracted address of the poster (string)
%F Contents of the From: header (string)
%f Contents of the From: or To: headers (string)
%x Contents of the Xref: header (string)
%D Date of the article (string)
%d Date of the article (string) in DD-MMM format
@ -1795,7 +1891,7 @@ such area.
The %U (status), %R (replied) and %z (zcore) specs have to be handled
with care. For reasons of efficiency, Gnus will compute what column
these characters will end up in, and \"hard-code\" that. This means that
it is illegal to have these specs after a variable-length spec. Well,
it is invalid to have these specs after a variable-length spec. Well,
you might not be arrested, but your summary buffer will look strange,
which is bad enough.
@ -1817,7 +1913,7 @@ This restriction may disappear in later versions of Gnus."
(define-key keymap (pop keys) 'undefined))))
(defvar gnus-article-mode-map
(let ((keymap (make-keymap)))
(let ((keymap (make-sparse-keymap)))
(gnus-suppress-keymap keymap)
keymap))
(defvar gnus-summary-mode-map
@ -2012,14 +2108,13 @@ If ARG, insert string at point."
(string-to-number
(if (zerop major)
(format "%s00%02d%02d"
(cond
((member alpha '("(ding)" "d")) "4.99")
((member alpha '("September" "s")) "5.01")
((member alpha '("Red" "r")) "5.03")
((member alpha '("Quassia" "q")) "5.05")
((member alpha '("p")) "5.07")
((member alpha '("o")) "5.09")
((member alpha '("n")) "5.11"))
(if (member alpha '("(ding)" "d"))
"4.99"
(+ 5 (* 0.02
(abs
(- (mm-char-int (aref (downcase alpha) 0))
(mm-char-int ?t))))
-0.01))
minor least)
(format "%d.%02d%02d" major minor least))))))
@ -2307,7 +2402,14 @@ that that variable is buffer-local to the summary buffers."
(not (equal server (format "%s:%s" (caaar opened)
(cadaar opened)))))
(pop opened))
(caar opened))))
(caar opened))
;; It could be a named method, search all servers
(let ((servers gnus-secondary-select-methods))
(while (and servers
(not (equal server (format "%s:%s" (caar servers)
(cadar servers)))))
(pop servers))
(car servers))))
(defmacro gnus-method-equal (ss1 ss2)
"Say whether two servers are equal."
@ -2320,6 +2422,15 @@ that that variable is buffer-local to the summary buffers."
(setq s1 (cdr s1)))
(null s1))))))
(defun gnus-methods-equal-p (m1 m2)
(let ((m1 (or m1 gnus-select-method))
(m2 (or m2 gnus-select-method)))
(or (equal m1 m2)
(and (eq (car m1) (car m2))
(or (not (memq 'address (assoc (symbol-name (car m1))
gnus-valid-select-methods)))
(equal (nth 1 m1) (nth 1 m2)))))))
(defun gnus-server-equal (m1 m2)
"Say whether two methods are equal."
(let ((m1 (cond ((null m1) gnus-select-method)
@ -2401,16 +2512,32 @@ You should probably use `gnus-find-method-for-group' instead."
possible
(list backend server))))))
(defsubst gnus-native-method-p (method)
"Return whether METHOD is the native select method."
(gnus-method-equal method gnus-select-method))
(defsubst gnus-secondary-method-p (method)
"Return whether METHOD is a secondary select method."
(let ((methods gnus-secondary-select-methods)
(gmethod (gnus-server-get-method nil method)))
(while (and methods
(not (equal (gnus-server-get-method nil (car methods))
gmethod)))
(not (gnus-method-equal
(gnus-server-get-method nil (car methods))
gmethod)))
(setq methods (cdr methods)))
methods))
(defun gnus-method-simplify (method)
"Return the shortest uniquely identifying string or method for METHOD."
(cond ((stringp method)
method)
((gnus-native-method-p method)
nil)
((gnus-secondary-method-p method)
(format "%s:%s" (nth 0 method) (nth 1 method)))
(t
method)))
(defun gnus-groups-from-server (server)
"Return a list of all groups that are fetched from SERVER."
(let ((alist (cdr gnus-newsrc-alist))
@ -2510,7 +2637,6 @@ If SCORE is nil, add 1 to the score of GROUP."
(when info
(gnus-info-set-score info (+ (gnus-info-score info) (or score 1))))))
;; Function written by Stainless Steel Rat <ratinox@peorth.gweep.net>
(defun gnus-short-group-name (group &optional levels)
"Collapse GROUP name LEVELS.
Select methods are stripped and any remote host name is stripped down to
@ -2520,40 +2646,51 @@ just the host name."
(depth 0)
(skip 1)
(levels (or levels
gnus-group-uncollapsed-levels
(progn
(while (string-match "\\." group skip)
(setq skip (match-end 0)
depth (+ depth 1)))
depth))))
;; separate foreign select method from group name and collapse.
;; if method contains a server, collapse to non-domain server name,
;; otherwise collapse to select method
(when (string-match ":" group)
(cond ((string-match "+" group)
(let* ((plus (string-match "+" group))
(colon (string-match ":" group (or plus 0)))
(dot (string-match "\\." group)))
(setq foreign (concat
(substring group (+ 1 plus)
(cond ((null dot) colon)
((< colon dot) colon)
((< dot colon) dot)))
":")
group (substring group (+ 1 colon)))))
(t
(let* ((colon (string-match ":" group)))
(setq foreign (concat (substring group 0 (+ 1 colon)))
group (substring group (+ 1 colon)))))))
;; collapse group name leaving LEVELS uncollapsed elements
(while group
(if (and (string-match "\\." group) (> levels 0))
(setq name (concat name (substring group 0 1))
group (substring group (match-end 0))
levels (- levels 1)
name (concat name "."))
(setq name (concat foreign name group)
group nil)))
name))
;; Separate foreign select method from group name and collapse.
;; If method contains a server, collapse to non-domain server name,
;; otherwise collapse to select method.
(let* ((colon (string-match ":" group))
(server (and colon (substring group 0 colon)))
(plus (and server (string-match "+" server))))
(when server
(if plus
(setq foreign (substring server (+ 1 plus)
(string-match "\\." server))
group (substring group (+ 1 colon)))
(setq foreign server
group (substring group (+ 1 colon))))
(setq foreign (concat foreign ":")))
;; Collapse group name leaving LEVELS uncollapsed elements
(let* ((slist (split-string group "/"))
(slen (length slist))
(dlist (split-string group "\\."))
(dlen (length dlist))
glist
glen
gsep
res)
(if (> slen dlen)
(setq glist slist
glen slen
gsep "/")
(setq glist dlist
glen dlen
gsep "."))
(setq levels (- glen levels))
(dolist (g glist)
(push (if (>= (decf levels) 0)
(if (zerop (length g))
""
(substring g 0 1))
g)
res))
(concat foreign (mapconcat 'identity (nreverse res) gsep))))))
(defun gnus-narrow-to-body ()
"Narrow to the body of an article."
@ -2631,6 +2768,7 @@ If NEWSGROUP is nil, return the global kill file name instead."
(let ((opened gnus-opened-servers))
(while (and method opened)
(when (and (equal (cadr method) (cadaar opened))
(equal (car method) (caaar opened))
(not (equal method (caar opened))))
(setq method nil))
(pop opened))
@ -2667,6 +2805,8 @@ If NEWSGROUP is nil, return the global kill file name instead."
(or gnus-override-method
(and (not group)
gnus-select-method)
(and (not (gnus-group-entry group));; a new group
(gnus-group-name-to-method group))
(let ((info (or info (gnus-get-info group)))
method)
(if (or (not info)
@ -2699,16 +2839,16 @@ If NEWSGROUP is nil, return the global kill file name instead."
(defun gnus-read-group (prompt &optional default)
"Prompt the user for a group name.
Disallow illegal group names."
Disallow invalid group names."
(let ((prefix "")
group)
(while (not group)
(when (string-match
"[: `'\"/]\\|^$"
(when (string-match
gnus-invalid-group-regexp
(setq group (read-string (concat prefix prompt)
(cons (or default "") 0)
'gnus-group-history)))
(setq prefix (format "Illegal group name: \"%s\". " group)
(setq prefix (format "Invalid group name: \"%s\". " group)
group nil)))
group))
@ -2717,6 +2857,9 @@ Disallow illegal group names."
Allow completion over sensible values."
(let* ((servers
(append gnus-valid-select-methods
(mapcar (lambda (i) (list (format "%s:%s" (caar i)
(cadar i))))
gnus-opened-servers)
gnus-predefined-server-alist
gnus-server-alist))
(method
@ -2727,11 +2870,18 @@ Allow completion over sensible values."
((equal method "")
(setq method gnus-select-method))
((assoc method gnus-valid-select-methods)
(list (intern method)
(if (memq 'prompt-address
(assoc method gnus-valid-select-methods))
(read-string "Address: ")
"")))
(let ((address (if (memq 'prompt-address
(assoc method gnus-valid-select-methods))
(read-string "Address: ")
"")))
(or (let ((opened gnus-opened-servers))
(while (and opened
(not (equal (format "%s:%s" method address)
(format "%s:%s" (caaar opened)
(cadaar opened)))))
(pop opened))
(caar opened))
(list (intern method) address))))
((assoc method servers)
method)
(t
@ -2769,12 +2919,13 @@ As opposed to `gnus', this command will not connect to the local server."
(let ((window (get-buffer-window gnus-group-buffer)))
(cond (window
(select-frame (window-frame window)))
((= (length (frame-list)) 1)
(select-frame (make-frame)))
(t
(other-frame 1))))
(t
(select-frame (make-frame)))))
(gnus arg))
;;(setq thing ? ; this is a comment
;; more 'yes)
;;;###autoload
(defun gnus (&optional arg dont-connect slave)
"Read network news.

1542
lisp/gnus/message.el
View File

File diff suppressed because it is too large Load Diff

5
lisp/gnus/messcompat.el
View File

@ -1,5 +1,7 @@
;;; messcompat.el --- making message mode compatible with mail mode
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
@ -70,6 +72,7 @@ If t, the `message-signature-file' file will be inserted instead.
If a function, the result from the function will be used instead.
If a form, the result from the form will be used instead.")
;; Deleted the autoload cookie because this crashes in loaddefs.el.
(defvar message-signature-file mail-signature-file
"*File containing the text inserted at end of the message buffer.")

85
lisp/gnus/nnagent.el
View File

@ -1,5 +1,5 @@
;;; nnagent.el --- offline backend for Gnus
;; Copyright (C) 1997,98 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@ -58,13 +58,18 @@
(nnoo-define-basics nnagent)
(defun nnagent-server (server)
(and server (format "%s+%s" (car gnus-command-method) server)))
(deffoo nnagent-open-server (server &optional defs)
(setq defs
`((nnagent-directory ,(gnus-agent-directory))
(nnagent-active-file ,(gnus-agent-lib-file "active"))
(nnagent-newsgroups-file ,(gnus-agent-lib-file "newsgroups"))
(nnagent-get-new-mail nil)))
(nnoo-change-server 'nnagent server defs)
(nnoo-change-server 'nnagent
(nnagent-server server)
defs)
(let ((dir (gnus-agent-directory))
err)
(cond
@ -111,7 +116,81 @@
(deffoo nnagent-request-post (&optional server)
(gnus-agent-insert-meta-information 'news gnus-command-method)
(gnus-request-accept-article "nndraft:queue"))
(gnus-request-accept-article "nndraft:queue" nil t t))
(deffoo nnagent-request-set-mark (group action server)
(with-temp-buffer
(insert (format "(%s-request-set-mark \"%s\" '%s \"%s\")\n"
(nth 0 gnus-command-method) group action
(or server (nth 1 gnus-command-method))))
(append-to-file (point-min) (point-max) (gnus-agent-lib-file "flags")))
nil)
(deffoo nnagent-request-group (group &optional server dont-check)
(nnoo-parent-function 'nnagent 'nnml-request-group
(list group (nnagent-server server) dont-check)))
(deffoo nnagent-close-group (group &optional server)
(nnoo-parent-function 'nnagent 'nnml-close-group
(list group (nnagent-server server))))
(deffoo nnagent-request-accept-article (group &optional server last)
(nnoo-parent-function 'nnagent 'nnml-request-accept-article
(list group (nnagent-server server) last)))
(deffoo nnagent-request-article (id &optional group server buffer)
(nnoo-parent-function 'nnagent 'nnml-request-article
(list id group (nnagent-server server) buffer)))
(deffoo nnagent-request-create-group (group &optional server args)
(nnoo-parent-function 'nnagent 'nnml-request-create-group
(list group (nnagent-server server) args)))
(deffoo nnagent-request-delete-group (group &optional force server)
(nnoo-parent-function 'nnagent 'nnml-request-delete-group
(list group force (nnagent-server server))))
(deffoo nnagent-request-expire-articles (articles group &optional server force)
(nnoo-parent-function 'nnagent 'nnml-request-expire-articles
(list articles group (nnagent-server server) force)))
(deffoo nnagent-request-list (&optional server)
(nnoo-parent-function 'nnagent 'nnml-request-list
(list (nnagent-server server))))
(deffoo nnagent-request-list-newsgroups (&optional server)
(nnoo-parent-function 'nnagent 'nnml-request-list-newsgroups
(list (nnagent-server server))))
(deffoo nnagent-request-move-article
(article group server accept-form &optional last)
(nnoo-parent-function 'nnagent 'nnml-request-move-article
(list article group (nnagent-server server)
accept-form last)))
(deffoo nnagent-request-rename-group (group new-name &optional server)
(nnoo-parent-function 'nnagent 'nnml-request-rename-group
(list group new-name (nnagent-server server))))
(deffoo nnagent-request-scan (&optional group server)
(nnoo-parent-function 'nnagent 'nnml-request-scan
(list group (nnagent-server server))))
(deffoo nnagent-retrieve-headers (sequence &optional group server fetch-old)
(nnoo-parent-function 'nnagent 'nnml-retrieve-headers
(list sequence group (nnagent-server server) fetch-old)))
(deffoo nnagent-set-status (article name value &optional group server)
(nnoo-parent-function 'nnagent 'nnml-set-status
(list article name value group (nnagent-server server))))
(deffoo nnagent-server-opened (&optional server)
(nnoo-parent-function 'nnagent 'nnml-server-opened
(list (nnagent-server server))))
(deffoo nnagent-status-message (&optional server)
(nnoo-parent-function 'nnagent 'nnml-status-message
(list (nnagent-server server))))
;; Use nnml functions for just about everything.
(nnoo-import nnagent

29
lisp/gnus/nnbabyl.el
View File

@ -1,5 +1,7 @@
;;; nnbabyl.el --- rmail mbox access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -32,7 +34,8 @@
(require 'nnheader)
(condition-case nil
(require 'rmail)
(t (nnheader-message 5 "Ignore rmail errors from this file, you don't have rmail")))
(t (nnheader-message
5 "Ignore rmail errors from this file, you don't have rmail")))
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
@ -259,7 +262,7 @@
(nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
(deffoo nnbabyl-request-expire-articles
(articles newsgroup &optional server force)
(articles newsgroup &optional server force)
(nnbabyl-possibly-change-newsgroup newsgroup server)
(let* ((is-old t)
rest)
@ -295,7 +298,7 @@
(nconc rest articles))))
(deffoo nnbabyl-request-move-article
(article group server accept-form &optional last)
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnbabyl move*"))
result)
(and
@ -431,9 +434,9 @@
(widen)
(narrow-to-region
(save-excursion
(unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
(goto-char (point-min))
(end-of-line))
(unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
(goto-char (point-min))
(end-of-line))
(if leave-delim (progn (forward-line 1) (point))
(match-beginning 0)))
(progn
@ -557,10 +560,10 @@
(nnbabyl-create-mbox)
(unless (and nnbabyl-mbox-buffer
(buffer-name nnbabyl-mbox-buffer)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
(buffer-name nnbabyl-mbox-buffer)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
;; This buffer has changed since we read it last. Possibly.
(save-excursion
(let ((delim (concat "^" nnbabyl-mail-delimiter))
@ -568,13 +571,13 @@
start end number)
(set-buffer (setq nnbabyl-mbox-buffer
(nnheader-find-file-noselect
nnbabyl-mbox-file nil 'raw)))
nnbabyl-mbox-file nil t)))
;; Save previous buffer mode.
(setq nnbabyl-previous-buffer-mode
(cons (cons (point-min) (point-max))
major-mode))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(widen)
(setq buffer-read-only nil)
(fundamental-mode)

4
lisp/gnus/nndir.el
View File

@ -1,5 +1,7 @@
;;; nndir.el --- single directory newsgroup access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news

304
lisp/gnus/nndoc.el
View File

@ -1,5 +1,6 @@
;;; nndoc.el --- single file access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -31,6 +32,7 @@
(require 'nnmail)
(require 'nnoo)
(require 'gnus-util)
(require 'mm-util)
(eval-when-compile (require 'cl))
(nnoo-declare nndoc)
@ -38,8 +40,8 @@
(defvoo nndoc-article-type 'guess
"*Type of the file.
One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
`rfc934', `rfc822-forward', `mime-digest', `mime-parts', `standard-digest',
`slack-digest', `clari-briefs' or `guess'.")
`rfc934', `rfc822-forward', `mime-parts', `standard-digest',
`slack-digest', `clari-briefs', `nsmail' or `guess'.")
(defvoo nndoc-post-type 'mail
"*Whether the nndoc group is `mail' or `post'.")
@ -47,12 +49,14 @@ One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
(defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr
"Hook run after opening a document.
The default function removes all trailing carriage returns
from the document.")
from the document.")
(defvar nndoc-type-alist
`((mmdf
(article-begin . "^\^A\^A\^A\^A\n")
(body-end . "^\^A\^A\^A\^A\n"))
(nsmail
(article-begin . "^From - "))
(news
(article-begin . "^Path:"))
(rnews
@ -67,8 +71,8 @@ from the document.")
(body-begin-function . nndoc-babyl-body-begin)
(head-begin-function . nndoc-babyl-head-begin))
(forward
(article-begin . "^-+ Start of forwarded message -+\n+")
(body-end . "^-+ End of forwarded message -+$")
(article-begin . "^-+ \\(Start of \\)?forwarded message.*\n+")
(body-end . "^-+ End \\(of \\)?forwarded message.*$")
(prepare-body-function . nndoc-unquote-dashes))
(rfc934
(article-begin . "^--.*\n+")
@ -83,6 +87,7 @@ from the document.")
(article-transform-function . nndoc-transform-clari-briefs))
(mime-digest
(article-begin . "")
(head-begin . "^ ?\n")
(head-end . "^ ?$")
(body-end . "")
(file-end . "")
@ -120,6 +125,9 @@ from the document.")
(rfc822-forward
(article-begin . "^\n")
(body-end-function . nndoc-rfc822-forward-body-end-function))
(outlook
(article-begin-function . nndoc-outlook-article-begin)
(body-end . "\0"))
(guess
(guess . t)
(subtype nil))
@ -143,10 +151,13 @@ from the document.")
(defvoo nndoc-head-begin-function nil)
(defvoo nndoc-body-end nil)
;; nndoc-dissection-alist is a list of sublists. Each sublist holds the
;; following items. ARTICLE is an ordinal starting at 1. HEAD-BEGIN,
;; HEAD-END, BODY-BEGIN and BODY-END are positions in the `nndoc' buffer.
;; LINE-COUNT is a count of lines in the body. SUBJECT, MESSAGE-ID and
;; REFERENCES, only present for MIME dissections, are field values.
;; following items. ARTICLE acts as the association key and is an ordinal
;; starting at 1. HEAD-BEGIN [0], HEAD-END [1], BODY-BEGIN [2] and BODY-END
;; [3] are positions in the `nndoc' buffer. LINE-COUNT [4] is a count of
;; lines in the body. For MIME dissections only, ARTICLE-INSERT [5] and
;; SUMMARY-INSERT [6] give headers to insert for full article or summary line
;; generation, respectively. Other headers usually follow directly from the
;; buffer. Value `nil' means no insert.
(defvoo nndoc-dissection-alist nil)
(defvoo nndoc-prepare-body-function nil)
(defvoo nndoc-generate-head-function nil)
@ -158,8 +169,6 @@ from the document.")
(defvoo nndoc-current-buffer nil
"Current nndoc news buffer.")
(defvoo nndoc-address nil)
(defvoo nndoc-mime-header nil)
(defvoo nndoc-mime-subject nil)
(defconst nndoc-version "nndoc 1.0"
"nndoc version.")
@ -187,7 +196,7 @@ from the document.")
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry)))
(goto-char (point-max))
(unless (= (char-after (1- (point))) ?\n)
(unless (eq (char-after (1- (point))) ?\n)
(insert "\n"))
(insert (format "Lines: %d\n" (nth 4 entry)))
(insert ".\n")))
@ -289,7 +298,6 @@ from the document.")
(setq nndoc-dissection-alist nil)
(save-excursion
(set-buffer nndoc-current-buffer)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(if (stringp nndoc-address)
(nnheader-insert-file-contents nndoc-address)
@ -343,6 +351,9 @@ from the document.")
(setq entry (pop alist)))
(when (memq subtype (or (cdr (assq 'subtype entry)) '(guess)))
(goto-char (point-min))
;; Remove blank lines.
(while (eq (following-char) ?\n)
(delete-char 1))
(when (numberp (setq result (funcall (intern
(format "nndoc-%s-type-p"
(car entry))))))
@ -425,7 +436,8 @@ from the document.")
t))
(defun nndoc-forward-type-p ()
(when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
(when (and (re-search-forward "^-+ \\(Start of \\)?forwarded message.*\n+"
nil t)
(not (re-search-forward "^Subject:.*digest" nil t))
(not (re-search-backward "^From:" nil t 2))
(not (re-search-forward "^From:" nil t 2)))
@ -452,38 +464,30 @@ from the document.")
(limit (search-forward "\n\n" nil t)))
(goto-char (point-min))
(when (and limit
(re-search-forward
(concat "\
^Content-Type:[ \t]*multipart/[a-z]+;\\(.*;\\)*"
"[ \t\n]*[ \t]boundary=\"?[^\"\n]*[^\" \t\n]")
limit t))
(re-search-forward
(concat "\
^Content-Type:[ \t]*multipart/[a-z]+ *; *\\(\\(\n[ \t]\\)?.*;\\)*"
"\\(\n[ \t]\\)?[ \t]*boundary=\"?[^\"\n]*[^\" \t\n]")
limit t))
t)))
(defun nndoc-transform-mime-parts (article)
(unless (= article 1)
;; Ensure some MIME-Version.
(goto-char (point-min))
(search-forward "\n\n")
(let ((case-fold-search nil)
(limit (point)))
(let* ((entry (cdr (assq article nndoc-dissection-alist)))
(headers (nth 5 entry)))
(when headers
(goto-char (point-min))
(or (save-excursion (re-search-forward "^MIME-Version:" limit t))
(insert "Mime-Version: 1.0\n")))
;; Generate default header before entity fields.
(goto-char (point-min))
(nndoc-generate-mime-parts-head article t)))
(insert headers))))
(defun nndoc-generate-mime-parts-head (article &optional body-present)
(let ((entry (cdr (assq (if body-present 1 article) nndoc-dissection-alist))))
(let ((subject (if body-present
nndoc-mime-subject
(concat "<" (nth 5 entry) ">")))
(message-id (nth 6 entry))
(references (nth 7 entry)))
(insert nndoc-mime-header)
(and subject (insert "Subject: " subject "\n"))
(and message-id (insert "Message-ID: " message-id "\n"))
(and references (insert "References: " references "\n")))))
(defun nndoc-generate-mime-parts-head (article)
(let* ((entry (cdr (assq article nndoc-dissection-alist)))
(headers (nth 6 entry)))
(save-restriction
(narrow-to-region (point) (point))
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry))
(goto-char (point-max)))
(when headers
(insert headers))))
(defun nndoc-clari-briefs-type-p ()
(when (let ((case-fold-search nil))
@ -516,6 +520,7 @@ from the document.")
(insert "From: " "clari@clari.net (" (or from "unknown") ")"
"\nSubject: " (or subject "(no subject)") "\n")))
(defun nndoc-mime-digest-type-p ()
(let ((case-fold-search t)
boundary-id b-delimiter entry)
@ -526,10 +531,11 @@ from the document.")
nil t)
(match-beginning 1))
(setq boundary-id (match-string 1)
b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
b-delimiter (concat "\n--" boundary-id "[ \t]*$"))
(setq entry (assq 'mime-digest nndoc-type-alist))
(setcdr entry
(list
(cons 'head-begin "^ ?\n")
(cons 'head-end "^ ?$")
(cons 'body-begin "^ ?\n")
(cons 'article-begin b-delimiter)
@ -558,10 +564,7 @@ from the document.")
(defun nndoc-transform-lanl-gov-announce (article)
(goto-char (point-max))
(when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
(replace-match "\n\nGet it at \\1 (\\2)" t nil))
;; (when (re-search-backward "^\\\\\\\\$" nil t)
;; (replace-match "" t t))
)
(replace-match "\n\nGet it at \\1 (\\2)" t nil)))
(defun nndoc-generate-lanl-gov-head (article)
(let ((entry (cdr (assq article nndoc-dissection-alist)))
@ -579,18 +582,28 @@ from the document.")
(when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)"
nil t)
(setq subject (concat (match-string 1) subject))
(setq from (concat (match-string 2) " <" e-mail ">"))))
))
(setq from (concat (match-string 2) " <" e-mail ">"))))))
(while (and from (string-match "(\[^)\]*)" from))
(setq from (replace-match "" t t from)))
(insert "From: " (or from "unknown")
"\nSubject: " (or subject "(no subject)") "\n")))
(defun nndoc-nsmail-type-p ()
(when (looking-at "From - ")
t))
(defun nndoc-outlook-article-begin ()
(prog1 (re-search-forward "From:\\|Received:" nil t)
(goto-char (match-beginning 0))))
(defun nndoc-outlook-type-p ()
;; FIXME: Is JMF the magic of outlook mailbox? -- ShengHuo.
(looking-at "JMF"))
(deffoo nndoc-request-accept-article (group &optional server last)
nil)
;;;
;;; Functions for dissecting the documents
;;;
@ -609,6 +622,9 @@ from the document.")
(save-excursion
(set-buffer nndoc-current-buffer)
(goto-char (point-min))
;; Remove blank lines.
(while (eq (following-char) ?\n)
(delete-char 1))
;; Find the beginning of the file.
(when nndoc-file-begin
(nndoc-search nndoc-file-begin))
@ -669,92 +685,128 @@ the header of this entity, and one article per sub-entity."
nndoc-mime-split-ordinal 0)
(save-excursion
(set-buffer nndoc-current-buffer)
(message-narrow-to-head)
(let ((case-fold-search t)
(message-id (message-fetch-field "Message-ID"))
(references (message-fetch-field "References")))
(setq nndoc-mime-header (buffer-substring (point-min) (point-max))
nndoc-mime-subject (message-fetch-field "Subject"))
(while (string-match "\
^\\(Subject\\|Message-ID\\|References\\|Lines\\|\
MIME-Version\\|Content-Type\\|Content-Transfer-Encoding\\|\
\\):.*\n\\([ \t].*\n\\)*"
nndoc-mime-header)
(setq nndoc-mime-header (replace-match "" t t nndoc-mime-header)))
(widen)
(nndoc-dissect-mime-parts-sub (point-min) (point-max)
nil message-id references))))
(nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil)))
(defun nndoc-dissect-mime-parts-sub (begin end position message-id references)
"Dissect an entity within a composite MIME message.
The article, which corresponds to a MIME entity, extends from BEGIN to END.
(defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert
position parent)
"Dissect an entity, within a composite MIME message.
The complete message or MIME entity extends from HEAD-BEGIN to BODY-END.
ARTICLE-INSERT should be added at beginning for generating a full article.
The string POSITION holds a dotted decimal representation of the article
position in the hierarchical structure, it is nil for the outer entity.
The generated article should use MESSAGE-ID and REFERENCES field values."
;; Note: `case-fold-search' is already `t' from the calling function.
(let ((head-begin begin)
(body-end end)
head-end body-begin type subtype composite comment)
(save-excursion
;; Gracefully handle a missing body.
(goto-char head-begin)
(if (search-forward "\n\n" body-end t)
(setq head-end (1- (point))
body-begin (point))
(setq head-end end
body-begin end))
;; Save MIME attributes.
(goto-char head-begin)
(if (re-search-forward "\
^Content-Type: *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)"
head-end t)
(setq type (downcase (match-string 1))
subtype (downcase (match-string 2)))
(setq type "text"
subtype "plain"))
(setq composite (string= type "multipart")
comment (concat position
(when (and position composite) ".")
(when composite "*")
(when (or position composite) " ")
(cond ((string= subtype "plain") type)
((string= subtype "basic") type)
(t subtype))))
;; Generate dissection information for this entity.
(push (list (incf nndoc-mime-split-ordinal)
head-begin head-end body-begin body-end
(count-lines body-begin body-end)
comment message-id references)
nndoc-dissection-alist)
;; Recurse for all sub-entities, if any.
(goto-char head-begin)
(when (re-search-forward
(concat "\
^Content-Type: *multipart/\\([a-z]+\\);\\(.*;\\)*"
"[ \t\n]*[ \t]boundary=\"?\\([^\"\n]*[^\" \t\n]\\)")
head-end t)
(let ((boundary (concat "\n--" (match-string 3) "\\(--\\)?[ \t]*\n"))
(part-counter 0)
begin end eof-flag)
(goto-char head-end)
(setq eof-flag (not (re-search-forward boundary body-end t)))
PARENT is the message-ID of the parent summary line, or nil for none."
(let ((case-fold-search t)
(message-id (nnmail-message-id))
head-end body-begin summary-insert message-rfc822 multipart-any
subject content-type type subtype boundary-regexp)
;; Gracefully handle a missing body.
(goto-char head-begin)
(if (search-forward "\n\n" body-end t)
(setq head-end (1- (point))
body-begin (point))
(setq head-end body-end
body-begin body-end))
(narrow-to-region head-begin head-end)
;; Save MIME attributes.
(goto-char head-begin)
(setq content-type (message-fetch-field "Content-Type"))
(when content-type
(when (string-match
"^ *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" content-type)
(setq type (downcase (match-string 1 content-type))
subtype (downcase (match-string 2 content-type))
message-rfc822 (and (string= type "message")
(string= subtype "rfc822"))
multipart-any (string= type "multipart")))
(when (string-match ";[ \t\n]*name=\\([^ \t\n;]+\\)" content-type)
(setq subject (match-string 1 content-type)))
(when (string-match "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)" content-type)
(setq boundary-regexp (concat "^--"
(regexp-quote
(match-string 1 content-type))
"\\(--\\)?[ \t]*\n"))))
(unless subject
(when (or multipart-any (not article-insert))
(setq subject (message-fetch-field "Subject"))))
(unless type
(setq type "text"
subtype "plain"))
;; Prepare the article and summary inserts.
(unless article-insert
(setq article-insert (buffer-substring (point-min) (point-max))
head-end head-begin))
(setq summary-insert article-insert)
;; - summary Subject.
(setq summary-insert
(let ((line (concat "Subject: <" position
(and position multipart-any ".")
(and multipart-any "*")
(and (or position multipart-any) " ")
(cond ((string= subtype "plain") type)
((string= subtype "basic") type)
(t subtype))
">"
(and subject " ")
subject
"\n")))
(if (string-match "Subject:.*\n\\([ \t].*\n\\)*" summary-insert)
(replace-match line t t summary-insert)
(concat summary-insert line))))
;; - summary Message-ID.
(setq summary-insert
(let ((line (concat "Message-ID: " message-id "\n")))
(if (string-match "Message-ID:.*\n\\([ \t].*\n\\)*" summary-insert)
(replace-match line t t summary-insert)
(concat summary-insert line))))
;; - summary References.
(when parent
(setq summary-insert
(let ((line (concat "References: " parent "\n")))
(if (string-match "References:.*\n\\([ \t].*\n\\)*"
summary-insert)
(replace-match line t t summary-insert)
(concat summary-insert line)))))
;; Generate dissection information for this entity.
(push (list (incf nndoc-mime-split-ordinal)
head-begin head-end body-begin body-end
(count-lines body-begin body-end)
article-insert summary-insert)
nndoc-dissection-alist)
;; Recurse for all sub-entities, if any.
(widen)
(cond
(message-rfc822
(save-excursion
(nndoc-dissect-mime-parts-sub body-begin body-end nil
position message-id)))
((and multipart-any boundary-regexp)
(let ((part-counter 0)
part-begin part-end eof-flag)
(while (string-match "\
^\\(Lines\\|Content-\\(Type\\|Transfer-Encoding\\|Disposition\\)\\):.*\n\\([ \t].*\n\\)*"
article-insert)
(setq article-insert (replace-match "" t t article-insert)))
(let ((case-fold-search nil))
(goto-char body-begin)
(setq eof-flag (not (re-search-forward boundary-regexp body-end t)))
(while (not eof-flag)
(setq begin (point))
(cond ((re-search-forward boundary body-end t)
(setq part-begin (point))
(cond ((re-search-forward boundary-regexp body-end t)
(or (not (match-string 1))
(string= (match-string 1) "")
(setq eof-flag t))
(forward-line -1)
(setq end (point))
(setq part-end (point))
(forward-line 1))
(t (setq end body-end
(t (setq part-end body-end
eof-flag t)))
(nndoc-dissect-mime-parts-sub begin end
(concat position (when position ".")
(format "%d"
(incf part-counter)))
(nnmail-message-id)
message-id)))))))
(save-excursion
(nndoc-dissect-mime-parts-sub
part-begin part-end article-insert
(concat position
(and position ".")
(format "%d" (incf part-counter)))
message-id)))))))))
;;;###autoload
(defun nndoc-add-type (definition &optional position)

68
lisp/gnus/nndraft.el
View File

@ -1,5 +1,6 @@
;;; nndraft.el --- draft article access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -30,6 +31,7 @@
(require 'gnus-start)
(require 'nnmh)
(require 'nnoo)
(require 'mm-util)
(eval-when-compile
(require 'cl)
;; This is just to shut up the byte-compiler.
@ -77,16 +79,12 @@
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let* ((buf (get-buffer-create " *draft headers*"))
article)
(set-buffer buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(let* (article)
;; We don't support fetching by Message-ID.
(if (stringp (car articles))
'headers
(while articles
(set-buffer buf)
(narrow-to-region (point) (point))
(when (nndraft-request-article
(setq article (pop articles)) group server (current-buffer))
(goto-char (point-min))
@ -94,10 +92,10 @@
(forward-line -1)
(goto-char (point-max)))
(delete-region (point) (point-max))
(set-buffer nntp-server-buffer)
(goto-char (point-max))
(goto-char (point-min))
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring buf)
(widen)
(goto-char (point-max))
(insert ".\n")))
(nnheader-fold-continuation-lines)
@ -113,7 +111,13 @@
(newest (if (file-newer-than-file-p file auto) file auto))
(nntp-server-buffer (or buffer nntp-server-buffer)))
(when (and (file-exists-p newest)
(nnmail-find-file newest))
(let ((nnmail-file-coding-system
(if (file-newer-than-file-p file auto)
(if (equal group "drafts")
message-draft-coding-system
mm-text-coding-system)
mm-auto-save-coding-system)))
(nnmail-find-file newest)))
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-min))
@ -138,8 +142,9 @@
info
(gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft ""))
(nndraft-articles) t))
(let (marks)
(when (setq marks (nth 3 info))
(let ((marks (nth 3 info)))
(when marks
;; Nix out all marks except the `unsend'-able article marks.
(setcar (nthcdr 3 info)
(if (assq 'unsend marks)
(list (assq 'unsend marks))
@ -153,14 +158,14 @@
(nndraft-possibly-change-group group)
(let ((gnus-verbose-backends nil)
(buf (current-buffer))
article file)
(nnheader-temp-write nil
(insert-buffer buf)
article file)
(with-temp-buffer
(insert-buffer-substring buf)
(setq article (nndraft-request-accept-article
group (nnoo-current-server 'nndraft) t 'noinsert))
(setq file (nndraft-article-filename article)))
(setq buffer-file-name (expand-file-name file))
(setq buffer-auto-save-file-name (make-auto-save-file-name))
group (nnoo-current-server 'nndraft) t 'noinsert)
file (nndraft-article-filename article)))
(setq buffer-file-name (expand-file-name file)
buffer-auto-save-file-name (make-auto-save-file-name))
(clear-visited-file-modtime)
article))
@ -177,7 +182,14 @@
(let ((auto (nndraft-auto-save-file-name
(nndraft-article-filename article))))
(when (file-exists-p auto)
(funcall nnmail-delete-file-function auto)))))
(funcall nnmail-delete-file-function auto)))
(dolist (backup
(let ((kept-new-versions 1)
(kept-old-versions 0))
(find-backup-file-name
(nndraft-article-filename article))))
(when (file-exists-p backup)
(funcall nnmail-delete-file-function backup)))))
res))
(deffoo nndraft-request-accept-article (group &optional server last noinsert)
@ -186,6 +198,15 @@
(nnoo-parent-function 'nndraft 'nnmh-request-accept-article
(list group server last noinsert))))
(deffoo nndraft-request-replace-article (article group buffer)
(nndraft-possibly-change-group group)
(let ((nnmail-file-coding-system
(if (equal group "drafts")
mm-auto-save-coding-system
mm-text-coding-system)))
(nnoo-parent-function 'nndraft 'nnmh-request-replace-article
(list article group buffer))))
(deffoo nndraft-request-create-group (group &optional server args)
(nndraft-possibly-change-group group)
(if (file-exists-p nndraft-current-directory)
@ -237,10 +258,9 @@
nnmh-retrieve-headers
nnmh-request-group
nnmh-close-group
nnmh-request-list
nnmh-request-list
nnmh-request-newsgroups
nnmh-request-move-article
nnmh-request-replace-article))
nnmh-request-move-article))
(provide 'nndraft)

55
lisp/gnus/nneething.el
View File

@ -1,5 +1,7 @@
;;; nneething.el --- arbitrary file access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -45,6 +47,11 @@
"Regexp saying what files to exclude from the group.
If this variable is nil, no files will be excluded.")
(defvoo nneething-include-files nil
"Regexp saying what files to include in the group.
If this variable is non-nil, only files matching this regexp will be
included.")
;;; Internal variables.
@ -68,8 +75,6 @@ If this variable is nil, no files will be excluded.")
(autoload 'gnus-encode-coding-string "gnus-ems")
;;; Interface functions.
(nnoo-define-basics nneething)
@ -104,7 +109,7 @@ If this variable is nil, no files will be excluded.")
(and large
(zerop (% count 20))
(nnheader-message 5 "nneething: Receiving headers... %d%%"
(/ (* count 100) number))))
(/ (* count 100) number))))
(when large
(nnheader-message 5 "nneething: Receiving headers...done"))
@ -124,7 +129,8 @@ If this variable is nil, no files will be excluded.")
(nnmail-find-file file) ; Insert the file in the nntp buf.
(unless (nnheader-article-p) ; Either it's a real article...
(goto-char (point-min))
(nneething-make-head file (current-buffer)) ; ... or we fake some headers.
(nneething-make-head
file (current-buffer)) ; ... or we fake some headers.
(insert "\n"))
t))))
@ -213,17 +219,27 @@ If this variable is nil, no files will be excluded.")
(setq files (cdr files)))
(setq prev f))
(setq f (cdr f)))))
;; Remove files not matching the inclusion regexp.
(when nneething-include-files
(let ((f files)
prev)
(while f
(if (not (string-match nneething-include-files (car f)))
(if prev (setcdr prev (cdr f))
(setq files (cdr files)))
(setq prev f))
(setq f (cdr f)))))
;; Remove deleted files from the map.
(let ((map nneething-map)
prev)
(while map
(if (and (member (cadar map) files)
(if (and (member (cadr (car map)) files)
;; We also remove files that have changed mod times.
(equal (nth 5 (file-attributes
(nneething-file-name (cadar map))))
(caddar map)))
(nneething-file-name (cadr (car map)))))
(cadr (cdar map))))
(progn
(push (cadar map) map-files)
(push (cadr (car map)) map-files)
(setq prev map))
(setq touched t)
(if prev
@ -243,7 +259,7 @@ If this variable is nil, no files will be excluded.")
(setq files (cdr files)))
(when (and touched
(not nneething-read-only))
(nnheader-temp-write map-file
(with-temp-file map-file
(insert "(setq nneething-map '")
(gnus-prin1 nneething-map)
(insert ")\n(setq nneething-active '")
@ -281,8 +297,7 @@ If this variable is nil, no files will be excluded.")
(concat "Lines: " (int-to-string
(count-lines (point-min) (point-max)))
"\n"))
"")
)))
""))))
(defun nneething-from-line (uid &optional file)
"Return a From header based of UID."
@ -302,7 +317,8 @@ If this variable is nil, no files will be excluded.")
(substring file
(match-beginning 1)
(match-end 1))
(when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
(when (string-match
"/\\(users\\|home\\)/\\([^/]+\\)/" file)
(setq login (substring file
(match-beginning 2)
(match-end 2))
@ -316,7 +332,7 @@ If this variable is nil, no files will be excluded.")
(save-excursion
(set-buffer (get-buffer-create nneething-work-buffer))
(setq case-fold-search nil)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
(cond
((not (file-exists-p file))
@ -344,10 +360,13 @@ If this variable is nil, no files will be excluded.")
(defun nneething-file-name (article)
"Return the file name of ARTICLE."
(concat (file-name-as-directory nneething-address)
(if (numberp article)
(cadr (assq article nneething-map))
article)))
(let ((dir (file-name-as-directory nneething-address))
fname)
(if (numberp article)
(if (setq fname (cadr (assq article nneething-map)))
(expand-file-name fname dir)
(make-temp-name (expand-file-name "nneething" dir)))
(expand-file-name article dir))))
(provide 'nneething)

244
lisp/gnus/nnfolder.el
View File

@ -1,5 +1,6 @@
;;; nnfolder.el --- mail folder access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Scott Byer <byer@mv.us.adobe.com>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -40,27 +41,29 @@
"The name of the nnfolder directory.")
(defvoo nnfolder-active-file
(nnheader-concat nnfolder-directory "active")
(nnheader-concat nnfolder-directory "active")
"The name of the active file.")
;; I renamed this variable to something more in keeping with the general GNU
;; style. -SLB
(defvoo nnfolder-ignore-active-file nil
"If non-nil, causes nnfolder to do some extra work in order to determine
the true active ranges of an mbox file. Note that the active file is still
saved, but it's values are not used. This costs some extra time when
scanning an mbox when opening it.")
"If non-nil, the active file is ignores.
This causes nnfolder to do some extra work in order to determine the
true active ranges of an mbox file. Note that the active file is
still saved, but it's values are not used. This costs some extra time
when scanning an mbox when opening it.")
(defvoo nnfolder-distrust-mbox nil
"If non-nil, causes nnfolder to not trust the user with respect to
inserting unaccounted for mail in the middle of an mbox file. This can greatly
slow down scans, which now must scan the entire file for unmarked messages.
When nil, scans occur forward from the last marked message, a huge
time saver for large mailboxes.")
"If non-nil, the folder will be distrusted.
This means that nnfolder will not trust the user with respect to
inserting unaccounted for mail in the middle of an mbox file. This
can greatly slow down scans, which now must scan the entire file for
unmarked messages. When nil, scans occur forward from the last marked
message, a huge time saver for large mailboxes.")
(defvoo nnfolder-newsgroups-file
(concat (file-name-as-directory nnfolder-directory) "newsgroups")
(concat (file-name-as-directory nnfolder-directory) "newsgroups")
"Mail newsgroups description file.")
(defvoo nnfolder-get-new-mail t
@ -90,6 +93,13 @@ time saver for large mailboxes.")
(defvoo nnfolder-buffer-alist nil)
(defvoo nnfolder-scantime-alist nil)
(defvoo nnfolder-active-timestamp nil)
(defvoo nnfolder-active-file-coding-system mm-text-coding-system)
(defvoo nnfolder-active-file-coding-system-for-write
nnmail-active-file-coding-system)
(defvoo nnfolder-file-coding-system mm-text-coding-system)
(defvoo nnfolder-file-coding-system-for-write nnheader-file-coding-system
"Coding system for save nnfolder file.
If NIL, NNFOLDER-FILE-CODING-SYSTEM is used.")
@ -112,8 +122,9 @@ time saver for large mailboxes.")
(set-buffer nnfolder-current-buffer)
(when (nnfolder-goto-article article)
(setq start (point))
(search-forward "\n\n" nil t)
(setq stop (1- (point)))
(setq stop (if (search-forward "\n\n" nil t)
(1- (point))
(point-max)))
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nnfolder-current-buffer start stop)
@ -176,11 +187,13 @@ time saver for large mailboxes.")
(if (numberp article)
(cons nnfolder-current-group article)
(goto-char (point-min))
(search-forward (concat "\n" nnfolder-article-marker))
(cons nnfolder-current-group
(string-to-int
(buffer-substring
(point) (progn (end-of-line) (point)))))))))))
(if (search-forward (concat "\n" nnfolder-article-marker)
nil t)
(string-to-int
(buffer-substring
(point) (progn (end-of-line) (point))))
-1))))))))
(deffoo nnfolder-request-group (group &optional server dont-check)
(nnfolder-possibly-change-group group server t)
@ -266,15 +279,14 @@ 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)
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-read-folder group)))
t)
(deffoo nnfolder-request-list (&optional server)
(nnfolder-possibly-change-group nil server)
(save-excursion
(let ((nnmail-file-coding-system nnmail-active-file-coding-system)
(pathname-coding-system 'binary))
(let ((nnmail-file-coding-system nnfolder-active-file-coding-system))
(nnmail-find-file nnfolder-active-file)
(setq nnfolder-group-alist (nnmail-get-active)))
t))
@ -286,38 +298,69 @@ time saver for large mailboxes.")
(deffoo nnfolder-request-list-newsgroups (&optional server)
(nnfolder-possibly-change-group nil server)
(save-excursion
(nnmail-find-file nnfolder-newsgroups-file)))
(let ((nnmail-file-coding-system nnfolder-file-coding-system))
(nnmail-find-file nnfolder-newsgroups-file))))
;; Return a list consisting of all article numbers existing in the
;; current folder.
(defun nnfolder-existing-articles ()
(save-excursion
(when nnfolder-current-buffer
(set-buffer nnfolder-current-buffer)
(goto-char (point-min))
(let ((marker (concat "\n" nnfolder-article-marker))
(number "[0-9]+")
numbers)
(while (and (search-forward marker nil t)
(re-search-forward number nil t))
(let ((newnum (string-to-number (match-string 0))))
(if (nnmail-within-headers-p)
(push newnum numbers))))
numbers))))
(deffoo nnfolder-request-expire-articles
(articles newsgroup &optional server force)
(articles newsgroup &optional server force)
(nnfolder-possibly-change-group newsgroup server)
(let* ((is-old t)
rest)
;; The articles we have deleted so far.
(deleted-articles nil)
;; The articles that really exist and will
;; be expired if they are old enough.
(maybe-expirable
(gnus-intersection articles (nnfolder-existing-articles))))
(nnmail-activate 'nnfolder)
(save-excursion
(set-buffer nnfolder-current-buffer)
(while (and articles is-old)
;; Since messages are sorted in arrival order and expired in the
;; same order, we can stop as soon as we find a message that is
;; too old.
(while (and maybe-expirable is-old)
(goto-char (point-min))
(when (nnfolder-goto-article (car articles))
(if (setq is-old
(nnmail-expired-article-p
newsgroup
(buffer-substring
(point) (progn (end-of-line) (point)))
force nnfolder-inhibit-expiry))
(progn
(nnheader-message 5 "Deleting article %d..."
(car articles) newsgroup)
(nnfolder-delete-mail))
(push (car articles) rest)))
(setq articles (cdr articles)))
(when (and (nnfolder-goto-article (car maybe-expirable))
(search-forward (concat "\n" nnfolder-article-marker)
nil t))
(forward-sexp)
(when (setq is-old
(nnmail-expired-article-p
newsgroup
(buffer-substring
(point) (progn (end-of-line) (point)))
force nnfolder-inhibit-expiry))
(nnheader-message 5 "Deleting article %d..."
(car maybe-expirable) newsgroup)
(nnfolder-delete-mail)
;; Must remember which articles were actually deleted
(push (car maybe-expirable) deleted-articles)))
(setq maybe-expirable (cdr maybe-expirable)))
(unless nnfolder-inhibit-expiry
(nnheader-message 5 "Deleting articles...done"))
(nnfolder-save-buffer)
(nnfolder-adjust-min-active newsgroup)
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nconc rest articles))))
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
(gnus-sorted-complement articles (nreverse deleted-articles)))))
(deffoo nnfolder-request-move-article (article group server
accept-form &optional last)
@ -328,13 +371,13 @@ time saver for large mailboxes.")
(nnfolder-request-article article group server)
(save-excursion
(set-buffer buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
(while (re-search-forward
(concat "^" nnfolder-article-marker)
(save-excursion (search-forward "\n\n" nil t) (point)) t)
(save-excursion (and (search-forward "\n\n" nil t) (point)))
t)
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
(setq result (eval accept-form))
@ -349,7 +392,7 @@ time saver for large mailboxes.")
(when last
(nnfolder-save-buffer)
(nnfolder-adjust-min-active group)
(nnmail-save-active nnfolder-group-alist nnfolder-active-file))))
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file))))
result)))
(deffoo nnfolder-request-accept-article (group &optional server last)
@ -366,8 +409,9 @@ time saver for large mailboxes.")
(save-excursion
(set-buffer buf)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-line -1)
(if (search-forward "\n\n" nil t)
(forward-line -1)
(goto-char (point-max)))
(while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
(delete-region (point) (progn (forward-line 1) (point))))
(when nnmail-cache-accepted-message-ids
@ -387,7 +431,7 @@ time saver for large mailboxes.")
(nnfolder-save-buffer)
(when nnmail-cache-accepted-message-ids
(nnmail-cache-close)))))
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
(unless result
(nnheader-report 'nnfolder "Couldn't store article"))
result)))
@ -404,7 +448,7 @@ time saver for large mailboxes.")
(goto-char (point-min))
(if xfrom
(insert "From " xfrom "\n")
(unless (looking-at message-unix-mail-delimiter)
(unless (looking-at "From ")
(insert "From nobody " (current-time-string) "\n"))))
(nnfolder-normalize-buffer)
(set-buffer nnfolder-current-buffer)
@ -430,7 +474,7 @@ time saver for large mailboxes.")
nnfolder-current-group nil
nnfolder-current-buffer nil)
;; Save the active file.
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
t)
(deffoo nnfolder-request-rename-group (group new-name &optional server)
@ -441,7 +485,9 @@ time saver for large mailboxes.")
(ignore-errors
(rename-file
buffer-file-name
(nnfolder-group-pathname new-name))
(let ((new-file (nnfolder-group-pathname new-name)))
(gnus-make-directory (file-name-directory new-file))
new-file))
t)
;; That went ok, so we change the internal structures.
(let ((entry (assoc group nnfolder-group-alist)))
@ -449,7 +495,7 @@ time saver for large mailboxes.")
(setq nnfolder-current-buffer nil
nnfolder-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
;; We kill the buffer instead of renaming it and stuff.
(kill-buffer (current-buffer))
t))))
@ -511,17 +557,21 @@ Returns t if successful, nil otherwise."
"Delete the message that point is in.
If optional argument LEAVE-DELIM is t, then mailbox delimiter is not
deleted. Point is left where the deleted region was."
(delete-region
(save-excursion
(forward-line 1) ; in case point is at beginning of message already
(nnmail-search-unix-mail-delim-backward)
(if leave-delim (progn (forward-line 1) (point))
(point)))
(progn
(forward-line 1)
(if (nnmail-search-unix-mail-delim)
(point)
(point-max)))))
(save-restriction
(narrow-to-region
(save-excursion
;; In case point is at the beginning of the message already.
(forward-line 1)
(nnmail-search-unix-mail-delim-backward)
(if leave-delim (progn (forward-line 1) (point))
(point)))
(progn
(forward-line 1)
(if (nnmail-search-unix-mail-delim)
(point)
(point-max))))
(run-hooks 'nnfolder-delete-mail-hook)
(delete-region (point-min) (point-max))))
(defun nnfolder-possibly-change-group (group &optional server dont-check)
;; Change servers.
@ -534,15 +584,14 @@ deleted. Point is left where the deleted region was."
;; Change group.
(when (and group
(not (equal group nnfolder-current-group)))
(let ((file-name-coding-system 'binary)
(pathname-coding-system 'binary))
(let ((file-name-coding-system nnmail-pathname-coding-system))
(nnmail-activate 'nnfolder)
(when (and (not (assoc group nnfolder-group-alist))
(not (file-exists-p
(nnfolder-group-pathname group))))
;; 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))
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file))
(if dont-check
(setq nnfolder-current-group group
@ -572,7 +621,10 @@ deleted. Point is left where the deleted region was."
;; See whether we need to create the new file.
(unless (file-exists-p file)
(gnus-make-directory (file-name-directory file))
(nnmail-write-region 1 1 file t 'nomesg))
(let ((nnmail-file-coding-system
(or nnfolder-file-coding-system-for-write
nnfolder-file-coding-system-for-write)))
(nnmail-write-region 1 1 file t 'nomesg)))
(when (setq nnfolder-current-buffer (nnfolder-read-folder group))
(set-buffer nnfolder-current-buffer)
(push (list group nnfolder-current-buffer)
@ -583,19 +635,14 @@ deleted. Point is left where the deleted region was."
(let* (save-list group-art)
(goto-char (point-min))
;; The From line may have been quoted by movemail.
(when (looking-at (concat ">" message-unix-mail-delimiter))
(when (looking-at ">From")
(delete-char 1))
;; This might come from somewhere else.
(unless (looking-at message-unix-mail-delimiter)
(unless (looking-at "From ")
(insert "From nobody " (current-time-string) "\n")
(goto-char (point-min)))
(forward-line 1)
;; Quote subsequent "From " lines in the header.
(while (looking-at message-unix-mail-delimiter)
(delete-region (point) (+ (point) 4))
(insert "X-From-Line:")
(forward-line 1))
;; Quote all "From " lines in the article.
(forward-line 1)
(let (case-fold-search)
(while (re-search-forward "^From " nil t)
(beginning-of-line)
@ -610,8 +657,9 @@ deleted. Point is left where the deleted region was."
(while (setq group-art (pop group-art-list))
;; Kill any previous newsgroup markers.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-line -1)
(if (search-forward "\n\n" nil t)
(forward-line -1)
(goto-char (point-max)))
(while (search-backward (concat "\n" nnfolder-article-marker) nil t)
(delete-region (1+ (point)) (progn (forward-line 2) (point))))
@ -640,10 +688,12 @@ deleted. Point is left where the deleted region was."
(defun nnfolder-insert-newsgroup-line (group-art)
(save-excursion
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(forward-char -1)
(insert (format (concat nnfolder-article-marker "%d %s\n")
(cdr group-art) (current-time-string))))))
(unless (search-forward "\n\n" nil t)
(goto-char (point-max))
(insert "\n"))
(forward-char -1)
(insert (format (concat nnfolder-article-marker "%d %s\n")
(cdr group-art) (current-time-string)))))
(defun nnfolder-active-number (group)
;; Find the next article number in GROUP.
@ -665,7 +715,7 @@ deleted. Point is left where the deleted region was."
(when inf
(setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)))
(when nnfolder-group-alist
(nnmail-save-active nnfolder-group-alist nnfolder-active-file))
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file))
(push (list group (nnfolder-read-folder group))
nnfolder-buffer-alist))))
@ -686,7 +736,10 @@ deleted. Point is left where the deleted region was."
(defun nnfolder-read-folder (group)
(let* ((file (nnfolder-group-pathname group))
(buffer (set-buffer (nnheader-find-file-noselect file))))
(buffer (set-buffer
(let ((nnheader-file-coding-system
nnfolder-file-coding-system))
(nnheader-find-file-noselect file)))))
(if (equal (cadr (assoc group nnfolder-scantime-alist))
(nth 5 (file-attributes file)))
;; This looks up-to-date, so we don't do any scanning.
@ -694,12 +747,16 @@ deleted. Point is left where the deleted region was."
buffer
(push (list group buffer) nnfolder-buffer-alist)
(set-buffer-modified-p t)
(save-buffer))
(nnfolder-save-buffer))
;; Parse the damn thing.
(save-excursion
(goto-char (point-min))
;; Remove any blank lines at the start.
(while (eq (following-char) ?\n)
(delete-char 1))
(nnmail-activate 'nnfolder)
;; Read in the file.
(let ((delim (concat "^" message-unix-mail-delimiter))
(let ((delim "^From ")
(marker (concat "\n" nnfolder-article-marker))
(number "[0-9]+")
(active (or (cadr (assoc group nnfolder-group-alist))
@ -708,7 +765,7 @@ deleted. Point is left where the deleted region was."
(minid (lsh -1 -1))
maxid start end newscantime
buffer-read-only)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(setq maxid (cdr active))
(goto-char (point-min))
@ -768,7 +825,7 @@ deleted. Point is left where the deleted region was."
(set-marker end nil)
;; Make absolutely sure that the active list reflects reality!
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
;; Set the scantime for this group.
(setq newscantime (visited-file-modtime))
(if scantime
@ -779,7 +836,8 @@ deleted. Point is left where the deleted region was."
;;;###autoload
(defun nnfolder-generate-active-file ()
"Look for mbox folders in the nnfolder directory and make them into groups."
"Look for mbox folders in the nnfolder directory and make them into groups.
This command does not work if you use short group names."
(interactive)
(nnmail-activate 'nnfolder)
(let ((files (directory-files nnfolder-directory))
@ -803,7 +861,8 @@ deleted. Point is left where the deleted region was."
(defun nnfolder-group-pathname (group)
"Make pathname for GROUP."
(setq group (gnus-encode-coding-string group nnmail-pathname-coding-system))
(setq group
(mm-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
@ -817,7 +876,16 @@ deleted. Point is left where the deleted region was."
(when (buffer-modified-p)
(run-hooks 'nnfolder-save-buffer-hook)
(gnus-make-directory (file-name-directory (buffer-file-name)))
(save-buffer)))
(let ((coding-system-for-write
(or nnfolder-file-coding-system-for-write
nnfolder-file-coding-system)))
(save-buffer))))
(defun nnfolder-save-active (group-alist active-file)
(let ((nnmail-active-file-coding-system
(or nnfolder-active-file-coding-system-for-write
nnfolder-active-file-coding-system)))
(nnmail-save-active group-alist active-file)))
(provide 'nnfolder)

6
lisp/gnus/nngateway.el
View File

@ -1,5 +1,7 @@
;;; nngateway.el --- posting news via mail gateways
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@ -55,7 +57,7 @@ parameter -- the gateway address.")
(nngateway-open-server server))
;; Rewrite the header.
(let ((buf (current-buffer)))
(nnheader-temp-write nil
(with-temp-buffer
(insert-buffer-substring buf)
(message-narrow-to-head)
(funcall nngateway-header-transformation nngateway-address)

327
lisp/gnus/nnheader.el
View File

@ -1,5 +1,8 @@
;;; nnheader.el --- header access macros for Gnus and its backends
;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
;; 1997, 1998, 2000
;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -24,24 +27,12 @@
;;; Commentary:
;; These macros may look very much like the ones in GNUS 4.1. They
;; are, in a way, but you should note that the indices they use have
;; been changed from the internal GNUS format to the NOV format. The
;; makes it possible to read headers from XOVER much faster.
;;
;; The format of a header is now:
;; [number subject from date id references chars lines xref]
;;
;; (That last entry is defined as "misc" in the NOV format, but Gnus
;; uses it for xrefs.)
;;; Code:
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'mail-utils)
(require 'mm-util)
(defvar nnheader-max-head-length 4096
"*Max length of the head of articles.")
@ -51,23 +42,32 @@
(defvar nnheader-file-name-translation-alist nil
"*Alist that says how to translate characters in file names.
For instance, if \":\" is illegal as a file character in file names
For instance, if \":\" is invalid as a file character in file names
on your system, you could say something like:
\(setq nnheader-file-name-translation-alist '((?: . ?_)))")
(eval-and-compile
(autoload 'nnmail-message-id "nnmail")
(autoload 'mail-position-on-field "sendmail")
(autoload 'message-remove-header "message")
(autoload 'cancel-function-timers "timers")
(autoload 'gnus-point-at-eol "gnus-util")
(autoload 'gnus-delete-line "gnus-util")
(autoload 'gnus-buffer-live-p "gnus-util")
(autoload 'gnus-encode-coding-string "gnus-ems"))
(autoload 'nnmail-message-id "nnmail")
(autoload 'mail-position-on-field "sendmail")
(autoload 'message-remove-header "message")
(autoload 'gnus-point-at-eol "gnus-util")
(autoload 'gnus-delete-line "gnus-util")
(autoload 'gnus-buffer-live-p "gnus-util"))
;;; Header access macros.
;; These macros may look very much like the ones in GNUS 4.1. They
;; are, in a way, but you should note that the indices they use have
;; been changed from the internal GNUS format to the NOV format. The
;; makes it possible to read headers from XOVER much faster.
;;
;; The format of a header is now:
;; [number subject from date id references chars lines xref extra]
;;
;; (That next-to-last entry is defined as "misc" in the NOV format,
;; but Gnus uses it for xrefs.)
(defmacro mail-header-number (header)
"Return article number in HEADER."
`(aref ,header 0))
@ -139,17 +139,26 @@ on your system, you could say something like:
`(aref ,header 8))
(defmacro mail-header-set-xref (header xref)
"Set article xref of HEADER to xref."
"Set article XREF of HEADER to xref."
`(aset ,header 8 ,xref))
(defun make-mail-header (&optional init)
"Create a new mail header structure initialized with INIT."
(make-vector 9 init))
(defmacro mail-header-extra (header)
"Return the extra headers in HEADER."
`(aref ,header 9))
(defun make-full-mail-header (&optional number subject from date id
references chars lines xref)
(defmacro mail-header-set-extra (header extra)
"Set the extra headers in HEADER to EXTRA."
`(aset ,header 9 ',extra))
(defsubst make-mail-header (&optional init)
"Create a new mail header structure initialized with INIT."
(make-vector 10 init))
(defsubst make-full-mail-header (&optional number subject from date id
references chars lines xref
extra)
"Create a new mail header structure initialized with the parameters given."
(vector number subject from date id references chars lines xref))
(vector number subject from date id references chars lines xref extra))
;; fake message-ids: generation and detection
@ -235,11 +244,12 @@ on your system, you could say something like:
;; promising.
(if (and (search-forward "\nin-reply-to: " nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^>]+>" in-reply-to))
(string-match "<[^\n>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^>]+>" in-reply-to (match-end 0))
(while (string-match "<[^\n>]+>"
in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
@ -259,7 +269,20 @@ on your system, you could say something like:
(progn
(goto-char p)
(and (search-forward "\nxref: " nil t)
(nnheader-header-value)))))
(nnheader-header-value)))
;; Extra.
(when nnmail-extra-headers
(let ((extra nnmail-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ": ") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out))))
(when naked
(goto-char (point-min))
(delete-char 1)))))
@ -272,13 +295,29 @@ on your system, you could say something like:
(defmacro nnheader-nov-read-integer ()
'(prog1
(if (= (following-char) ?\t)
(if (eq (char-after) ?\t)
0
(let ((num (ignore-errors (read (current-buffer)))))
(let ((num (condition-case nil
(read (current-buffer))
(error nil))))
(if (numberp num) num 0)))
(or (eobp) (forward-char 1))))
;; (defvar nnheader-none-counter 0)
(defmacro nnheader-nov-parse-extra ()
'(let (out string)
(while (not (memq (char-after) '(?\n nil)))
(setq string (nnheader-nov-field))
(when (string-match "^\\([^ :]+\\): " string)
(push (cons (intern (match-string 1 string))
(substring string (match-end 0)))
out)))
out))
(defmacro nnheader-nov-read-message-id ()
'(let ((id (nnheader-nov-field)))
(if (string-match "^<[^>]+>$" id)
id
(nnheader-generate-fake-message-id))))
(defun nnheader-parse-nov ()
(let ((eol (gnus-point-at-eol)))
@ -287,34 +326,58 @@ on your system, you could say something like:
(nnheader-nov-field) ; subject
(nnheader-nov-field) ; from
(nnheader-nov-field) ; date
(or (nnheader-nov-field)
(nnheader-generate-fake-message-id)) ; id
(nnheader-nov-read-message-id) ; id
(nnheader-nov-field) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(if (= (following-char) ?\n)
(if (eq (char-after) ?\n)
nil
(nnheader-nov-field)) ; misc
)))
(nnheader-nov-parse-extra)))) ; extra
(defun nnheader-insert-nov (header)
(princ (mail-header-number header) (current-buffer))
(let ((p (point)))
(insert
"\t"
(or (mail-header-subject header) "(none)") "\t"
(or (mail-header-from header) "(nobody)") "\t"
(or (mail-header-date header) "") "\t"
(or (mail-header-id header)
(nnmail-message-id))
"\t"
(or (mail-header-references header) "") "\t")
(princ (or (mail-header-chars header) 0) (current-buffer))
(insert "\t")
(princ (or (mail-header-lines header) 0) (current-buffer))
(insert "\t")
(when (mail-header-xref header)
(insert "Xref: " (mail-header-xref header)))
(when (or (mail-header-xref header)
(mail-header-extra header))
(insert "\t"))
(when (mail-header-extra header)
(let ((extra (mail-header-extra header)))
(while extra
(insert (symbol-name (caar extra))
": " (cdar extra) "\t")
(pop extra))))
(insert "\n")
(backward-char 1)
(while (search-backward "\n" p t)
(delete-char 1))
(forward-line 1)))
(defun nnheader-insert-header (header)
(insert
"\t"
(or (mail-header-subject header) "(none)") "\t"
(or (mail-header-from header) "(nobody)") "\t"
(or (mail-header-date header) "") "\t"
(or (mail-header-id header)
(nnmail-message-id))
"\t"
(or (mail-header-references header) "") "\t")
(princ (or (mail-header-chars header) 0) (current-buffer))
(insert "\t")
"Subject: " (or (mail-header-subject header) "(none)") "\n"
"From: " (or (mail-header-from header) "(nobody)") "\n"
"Date: " (or (mail-header-date header) "") "\n"
"Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
"References: " (or (mail-header-references header) "") "\n"
"Lines: ")
(princ (or (mail-header-lines header) 0) (current-buffer))
(insert "\t")
(when (mail-header-xref header)
(insert "Xref: " (mail-header-xref header) "\t"))
(insert "\n"))
(insert "\n\n"))
(defun nnheader-insert-article-line (article)
(goto-char (point-min))
@ -401,6 +464,7 @@ the line could be found."
(save-excursion
(unless (gnus-buffer-live-p nntp-server-buffer)
(setq nntp-server-buffer (get-buffer-create " *nntpd*")))
(mm-enable-multibyte)
(set-buffer nntp-server-buffer)
(erase-buffer)
(kill-all-local-variables)
@ -447,7 +511,7 @@ the line could be found."
nil
(narrow-to-region (point-min) (1- (point)))
(goto-char (point-min))
(while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
(while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
(goto-char (match-end 0)))
(prog1
(eobp)
@ -456,7 +520,8 @@ the line could be found."
(defun nnheader-insert-references (references message-id)
"Insert a References header based on REFERENCES and MESSAGE-ID."
(if (and (not references) (not message-id))
() ; This is illegal, but not all articles have Message-IDs.
;; This is invalid, but not all articles have Message-IDs.
()
(mail-position-on-field "References")
(let ((begin (save-excursion (beginning-of-line) (point)))
(fill-column 78)
@ -495,58 +560,12 @@ the line could be found."
(defun nnheader-set-temp-buffer (name &optional noerase)
"Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
(set-buffer (get-buffer-create name))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(unless noerase
(erase-buffer))
(current-buffer))
(defmacro nnheader-temp-write (file &rest forms)
"Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
Return the value of FORMS.
If FILE is nil, just evaluate FORMS and don't save anything.
If FILE is t, return the buffer contents as a string."
(let ((temp-file (make-symbol "temp-file"))
(temp-buffer (make-symbol "temp-buffer"))
(temp-results (make-symbol "temp-results")))
`(save-excursion
(let* ((,temp-file ,file)
(default-major-mode 'fundamental-mode)
(,temp-buffer
(set-buffer
(get-buffer-create
(generate-new-buffer-name " *nnheader temp*"))))
,temp-results)
(unwind-protect
(progn
(setq ,temp-results (progn ,@forms))
(cond
;; Don't save anything.
((null ,temp-file)
,temp-results)
;; Return the buffer contents.
((eq ,temp-file t)
(set-buffer ,temp-buffer)
(buffer-string))
;; Save a file.
(t
(set-buffer ,temp-buffer)
;; Make sure the directory where this file is
;; to be saved exists.
(when (not (file-directory-p
(file-name-directory ,temp-file)))
(make-directory (file-name-directory ,temp-file) t))
;; Save the file.
(write-region (point-min) (point-max)
,temp-file nil 'nomesg)
,temp-results)))
;; Kill the buffer.
(when (buffer-name ,temp-buffer)
(kill-buffer ,temp-buffer)))))))
(put 'nnheader-temp-write 'lisp-indent-function 1)
(put 'nnheader-temp-write 'edebug-form-spec '(form body))
(defvar jka-compr-compression-info-list)
(eval-when-compile (defvar jka-compr-compression-info-list))
(defvar nnheader-numerical-files
(if (boundp 'jka-compr-compression-info-list)
(concat "\\([0-9]+\\)\\("
@ -563,7 +582,7 @@ If FILE is t, return the buffer contents as a string."
"Regexp that matches numerical full file paths.")
(defsubst nnheader-file-to-number (file)
"Take a file name and return the article number."
"Take a FILE name and return the article number."
(if (string= nnheader-numerical-short-files "^[0-9]+$")
(string-to-int file)
(string-match nnheader-numerical-short-files file)
@ -581,7 +600,7 @@ If FILE is t, return the buffer contents as a string."
second)))
(defun nnheader-directory-articles (dir)
"Return a list of all article files in a directory."
"Return a list of all article files in directory DIR."
(mapcar 'nnheader-file-to-number
(nnheader-directory-files-safe
dir nil nnheader-numerical-short-files t)))
@ -607,7 +626,9 @@ If FULL, translate everything."
(if full
;; Do complete translation.
(setq leaf (copy-sequence file)
path "")
path ""
i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1)))
2 0))
;; We translate -- but only the file name. We leave the directory
;; alone.
(if (string-match "/[^/]+\\'" file)
@ -638,7 +659,7 @@ The first string in ARGS can be a format string."
"Get the most recent report from BACKEND."
(condition-case ()
(nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
backend))))
backend))))
(error (nnheader-message 5 ""))))
(defun nnheader-insert (format &rest args)
@ -653,15 +674,33 @@ without formatting."
(apply 'insert format args))
t))
(defun nnheader-replace-chars-in-string (string from to)
(if (fboundp 'subst-char-in-string)
(defsubst nnheader-replace-chars-in-string (string from to)
(subst-char-in-string from to string))
(defun nnheader-replace-chars-in-string (string from to)
"Replace characters in STRING from FROM to TO."
(let ((string (substring string 0)) ;Copy string.
(len (length string))
(idx 0))
;; Replace all occurrences of FROM with TO.
(while (< idx len)
(when (= (aref string idx) from)
(aset string idx to))
(setq idx (1+ idx)))
string)))
(defun nnheader-replace-duplicate-chars-in-string (string from to)
"Replace characters in STRING from FROM to TO."
(let ((string (substring string 0)) ;Copy string.
(len (length string))
(idx 0))
(idx 0) prev i)
;; Replace all occurrences of FROM with TO.
(while (< idx len)
(when (= (aref string idx) from)
(setq i (aref string idx))
(when (and (eq prev from) (= i from))
(aset string (1- idx) to)
(aset string idx to))
(setq prev i)
(setq idx (1+ idx)))
string))
@ -690,12 +729,7 @@ without formatting."
(or (not (numberp gnus-verbose-backends))
(<= level gnus-verbose-backends)))
(defvar nnheader-pathname-coding-system 'iso-8859-1
"*Coding system for pathname.")
;; 1997/8/10 by MORIOKA Tomohiko
(defvar nnheader-pathname-coding-system
'iso-8859-1
(defvar nnheader-pathname-coding-system 'binary
"*Coding system for pathname.")
(defun nnheader-group-pathname (group dir &optional file)
@ -703,14 +737,14 @@ without formatting."
(concat
(let ((dir (file-name-as-directory (expand-file-name dir))))
;; If this directory exists, we use it directly.
(if (file-directory-p (concat dir group))
(concat dir group "/")
;; If not, we translate dots into slashes.
(concat dir
(gnus-encode-coding-string
(nnheader-replace-chars-in-string group ?. ?/)
nnheader-pathname-coding-system)
"/")))
(file-name-as-directory
(if (file-directory-p (concat dir group))
(expand-file-name group dir)
;; If not, we translate dots into slashes.
(expand-file-name (mm-encode-coding-string
(nnheader-replace-chars-in-string group ?. ?/)
nnheader-pathname-coding-system)
dir))))
(cond ((null file) "")
((numberp file) (int-to-string file))
(t file))))
@ -721,7 +755,7 @@ without formatting."
(and (listp form) (eq (car form) 'lambda))))
(defun nnheader-concat (dir &rest files)
"Concat DIR as directory to FILE."
"Concat DIR as directory to FILES."
(apply 'concat (file-name-as-directory dir) files))
(defun nnheader-ms-strip-cr ()
@ -770,45 +804,26 @@ If FILE, find the \".../etc/PACKAGE\" file instead."
(defvar nnheader-file-coding-system 'raw-text
"Coding system used in file backends of Gnus.")
;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
(defvar nnheader-file-coding-system nil
"Coding system used in file backends of Gnus.")
(defun nnheader-insert-file-contents (filename &optional visit beg end replace)
"Like `insert-file-contents', q.v., but only reads in the file.
A buffer may be modified in several ways after reading into the buffer due
to advanced Emacs features, such as file-name-handlers, format decoding,
find-file-hooks, etc.
This function ensures that none of these modifications will take place."
(let ((format-alist nil)
(auto-mode-alist (nnheader-auto-mode-alist))
(default-major-mode 'fundamental-mode)
(enable-local-variables nil)
(after-insert-file-functions nil)
(find-file-hooks nil)
(coding-system-for-read nnheader-file-coding-system))
(insert-file-contents filename visit beg end replace)))
(let ((coding-system-for-read nnheader-file-coding-system))
(mm-insert-file-contents filename visit beg end replace)))
(defun nnheader-find-file-noselect (&rest args)
(let ((format-alist nil)
(auto-mode-alist (nnheader-auto-mode-alist))
(auto-mode-alist (mm-auto-mode-alist))
(default-major-mode 'fundamental-mode)
(enable-local-variables nil)
(after-insert-file-functions nil)
(enable-local-eval nil)
(find-file-hooks nil)
(coding-system-for-read nnheader-file-coding-system))
(apply 'find-file-noselect args)))
(defun nnheader-auto-mode-alist ()
"Return an `auto-mode-alist' with only the .gz (etc) thingies."
(let ((alist auto-mode-alist)
out)
(while alist
(when (listp (cdar alist))
(push (car alist) out))
(pop alist))
(nreverse out)))
(defun nnheader-directory-regular-files (dir)
"Return a list of all regular files in DIR."
(let ((files (directory-files dir t))
@ -833,8 +848,6 @@ find-file-hooks, etc.
`(let ((new (generate-new-buffer " *nnheader replace*"))
(cur (current-buffer))
(start (point-min)))
(set-buffer new)
(buffer-disable-undo (current-buffer))
(set-buffer cur)
(goto-char (point-min))
(while (,(if regexp 're-search-forward 'search-forward)
@ -852,22 +865,22 @@ find-file-hooks, etc.
(set-buffer cur)))
(defun nnheader-replace-string (from to)
"Do a fast replacement of FROM to TO from point to point-max."
"Do a fast replacement of FROM to TO from point to `point-max'."
(nnheader-skeleton-replace from to))
(defun nnheader-replace-regexp (from to)
"Do a fast regexp replacement of FROM to TO from point to point-max."
"Do a fast regexp replacement of FROM to TO from point to `point-max'."
(nnheader-skeleton-replace from to t))
(defun nnheader-strip-cr ()
"Strip all \r's from the current buffer."
(nnheader-skeleton-replace "\r"))
(fset 'nnheader-run-at-time 'run-at-time)
(fset 'nnheader-cancel-timer 'cancel-timer)
(fset 'nnheader-cancel-function-timers 'cancel-function-timers)
(defalias 'nnheader-run-at-time 'run-at-time)
(defalias 'nnheader-cancel-timer 'cancel-timer)
(defalias 'nnheader-cancel-function-timers 'cancel-function-timers)
(when (string-match "XEmacs\\|Lucid" emacs-version)
(when (string-match "XEmacs" emacs-version)
(require 'nnheaderxm))
(run-hooks 'nnheader-load-hook)

33
lisp/gnus/nnkiboze.el
View File

@ -1,5 +1,7 @@
;;; nnkiboze.el --- select virtual news access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999,.2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -136,7 +138,7 @@
;; Remove NOV lines of articles that are marked as read.
(when (and (file-exists-p (nnkiboze-nov-file-name))
nnkiboze-remove-read-articles)
(nnheader-temp-write (nnkiboze-nov-file-name)
(with-temp-file (nnkiboze-nov-file-name)
(let ((cur (current-buffer)))
(nnheader-insert-file-contents (nnkiboze-nov-file-name))
(goto-char (point-min))
@ -155,15 +157,15 @@
(deffoo nnkiboze-request-delete-group (group &optional force server)
(nnkiboze-possibly-change-group group)
(when force
(let ((files (nconc
(nnkiboze-score-file group)
(list (nnkiboze-nov-file-name)
(nnkiboze-nov-file-name ".newsrc")))))
(while files
(and (file-exists-p (car files))
(file-writable-p (car files))
(delete-file (car files)))
(setq files (cdr files)))))
(let ((files (nconc
(nnkiboze-score-file group)
(list (nnkiboze-nov-file-name)
(nnkiboze-nov-file-name ".newsrc")))))
(while files
(and (file-exists-p (car files))
(file-writable-p (car files))
(delete-file (car files)))
(setq files (cdr files)))))
(setq nnkiboze-current-group nil)
t)
@ -184,6 +186,7 @@
Finds out what articles are to be part of the nnkiboze groups."
(interactive)
(let ((nnmail-spool-file nil)
(mail-sources nil)
(gnus-use-dribble-file nil)
(gnus-read-active-file t)
(gnus-expert-user t))
@ -209,7 +212,7 @@ 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
(newsrc-file (concat nnkiboze-directory
(nnheader-translate-file-chars
(concat group ".newsrc"))))
(nov-file (concat nnkiboze-directory
@ -230,7 +233,7 @@ Finds out what articles are to be part of the nnkiboze groups."
;; Load the kiboze newsrc file for this group.
(when (file-exists-p newsrc-file)
(load newsrc-file))
(nnheader-temp-write nov-file
(with-temp-file nov-file
(when (file-exists-p nov-file)
(insert-file-contents nov-file))
(setq nov-buffer (current-buffer))
@ -287,7 +290,7 @@ Finds out what articles are to be part of the nnkiboze groups."
(car ginfo)))
0))
(progn
(ignore-errors
(ignore-errors
(gnus-group-select-group nil))
(eq major-mode 'gnus-summary-mode)))
;; We are now in the group where we want to be.
@ -318,7 +321,7 @@ Finds out what articles are to be part of the nnkiboze groups."
(gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc))
(setq newsrc (cdr newsrc))))
;; We save the kiboze newsrc for this group.
(nnheader-temp-write newsrc-file
(with-temp-file newsrc-file
(insert "(setq nnkiboze-newsrc '")
(gnus-prin1 nnkiboze-newsrc)
(insert ")\n")))

29
lisp/gnus/nnlistserv.el
View File

@ -1,5 +1,6 @@
;;; nnlistserv.el --- retrieving articles via web mailing list archives
;; Copyright (C) 1997,98 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@ -31,8 +32,7 @@
(eval-when-compile (require 'cl))
(require 'nnoo)
(eval-when-compile (ignore-errors (require 'nnweb)))
(eval '(require 'nnweb))
(require 'nnweb)
(nnoo-declare nnlistserv
nnweb)
@ -46,15 +46,15 @@
nnweb-type)
(defvoo nnlistserv-type-definition
'((kk
(article . nnlistserv-kk-wash-article)
(map . nnlistserv-kk-create-mapping)
(search . nnlistserv-kk-search)
(address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/")
(pages "fra160396" "fra160796" "fra061196" "fra160197"
"fra090997" "fra040797" "fra130397" "nye")
(index . "date.html")
(identifier . nnlistserv-kk-identity)))
'((kk
(article . nnlistserv-kk-wash-article)
(map . nnlistserv-kk-create-mapping)
(search . nnlistserv-kk-search)
(address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/")
(pages "fra160396" "fra160796" "fra061196" "fra160197"
"fra090997" "fra040797" "fra130397" "nye")
(index . "date.html")
(identifier . nnlistserv-kk-identity)))
"Type-definition alist."
nnweb-type-definition)
@ -112,8 +112,7 @@
nil 0 0 url))
map)
(nnweb-set-hashtb (cadar map) (car map))
(nnheader-message 5 "%s %s %s" (cdr active) (point) pages)
))))
(nnheader-message 5 "%s %s %s" (cdr active) (point) pages)))))
;; Return the articles in the right order.
(setq nnweb-articles
(sort (nconc nnweb-articles map) 'car-less-than-car)))))
@ -142,7 +141,7 @@
(defun nnlistserv-kk-search (search)
(url-insert-file-contents
(concat (format (nnweb-definition 'address) search)
(concat (format (nnweb-definition 'address) search)
(nnweb-definition 'index)))
t)

1049
lisp/gnus/nnmail.el
View File

File diff suppressed because it is too large Load Diff

115
lisp/gnus/nnmbox.el
View File

@ -1,5 +1,7 @@
;;; nnmbox.el --- mail mbox access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -59,6 +61,11 @@
(defvoo nnmbox-group-alist nil)
(defvoo nnmbox-active-timestamp nil)
(defvoo nnmbox-file-coding-system mm-text-coding-system)
(defvoo nnmbox-file-coding-system-for-write nil)
(defvoo nnmbox-active-file-coding-system mm-text-coding-system)
(defvoo nnmbox-active-file-coding-system-for-write nil)
;;; Interface functions
@ -166,6 +173,7 @@
(nnmbox-article-group-number)))))))
(deffoo nnmbox-request-group (group &optional server dont-check)
(nnmbox-possibly-change-newsgroup nil server)
(let ((active (cadr (assoc group nnmbox-group-alist))))
(cond
((or (null active)
@ -180,6 +188,18 @@
(1+ (- (cdr active) (car active)))
(car active) (cdr active) group)))))
(defun nnmbox-save-buffer ()
(let ((coding-system-for-write
(or nnmbox-file-coding-system-for-write
nnmbox-file-coding-system)))
(save-buffer)))
(defun nnmbox-save-active (group-alist active-file)
(let ((nnmail-active-file-coding-system
(or nnmbox-active-file-coding-system-for-write
nnmbox-active-file-coding-system)))
(nnmail-save-active group-alist active-file)))
(deffoo nnmbox-request-scan (&optional group server)
(nnmbox-possibly-change-newsgroup group server)
(nnmbox-read-mbox)
@ -188,7 +208,7 @@
(lambda ()
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(save-buffer)))
(nnmbox-save-buffer)))
(file-name-directory nnmbox-mbox-file)
group
(lambda ()
@ -197,7 +217,7 @@
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-max))
(insert-buffer-substring in-buf)))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file))))
(deffoo nnmbox-close-group (group &optional server)
t)
@ -207,12 +227,14 @@
(unless (assoc group nnmbox-group-alist)
(push (list group (cons 1 0))
nnmbox-group-alist)
(nnmail-save-active nnmbox-group-alist nnmbox-active-file))
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file))
t)
(deffoo nnmbox-request-list (&optional server)
(save-excursion
(nnmail-find-file nnmbox-active-file)
(let ((nnmail-file-coding-system
nnmbox-active-file-coding-system))
(nnmail-find-file nnmbox-active-file))
(setq nnmbox-group-alist (nnmail-get-active))
t))
@ -223,7 +245,7 @@
(nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
(deffoo nnmbox-request-expire-articles
(articles newsgroup &optional server force)
(articles newsgroup &optional server force)
(nnmbox-possibly-change-newsgroup newsgroup server)
(let* ((is-old t)
rest)
@ -245,7 +267,7 @@
(nnmbox-delete-mail))
(push (car articles) rest)))
(setq articles (cdr articles)))
(save-buffer)
(nnmbox-save-buffer)
;; Find the lowest active article in this group.
(let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
(goto-char (point-min))
@ -254,18 +276,17 @@
(<= (car active) (cdr active)))
(setcar active (1+ (car active)))
(goto-char (point-min))))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
(nconc rest articles))))
(deffoo nnmbox-request-move-article
(article group server accept-form &optional last)
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnmbox move*"))
result)
(and
(nnmbox-request-article article group server)
(save-excursion
(set-buffer buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
@ -283,7 +304,7 @@
(goto-char (point-min))
(when (search-forward (nnmbox-article-string article) nil t)
(nnmbox-delete-mail))
(and last (save-buffer))))
(and last (nnmbox-save-buffer))))
result))
(deffoo nnmbox-request-accept-article (group &optional server last)
@ -323,8 +344,8 @@
(when last
(when nnmail-cache-accepted-message-ids
(nnmail-cache-close))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(save-buffer))))
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
(nnmbox-save-buffer))))
result))
(deffoo nnmbox-request-replace-article (article group buffer)
@ -336,7 +357,7 @@
nil
(nnmbox-delete-mail t t)
(insert-buffer-substring buffer)
(save-buffer)
(nnmbox-save-buffer)
t)))
(deffoo nnmbox-request-delete-group (group &optional force server)
@ -354,13 +375,13 @@
(setq found t)
(nnmbox-delete-mail))
(when found
(save-buffer)))))
(nnmbox-save-buffer)))))
;; Remove the group from all structures.
(setq nnmbox-group-alist
(delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
nnmbox-current-group nil)
;; Save the active file.
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
t)
(deffoo nnmbox-request-rename-group (group new-name &optional server)
@ -375,13 +396,13 @@
(replace-match new-ident t t)
(setq found t))
(when found
(save-buffer))))
(nnmbox-save-buffer))))
(let ((entry (assoc group nnmbox-group-alist)))
(when entry
(setcar entry new-name))
(setq nnmbox-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
t))
@ -425,9 +446,12 @@
(not (buffer-name nnmbox-mbox-buffer)))
(save-excursion
(set-buffer (setq nnmbox-mbox-buffer
(nnheader-find-file-noselect
nnmbox-mbox-file nil 'raw)))
(buffer-disable-undo (current-buffer))))
(let ((nnheader-file-coding-system
nnmbox-file-coding-system))
(nnheader-find-file-noselect
nnmbox-mbox-file nil t))))
(mm-enable-multibyte)
(buffer-disable-undo)))
(when (not nnmbox-group-alist)
(nnmail-activate 'nnmbox))
(if newsgroup
@ -496,7 +520,10 @@
(defun nnmbox-create-mbox ()
(when (not (file-exists-p nnmbox-mbox-file))
(nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg)))
(let ((nnmail-file-coding-system
(or nnmbox-file-coding-system-for-write
nnmbox-file-coding-system)))
(nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg))))
(defun nnmbox-read-mbox ()
(nnmail-activate 'nnmbox)
@ -512,9 +539,12 @@
(alist nnmbox-group-alist)
start end number)
(set-buffer (setq nnmbox-mbox-buffer
(nnheader-find-file-noselect
nnmbox-mbox-file nil 'raw)))
(buffer-disable-undo (current-buffer))
(let ((nnheader-file-coding-system
nnmbox-file-coding-system))
(nnheader-find-file-noselect
nnmbox-mbox-file nil t))))
(mm-enable-multibyte)
(buffer-disable-undo)
;; Go through the group alist and compare against
;; the mbox file.
@ -523,26 +553,31 @@
(when (and (re-search-backward
(format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
(caar alist)) nil t)
(>= (setq number
(string-to-number
(buffer-substring
(match-beginning 1) (match-end 1))))
(cdadar alist)))
(setcdr (cadar alist) (1+ number)))
(> (setq number
(string-to-number
(buffer-substring
(match-beginning 1) (match-end 1))))
(cdadar alist)))
(setcdr (cadar alist) number))
(setq alist (cdr alist)))
(goto-char (point-min))
(while (re-search-forward delim nil t)
(setq start (match-beginning 0))
(when (not (search-forward "\nX-Gnus-Newsgroup: "
(save-excursion
(setq end
(or
(and
(re-search-forward delim nil t)
(match-beginning 0))
(point-max))))
t))
(unless (search-forward
"\nX-Gnus-Newsgroup: "
(save-excursion
(setq end
(or
(and
;; skip to end of headers first, since mail
;; which has been respooled has additional
;; "From nobody" lines.
(search-forward "\n\n" nil t)
(re-search-forward delim nil t)
(match-beginning 0))
(point-max))))
t)
(save-excursion
(save-restriction
(narrow-to-region start end)

82
lisp/gnus/nnmh.el
View File

@ -1,5 +1,7 @@
;;; nnmh.el --- mhspool access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -48,7 +50,10 @@
"*Hook run narrowed to an article before saving.")
(defvoo nnmh-be-safe nil
"*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
"*If non-nil, nnmh will check all articles to make sure whether they are new or not.
Go through the .nnmh-articles file and compare with the actual
articles in this folder. The articles that are \"new\" will be marked
as unread by Gnus.")
@ -60,7 +65,10 @@
(defvoo nnmh-status-string "")
(defvoo nnmh-group-alist nil)
(defvoo nnmh-allow-delete-final nil)
;; Don't even think about setting this variable. It does not exist.
;; Forget about it. Uh-huh. Nope. Nobody here. It's only bound
;; dynamically by certain functions in nndraft.
(defvar nnmh-allow-delete-final nil)
@ -77,8 +85,7 @@
(large (and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)))
(count 0)
(file-name-coding-system 'binary)
(pathname-coding-system 'binary)
(file-name-coding-system nnmail-pathname-coding-system)
beg article)
(nnmh-possibly-change-directory newsgroup server)
;; We don't support fetching by Message-ID.
@ -106,7 +113,7 @@
(and large
(zerop (% count 20))
(nnheader-message 5 "nnmh: Receiving headers... %d%%"
(/ (* count 100) number))))
(/ (* count 100) number))))
(when large
(nnheader-message 5 "nnmh: Receiving headers...done"))
@ -137,8 +144,7 @@
(let ((file (if (stringp id)
nil
(concat nnmh-current-directory (int-to-string id))))
(pathname-coding-system 'binary)
(file-name-coding-system 'binary)
(file-name-coding-system nnmail-pathname-coding-system)
(nntp-server-buffer (or buffer nntp-server-buffer)))
(and (stringp file)
(file-exists-p file)
@ -150,8 +156,7 @@
(nnheader-init-server-buffer)
(nnmh-possibly-change-directory group server)
(let ((pathname (nnmail-group-pathname group nnmh-directory))
(pathname-coding-system 'binary)
(file-name-coding-system 'binary)
(file-name-coding-system nnmail-pathname-coding-system)
dir)
(cond
((not (file-directory-p pathname))
@ -174,16 +179,19 @@
(mapcar (lambda (name) (string-to-int name))
(directory-files pathname nil "^[0-9]+$" t))
'<))
(cond
(dir
(nnheader-report 'nnmh "Selected group %s" group)
(nnheader-insert
"211 %d %d %d %s\n" (length dir) (car dir)
(progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
group))
(t
(nnheader-report 'nnmh "Empty group %s" group)
(nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
(cond
(dir
(setq nnmh-group-alist
(delq (assoc group nnmh-group-alist) nnmh-group-alist))
(push (list group (cons (car dir) (car (last dir))))
nnmh-group-alist)
(nnheader-report 'nnmh "Selected group %s" group)
(nnheader-insert
"211 %d %d %d %s\n" (length dir) (car dir)
(car (last dir)) group))
(t
(nnheader-report 'nnmh "Empty group %s" group)
(nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
(deffoo nnmh-request-scan (&optional group server)
(nnmail-get-new-mail 'nnmh nil nnmh-directory group))
@ -191,10 +199,9 @@
(deffoo nnmh-request-list (&optional server dir)
(nnheader-insert "")
(nnmh-possibly-change-directory nil server)
(let* ((pathname-coding-system 'binary)
(file-name-coding-system 'binary)
(nnmh-toplev
(file-truename (or dir (file-name-as-directory nnmh-directory)))))
(let ((file-name-coding-system nnmail-pathname-coding-system)
(nnmh-toplev
(file-truename (or dir (file-name-as-directory nnmh-directory)))))
(nnmh-request-list-1 nnmh-toplev))
(setq nnmh-group-alist (nnmail-get-active))
t)
@ -233,8 +240,8 @@
(expand-file-name nnmh-toplev))))
dir)
(nnheader-replace-chars-in-string
(gnus-decode-coding-string (substring dir (match-end 0))
nnmail-pathname-coding-system)
(mm-decode-coding-string (substring dir (match-end 0))
nnmail-pathname-coding-system)
?/ ?.))
(apply 'max files)
(apply 'min files)))))))
@ -275,7 +282,7 @@
t)
(deffoo nnmh-request-move-article
(article group server accept-form &optional last)
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnmh move*"))
result)
(and
@ -405,8 +412,7 @@
(nnmh-open-server server))
(when newsgroup
(let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))
(file-name-coding-system 'binary)
(pathname-coding-system 'binary))
(file-name-coding-system nnmail-pathname-coding-system))
(if (file-directory-p pathname)
(setq nnmh-current-directory pathname)
(error "No such newsgroup: %s" newsgroup)))))
@ -455,8 +461,8 @@
"Compute the next article number in GROUP."
(let ((active (cadr (assoc group nnmh-group-alist)))
(dir (nnmail-group-pathname group nnmh-directory))
(file-name-coding-system 'binary)
(pathname-coding-system 'binary))
(file-name-coding-system nnmail-pathname-coding-system)
file)
(unless active
;; The group wasn't known to nnmh, so we just create an active
;; entry for it.
@ -474,9 +480,15 @@
(when files
(setcdr active (car files)))))
(setcdr active (1+ (cdr active)))
(while (file-exists-p
(concat (nnmail-group-pathname group nnmh-directory)
(int-to-string (cdr active))))
(while (or
;; See whether the file exists...
(file-exists-p
(setq file (concat (nnmail-group-pathname group nnmh-directory)
(int-to-string (cdr active)))))
;; ... or there is a buffer that will make that file exist
;; in the future.
(get-file-buffer file))
;; Skip past that file.
(setcdr active (1+ (cdr active))))
(cdr active)))
@ -539,7 +551,7 @@
(setq articles (sort articles (lambda (art1 art2)
(> (car art1) (car art2)))))
;; Finally write this list back to the .nnmh-articles file.
(nnheader-temp-write nnmh-file
(with-temp-file nnmh-file
(insert ";; Gnus article active file for " group "\n\n")
(insert "(setq nnmh-newsgroup-articles '")
(gnus-prin1 articles)

141
lisp/gnus/nnml.el
View File

@ -1,5 +1,6 @@
;;; nnml.el --- mail spool access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -41,11 +42,11 @@
"Spool directory for the nnml mail backend.")
(defvoo nnml-active-file
(concat (file-name-as-directory nnml-directory) "active")
(expand-file-name "active" nnml-directory)
"Mail active file.")
(defvoo nnml-newsgroups-file
(concat (file-name-as-directory nnml-directory) "newsgroups")
(expand-file-name "newsgroups" nnml-directory)
"Mail newsgroups description file.")
(defvoo nnml-get-new-mail t
@ -86,6 +87,8 @@ all. This may very well take some time.")
(defvar nnml-nov-buffer-file-name nil)
(defvoo nnml-file-coding-system nnmail-file-coding-system)
;;; Interface functions.
@ -100,8 +103,7 @@ all. This may very well take some time.")
(let ((file nil)
(number (length sequence))
(count 0)
(file-name-coding-system 'binary)
(pathname-coding-system 'binary)
(file-name-coding-system nnmail-pathname-coding-system)
beg article)
(if (stringp (car sequence))
'headers
@ -141,9 +143,7 @@ all. This may very well take some time.")
(deffoo nnml-open-server (server &optional defs)
(nnoo-change-server 'nnml server defs)
(when (not (file-exists-p nnml-directory))
(condition-case ()
(make-directory nnml-directory t)
(error)))
(ignore-errors (make-directory nnml-directory t)))
(cond
((not (file-exists-p nnml-directory))
(nnml-close-server)
@ -164,8 +164,7 @@ all. This may very well take some time.")
(deffoo nnml-request-article (id &optional group server buffer)
(nnml-possibly-change-directory group server)
(let* ((nntp-server-buffer (or buffer nntp-server-buffer))
(file-name-coding-system 'binary)
(pathname-coding-system 'binary)
(file-name-coding-system nnmail-pathname-coding-system)
path gpath group-num)
(if (stringp id)
(when (and (setq group-num (nnml-find-group-number id))
@ -185,7 +184,9 @@ all. This may very well take some time.")
(nnheader-report 'nnml "No such file: %s" path))
((file-directory-p path)
(nnheader-report 'nnml "File is a directory: %s" path))
((not (save-excursion (nnmail-find-file path)))
((not (save-excursion (let ((nnmail-file-coding-system
nnml-file-coding-system))
(nnmail-find-file path))))
(nnheader-report 'nnml "Couldn't read file: %s" path))
(t
(nnheader-report 'nnml "Article %s retrieved" id)
@ -194,8 +195,7 @@ all. This may very well take some time.")
(string-to-int (file-name-nondirectory path)))))))
(deffoo nnml-request-group (group &optional server dont-check)
(let ((pathname-coding-system 'binary)
(file-name-coding-system 'binary))
(let ((file-name-coding-system nnmail-pathname-coding-system))
(cond
((not (nnml-possibly-change-directory group server))
(nnheader-report 'nnml "Invalid group (no such directory)"))
@ -228,6 +228,7 @@ all. This may very well take some time.")
t)
(deffoo nnml-request-create-group (group &optional server args)
(nnml-possibly-change-directory nil server)
(nnmail-activate 'nnml)
(cond
((assoc group nnml-group-alist)
@ -252,10 +253,8 @@ all. This may very well take some time.")
(deffoo nnml-request-list (&optional server)
(save-excursion
(let ((nnmail-file-coding-system nnmail-active-file-coding-system)
(file-name-coding-system 'binary)
(pathname-coding-system 'binary))
(nnmail-find-file nnml-active-file)
)
(file-name-coding-system nnmail-pathname-coding-system))
(nnmail-find-file nnml-active-file))
(setq nnml-group-alist (nnmail-get-active))
t))
@ -266,8 +265,7 @@ all. This may very well take some time.")
(save-excursion
(nnmail-find-file nnml-newsgroups-file)))
(deffoo nnml-request-expire-articles (articles group
&optional server force)
(deffoo nnml-request-expire-articles (articles group &optional server force)
(nnml-possibly-change-directory group server)
(let ((active-articles
(nnheader-directory-articles nnml-current-directory))
@ -288,8 +286,16 @@ all. This may very well take some time.")
(nnmail-expired-article-p group mod-time force
nnml-inhibit-expiry)))
(progn
;; Allow a special target group.
(unless (eq nnmail-expiry-target 'delete)
(with-temp-buffer
(nnml-request-article number group server
(current-buffer))
(let ((nnml-current-directory nil))
(nnmail-expiry-target-group
nnmail-expiry-target group))))
(nnheader-message 5 "Deleting article %s in %s"
article group)
number group)
(condition-case ()
(funcall nnmail-delete-file-function article)
(file-error
@ -307,7 +313,7 @@ all. This may very well take some time.")
(nconc rest articles)))
(deffoo nnml-request-move-article
(article group server accept-form &optional last)
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnml move*"))
result)
(nnml-possibly-change-directory group server)
@ -315,12 +321,15 @@ all. This may very well take some time.")
(and
(nnml-deletable-article-p group article)
(nnml-request-article article group server)
(save-excursion
(set-buffer buf)
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
(let (nnml-current-directory
nnml-current-group
nnml-article-file-alist)
(save-excursion
(set-buffer buf)
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result))
(progn
(nnml-possibly-change-directory group server)
(condition-case ()
@ -368,16 +377,14 @@ all. This may very well take some time.")
(let ((chars (nnmail-insert-lines))
(art (concat (int-to-string article) "\t"))
headers)
(when (condition-case ()
(progn
(nnmail-write-region
(point-min) (point-max)
(or (nnml-article-to-file article)
(concat nnml-current-directory
(int-to-string article)))
nil (if (nnheader-be-verbose 5) nil 'nomesg))
t)
(error nil))
(when (ignore-errors
(nnmail-write-region
(point-min) (point-max)
(or (nnml-article-to-file article)
(expand-file-name (int-to-string article)
nnml-current-directory))
nil (if (nnheader-be-verbose 5) nil 'nomesg))
t)
(setq headers (nnml-parse-head chars article))
;; Replace the NOV line in the NOV file.
(save-excursion
@ -418,9 +425,7 @@ all. This may very well take some time.")
(nnheader-message 5 "Deleting article %s in %s..." article group)
(funcall nnmail-delete-file-function article))))
;; Try to delete the directory itself.
(condition-case ()
(delete-directory nnml-current-directory)
(error nil)))
(ignore-errors (delete-directory nnml-current-directory)))
;; Remove the group from all structures.
(setq nnml-group-alist
(delq (assoc group nnml-group-alist) nnml-group-alist)
@ -434,11 +439,9 @@ all. This may very well take some time.")
(nnml-possibly-change-directory group server)
(let ((new-dir (nnmail-group-pathname new-name nnml-directory))
(old-dir (nnmail-group-pathname group nnml-directory)))
(when (condition-case ()
(progn
(make-directory new-dir t)
t)
(error nil))
(when (ignore-errors
(make-directory new-dir t)
t)
;; We move the articles file by file instead of renaming
;; the directory -- there may be subgroups in this group.
;; One might be more clever, I guess.
@ -453,9 +456,7 @@ all. This may very well take some time.")
(when (file-exists-p overview)
(rename-file overview (concat new-dir nnml-nov-file-name))))
(when (<= (length (directory-files old-dir)) 2)
(condition-case ()
(delete-directory old-dir)
(error nil)))
(ignore-errors (delete-directory old-dir)))
;; That went ok, so we change the internal structures.
(let ((entry (assoc group nnml-group-alist)))
(when entry
@ -473,7 +474,7 @@ all. This may very well take some time.")
((not (file-exists-p file))
(nnheader-report 'nnml "File %s does not exist" file))
(t
(nnheader-temp-write file
(with-temp-file file
(nnheader-insert-file-contents file)
(nnmail-replace-status name value))
t))))
@ -485,7 +486,7 @@ all. This may very well take some time.")
(nnml-update-file-alist)
(let (file)
(if (setq file (cdr (assq article nnml-article-file-alist)))
(concat nnml-current-directory file)
(expand-file-name file nnml-current-directory)
;; Just to make sure nothing went wrong when reading over NFS --
;; check once more.
(when (file-exists-p
@ -507,7 +508,6 @@ all. This may very well take some time.")
(defun nnml-find-group-number (id)
(save-excursion
(set-buffer (get-buffer-create " *nnml id*"))
(buffer-disable-undo (current-buffer))
(let ((alist nnml-group-alist)
number)
;; We want to look through all .overview files, but we want to
@ -527,8 +527,8 @@ all. This may very well take some time.")
(defun nnml-find-id (group id)
(erase-buffer)
(let ((nov (concat (nnmail-group-pathname group nnml-directory)
nnml-nov-file-name))
(let ((nov (expand-file-name nnml-nov-file-name
(nnmail-group-pathname group nnml-directory)))
number found)
(when (file-exists-p nov)
(nnheader-insert-file-contents nov)
@ -542,15 +542,13 @@ all. This may very well take some time.")
(setq found t)
;; We return the article number.
(setq number
(condition-case ()
(read (current-buffer))
(error nil)))))
(ignore-errors (read (current-buffer))))))
number)))
(defun nnml-retrieve-headers-with-nov (articles &optional fetch-old)
(if (or gnus-nov-is-evil nnml-nov-is-evil)
nil
(let ((nov (concat nnml-current-directory nnml-nov-file-name)))
(let ((nov (expand-file-name nnml-nov-file-name nnml-current-directory)))
(when (file-exists-p nov)
(save-excursion
(set-buffer nntp-server-buffer)
@ -572,8 +570,7 @@ all. This may very well take some time.")
(if (not group)
t
(let ((pathname (nnmail-group-pathname group nnml-directory))
(file-name-coding-system 'binary)
(pathname-coding-system 'binary))
(file-name-coding-system nnmail-pathname-coding-system))
(when (not (equal pathname nnml-current-directory))
(setq nnml-current-directory pathname
nnml-current-group group
@ -581,15 +578,10 @@ all. This may very well take some time.")
(file-exists-p nnml-current-directory))))
(defun nnml-possibly-create-directory (group)
(let (dir dirs)
(setq dir (nnmail-group-pathname group nnml-directory))
(while (not (file-directory-p dir))
(push dir dirs)
(setq dir (file-name-directory (directory-file-name dir))))
(while dirs
(make-directory (directory-file-name (car dirs)))
(nnheader-message 5 "Creating mail directory %s" (car dirs))
(setq dirs (cdr dirs)))))
(let ((dir (nnmail-group-pathname group nnml-directory)))
(unless (file-exists-p dir)
(make-directory (directory-file-name dir) t)
(nnheader-message 5 "Creating mail directory %s" dir))))
(defun nnml-save-mail (group-art)
"Called narrowed to an article."
@ -652,8 +644,8 @@ all. This may very well take some time.")
(push (list group active) nnml-group-alist))
(setcdr active (1+ (cdr active)))
(while (file-exists-p
(concat (nnmail-group-pathname group nnml-directory)
(int-to-string (cdr active))))
(expand-file-name (int-to-string (cdr active))
(nnmail-group-pathname group nnml-directory)))
(setcdr active (1+ (cdr active))))
(cdr active)))
@ -693,8 +685,9 @@ all. This may very well take some time.")
(save-excursion
(set-buffer buffer)
(set (make-local-variable 'nnml-nov-buffer-file-name)
(concat (nnmail-group-pathname group nnml-directory)
nnml-nov-file-name))
(expand-file-name
nnml-nov-file-name
(nnmail-group-pathname group nnml-directory)))
(erase-buffer)
(when (file-exists-p nnml-nov-buffer-file-name)
(nnheader-insert-file-contents nnml-nov-buffer-file-name)))
@ -738,7 +731,7 @@ all. This may very well take some time.")
(let ((dirs (directory-files dir t nil t))
dir)
(while (setq dir (pop dirs))
(when (and (not (member (file-name-nondirectory dir) '("." "..")))
(when (and (not (string-match "^\\." (file-name-nondirectory dir)))
(file-directory-p dir))
(nnml-generate-nov-databases-1 dir seen))))
;; Do this directory.
@ -778,7 +771,7 @@ all. This may very well take some time.")
(save-excursion
;; Init the nov buffer.
(set-buffer nov-buffer)
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(erase-buffer)
(set-buffer nntp-server-buffer)
;; Delete the old NOV file.

14
lisp/gnus/nnoo.el
View File

@ -1,5 +1,7 @@
;;; nnoo.el --- OO Gnus Backends
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -105,11 +107,11 @@
(cdr (assq pbackend (nnoo-parents backend))))
(prog1
(apply function args)
;; Copy the changed variables back into the child.
(let ((vars (cdr (assq pbackend (nnoo-parents backend)))))
(while vars
(set (cadar vars) (symbol-value (caar vars)))
(setq vars (cdr vars)))))))
;; Copy the changed variables back into the child.
(let ((vars (cdr (assq pbackend (nnoo-parents backend)))))
(while vars
(set (cadar vars) (symbol-value (caar vars)))
(setq vars (cdr vars)))))))
(defun nnoo-execute (backend function &rest args)
"Execute FUNCTION on behalf of BACKEND."

69
lisp/gnus/nnsoup.el
View File

@ -1,5 +1,7 @@
;;; nnsoup.el --- SOUP access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -38,19 +40,22 @@
(defvoo nnsoup-directory "~/SOUP/"
"*SOUP packet directory.")
(defvoo nnsoup-tmp-directory temporary-file-directory
(defvoo nnsoup-tmp-directory
(cond ((fboundp 'temp-directory) (temp-directory))
((boundp 'temporary-file-directory) temporary-file-directory)
("/tmp/"))
"*Where nnsoup will store temporary files.")
(defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/")
(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory)
"*Directory where outgoing packets will be composed.")
(defvoo nnsoup-replies-format-type ?n
(defvoo nnsoup-replies-format-type ?u ;; u is USENET news format.
"*Format of the replies packages.")
(defvoo nnsoup-replies-index-type ?n
"*Index type of the replies packages.")
(defvoo nnsoup-active-file (concat nnsoup-directory "active")
(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory)
"Active file.")
(defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
@ -70,8 +75,8 @@ The SOUP packet file name will be inserted at the %s.")
"*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
(defvoo nnsoup-always-save t
"If non nil commit the reply buffer on each message send.
This is necessary if using message mode outside Gnus with nnsoup as a
"If non nil commit the reply buffer on each message send.
This is necessary if using message mode outside Gnus with nnsoup as a
backend for the messages.")
@ -252,7 +257,7 @@ backend for the messages.")
(nth 1 (nnsoup-article-to-area
article nnsoup-current-group))))))
(cond ((= kind ?m) 'mail)
((= kind ?n) 'news)
((= kind ?n) 'news)
(t 'unknown)))))
(deffoo nnsoup-close-group (group &optional server)
@ -310,7 +315,7 @@ backend for the messages.")
(setq info (pop infolist)
range-list (gnus-uncompress-range (car info))
prefix (gnus-soup-area-prefix (nth 1 info)))
(when ;; All the articles in this file are marked for expiry.
(when;; All the articles in this file are marked for expiry.
(and (or (setq mod-time (nth 5 (file-attributes
(nnsoup-file prefix))))
(setq mod-time (nth 5 (file-attributes
@ -376,7 +381,7 @@ backend for the messages.")
(or force
nnsoup-group-alist-touched))
(setq nnsoup-group-alist-touched nil)
(nnheader-temp-write nnsoup-active-file
(with-temp-file nnsoup-active-file
(gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
(insert "\n")
(gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
@ -419,12 +424,15 @@ backend for the messages.")
(setq cur-prefix (nnsoup-next-prefix))
(nnheader-message 5 "Incorporating file %s..." cur-prefix)
(when (file-exists-p
(setq file (concat nnsoup-tmp-directory
(gnus-soup-area-prefix area) ".IDX")))
(setq file
(expand-file-name
(concat (gnus-soup-area-prefix area) ".IDX")
nnsoup-tmp-directory)))
(rename-file file (nnsoup-file cur-prefix)))
(when (file-exists-p
(setq file (concat nnsoup-tmp-directory
(gnus-soup-area-prefix area) ".MSG")))
(setq file (expand-file-name
(concat (gnus-soup-area-prefix area) ".MSG")
nnsoup-tmp-directory)))
(rename-file file (nnsoup-file cur-prefix t))
(gnus-soup-set-area-prefix area cur-prefix)
;; Find the number of new articles in this area.
@ -473,7 +481,8 @@ backend for the messages.")
(goto-char (point-min))
(cond
;; rnews batch format
((= format ?n)
((or (= format ?u)
(= format ?n)) ;; Gnus back compatibility.
(while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
(forward-line 1)
(push (list
@ -527,17 +536,19 @@ backend for the messages.")
(let* ((file (concat prefix (if message ".MSG" ".IDX")))
(buffer-name (concat " *nnsoup " file "*")))
(or (get-buffer buffer-name) ; File already loaded.
(when (file-exists-p (concat nnsoup-directory file))
(when (file-exists-p (expand-file-name file nnsoup-directory))
(save-excursion ; Load the file.
(set-buffer (get-buffer-create buffer-name))
(buffer-disable-undo (current-buffer))
(buffer-disable-undo)
(push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
(nnheader-insert-file-contents (concat nnsoup-directory file))
(nnheader-insert-file-contents
(expand-file-name file nnsoup-directory))
(current-buffer))))))
(defun nnsoup-file (prefix &optional message)
(expand-file-name
(concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
(concat prefix (if message ".MSG" ".IDX"))
nnsoup-directory))
(defun nnsoup-message-buffer (prefix)
(nnsoup-index-buffer prefix 'msg))
@ -587,7 +598,7 @@ backend for the messages.")
(let ((format (gnus-soup-encoding-format
(gnus-soup-area-encoding (nth 1 area)))))
(goto-char end)
(when (or (= format ?n) (= format ?m))
(when (or (= format ?u) (= format ?n) (= format ?m))
(setq end (progn (forward-line -1) (point))))))
(set-buffer msg-buf))
(widen)
@ -666,8 +677,6 @@ backend for the messages.")
(require 'mail-utils)
(let ((tembuf (generate-new-buffer " message temp"))
(case-fold-search nil)
(real-header-separator mail-header-separator)
(mail-header-separator "")
delimline
(mailbuf (current-buffer)))
(unwind-protect
@ -693,15 +702,11 @@ backend for the messages.")
;; Change header-delimiter to be what sendmail expects.
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote real-header-separator) "\n"))
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(backward-char 1)
(setq delimline (point-marker))
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
(when (eval message-mailer-swallows-blank-line)
(newline))
(let ((msg-buf
(gnus-soup-store
nnsoup-replies-directory
@ -724,7 +729,7 @@ backend for the messages.")
(unless nnsoup-replies-list
(setq nnsoup-replies-list
(gnus-soup-parse-replies
(concat nnsoup-replies-directory "REPLIES"))))
(expand-file-name "REPLIES" nnsoup-replies-directory))))
(let ((replies nnsoup-replies-list))
(while (and replies
(not (string= kind (gnus-soup-reply-kind (car replies)))))
@ -752,7 +757,6 @@ backend for the messages.")
(string-to-int (match-string 1 f2)))))))
active group lines ident elem min)
(set-buffer (get-buffer-create " *nnsoup work*"))
(buffer-disable-undo (current-buffer))
(while files
(nnheader-message 5 "Doing %s..." (car files))
(erase-buffer)
@ -770,13 +774,13 @@ backend for the messages.")
(if (not (setq elem (assoc group active)))
(push (list group (cons 1 lines)
(list (cons 1 lines)
(vector ident group "ncm" "" lines)))
(vector ident group "ucm" "" lines)))
active)
(nconc elem
(list
(list (cons (1+ (setq min (cdadr elem)))
(+ min lines))
(vector ident group "ncm" "" lines))))
(vector ident group "ucm" "" lines))))
(setcdr (cadr elem) (+ min lines)))
(setq files (cdr files)))
(nnheader-message 5 "")
@ -804,7 +808,8 @@ backend for the messages.")
;; Sort and delete the files.
(setq non-files (sort non-files 'string<))
(map-y-or-n-p "Delete file %s? "
(lambda (file) (delete-file (concat nnsoup-directory file)))
(lambda (file) (delete-file
(expand-file-name file nnsoup-directory)))
non-files)))
(provide 'nnsoup)

45
lisp/gnus/nnspool.el
View File

@ -1,5 +1,7 @@
;;; nnspool.el --- spool access for GNU Emacs
;; Copyright (C) 1988,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998,
;; 2000 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -28,7 +30,6 @@
(require 'nnheader)
(require 'nntp)
(require 'timezone)
(require 'nnoo)
(eval-when-compile (require 'cl))
@ -85,10 +86,6 @@ there.")
(defvoo nnspool-file-coding-system nnheader-file-coding-system
"Coding system for nnspool.")
;; 1997/8/14 by MORIOKA Tomohiko
(defvoo nnspool-file-coding-system nnheader-file-coding-system
"Coding system for nnspool.")
(defconst nnspool-version "nnspool 2.0"
@ -141,15 +138,20 @@ there.")
(setq beg (point))
(inline (nnheader-insert-head file))
(goto-char beg)
(search-forward "\n\n" nil t)
(forward-char -1)
(insert ".\n")
(if (search-forward "\n\n" nil t)
(progn
(forward-char -1)
(insert ".\n"))
(goto-char (point-max))
(if (bolp)
(insert ".\n")
(insert "\n.\n")))
(delete-region (point) (point-max)))
(and do-message
(zerop (% (incf count) 20))
(nnheader-message 5 "nnspool: Receiving headers... %d%%"
(/ (* count 100) number))))
(/ (* count 100) number))))
(when do-message
(nnheader-message 5 "nnspool: Receiving headers...done"))
@ -284,7 +286,7 @@ there.")
(while (and (not (looking-at
"\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] "))
(zerop (forward-line -1))))
(let ((seconds (nnspool-seconds-since-epoch date))
(let ((seconds (time-to-seconds (date-to-time date)))
groups)
;; Go through lines and add the latest groups to a list.
(while (and (looking-at "\\([^ ]+\\) +[0-9]+ ")
@ -299,8 +301,8 @@ there.")
(read (current-buffer)))
seconds))
(push (buffer-substring
(match-beginning 1) (match-end 1))
groups)
(match-beginning 1) (match-end 1))
groups)
(zerop (forward-line -1))))
(erase-buffer)
(while groups
@ -424,7 +426,6 @@ there.")
(defun nnspool-find-id (id)
(save-excursion
(set-buffer (get-buffer-create " *nnspool work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(ignore-errors
(call-process "grep" nil t nil (regexp-quote id) nnspool-history-file))
@ -439,8 +440,8 @@ there.")
(set-buffer nntp-server-buffer)
(erase-buffer)
(condition-case ()
(let ((nnheader-file-coding-system nnspool-file-coding-system))
(nnheader-insert-file-contents file)
(let ((coding-system-for-read nnspool-file-coding-system))
(mm-insert-file-contents file)
t)
(file-error nil)))
@ -457,18 +458,6 @@ there.")
"Find the path for GROUP."
(nnheader-group-pathname group nnspool-spool-directory article))
(defun nnspool-seconds-since-epoch (date)
(let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
(timezone-parse-date date)))
(ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
(timezone-parse-time
(aref (timezone-parse-date date) 3))))
(unix (encode-time (nth 2 ttime) (nth 1 ttime) (nth 0 ttime)
(nth 2 tdate) (nth 1 tdate) (nth 0 tdate)
(nth 4 tdate))))
(+ (* (car unix) 65536.0)
(cadr unix))))
(provide 'nnspool)
;;; nnspool.el ends here

531
lisp/gnus/nntp.el
View File

@ -1,5 +1,7 @@
;;; nntp.el --- nntp access for Gnus Copyright (C) 1987-90,92-97 Free
;;; Software Foundation, Inc.
;;; nntp.el --- nntp access for Gnus
;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996,
;; 1997, 1998, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -28,13 +30,9 @@
(require 'nnoo)
(require 'gnus-util)
(eval-when-compile (require 'cl))
(nnoo-declare nntp)
(eval-and-compile
(unless (fboundp 'open-network-stream)
(require 'tcp)))
(eval-when-compile (require 'cl))
(defvoo nntp-address nil
"Address of the physical nntp server.")
@ -52,10 +50,10 @@ server spawn an nnrpd server.")
It is called with no parameters.")
(defvoo nntp-server-action-alist
'(("nntpd 1\\.5\\.11t"
(remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))
("NNRP server Netscape"
(setq nntp-server-list-active-group nil)))
'(("nntpd 1\\.5\\.11t"
(remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))
("NNRP server Netscape"
(setq nntp-server-list-active-group nil)))
"Alist of regexps to match on server types and actions to be taken.
For instance, if you want Gnus to beep every time you connect
to innd, you could say something like:
@ -89,7 +87,8 @@ case, this list will be used as the parameter list given to rsh.")
(defvoo nntp-rlogin-user-name nil
"*User name on remote system when using the rlogin connect method.")
(defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp")
(defvoo nntp-telnet-parameters
'("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp")
"*Parameters to `nntp-open-telnet'.
That function may be used as `nntp-open-connection-function'. In that
case, this list will be executed as a command after logging in
@ -177,13 +176,6 @@ server there that you can connect to. See also
(const :format "" "password")
(string :format "Password: %v")))))))
;; 1997/5/4 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
(defvoo nntp-coding-system-for-read 'binary
"*Coding system to read from NNTP.")
(defvoo nntp-coding-system-for-write 'binary
"*Coding system to write to NNTP.")
(defvoo nntp-connection-timeout nil
@ -220,8 +212,18 @@ If this variable is nil, which is the default, no timers are set.")
(defvoo nntp-server-xover 'try)
(defvoo nntp-server-list-active-group 'try)
(defvar nntp-async-needs-kluge
(string-match "^GNU Emacs 20\\.3\\." (emacs-version))
"*When non-nil, nntp will poll asynchronous connections
once a second. By default, this is turned on only for Emacs
20.3, which has a bug that breaks nntp's normal method of
noticing asynchronous data.")
(defvar nntp-async-timer nil)
(defvar nntp-async-process-list nil)
(eval-and-compile
(autoload 'nnmail-read-passwd "nnmail")
(autoload 'mail-source-read-passwd "mail-source")
(autoload 'open-ssl-stream "ssl"))
@ -281,9 +283,9 @@ If this variable is nil, which is the default, no timers are set.")
(nntp-decode-text (not decode))
(unless discard
(save-excursion
(set-buffer buffer)
(goto-char (point-max))
(insert-buffer-substring (process-buffer process))
(set-buffer buffer)
(goto-char (point-max))
(insert-buffer-substring (process-buffer process))
;; Nix out "nntp reading...." message.
(when nntp-have-messaged
(setq nntp-have-messaged nil)
@ -292,6 +294,11 @@ If this variable is nil, which is the default, no timers are set.")
(unless discard
(erase-buffer)))))
(defun nntp-kill-buffer (buffer)
(when (buffer-name buffer)
(kill-buffer buffer)
(nnheader-init-server-buffer)))
(defsubst nntp-find-connection (buffer)
"Find the connection delivering to BUFFER."
(let ((alist nntp-connection-alist)
@ -304,8 +311,7 @@ If this variable is nil, which is the default, no timers are set.")
(when process
(if (memq (process-status process) '(open run))
process
(when (buffer-name (process-buffer process))
(kill-buffer (process-buffer process)))
(nntp-kill-buffer (process-buffer process))
(setq nntp-connection-alist (delq entry nntp-connection-alist))
nil))))
@ -330,27 +336,23 @@ If this variable is nil, which is the default, no timers are set.")
(save-excursion
(set-buffer (process-buffer process))
(erase-buffer)))
(when command
(nntp-send-string process command))
(cond
((eq callback 'ignore)
t)
((and callback wait-for)
(save-excursion
(set-buffer (process-buffer process))
(unless nntp-inside-change-function
(erase-buffer))
(setq nntp-process-decode decode
nntp-process-to-buffer buffer
nntp-process-wait-for wait-for
nntp-process-callback callback
nntp-process-start-point (point-max)
after-change-functions
(list 'nntp-after-change-function-callback)))
t)
(wait-for
(nntp-wait-for process wait-for buffer decode))
(t t)))))
(condition-case err
(progn
(when command
(nntp-send-string process command))
(cond
((eq callback 'ignore)
t)
((and callback wait-for)
(nntp-async-wait process wait-for buffer decode callback)
t)
(wait-for
(nntp-wait-for process wait-for buffer decode))
(t t)))
(error
(nnheader-report 'nntp "Couldn't open connection to %s: %s"
address err))
(quit nil)))))
(defsubst nntp-send-command (wait-for &rest strings)
"Send STRINGS to server and wait until WAIT-FOR returns."
@ -407,7 +409,7 @@ If this variable is nil, which is the default, no timers are set.")
(cond
;; A result that starts with a 2xx code is terminated by
;; a line with only a "." on it.
((eq (following-char) ?2)
((eq (char-after) ?2)
(if (re-search-forward "\n\\.\r?\n" nil t)
t
nil))
@ -442,36 +444,36 @@ If this variable is nil, which is the default, no timers are set.")
(nntp-inhibit-erase t)
article)
;; Send HEAD commands.
(while (setq article (pop articles))
(nntp-send-command
nil
"HEAD" (if (numberp article)
(int-to-string article)
;; `articles' is either a list of article numbers
;; or a list of article IDs.
article))
(incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null articles) ;All requests have been sent.
(zerop (% count nntp-maximum-request)))
(nntp-accept-response)
(while (progn
(set-buffer buf)
(goto-char last-point)
;; Count replies.
(while (nntp-next-result-arrived-p)
(setq last-point (point))
(incf received))
(< received count))
;; If number of headers is greater than 100, give
;; informative messages.
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(zerop (% received 20))
(nnheader-message 6 "NNTP: Receiving headers... %d%%"
(/ (* received 100) number)))
(nntp-accept-response))))
(while (setq article (pop articles))
(nntp-send-command
nil
"HEAD" (if (numberp article)
(int-to-string article)
;; `articles' is either a list of article numbers
;; or a list of article IDs.
article))
(incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null articles) ;All requests have been sent.
(zerop (% count nntp-maximum-request)))
(nntp-accept-response)
(while (progn
(set-buffer buf)
(goto-char last-point)
;; Count replies.
(while (nntp-next-result-arrived-p)
(setq last-point (point))
(incf received))
(< received count))
;; If number of headers is greater than 100, give
;; informative messages.
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(zerop (% received 20))
(nnheader-message 6 "NNTP: Receiving headers... %d%%"
(/ (* received 100) number)))
(nntp-accept-response))))
(and (numberp nntp-large-newsgroup)
(> number nntp-large-newsgroup)
(nnheader-message 6 "NNTP: Receiving headers...done"))
@ -486,64 +488,75 @@ If this variable is nil, which is the default, no timers are set.")
(deffoo nntp-retrieve-groups (groups &optional server)
"Retrieve group info on GROUPS."
(nntp-possibly-change-group nil server)
(save-excursion
(set-buffer (nntp-find-connection-buffer nntp-server-buffer))
;; The first time this is run, this variable is `try'. So we
;; try.
(when (eq nntp-server-list-active-group 'try)
(nntp-try-list-active (car groups)))
(erase-buffer)
(let ((count 0)
(received 0)
(last-point (point-min))
(nntp-inhibit-erase t)
(command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP")))
(while groups
;; Send the command to the server.
(nntp-send-command nil command (pop groups))
(incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null groups) ;All requests have been sent.
(zerop (% count nntp-maximum-request)))
(nntp-accept-response)
(when (nntp-find-connection-buffer nntp-server-buffer)
(save-excursion
;; Erase nntp-server-buffer before nntp-inhibit-erase.
(set-buffer nntp-server-buffer)
(erase-buffer)
(set-buffer (nntp-find-connection-buffer nntp-server-buffer))
;; The first time this is run, this variable is `try'. So we
;; try.
(when (eq nntp-server-list-active-group 'try)
(nntp-try-list-active (car groups)))
(erase-buffer)
(let ((count 0)
(received 0)
(last-point (point-min))
(nntp-inhibit-erase t)
(buf (nntp-find-connection-buffer nntp-server-buffer))
(command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP")))
(while groups
;; Send the command to the server.
(nntp-send-command nil command (pop groups))
(incf count)
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null groups) ;All requests have been sent.
(zerop (% count nntp-maximum-request)))
(nntp-accept-response)
(while (progn
;; Search `blue moon' in this file for the
;; reason why set-buffer here.
(set-buffer buf)
(goto-char last-point)
;; Count replies.
(while (re-search-forward "^[0-9]" nil t)
(incf received))
(setq last-point (point))
(< received count))
(nntp-accept-response))))
;; Wait for the reply from the final command.
(set-buffer buf)
(goto-char (point-max))
(re-search-backward "^[0-9]" nil t)
(when (looking-at "^[23]")
(while (progn
(goto-char last-point)
;; Count replies.
(while (re-search-forward "^[0-9]" nil t)
(incf received))
(setq last-point (point))
(< received count))
(nntp-accept-response))))
(set-buffer buf)
(goto-char (point-max))
(if (not nntp-server-list-active-group)
(not (re-search-backward "\r?\n" (- (point) 3) t))
(not (re-search-backward "^\\.\r?\n" (- (point) 4) t))))
(nntp-accept-response)))
;; Wait for the reply from the final command.
(goto-char (point-max))
(re-search-backward "^[0-9]" nil t)
(when (looking-at "^[23]")
(while (progn
(goto-char (point-max))
(if (not nntp-server-list-active-group)
(not (re-search-backward "\r?\n" (- (point) 3) t))
(not (re-search-backward "^\\.\r?\n" (- (point) 4) t))))
(nntp-accept-response)))
;; Now all replies are received. We remove CRs.
(goto-char (point-min))
(while (search-forward "\r" nil t)
(replace-match "" t t))
(if (not nntp-server-list-active-group)
(progn
(copy-to-buffer nntp-server-buffer (point-min) (point-max))
'group)
;; We have read active entries, so we just delete the
;; superfluous gunk.
;; Now all replies are received. We remove CRs.
(set-buffer buf)
(goto-char (point-min))
(while (re-search-forward "^[.2-5]" nil t)
(delete-region (match-beginning 0)
(progn (forward-line 1) (point))))
(copy-to-buffer nntp-server-buffer (point-min) (point-max))
'active))))
(while (search-forward "\r" nil t)
(replace-match "" t t))
(if (not nntp-server-list-active-group)
(progn
(copy-to-buffer nntp-server-buffer (point-min) (point-max))
'group)
;; We have read active entries, so we just delete the
;; superfluous gunk.
(goto-char (point-min))
(while (re-search-forward "^[.2-5]" nil t)
(delete-region (match-beginning 0)
(progn (forward-line 1) (point))))
(copy-to-buffer nntp-server-buffer (point-min) (point-max))
'active)))))
(deffoo nntp-retrieve-articles (articles &optional group server)
(nntp-possibly-change-group group server)
@ -625,9 +638,14 @@ If this variable is nil, which is the default, no timers are set.")
(setq nntp-server-list-active-group t)))))
(deffoo nntp-list-active-group (group &optional server)
"Return the active info on GROUP (which can be a regexp."
"Return the active info on GROUP (which can be a regexp)."
(nntp-possibly-change-group nil server)
(nntp-send-command "^.*\r?\n" "LIST ACTIVE" group))
(nntp-send-command "^\\.*\r?\n" "LIST ACTIVE" group))
(deffoo nntp-request-group-articles (group &optional server)
"Return the list of existing articles in GROUP."
(nntp-possibly-change-group nil server)
(nntp-send-command "^\\.*\r?\n" "LISTGROUP" group))
(deffoo nntp-request-article (article &optional group server buffer command)
(nntp-possibly-change-group group server)
@ -700,8 +718,7 @@ If this variable is nil, which is the default, no timers are set.")
;; QUIT command actually is sent out before we kill
;; the process.
(sleep-for 1))))
(when (buffer-name (process-buffer process))
(kill-buffer (process-buffer process)))
(nntp-kill-buffer (process-buffer process))
(setq process (car (pop nntp-connection-alist))))
(nnoo-close-server 'nntp)))
@ -717,8 +734,7 @@ If this variable is nil, which is the default, no timers are set.")
;; QUIT command actually is sent out before we kill
;; the process.
(sleep-for 1))))
(when (buffer-name (process-buffer process))
(kill-buffer (process-buffer process))))))
(nntp-kill-buffer (process-buffer process)))))
(deffoo nntp-request-list (&optional server)
(nntp-possibly-change-group nil server)
@ -735,7 +751,7 @@ If this variable is nil, which is the default, no timers are set.")
(prog1
(nntp-send-command
"^\\.\r?\n" "NEWGROUPS"
(format-time-string "%y%m%d %H%M%S" (nnmail-date-to-time date)))
(format-time-string "%y%m%d %H%M%S" (date-to-time date)))
(nntp-decode-text))))
(deffoo nntp-request-post (&optional server)
@ -756,7 +772,7 @@ If this variable is nil, which is the default, no timers are set.")
This function is supposed to be called from `nntp-server-opened-hook'.
It will make innd servers spawn an nnrpd process to allow actual article
reading."
(nntp-send-command "^.*\r?\n" "MODE READER"))
(nntp-send-command "^.*\n" "MODE READER"))
(defun nntp-send-authinfo (&optional send-if-force)
"Send the AUTHINFO to the nntp server.
@ -767,7 +783,7 @@ and a password.
If SEND-IF-FORCE, only send authinfo to the server if the
.authinfo file has the FORCE token."
(let* ((list (gnus-parse-netrc nntp-authinfo-file))
(alist (gnus-netrc-machine list nntp-address))
(alist (gnus-netrc-machine list nntp-address "nntp"))
(force (gnus-netrc-get alist "force"))
(user (or (gnus-netrc-get alist "login") nntp-authinfo-user))
(passwd (gnus-netrc-get alist "password")))
@ -779,13 +795,13 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(unless (member user '(nil ""))
(nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
(when t ;???Should check if AUTHINFO succeeded
(nntp-send-command
"^2.*\r?\n" "AUTHINFO PASS"
(or passwd
nntp-authinfo-password
(setq nntp-authinfo-password
(nnmail-read-passwd (format "NNTP (%s@%s) password: "
user nntp-address))))))))))
(nntp-send-command
"^2.*\r?\n" "AUTHINFO PASS"
(or passwd
nntp-authinfo-password
(setq nntp-authinfo-password
(mail-source-read-passwd (format "NNTP (%s@%s) password: "
user nntp-address))))))))))
(defun nntp-send-nosy-authinfo ()
"Send the AUTHINFO to the nntp server."
@ -794,8 +810,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
(when t ;???Should check if AUTHINFO succeeded
(nntp-send-command "^2.*\r?\n" "AUTHINFO PASS"
(nnmail-read-passwd "NNTP (%s@%s) password: "
user nntp-address))))))
(mail-source-read-passwd "NNTP (%s@%s) password: "
user nntp-address))))))
(defun nntp-send-authinfo-from-file ()
"Send the AUTHINFO to the nntp server.
@ -803,7 +819,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
The authinfo login name is taken from the user's login name and the
password contained in '~/.nntp-authinfo'."
(when (file-exists-p "~/.nntp-authinfo")
(nnheader-temp-write nil
(with-temp-buffer
(insert-file-contents "~/.nntp-authinfo")
(goto-char (point-min))
(nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name))
@ -832,7 +848,7 @@ password contained in '~/.nntp-authinfo'."
(format " *server %s %s %s*"
nntp-address nntp-port-number
(gnus-buffer-exists-p buffer))))
(buffer-disable-undo (current-buffer))
(mm-enable-multibyte)
(set (make-local-variable 'after-change-functions) nil)
(set (make-local-variable 'nntp-process-wait-for) nil)
(set (make-local-variable 'nntp-process-callback) nil)
@ -850,8 +866,7 @@ password contained in '~/.nntp-authinfo'."
(nnheader-run-at-time
nntp-connection-timeout nil
`(lambda ()
(when (buffer-name ,pbuffer)
(kill-buffer ,pbuffer))))))
(nntp-kill-buffer ,pbuffer)))))
(process
(condition-case ()
(let ((coding-system-for-read nntp-coding-system-for-read)
@ -877,8 +892,7 @@ password contained in '~/.nntp-authinfo'."
(let ((nnheader-callback-function nil))
(run-hooks 'nntp-server-opened-hook)
(nntp-send-authinfo t))))
(when (buffer-name (process-buffer process))
(kill-buffer (process-buffer process)))
(nntp-kill-buffer (process-buffer process))
nil))))
(defun nntp-open-network-stream (buffer)
@ -910,40 +924,97 @@ password contained in '~/.nntp-authinfo'."
(eval (cadr entry))
(funcall (cadr entry)))))))
(defun nntp-after-change-function-callback (beg end len)
(when nntp-process-callback
(save-match-data
(if (and (= beg (point-min))
(memq (char-after beg) '(?4 ?5)))
;; Report back error messages.
(save-excursion
(goto-char beg)
(if (looking-at "480")
(nntp-handle-authinfo nntp-process-to-buffer)
(nntp-snarf-error-message)
(funcall nntp-process-callback nil)))
(goto-char end)
(when (and (> (point) nntp-process-start-point)
(re-search-backward nntp-process-wait-for
nntp-process-start-point t))
(defun nntp-async-wait (process wait-for buffer decode callback)
(save-excursion
(set-buffer (process-buffer process))
(unless nntp-inside-change-function
(erase-buffer))
(setq nntp-process-wait-for wait-for
nntp-process-to-buffer buffer
nntp-process-decode decode
nntp-process-callback callback
nntp-process-start-point (point-max))
(setq after-change-functions '(nntp-after-change-function))
(if nntp-async-needs-kluge
(nntp-async-kluge process))))
(defun nntp-async-kluge (process)
;; emacs 20.3 bug: process output with encoding 'binary
;; doesn't trigger after-change-functions.
(unless nntp-async-timer
(setq nntp-async-timer
(nnheader-run-at-time 1 1 'nntp-async-timer-handler)))
(add-to-list 'nntp-async-process-list process))
(defun nntp-async-timer-handler ()
(mapcar
(lambda (proc)
(if (memq (process-status proc) '(open run))
(nntp-async-trigger proc)
(nntp-async-stop proc)))
nntp-async-process-list))
(defun nntp-async-stop (proc)
(setq nntp-async-process-list (delq proc nntp-async-process-list))
(when (and nntp-async-timer (not nntp-async-process-list))
(nnheader-cancel-timer nntp-async-timer)
(setq nntp-async-timer nil)))
(defun nntp-after-change-function (beg end len)
(unwind-protect
;; we only care about insertions at eob
(when (and (eq 0 len) (eq (point-max) end))
(save-match-data
(let ((proc (get-buffer-process (current-buffer))))
(when proc
(nntp-async-trigger proc)))))
;; any throw from after-change-functions will leave it
;; set to nil. so we reset it here, if necessary.
(when quit-flag
(setq after-change-functions '(nntp-after-change-function)))))
(defun nntp-async-trigger (process)
(save-excursion
(set-buffer (process-buffer process))
(when nntp-process-callback
;; do we have an error message?
(goto-char nntp-process-start-point)
(if (memq (following-char) '(?4 ?5))
;; wants credentials?
(if (looking-at "480")
(nntp-handle-authinfo nntp-process-to-buffer)
;; report error message.
(nntp-snarf-error-message)
(nntp-do-callback nil))
;; got what we expect?
(goto-char (point-max))
(when (re-search-backward
nntp-process-wait-for nntp-process-start-point t)
(nntp-async-stop process)
;; convert it.
(when (gnus-buffer-exists-p nntp-process-to-buffer)
(let ((cur (current-buffer))
(start nntp-process-start-point))
(let ((buf (current-buffer))
(start nntp-process-start-point)
(decode nntp-process-decode))
(save-excursion
(set-buffer nntp-process-to-buffer)
(goto-char (point-max))
(let ((b (point)))
(insert-buffer-substring cur start)
(narrow-to-region b (point-max))
(nntp-decode-text)
(widen)))))
(goto-char end)
(let ((callback nntp-process-callback)
(nntp-inside-change-function t))
(setq nntp-process-callback nil)
(save-excursion
(funcall callback (buffer-name
(get-buffer nntp-process-to-buffer))))))))))
(save-restriction
(narrow-to-region (point) (point))
(insert-buffer-substring buf start)
(when decode
(nntp-decode-text))))))
;; report it.
(goto-char (point-max))
(nntp-do-callback
(buffer-name (get-buffer nntp-process-to-buffer))))))))
(defun nntp-do-callback (arg)
(let ((callback nntp-process-callback)
(nntp-inside-change-function t))
(setq nntp-process-callback nil)
(funcall callback arg)))
(defun nntp-snarf-error-message ()
"Save the error message in the current buffer."
@ -953,7 +1024,7 @@ password contained in '~/.nntp-authinfo'."
(nnheader-report 'nntp message)
message))
(defun nntp-accept-process-output (process)
(defun nntp-accept-process-output (process &optional timeout)
"Wait for output from PROCESS and message some dots."
(save-excursion
(set-buffer (or (nntp-find-connection-buffer nntp-server-buffer)
@ -963,7 +1034,7 @@ password contained in '~/.nntp-authinfo'."
(unless (< len 10)
(setq nntp-have-messaged t)
(nnheader-message 7 "nntp read: %dk" len)))
(accept-process-output process 1)))
(accept-process-output process (or timeout 1))))
(defun nntp-accept-response ()
"Wait for output from the process that outputs to BUFFER."
@ -985,10 +1056,7 @@ password contained in '~/.nntp-authinfo'."
(save-excursion
(set-buffer (process-buffer (car entry)))
(erase-buffer)
(nntp-send-string (car entry) (concat "GROUP " group))
;; allow for unexpected responses, since this can be called
;; from a timer with quit inhibited
(nntp-wait-for-string "^[245].*\n")
(nntp-send-command "^[245].*\n" "GROUP" group)
(setcar (cddr entry) group)
(erase-buffer))))))
@ -1051,7 +1119,7 @@ password contained in '~/.nntp-authinfo'."
(car (last articles)) 'wait)
(goto-char (point-min))
(when (looking-at "[1-5][0-9][0-9] ")
(when (looking-at "[1-5][0-9][0-9] .*\n")
(delete-region (point) (progn (forward-line 1) (point))))
(while (search-forward "\r" nil t)
(replace-match "" t t))
@ -1068,9 +1136,10 @@ password contained in '~/.nntp-authinfo'."
((numberp nntp-nov-gap)
(let ((count 0)
(received 0)
(last-point (point-min))
last-point
in-process-buffer-p
(buf nntp-server-buffer)
;;(process-buffer (nntp-find-connection (current-buffer))))
(process-buffer (nntp-find-connection-buffer nntp-server-buffer))
first)
;; We have to check `nntp-server-xover'. If it gets set to nil,
;; that means that the server does not understand XOVER, but we
@ -1083,40 +1152,58 @@ password contained in '~/.nntp-authinfo'."
(< (- (nth 1 articles) (car articles)) nntp-nov-gap))
(setq articles (cdr articles)))
(when (nntp-send-xover-command first (car articles))
(setq articles (cdr articles)
count (1+ count))
(setq in-process-buffer-p (stringp nntp-server-xover))
(nntp-send-xover-command first (car articles))
(setq articles (cdr articles))
(when (and nntp-server-xover in-process-buffer-p)
;; Don't count tried request.
(setq count (1+ count))
;; Every 400 requests we have to read the stream in
;; order to avoid deadlocks.
(when (or (null articles) ;All requests have been sent.
(zerop (% count nntp-maximum-request)))
(accept-process-output)
;; On some Emacs versions the preceding function has
;; a tendency to change the buffer. Perhaps. It's
;; quite difficult to reproduce, because it only
;; seems to happen once in a blue moon.
(set-buffer buf)
(nntp-accept-response)
;; On some Emacs versions the preceding function has a
;; tendency to change the buffer. Perhaps. It's quite
;; difficult to reproduce, because it only seems to happen
;; once in a blue moon.
(set-buffer process-buffer)
(while (progn
(goto-char last-point)
(goto-char (or last-point (point-min)))
;; Count replies.
(while (re-search-forward "^[0-9][0-9][0-9] " nil t)
(setq received (1+ received)))
(while (re-search-forward "^[0-9][0-9][0-9] .*\n" nil t)
(incf received))
(setq last-point (point))
(< received count))
(accept-process-output)
(set-buffer buf)))))
(nntp-accept-response)
(set-buffer process-buffer))
(set-buffer buf))))
(when nntp-server-xover
;; Wait for the reply from the final command.
(goto-char (point-max))
(re-search-backward "^[0-9][0-9][0-9] " nil t)
(when (looking-at "^[23]")
(while (progn
(goto-char (point-max))
(forward-line -1)
(not (looking-at "^\\.\r?\n")))
(nntp-accept-response)))
(when in-process-buffer-p
(set-buffer process-buffer)
;; Wait for the reply from the final command.
(goto-char (point-max))
(while (not (re-search-backward "^[0-9][0-9][0-9] " nil t))
(nntp-accept-response)
(set-buffer process-buffer)
(goto-char (point-max)))
(when (looking-at "^[23]")
(while (progn
(goto-char (point-max))
(forward-line -1)
(not (looking-at "^\\.\r?\n")))
(nntp-accept-response)
(set-buffer process-buffer)))
(set-buffer buf)
(goto-char (point-max))
(insert-buffer-substring process-buffer)
(set-buffer process-buffer)
(erase-buffer)
(set-buffer buf))
;; We remove any "." lines and status lines.
(goto-char (point-min))
@ -1124,7 +1211,6 @@ password contained in '~/.nntp-authinfo'."
(delete-char -1))
(goto-char (point-min))
(delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ")
;;(copy-to-buffer nntp-server-buffer (point-min) (point-max))
t))))
nntp-server-xover)
@ -1140,7 +1226,7 @@ password contained in '~/.nntp-authinfo'."
(nntp-send-command-nodelete
"\r?\n\\.\r?\n" nntp-server-xover range)
;; We do not wait for the reply.
(nntp-send-command-nodelete "\r?\n\\.\r?\n" nntp-server-xover range))
(nntp-send-command-nodelete nil nntp-server-xover range))
(let ((commands nntp-xover-commands))
;; `nntp-xover-commands' is a list of possible XOVER commands.
;; We try them all until we get at positive response.
@ -1206,9 +1292,8 @@ password contained in '~/.nntp-authinfo'."
proc (concat
(or nntp-telnet-passwd
(setq nntp-telnet-passwd
(nnmail-read-passwd "Password: ")))
(mail-source-read-passwd "Password: ")))
"\n"))
(erase-buffer)
(nntp-wait-for-string nntp-telnet-shell-prompt)
(process-send-string
proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n"))

157
lisp/gnus/nnvirtual.el
View File

@ -1,5 +1,6 @@
;;; nnvirtual.el --- virtual newsgroups access for Gnus
;; Copyright (C) 1994,95,96,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: David Moore <dmoore@ucsd.edu>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -45,10 +46,9 @@
(defvoo nnvirtual-always-rescan t
"*If non-nil, always scan groups for unread articles when entering a group.
If this variable is nil (which is the default) and you read articles
in a component group after the virtual group has been activated, the
read articles from the component group will show up when you enter the
virtual group.")
If this variable is nil and you read articles in a component group
after the virtual group has been activated, the read articles from the
component group will show up when you enter the virtual group.")
(defvoo nnvirtual-component-regexp nil
"*Regexp to match component groups.")
@ -63,8 +63,7 @@ virtual group.")
(defvoo nnvirtual-current-group nil)
(defvoo nnvirtual-mapping-table nil
"Table of rules on how to map between component group and article number
to virtual article number.")
"Table of rules on how to map between component group and article number to virtual article number.")
(defvoo nnvirtual-mapping-offsets nil
"Table indexed by component group to an offset to be applied to article numbers in that group.")
@ -122,47 +121,47 @@ to virtual article number.")
(let ((gnus-use-cache t))
(setq result (gnus-retrieve-headers
articles cgroup nil))))
(set-buffer nntp-server-buffer)
;; If we got HEAD headers, we convert them into NOV
;; headers. This is slow, inefficient and, come to think
;; of it, downright evil. So sue me. I couldn't be
;; bothered to write a header parse routine that could
;; parse a mixed HEAD/NOV buffer.
(when (eq result 'headers)
(nnvirtual-convert-headers))
(goto-char (point-min))
(while (not (eobp))
(delete-region (point)
(progn
(setq carticle (read nntp-server-buffer))
(point)))
(set-buffer nntp-server-buffer)
;; If we got HEAD headers, we convert them into NOV
;; headers. This is slow, inefficient and, come to think
;; of it, downright evil. So sue me. I couldn't be
;; bothered to write a header parse routine that could
;; parse a mixed HEAD/NOV buffer.
(when (eq result 'headers)
(nnvirtual-convert-headers))
(goto-char (point-min))
(while (not (eobp))
(delete-region (point)
(progn
(setq carticle (read nntp-server-buffer))
(point)))
;; We remove this article from the articles list, if
;; anything is left in the articles list after going through
;; the entire buffer, then those articles have been
;; expired or canceled, so we appropriately update the
;; component group below. They should be coming up
;; generally in order, so this shouldn't be slow.
(setq articles (delq carticle articles))
;; We remove this article from the articles list, if
;; anything is left in the articles list after going through
;; the entire buffer, then those articles have been
;; expired or canceled, so we appropriately update the
;; component group below. They should be coming up
;; generally in order, so this shouldn't be slow.
(setq articles (delq carticle articles))
(setq article (nnvirtual-reverse-map-article cgroup carticle))
(if (null article)
;; This line has no reverse mapping, that means it
;; was an extra article reference returned by nntp.
(progn
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point))))
;; Otherwise insert the virtual article number,
;; and clean up the xrefs.
(princ article nntp-server-buffer)
(nnvirtual-update-xref-header cgroup carticle
prefix system-name)
(forward-line 1))
)
(setq article (nnvirtual-reverse-map-article cgroup carticle))
(if (null article)
;; This line has no reverse mapping, that means it
;; was an extra article reference returned by nntp.
(progn
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point))))
;; Otherwise insert the virtual article number,
;; and clean up the xrefs.
(princ article nntp-server-buffer)
(nnvirtual-update-xref-header cgroup carticle
prefix system-name)
(forward-line 1))
)
(set-buffer vbuf)
(goto-char (point-max))
(insert-buffer-substring nntp-server-buffer))
(set-buffer vbuf)
(goto-char (point-max))
(insert-buffer-substring nntp-server-buffer))
;; Anything left in articles is expired or canceled.
;; Could be smart and not tell it about articles already known?
(when articles
@ -199,8 +198,9 @@ to virtual article number.")
(save-excursion
(when buffer
(set-buffer buffer))
(let ((method (gnus-find-method-for-group
nnvirtual-last-accessed-component-group)))
(let* ((gnus-override-method nil)
(method (gnus-find-method-for-group
nnvirtual-last-accessed-component-group)))
(funcall (gnus-get-function method 'request-article)
article nil (nth 1 method) buffer)))))
;; This is a fetch by number.
@ -219,7 +219,9 @@ to virtual article number.")
(if buffer
(save-excursion
(set-buffer buffer)
(gnus-request-article-this-buffer (cdr amap) cgroup))
;; We bind this here to avoid double decoding.
(let ((gnus-article-decode-hook nil))
(gnus-request-article-this-buffer (cdr amap) cgroup)))
(gnus-request-article (cdr amap) cgroup))))))))
@ -283,11 +285,11 @@ to virtual article number.")
(deffoo nnvirtual-request-update-mark (group article mark)
(let* ((nart (nnvirtual-map-article article))
(cgroup (car nart))
;; The component group might be a virtual group.
(nmark (gnus-request-update-mark cgroup (cdr nart) mark)))
(cgroup (car nart)))
(when (and nart
(= mark nmark)
(memq mark gnus-auto-expirable-marks)
;; The component group might be a virtual group.
(= mark (gnus-request-update-mark cgroup (cdr nart) mark))
(gnus-group-auto-expirable-p cgroup))
(setq mark gnus-expirable-mark)))
mark)
@ -359,6 +361,22 @@ to virtual article number.")
(cdr gnus-message-group-art)))))
(gnus-request-post (gnus-find-method-for-group group)))))
(deffoo nnvirtual-request-expire-articles (articles group
&optional server force)
(nnvirtual-possibly-change-server server)
(setq nnvirtual-component-groups
(delete (nnvirtual-current-group) nnvirtual-component-groups))
(let (unexpired)
(dolist (group nnvirtual-component-groups)
(setq unexpired (nconc unexpired
(mapcar
#'(lambda (article)
(nnvirtual-reverse-map-article
group article))
(gnus-group-expire-articles-1 group)))))
(sort unexpired '<)))
;;; Internal functions.
@ -385,7 +403,7 @@ to virtual article number.")
(insert "\t"))
;; Remove any spaces at the beginning of the Xref field.
(while (= (char-after (1- (point))) ? )
(while (eq (char-after (1- (point))) ? )
(forward-char -1)
(delete-char 1))
@ -417,7 +435,7 @@ to virtual article number.")
;; Ensure a trailing \t.
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(or (eq (char-after (1- (point))) ?\t)
(insert ?\t)))
@ -436,19 +454,24 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components."
(nnvirtual-partition-sequence
(gnus-list-of-unread-articles
(nnvirtual-current-group)))))
(type-marks (mapcar (lambda (ml)
(cons (car ml)
(nnvirtual-partition-sequence (cdr ml))))
(gnus-info-marks (gnus-get-info
(nnvirtual-current-group)))))
(type-marks
(delq nil
(mapcar (lambda (ml)
(if (eq (car ml) 'score)
nil
(cons (car ml)
(nnvirtual-partition-sequence (cdr ml)))))
(gnus-info-marks (gnus-get-info
(nnvirtual-current-group))))))
mark type groups carticles info entry)
;; Ok, atomically move all of the (un)read info, clear any old
;; marks, and move all of the current marks. This way if someone
;; hits C-g, you won't leave the component groups in a half-way state.
(gnus-atomic-progn
(progn
;; move (un)read
(let ((gnus-newsgroup-active nil)) ;workaround guns-update-read-articles
;; bind for workaround guns-update-read-articles
(let ((gnus-newsgroup-active nil))
(while (setq entry (pop unreads))
(gnus-update-read-articles (car entry) (cdr entry))))
@ -457,7 +480,11 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components."
(while groups
(when (and (setq info (gnus-get-info (pop groups)))
(gnus-info-marks info))
(gnus-info-set-marks info nil)))
(gnus-info-set-marks
info
(if (assq 'score (gnus-info-marks info))
(list (assq 'score (gnus-info-marks info)))
nil))))
;; Ok, currently type-marks is an assq list with keys of a mark type,
;; with data of an assq list with keys of component group names
@ -571,7 +598,7 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components."
(aref entry 1)
(cdr (aref nnvirtual-mapping-offsets group-pos)))
))
))
))
@ -629,7 +656,7 @@ then it is left out of the result."
"Return an association list of component article numbers.
These are indexed by elements of nnvirtual-component-groups, based on
the sequence ARTICLES of virtual article numbers. ARTICLES should be
sorted, and can be a compressed sequence. If any of the article
sorted, and can be a compressed sequence. If any of the article
numbers has no corresponding component article, then it is left out of
the result."
(when (numberp (cdr-safe articles))
@ -692,7 +719,7 @@ based on the marks on the component groups."
(setq cnt (1+ cnt)
tot (+ tot size)
M (max M size))))
nnvirtual-component-groups)
nnvirtual-component-groups)
;; Number of articles in the virtual group.
(setq nnvirtual-mapping-len tot)

416
lisp/gnus/nnweb.el
View File

@ -1,5 +1,6 @@
;;; nnweb.el --- retrieving articles via web search engines
;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -30,23 +31,24 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'cl))
(require 'nnoo)
(require 'message)
(require 'gnus-util)
(require 'gnus)
(require 'nnmail)
(require 'mm-util)
(eval-when-compile
(ignore-errors
(require 'w3)
(require 'url)
(require 'w3-forms)))
(require 'w3)
(require 'url)
(require 'w3-forms)))
;; Report failure to find w3 at load time if appropriate.
(eval '(progn
(require 'w3)
(require 'url)
(require 'w3-forms)))
(unless noninteractive
(eval '(progn
(require 'w3)
(require 'url)
(require 'w3-forms))))
(nnoo-declare nnweb)
@ -58,18 +60,19 @@
Valid types include `dejanews', `dejanewsold', `reference',
and `altavista'.")
(defvoo nnweb-type-definition
(defvar nnweb-type-definition
'((dejanews
(article . nnweb-dejanews-wash-article)
(article . ignore)
(id . "http://search.dejanews.com/msgid.xp?MID=%s&fmt=text")
(map . nnweb-dejanews-create-mapping)
(search . nnweb-dejanews-search)
(address . "http://x8.dejanews.com/dnquery.xp")
(address . "http://www.deja.com/=dnc/qs.xp")
(identifier . nnweb-dejanews-identity))
(dejanewsold
(article . nnweb-dejanews-wash-article)
(article . ignore)
(map . nnweb-dejanews-create-mapping)
(search . nnweb-dejanewsold-search)
(address . "http://x8.dejanews.com/dnquery.xp")
(address . "http://www.deja.com/dnquery.xp")
(identifier . nnweb-dejanews-identity))
(reference
(article . nnweb-reference-wash-article)
@ -113,14 +116,14 @@ and `altavista'.")
(set-buffer nntp-server-buffer)
(erase-buffer)
(let (article header)
(while (setq article (pop articles))
(when (setq header (cadr (assq article nnweb-articles)))
(nnheader-insert-nov header)))
(mm-with-unibyte-current-buffer
(while (setq article (pop articles))
(when (setq header (cadr (assq article nnweb-articles)))
(nnheader-insert-nov header))))
'nov)))
(deffoo nnweb-request-scan (&optional group server)
(nnweb-possibly-change-server group server)
(setq nnweb-hashtb (gnus-make-hashtable 4095))
(funcall (nnweb-definition 'map))
(unless nnweb-ephemeral-p
(nnweb-write-active)
@ -132,11 +135,12 @@ and `altavista'.")
(not (equal group nnweb-group))
(not nnweb-ephemeral-p))
(let ((info (assoc group nnweb-group-alist)))
(setq nnweb-group group)
(setq nnweb-type (nth 2 info))
(setq nnweb-search (nth 3 info))
(unless dont-check
(nnweb-read-overview group))))
(when info
(setq nnweb-group group)
(setq nnweb-type (nth 2 info))
(setq nnweb-search (nth 3 info))
(unless dont-check
(nnweb-read-overview group)))))
(cond
((not nnweb-articles)
(nnheader-report 'nnweb "No matching articles"))
@ -166,7 +170,8 @@ and `altavista'.")
(let* ((header (cadr (assq article nnweb-articles)))
(url (and header (mail-header-xref header))))
(when (or (and url
(nnweb-fetch-url url))
(mm-with-unibyte-current-buffer
(nnweb-fetch-url url)))
(and (stringp article)
(nnweb-definition 'id t)
(let ((fetch (nnweb-definition 'id))
@ -175,13 +180,14 @@ and `altavista'.")
(setq art (match-string 1 article)))
(and fetch
art
(nnweb-fetch-url
(format fetch article))))))
(mm-with-unibyte-current-buffer
(nnweb-fetch-url
(format fetch article)))))))
(unless nnheader-callback-function
(funcall (nnweb-definition 'article))
(nnweb-decode-entities))
(nnheader-report 'nnweb "Fetched article %s" article)
t))))
(cons group (and (numberp article) article))))))
(deffoo nnweb-close-server (&optional server)
(when (and (nnweb-server-opened server)
@ -200,9 +206,7 @@ and `altavista'.")
t))
(deffoo nnweb-request-update-info (group info &optional server)
(nnweb-possibly-change-server group server)
;;(setcar (cddr info) nil)
)
(nnweb-possibly-change-server group server))
(deffoo nnweb-asynchronous-p ()
t)
@ -216,7 +220,8 @@ and `altavista'.")
(deffoo nnweb-request-delete-group (group &optional force server)
(nnweb-possibly-change-server group server)
(gnus-pull group nnweb-group-alist)
(gnus-pull group nnweb-group-alist t)
(nnweb-write-active)
(gnus-delete-file (nnweb-overview-file group))
t)
@ -227,7 +232,7 @@ and `altavista'.")
(defun nnweb-read-overview (group)
"Read the overview of GROUP and build the map."
(when (file-exists-p (nnweb-overview-file group))
(nnheader-temp-write nil
(mm-with-unibyte-buffer
(nnheader-insert-file-contents (nnweb-overview-file group))
(goto-char (point-min))
(let (header)
@ -241,7 +246,7 @@ and `altavista'.")
(defun nnweb-write-overview (group)
"Write the overview file for GROUP."
(nnheader-temp-write (nnweb-overview-file group)
(with-temp-file (nnweb-overview-file group)
(let ((articles nnweb-articles))
(while articles
(nnheader-insert-nov (cadr (pop articles)))))))
@ -262,7 +267,8 @@ and `altavista'.")
(defun nnweb-write-active ()
"Save the active file."
(nnheader-temp-write (nnheader-concat nnweb-directory "active")
(gnus-make-directory nnweb-directory)
(with-temp-file (nnheader-concat nnweb-directory "active")
(prin1 `(setq nnweb-group-alist ',nnweb-group-alist) (current-buffer))))
(defun nnweb-read-active ()
@ -287,6 +293,7 @@ and `altavista'.")
(when group
(when (and (not nnweb-ephemeral-p)
(not (equal group nnweb-group)))
(setq nnweb-hashtb (gnus-make-hashtable 4095))
(nnweb-request-group group nil t))))
(defun nnweb-init (server)
@ -294,22 +301,30 @@ and `altavista'.")
(unless (gnus-buffer-live-p nnweb-buffer)
(setq nnweb-buffer
(save-excursion
(nnheader-set-temp-buffer
(format " *nnweb %s %s %s*" nnweb-type nnweb-search server))))))
(mm-with-unibyte
(nnheader-set-temp-buffer
(format " *nnweb %s %s %s*"
nnweb-type nnweb-search server))
(current-buffer))))))
(defun nnweb-fetch-url (url)
(save-excursion
(if (not nnheader-callback-function)
(let ((buf (current-buffer)))
(save-excursion
(set-buffer nnweb-buffer)
(let (buf)
(save-excursion
(if (not nnheader-callback-function)
(progn
(with-temp-buffer
(mm-enable-multibyte)
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary)
(default-process-coding-system 'binary))
(nnweb-insert url))
(setq buf (buffer-string)))
(erase-buffer)
(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)))
(insert buf)
t)
(nnweb-url-retrieve-asynch
url 'nnweb-callback (current-buffer) nnheader-callback-function)
t))))
(defun nnweb-callback (buffer callback)
(when (gnus-buffer-live-p url-working-buffer)
@ -338,42 +353,6 @@ and `altavista'.")
(url-retrieve url))
(setq-default url-be-asynchronous old-asynch)))
(defun nnweb-encode-www-form-urlencoded (pairs)
"Return PAIRS encoded for forms."
(mapconcat
(function
(lambda (data)
(concat (w3-form-encode-xwfu (car data)) "="
(w3-form-encode-xwfu (cdr data)))))
pairs "&"))
(defun nnweb-fetch-form (url pairs)
(let ((url-request-data (nnweb-encode-www-form-urlencoded pairs))
(url-request-method "POST")
(url-request-extra-headers
'(("Content-type" . "application/x-www-form-urlencoded"))))
(url-insert-file-contents url)
(setq buffer-file-name nil))
t)
(defun nnweb-decode-entities ()
(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))
?#))
t t)))
(defun nnweb-remove-markup ()
(goto-char (point-min))
(while (search-forward "<!--" nil t)
(delete-region (match-beginning 0)
(or (search-forward "-->" nil t)
(point-max))))
(goto-char (point-min))
(while (re-search-forward "<[^>]+>" nil t)
(replace-match "" t t)))
;;;
;;; DejaNews functions.
;;;
@ -389,51 +368,46 @@ and `altavista'.")
(case-fold-search t)
(active (or (cadr (assoc nnweb-group nnweb-group-alist))
(cons 1 0)))
Subject (Score "0") Date Newsgroup Author
map url)
subject date from
map url parse a table group text)
(while more
;; Go through all the article hits on this page.
(goto-char (point-min))
(nnweb-decode-entities)
(goto-char (point-min))
(while (re-search-forward "^ <P>\n" nil t)
(narrow-to-region
(point)
(cond ((re-search-forward "^ <P>\n" nil t)
(match-beginning 0))
((search-forward "\n\n" nil t)
(point))
(t
(point-max))))
(goto-char (point-min))
(looking-at ".*HREF=\"\\([^\"]+\\)\"\\(.*\\)")
(setq url (match-string 1))
(let ((begin (point)))
(nnweb-remove-markup)
(goto-char begin)
(while (search-forward "\t" nil t)
(replace-match " "))
(goto-char begin)
(end-of-line)
(setq Subject (buffer-substring begin (point)))
(if (re-search-forward
"^ Newsgroup: \\(.*\\)\n Posted on \\([0-9/]+\\) by \\(.*\\)$" nil t)
(setq Newsgroup (match-string 1)
Date (match-string 2)
Author (match-string 3))))
(widen)
(incf i)
(unless (nnweb-get-hashtb url)
(push
(list
(incf (cdr active))
(make-full-mail-header
(cdr active) Subject Author Date
(concat "<" (nnweb-identifier url) "@dejanews>")
nil 0 (string-to-int Score) url))
map)
(nnweb-set-hashtb (cadar map) (car map))))
(setq parse (w3-parse-buffer (current-buffer))
table (nth 1 (nnweb-parse-find-all 'table parse)))
(dolist (row (nth 2 (car (nth 2 table))))
(setq a (nnweb-parse-find 'a row)
url (cdr (assq 'href (nth 1 a)))
text (nreverse (nnweb-text row)))
(when a
(setq subject (nth 4 text)
group (nth 2 text)
date (nth 1 text)
from (nth 0 text))
(if (string-match "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)" date)
(setq date (format "%s %s 00:00:00 %s"
(car (rassq (string-to-number
(match-string 2 date))
parse-time-months))
(match-string 3 date)
(match-string 1 date)))
(setq date "Jan 1 00:00:00 0000"))
(incf i)
(setq url (concat url "&fmt=text"))
(when (string-match "&context=[^&]+" url)
(setq url (replace-match "" t t url)))
(unless (nnweb-get-hashtb url)
(push
(list
(incf (cdr active))
(make-full-mail-header
(cdr active) (concat subject " (" group ")") from date
(concat "<" (nnweb-identifier url) "@dejanews>")
nil 0 0 url))
map)
(nnweb-set-hashtb (cadar map) (car map)))))
;; See whether there is a "Get next 20 hits" button here.
(goto-char (point-min))
(if (or (not (re-search-forward
"HREF=\"\\([^\"]+\\)\"[<>b]+Next result" nil t))
(>= i nnweb-max-hits))
@ -446,39 +420,25 @@ and `altavista'.")
(setq nnweb-articles
(sort (nconc nnweb-articles map) 'car-less-than-car))))))
(defun nnweb-dejanews-wash-article ()
(let ((case-fold-search t))
(goto-char (point-min))
(re-search-forward "<PRE>" nil t)
(delete-region (point-min) (point))
(re-search-forward "</PRE>" nil t)
(delete-region (point) (point-max))
(nnweb-remove-markup)
(goto-char (point-min))
(while (and (looking-at " *$")
(not (eobp)))
(gnus-delete-line))
(while (looking-at "\\(^[^ ]+:\\) *")
(replace-match "\\1 " t)
(forward-line 1))
(when (re-search-forward "\n\n+" nil 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
(nnweb-definition 'address)
`(("query" . ,search)
("defaultOp" . "AND")
("svcclass" . "dncurrent")
("maxhits" . "100")
("format" . "verbose2")
("threaded" . "0")
("showsort" . "date")
("agesign" . "1")
("ageweight" . "1")))
(nnweb-insert
(concat
(nnweb-definition 'address)
"?"
(nnweb-encode-www-form-urlencoded
`(("ST" . "PS")
("svcclass" . "dnyr")
("QRY" . ,search)
("defaultOp" . "AND")
("DBS" . "1")
("OP" . "dnquery.xp")
("LNG" . "ALL")
("maxhits" . "100")
("threaded" . "0")
("format" . "verbose2")
("showsort" . "date")
("agesign" . "1")
("ageweight" . "1")))))
t)
(defun nnweb-dejanewsold-search (search)
@ -497,7 +457,7 @@ and `altavista'.")
(defun nnweb-dejanews-identity (url)
"Return an unique identifier based on URL."
(if (string-match "recnum=\\([0-9]+\\)" url)
(if (string-match "AN=\\([0-9]+\\)" url)
(match-string 1 url)
url))
@ -523,7 +483,6 @@ and `altavista'.")
(goto-char (point-min))
(search-forward "</pre><hr>" nil t)
(delete-region (point-min) (point))
;(nnweb-decode-entities)
(goto-char (point-min))
(while (re-search-forward "^ +[0-9]+\\." nil t)
(narrow-to-region
@ -719,6 +678,145 @@ and `altavista'.")
(setq buffer-file-name nil)
t)
;;;
;;; General web/w3 interface utility functions
;;;
(defun nnweb-insert-html (parse)
"Insert HTML based on a w3 parse tree."
(if (stringp parse)
(insert parse)
(insert "<" (symbol-name (car parse)) " ")
(insert (mapconcat
(lambda (param)
(concat (symbol-name (car param)) "="
(prin1-to-string
(if (consp (cdr param))
(cadr param)
(cdr param)))))
(nth 1 parse)
" "))
(insert ">\n")
(mapcar 'nnweb-insert-html (nth 2 parse))
(insert "</" (symbol-name (car parse)) ">\n")))
(defun nnweb-encode-www-form-urlencoded (pairs)
"Return PAIRS encoded for forms."
(mapconcat
(function
(lambda (data)
(concat (w3-form-encode-xwfu (car data)) "="
(w3-form-encode-xwfu (cdr data)))))
pairs "&"))
(defun nnweb-fetch-form (url pairs)
"Fetch a form from URL with PAIRS as the data using the POST method."
(let ((url-request-data (nnweb-encode-www-form-urlencoded pairs))
(url-request-method "POST")
(url-request-extra-headers
'(("Content-type" . "application/x-www-form-urlencoded"))))
(url-insert-file-contents url)
(setq buffer-file-name nil))
t)
(defun nnweb-decode-entities ()
"Decode all HTML entities."
(goto-char (point-min))
(while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
(replace-match (char-to-string
(if (eq (aref (match-string 1) 0) ?\#)
(let ((c
(string-to-number (substring
(match-string 1) 1))))
(if (mm-char-or-char-int-p c) c 32))
(or (cdr (assq (intern (match-string 1))
w3-html-entities))
?#)))
t t)))
(defun nnweb-decode-entities-string (str)
(with-temp-buffer
(insert str)
(nnweb-decode-entities)
(buffer-substring (point-min) (point-max))))
(defun nnweb-remove-markup ()
"Remove all HTML markup, leaving just plain text."
(goto-char (point-min))
(while (search-forward "<!--" nil t)
(delete-region (match-beginning 0)
(or (search-forward "-->" nil t)
(point-max))))
(goto-char (point-min))
(while (re-search-forward "<[^>]+>" nil t)
(replace-match "" t t)))
(defun nnweb-insert (url &optional follow-refresh)
"Insert the contents from an URL in the current buffer.
If FOLLOW-REFRESH is non-nil, redirect refresh url in META."
(let ((name buffer-file-name))
(if follow-refresh
(save-restriction
(narrow-to-region (point) (point))
(url-insert-file-contents url)
(goto-char (point-min))
(when (re-search-forward
"<meta[ \t\r\n]*http-equiv=\"Refresh\"[^>]*URL=\\([^\"]+\\)\"" nil t)
(let ((url (match-string 1)))
(delete-region (point-min) (point-max))
(nnweb-insert url t))))
(url-insert-file-contents url))
(setq buffer-file-name name)))
(defun nnweb-parse-find (type parse &optional maxdepth)
"Find the element of TYPE in PARSE."
(catch 'found
(nnweb-parse-find-1 type parse maxdepth)))
(defun nnweb-parse-find-1 (type contents maxdepth)
(when (or (null maxdepth)
(not (zerop maxdepth)))
(when (consp contents)
(when (eq (car contents) type)
(throw 'found contents))
(when (listp (cdr contents))
(dolist (element contents)
(when (consp element)
(nnweb-parse-find-1 type element
(and maxdepth (1- maxdepth)))))))))
(defun nnweb-parse-find-all (type parse)
"Find all elements of TYPE in PARSE."
(catch 'found
(nnweb-parse-find-all-1 type parse)))
(defun nnweb-parse-find-all-1 (type contents)
(let (result)
(when (consp contents)
(if (eq (car contents) type)
(push contents result)
(when (listp (cdr contents))
(dolist (element contents)
(when (consp element)
(setq result
(nconc result (nnweb-parse-find-all-1 type element))))))))
result))
(defvar nnweb-text)
(defun nnweb-text (parse)
"Return a list of text contents in PARSE."
(let ((nnweb-text nil))
(nnweb-text-1 parse)
(nreverse nnweb-text)))
(defun nnweb-text-1 (contents)
(dolist (element contents)
(if (stringp element)
(push element nnweb-text)
(when (and (consp element)
(listp (cdr element)))
(nnweb-text-1 element)))))
(provide 'nnweb)
;;; nnweb.el ends here

117
lisp/gnus/parse-time.el
View File

@ -1,6 +1,6 @@
;;; parse-time.el --- Parsing time strings
;; Copyright (C) 1996 by Free Software Foundation, Inc.
;; Copyright (C) 1996, 2000 by Free Software Foundation, Inc.
;; Author: Erik Naggum <erik@naggum.no>
;; Keywords: util
@ -36,12 +36,10 @@
;;; Code:
(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it
(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it
(put 'parse-time-syntax 'char-table-extra-slots 0)
(defvar parse-time-syntax (make-char-table 'parse-time-syntax))
(defvar parse-time-digits (make-char-table 'parse-time-syntax))
(defvar parse-time-syntax (make-vector 256 nil))
(defvar parse-time-digits (make-vector 256 nil))
;; Byte-compiler warnings
(defvar elt)
@ -49,18 +47,18 @@
(unless (aref parse-time-digits ?0)
(loop for i from ?0 to ?9
do (set-char-table-range parse-time-digits i (- i ?0))))
do (aset parse-time-digits i (- i ?0))))
(unless (aref parse-time-syntax ?0)
(loop for i from ?0 to ?9
do (set-char-table-range parse-time-syntax i ?0))
do (aset parse-time-syntax i ?0))
(loop for i from ?A to ?Z
do (set-char-table-range parse-time-syntax i ?A))
do (aset parse-time-syntax i ?A))
(loop for i from ?a to ?z
do (set-char-table-range parse-time-syntax i ?a))
(set-char-table-range parse-time-syntax ?+ 1)
(set-char-table-range parse-time-syntax ?- -1)
(set-char-table-range parse-time-syntax ?: ?d)
do (aset parse-time-syntax i ?a))
(aset parse-time-syntax ?+ 1)
(aset parse-time-syntax ?- -1)
(aset parse-time-syntax ?: ?d)
)
(defsubst digit-char-p (char)
@ -89,7 +87,8 @@
(setq integer (+ (* integer 10) digit)
index (1+ index)))
(if (/= index end)
(signal 'parse-error `("not an integer" ,(substring string (or start 0) end)))
(signal 'parse-error `("not an integer"
,(substring string (or start 0) end)))
(* sign integer))))))
(defun parse-time-tokenize (string)
@ -114,24 +113,24 @@
list)))
(nreverse list)))
(defvar parse-time-months '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3)
("Apr" . 4) ("May" . 5) ("Jun" . 6)
("Jul" . 7) ("Aug" . 8) ("Sep" . 9)
("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
(defvar parse-time-weekdays '(("Sun" . 0) ("Mon" . 1) ("Tue" . 2)
("Wed" . 3) ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
(defvar parse-time-zoneinfo `(("Z" 0) ("UT" 0) ("GMT" 0)
("PST" ,(* -8 3600)) ("PDT" ,(* -7 3600) t)
("MST" ,(* -7 3600)) ("MDT" ,(* -6 3600) t)
("CST" ,(* -6 3600)) ("CDT" ,(* -5 3600) t)
("EST" ,(* -5 3600)) ("EDT" ,(* -4 3600) t))
(defvar parse-time-months '(("jan" . 1) ("feb" . 2) ("mar" . 3)
("apr" . 4) ("may" . 5) ("jun" . 6)
("jul" . 7) ("aug" . 8) ("sep" . 9)
("oct" . 10) ("nov" . 11) ("dec" . 12)))
(defvar parse-time-weekdays '(("sun" . 0) ("mon" . 1) ("tue" . 2)
("wed" . 3) ("thu" . 4) ("fri" . 5) ("sat" . 6)))
(defvar parse-time-zoneinfo `(("z" 0) ("ut" 0) ("gmt" 0)
("pst" ,(* -8 3600)) ("pdt" ,(* -7 3600) t)
("mst" ,(* -7 3600)) ("mdt" ,(* -6 3600) t)
("cst" ,(* -6 3600)) ("cdt" ,(* -5 3600) t)
("est" ,(* -5 3600)) ("edt" ,(* -4 3600) t))
"(zoneinfo seconds-off daylight-savings-time-p)")
(defvar parse-time-rules
`(((6) parse-time-weekdays)
((3) (1 31))
((4) parse-time-months)
((5) (1970 2038))
((5) (100 4038))
((2 1 0)
,#'(lambda () (and (stringp elt)
(= (length elt) 8)
@ -150,20 +149,34 @@
(* 60 (parse-integer elt 1 3)))
(if (= (aref elt 0) ?-) -1 1))))
((5 4 3)
,#'(lambda () (and (stringp elt) (= (length elt) 10) (= (aref elt 4) ?-) (= (aref elt 7) ?-)))
,#'(lambda () (and (stringp elt)
(= (length elt) 10)
(= (aref elt 4) ?-)
(= (aref elt 7) ?-)))
[0 4] [5 7] [8 10])
((2 1)
((2 1 0)
,#'(lambda () (and (stringp elt) (= (length elt) 5) (= (aref elt 2) ?:)))
[0 2] [3 5])
((5) (70 99) ,#'(lambda () (+ 1900 elt))))
[0 2] [3 5] ,#'(lambda () 0))
((2 1 0)
,#'(lambda () (and (stringp elt)
(= (length elt) 4)
(= (aref elt 1) ?:)))
[0 1] [2 4] ,#'(lambda () 0))
((2 1 0)
,#'(lambda () (and (stringp elt)
(= (length elt) 7)
(= (aref elt 1) ?:)))
[0 1] [2 4] [5 7])
((5) (50 110) ,#'(lambda () (+ 1900 elt)))
((5) (0 49) ,#'(lambda () (+ 2000 elt))))
"(slots predicate extractor...)")
(defun parse-time-string (string)
"Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ).
The values are identical to those of `decode-time', but any values that are
unknown are returned as nil."
(let ((time (list nil nil nil nil nil nil nil nil nil nil))
(temp (parse-time-tokenize string)))
(let ((time (list nil nil nil nil nil nil nil nil nil))
(temp (parse-time-tokenize (downcase string))))
(while temp
(let ((elt (pop temp))
(rules parse-time-rules)
@ -173,25 +186,27 @@ unknown are returned as nil."
(slots (pop rule))
(predicate (pop rule))
(val))
(if (and (not (nth (car slots) time)) ;not already set
(setq val (cond ((and (consp predicate)
(not (eq (car predicate) 'lambda)))
(and (numberp elt)
(<= (car predicate) elt)
(<= elt (cadr predicate))
elt))
((symbolp predicate)
(cdr (assoc elt (symbol-value predicate))))
((funcall predicate)))))
(progn
(setq exit t)
(while slots
(let ((new-val (and rule
(let ((this (pop rule)))
(if (vectorp this)
(parse-integer elt (aref this 0) (aref this 1))
(funcall this))))))
(rplaca (nthcdr (pop slots) time) (or new-val val))))))))))
(when (and (not (nth (car slots) time)) ;not already set
(setq val (cond ((and (consp predicate)
(not (eq (car predicate)
'lambda)))
(and (numberp elt)
(<= (car predicate) elt)
(<= elt (cadr predicate))
elt))
((symbolp predicate)
(cdr (assoc elt
(symbol-value predicate))))
((funcall predicate)))))
(setq exit t)
(while slots
(let ((new-val (and rule
(let ((this (pop rule)))
(if (vectorp this)
(parse-integer
elt (aref this 0) (aref this 1))
(funcall this))))))
(rplaca (nthcdr (pop slots) time) (or new-val val)))))))))
time))
(provide 'parse-time)

3
lisp/gnus/pop3.el
View File

@ -1,6 +1,7 @@
;;; pop3.el --- Post Office Protocol (RFC 1460) interface
;; Copyright (C) 1996, 96, 97, 98, 1999 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
;; Maintainer: FSF

19
lisp/gnus/score-mode.el
View File

@ -25,9 +25,8 @@
;;; Code:
(require 'easymenu)
(require 'timezone)
(eval-when-compile (require 'cl))
(require 'mm-util) ; for mm-auto-save-coding-system
(defvar gnus-score-mode-hook nil
"*Hook run in score mode buffers.")
@ -40,7 +39,8 @@
(defvar gnus-score-mode-map nil)
(unless gnus-score-mode-map
(setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
(setq gnus-score-mode-map (make-sparse-keymap))
(set-keymap-parent gnus-score-mode-map emacs-lisp-mode-map)
(define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-exit)
(define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)
(define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print))
@ -51,6 +51,9 @@
table)
"Syntax table used in score-mode buffers.")
;; We need this to cope with non-ASCII scoring.
(defvar score-mode-coding-system mm-auto-save-coding-system)
;;;###autoload
(defun gnus-score-mode ()
"Mode for editing Gnus score files.
@ -81,7 +84,7 @@ This mode is an extended emacs-lisp mode.
(defun gnus-score-edit-insert-date ()
"Insert date in numerical format."
(interactive)
(princ (gnus-score-day-number (current-time)) (current-buffer)))
(princ (time-to-days (current-time)) (current-buffer)))
(defun gnus-score-pretty-print ()
"Format the current score file."
@ -98,7 +101,8 @@ This mode is an extended emacs-lisp mode.
(interactive)
(unless (file-exists-p (file-name-directory (buffer-file-name)))
(make-directory (file-name-directory (buffer-file-name)) t))
(save-buffer)
(let ((coding-system-for-write score-mode-coding-system))
(save-buffer))
(bury-buffer (current-buffer))
(let ((buf (current-buffer)))
(when gnus-score-edit-exit-function
@ -106,11 +110,6 @@ This mode is an extended emacs-lisp mode.
(when (eq buf (current-buffer))
(switch-to-buffer (other-buffer (current-buffer))))))
(defun gnus-score-day-number (time)
(let ((dat (decode-time time)))
(timezone-absolute-from-gregorian
(nth 4 dat) (nth 3 dat) (nth 5 dat))))
(provide 'score-mode)
;;; score-mode.el ends here