mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-08 15:35:02 +00:00
Code Issues Releases Activity

New version.

Browse Source
This commit is contained in:
Lars Magne Ingebrigtsen 1996-06-25 22:21:39 +00:00
parent b8c631a53b
commit 231f989be9
27 changed files with 19992 additions and 16417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

220
lisp/custom.el
View File

@ -68,15 +68,50 @@
;;; Code:
(eval-when-compile
(require 'cl))
;;; Compatibility:
(or (fboundp 'buffer-substring-no-properties)
;; Introduced in Emacs 19.29.
(defun buffer-substring-no-properties (beg end)
"Return the text from BEG to END, without text properties, as a string."
(let ((string (buffer-substring beg end)))
(set-text-properties 0 (length string) nil string)
string)))
(defun custom-xmas-add-text-properties (start end props &optional object)
(add-text-properties start end props object)
(put-text-property start end 'start-open t object)
(put-text-property start end 'end-open t object))
(defun custom-xmas-put-text-property (start end prop value &optional object)
(put-text-property start end prop value object)
(put-text-property start end 'start-open t object)
(put-text-property start end 'end-open t object))
(defun custom-xmas-extent-start-open ()
(map-extents (lambda (extent arg)
(set-extent-property extent 'start-open t))
nil (point) (min (1+ (point)) (point-max))))
(if (string-match "XEmacs\\|Lucid" emacs-version)
(progn
(fset 'custom-add-text-properties 'custom-xmas-add-text-properties)
(fset 'custom-put-text-property 'custom-xmas-put-text-property)
(fset 'custom-extent-start-open 'custom-xmas-extent-start-open)
(fset 'custom-set-text-properties
(if (fboundp 'set-text-properties)
'set-text-properties))
(fset 'custom-buffer-substring-no-properties
(if (fboundp 'buffer-substring-no-properties)
'buffer-substring-no-properties
'custom-xmas-buffer-substring-no-properties)))
(fset 'custom-add-text-properties 'add-text-properties)
(fset 'custom-put-text-property 'put-text-property)
(fset 'custom-extent-start-open 'ignore)
(fset 'custom-set-text-properties 'set-text-properties)
(fset 'custom-buffer-substring-no-properties
'buffer-substring-no-properties))
(defun custom-xmas-buffer-substring-no-properties (beg end)
"Return the text from BEG to END, without text properties, as a string."
(let ((string (buffer-substring beg end)))
(custom-set-text-properties 0 (length string) nil string)
string))
(or (fboundp 'add-to-list)
;; Introduced in Emacs 19.29.
@ -171,16 +206,14 @@ STRING should be given if the last search was by `string-match' on STRING."
(and (fboundp 'set-face-underline-p)
(funcall 'set-face-underline-p 'underline t))))
(or (fboundp 'set-text-properties)
;; Missing in XEmacs 19.12.
(defun set-text-properties (start end props &optional buffer)
(if (or (null buffer) (bufferp buffer))
(if props
(while props
(put-text-property
start end (car props) (nth 1 props) buffer)
(setq props (nthcdr 2 props)))
(remove-text-properties start end ())))))
(defun custom-xmas-set-text-properties (start end props &optional buffer)
(if (null buffer)
(if props
(while props
(custom-put-text-property
start end (car props) (nth 1 props) buffer)
(setq props (nthcdr 2 props)))
(remove-text-properties start end ()))))
(or (fboundp 'event-point)
;; Missing in Emacs 19.29.
@ -201,60 +234,6 @@ into the buffer visible in the event's window."
(defvar custom-mouse-face nil)
(defvar custom-field-active-face nil))
(or (and (fboundp 'modify-face) (not (featurep 'face-lock)))
;; Introduced in Emacs 19.29. Incompatible definition also introduced
;; by face-lock.el version 3.00 and above for Emacs 19.28 and below.
;; face-lock does not call modify-face, so we can safely redefine it.
(defun modify-face (face foreground background stipple
bold-p italic-p underline-p)
"Change the display attributes for face FACE.
FOREGROUND and BACKGROUND should be color strings or nil.
STIPPLE should be a stipple pattern name or nil.
BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
in italic, and underlined, respectively. (Yes if non-nil.)
If called interactively, prompts for a face and face attributes."
(interactive
(let* ((completion-ignore-case t)
(face (symbol-name (read-face-name "Modify face: ")))
(colors (mapcar 'list x-colors))
(stipples (mapcar 'list
(apply 'nconc
(mapcar 'directory-files
x-bitmap-file-path))))
(foreground (modify-face-read-string
face (face-foreground (intern face))
"foreground" colors))
(background (modify-face-read-string
face (face-background (intern face))
"background" colors))
(stipple (modify-face-read-string
face (face-stipple (intern face))
"stipple" stipples))
(bold-p (y-or-n-p (concat "Set face " face " bold ")))
(italic-p (y-or-n-p (concat "Set face " face " italic ")))
(underline-p (y-or-n-p (concat "Set face " face " underline "))))
(message "Face %s: %s" face
(mapconcat 'identity
(delq nil
(list (and foreground (concat (downcase foreground) " foreground"))
(and background (concat (downcase background) " background"))
(and stipple (concat (downcase stipple) " stipple"))
(and bold-p "bold") (and italic-p "italic")
(and underline-p "underline"))) ", "))
(list (intern face) foreground background stipple
bold-p italic-p underline-p)))
(condition-case nil (set-face-foreground face foreground) (error nil))
(condition-case nil (set-face-background face background) (error nil))
(condition-case nil (set-face-stipple face stipple) (error nil))
(if (string-match "XEmacs" emacs-version)
(progn
(funcall (if bold-p 'make-face-bold 'make-face-unbold) face)
(funcall (if italic-p 'make-face-italic 'make-face-unitalic) face))
(funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
(funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t))
(set-face-underline-p face underline-p)
(and (interactive-p) (redraw-display))))
;; We can't easily check for a working intangible.
(defconst intangible (if (and (boundp 'emacs-minor-version)
(or (> emacs-major-version 19)
@ -281,9 +260,10 @@ If called interactively, prompts for a face and face attributes."
;; Put it in the Help menu, if possible.
(if (string-match "XEmacs" emacs-version)
;; XEmacs (disabled because it doesn't work)
(and current-menubar
(add-menu-item '("Help") "Customize..." 'customize nil))
(if (featurep 'menubar)
;; XEmacs (disabled because it doesn't work)
(and current-menubar
(add-menu-item '("Help") "Customize..." 'customize t)))
;; Emacs 19.28 and earlier
(global-set-key [ menu-bar help customize ]
'("Customize..." . customize))
@ -359,7 +339,7 @@ If called interactively, prompts for a face and face attributes."
(defun custom-category-set (from to category)
"Make text between FROM and TWO have category CATEGORY."
(put-text-property from to 'category category)))
(custom-put-text-property from to 'category category)))
;;; External Data:
;;
@ -419,7 +399,7 @@ If called interactively, prompts for a face and face attributes."
;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
;; property and `custom-type-properties'.
(defvar custom-file (convert-standard-filename "~/.custom.el")
(defvar custom-file "~/.custom.el"
"Name of file with customization information.")
(defconst custom-data
@ -1080,6 +1060,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(end (make-marker))
(data (vector repeat nil start end))
field)
(custom-extent-start-open)
(insert-before-markers "\n")
(backward-char 1)
(set-marker start (point))
@ -1309,7 +1290,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(face-tag (custom-face-tag custom))
current)
(if face-tag
(put-text-property from (+ from (length (custom-tag custom)))
(custom-put-text-property from (+ from (length (custom-tag custom)))
'face (funcall face-tag field value)))
(if original
(custom-field-original-set field value))
@ -1395,9 +1376,10 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
()
(setq begin (point)
found (custom-insert (custom-property custom 'none) nil))
(add-text-properties begin (point)
(list rear-nonsticky t
'face custom-field-uninitialized-face)))
(custom-add-text-properties
begin (point)
(list rear-nonsticky t
'face custom-field-uninitialized-face)))
(or original
(custom-field-original-set found (custom-field-original field)))
(custom-field-accept found value original)
@ -1483,7 +1465,8 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(defun custom-face-import (custom value)
"Modify CUSTOM's VALUE to match internal expectations."
(let ((name (symbol-name value)))
(let ((name (or (and (facep value) (symbol-name (face-name value)))
(symbol-name value))))
(list (if (string-match "\
custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
name)
@ -1496,9 +1479,8 @@ custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
(intern (match-string 6 name)))
value))))
(defun custom-face-lookup (fg bg stipple bold italic underline)
"Lookup or create a face with specified attributes.
FG BG STIPPLE BOLD ITALIC UNDERLINE"
(defun custom-face-lookup (&optional fg bg stipple bold italic underline)
"Lookup or create a face with specified attributes."
(let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
(or fg "default")
(or bg "default")
@ -1507,12 +1489,37 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
(if (and (custom-facep name)
(fboundp 'make-face))
()
(make-face name)
(modify-face name
(if (string-equal fg "default") nil fg)
(if (string-equal bg "default") nil bg)
(if (string-equal stipple "default") nil stipple)
bold italic underline))
(copy-face 'default name)
(when (and fg
(not (string-equal fg "default")))
(condition-case ()
(set-face-foreground name fg)
(error nil)))
(when (and bg
(not (string-equal bg "default")))
(condition-case ()
(set-face-background name bg)
(error nil)))
(when (and stipple
(not (string-equal stipple "default"))
(not (eq stipple 'custom:asis))
(fboundp 'set-face-stipple))
(set-face-stipple name stipple))
(when (and bold
(not (eq bold 'custom:asis)))
(condition-case ()
(make-face-bold name)
(error nil)))
(when (and italic
(not (eq italic 'custom:asis)))
(condition-case ()
(make-face-italic name)
(error nil)))
(when (and underline
(not (eq underline 'custom:asis)))
(condition-case ()
(set-face-underline-p name t)
(error nil))))
name))
(defun custom-face-hack (field value)
@ -1528,7 +1535,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
(face (custom-field-face field))
(from (point)))
(custom-text-insert (custom-tag custom))
(add-text-properties from (point)
(custom-add-text-properties from (point)
(list 'face face
rear-nonsticky t))
(custom-documentation-insert custom)
@ -1539,7 +1546,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
"Update face of FIELD."
(let ((from (custom-field-start field))
(custom (custom-field-custom field)))
(put-text-property from (+ from (length (custom-tag custom)))
(custom-put-text-property from (+ from (length (custom-tag custom)))
'face (custom-field-face field))))
(defun custom-const-valid (custom value)
@ -1828,9 +1835,9 @@ If the optional argument SAVE is non-nil, use that for saving changes."
(let ((from (point)))
(insert tag)
(custom-category-set from (point) 'custom-button-properties)
(put-text-property from (point) 'custom-tag field)
(custom-put-text-property from (point) 'custom-tag field)
(if data
(add-text-properties from (point) (list 'custom-data data)))))
(custom-add-text-properties from (point) (list 'custom-data data)))))
(defun custom-documentation-insert (custom &rest ignore)
"Insert documentation from CUSTOM in current buffer."
@ -1849,11 +1856,13 @@ If the optional argument SAVE is non-nil, use that for saving changes."
"Describe how to execute COMMAND."
(let ((from (point)))
(insert "`" (key-description (where-is-internal command nil t)) "'")
(set-text-properties from (point)
(list 'face custom-button-face
mouse-face custom-mouse-face
'custom-jump t ;Make TAB jump over it.
'custom-tag command))
(custom-set-text-properties from (point)
(list 'face custom-button-face
mouse-face custom-mouse-face
'custom-jump t ;Make TAB jump over it.
'custom-tag command
'start-open t
'end-open t))
(custom-category-set from (point) 'custom-documentation-properties))
(custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
@ -2175,17 +2184,18 @@ If the optional argument is non-nil, show text iff the argument is positive."
(insert-char (custom-padding custom)
(- (custom-width custom) (- (point) from)))
(custom-field-move field from (point))
(set-text-properties
(custom-set-text-properties
from (point)
(list 'custom-field field
'custom-tag field
'face (custom-field-face field)
front-sticky t))))
'start-open t
'end-open t))))
(defun custom-field-read (field)
;; Read the screen content of FIELD.
(custom-read (custom-field-custom field)
(buffer-substring-no-properties (custom-field-start field)
(custom-buffer-substring-no-properties (custom-field-start field)
(custom-field-end field))))
;; Fields are shown in a special `active' face when point is inside
@ -2196,7 +2206,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
;; Deactivate FIELD.
(let ((before-change-functions nil)
(after-change-functions nil))
(put-text-property (custom-field-start field) (custom-field-end field)
(custom-put-text-property (custom-field-start field) (custom-field-end field)
'face (custom-field-face field))))
(defun custom-field-enter (field)
@ -2214,7 +2224,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
(setq pos (1- pos)))
(if (< pos (point))
(goto-char pos))))
(put-text-property start end 'face custom-field-active-face)))
(custom-put-text-property start end 'face custom-field-active-face)))
(defun custom-field-resize (field)
;; Resize FIELD after change.
@ -2296,7 +2306,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
(let ((field custom-field-was))
(custom-assert '(prog1 field (setq custom-field-was nil)))
;; Prevent mixing fields properties.
(put-text-property begin end 'custom-field field)
(custom-put-text-property begin end 'custom-field field)
;; Update the field after modification.
(if (eq (custom-field-property begin) field)
(let ((field-end (custom-field-end field)))

643
lisp/gnus-cache.el
View File

@ -1,6 +1,5 @@
;;; gnus-cache.el --- cache interface for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
@ -27,45 +26,55 @@
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-cache-directory (concat gnus-article-save-directory "cache/")
(defvar gnus-cache-directory
(nnheader-concat gnus-directory "cache/")
"*The directory where cached articles will be stored.")
(defvar gnus-cache-active-file
(concat (file-name-as-directory gnus-cache-directory) "active")
"*The cache active file.")
(defvar gnus-cache-enter-articles '(ticked dormant)
"*Classes of articles to enter into the cache.")
(defvar gnus-cache-remove-articles '(read)
"*Classes of articles to remove from the cache.")
(defvar gnus-uncacheable-groups nil
"*Groups that match this regexp will not be cached.
If you want to avoid caching your nnml groups, you could set this
variable to \"^nnml\".")
;;; Internal variables.
(defvar gnus-cache-buffer nil)
(defvar gnus-cache-active-hashtb nil)
(defvar gnus-cache-active-altered nil)
(eval-and-compile
(autoload 'nnml-generate-nov-databases-1 "nnml")
(autoload 'nnvirtual-find-group-art "nnvirtual"))
(defun gnus-cache-change-buffer (group)
(and gnus-cache-buffer
;; see if the current group's overview cache has been loaded
(or (string= group (car gnus-cache-buffer))
;; another overview cache is current, save it
(gnus-cache-save-buffers)))
;; if gnus-cache buffer is nil, create it
(or gnus-cache-buffer
;; create cache buffer
(save-excursion
(setq gnus-cache-buffer
(cons group
(set-buffer (get-buffer-create " *gnus-cache-overview*"))))
(buffer-disable-undo (current-buffer))
;; insert the contents of this groups cache overview
(erase-buffer)
(let ((file (gnus-cache-file-name group ".overview")))
(and (file-exists-p file)
(insert-file-contents file)))
;; we have a fresh (empty/just loaded) buffer,
;; mark it as unmodified to save a redundant write later.
(set-buffer-modified-p nil))))
;;; Functions called from Gnus.
(defun gnus-cache-open ()
"Initialize the cache."
(gnus-cache-read-active))
(gnus-add-shutdown 'gnus-cache-close 'gnus)
(defun gnus-cache-close ()
"Shut down the cache."
(gnus-cache-write-active)
(gnus-cache-save-buffers)
(setq gnus-cache-active-hashtb nil))
(defun gnus-cache-save-buffers ()
;; save the overview buffer if it exists and has been modified
@ -99,185 +108,318 @@
(gnus-kill-buffer buffer)
(setq gnus-cache-buffer nil))))
(defun gnus-cache-possibly-enter-article
(group article headers 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 dir)
(when (and (> number 0) ; Reffed article.
(or (not gnus-uncacheable-groups)
(not (string-match gnus-uncacheable-groups group)))
(or force
(gnus-cache-member-of-class
gnus-cache-enter-articles ticked dormant unread))
(not (file-exists-p (setq file (gnus-cache-file-name
group number)))))
;; Possibly create the cache directory.
(or (file-exists-p (setq dir (file-name-directory file)))
(gnus-make-directory dir))
;; Save the article in the cache.
(if (file-exists-p file)
t ; The article already is saved.
(save-excursion
(set-buffer nntp-server-buffer)
(let ((gnus-use-cache nil))
(gnus-request-article-this-buffer number group))
(when (> (buffer-size) 0)
(write-region (point-min) (point-max) file nil 'quiet)
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-max))
(forward-line -1)
(while (condition-case ()
(and (not (bobp))
(> (read (current-buffer)) number))
(error
;; The line was malformed, so we just remove it!!
(gnus-delete-line)
t))
(forward-line -1))
(if (bobp)
(if (not (eobp))
(progn
(beginning-of-line)
(if (< (read (current-buffer)) number)
(forward-line 1)))
(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) "")))
;; Update the active info.
(set-buffer gnus-summary-buffer)
(gnus-cache-update-active group number)
(push article gnus-newsgroup-cached)
(gnus-summary-update-secondary-mark article))
t))))))
(defun gnus-cache-enter-remove-article (article)
"Mark ARTICLE for later possible removal."
(when article
(push article gnus-cache-removable-articles)))
(defun gnus-cache-possibly-remove-articles ()
"Possibly remove some of the removable articles."
(if (not (gnus-virtual-group-p gnus-newsgroup-name))
(gnus-cache-possibly-remove-articles-1)
(let ((arts gnus-cache-removable-articles)
ga)
(while arts
(when (setq ga (nnvirtual-find-group-art
(gnus-group-real-name gnus-newsgroup-name) (pop arts)))
(let ((gnus-cache-removable-articles (list (cdr ga)))
(gnus-newsgroup-name (car ga)))
(gnus-cache-possibly-remove-articles-1)))))
(setq gnus-cache-removable-articles nil)))
(defun gnus-cache-possibly-remove-articles-1 ()
"Possibly remove some of the removable articles."
(unless (eq gnus-use-cache 'passive)
(let ((articles gnus-cache-removable-articles)
(cache-articles gnus-newsgroup-cached)
article)
(gnus-cache-change-buffer gnus-newsgroup-name)
(while articles
(if (memq (setq article (pop articles)) cache-articles)
;; The article was in the cache, so we see whether we are
;; supposed to remove it from the cache.
(gnus-cache-possibly-remove-article
article (memq article gnus-newsgroup-marked)
(memq article gnus-newsgroup-dormant)
(or (memq article gnus-newsgroup-unreads)
(memq article gnus-newsgroup-unselected))))))
;; The overview file might have been modified, save it
;; safe because we're only called at group exit anyway.
(gnus-cache-save-buffers)))
(defun gnus-cache-request-article (article group)
"Retrieve ARTICLE in GROUP from the cache."
(let ((file (gnus-cache-file-name group article))
(buffer-read-only nil))
(when (file-exists-p file)
(erase-buffer)
(gnus-kill-all-overlays)
(insert-file-contents file)
t)))
(defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
(and cache-active
(< (car cache-active) (car active))
(setcar active (car cache-active)))
(and cache-active
(> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active)))))
(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
"Retrieve the headers for ARTICLES in GROUP."
(let ((cached
(setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
(if (not cached)
;; No cached articles here, so we just retrieve them
;; the normal way.
(let ((gnus-use-cache nil))
(gnus-retrieve-headers articles group fetch-old))
(let ((uncached-articles (gnus-sorted-intersection
(gnus-sorted-complement articles cached)
articles))
(cache-file (gnus-cache-file-name group ".overview"))
type)
;; We first retrieve all the headers that we don't have in
;; the cache.
(let ((gnus-use-cache nil))
(when uncached-articles
(setq type (and articles
(gnus-retrieve-headers
uncached-articles group fetch-old)))))
(gnus-cache-save-buffers)
;; Then we insert the cached headers.
(save-excursion
(cond
((not (file-exists-p cache-file))
;; There are no cached headers.
type)
((null type)
;; There were no uncached headers (or retrieval was
;; unsuccessful), so we use the cached headers exclusively.
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-file-contents cache-file)
'nov)
((eq type 'nov)
;; We have both cached and uncached NOV headers, so we
;; braid them.
(gnus-cache-braid-nov group cached)
type)
(t
;; We braid HEADs.
(gnus-cache-braid-heads group (gnus-sorted-intersection
cached articles))
type)))))))
(defun gnus-cache-enter-article (&optional n)
"Enter the next N articles into the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles entered."
(interactive "P")
(gnus-set-global-variables)
(let ((articles (gnus-summary-work-articles n))
article out)
(while articles
(setq article (pop articles))
(when (gnus-cache-possibly-enter-article
gnus-newsgroup-name article (gnus-summary-article-header article)
nil nil nil t)
(push article out))
(gnus-summary-remove-process-mark article)
(gnus-summary-update-secondary-mark article))
(gnus-summary-next-subject 1)
(gnus-summary-position-point)
(nreverse out)))
(defun gnus-cache-remove-article (n)
"Remove the next N articles from the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles removed."
(interactive "P")
(gnus-set-global-variables)
(gnus-cache-change-buffer gnus-newsgroup-name)
(let ((articles (gnus-summary-work-articles n))
article out)
(while articles
(setq article (pop articles))
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(push article out))
(gnus-summary-remove-process-mark article)
(gnus-summary-update-secondary-mark article))
(gnus-summary-next-subject 1)
(gnus-summary-position-point)
(nreverse out)))
(defun gnus-cached-article-p (article)
"Say whether ARTICLE is cached in the current group."
(memq article gnus-newsgroup-cached))
;;; Internal functions.
(defun gnus-cache-change-buffer (group)
(and gnus-cache-buffer
;; See if the current group's overview cache has been loaded.
(or (string= group (car gnus-cache-buffer))
;; Another overview cache is current, save it.
(gnus-cache-save-buffers)))
;; if gnus-cache buffer is nil, create it
(or gnus-cache-buffer
;; Create cache buffer
(save-excursion
(setq gnus-cache-buffer
(cons group
(set-buffer (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")))
(and (file-exists-p file)
(insert-file-contents file)))
;; We have a fresh (empty/just loaded) buffer,
;; mark it as unmodified to save a redundant write later.
(set-buffer-modified-p nil))))
;; Return whether an article is a member of a class.
(defun gnus-cache-member-of-class (class ticked dormant unread)
(or (and ticked (memq 'ticked class))
(and dormant (memq 'dormant class))
(and unread (memq 'unread class))
(and (not unread) (memq 'read class))))
(and (not unread) (not ticked) (not dormant) (memq 'read class))))
(defun gnus-cache-file-name (group article)
(concat (file-name-as-directory gnus-cache-directory)
(if (gnus-use-long-file-name 'not-cache)
group
(let ((group (concat group "")))
(if (string-match ":" group)
(aset group (match-beginning 0) ?/))
(gnus-replace-chars-in-string group ?. ?/)))
"/" (if (stringp article) article (int-to-string article))))
(file-name-as-directory
(if (gnus-use-long-file-name 'not-cache)
group
(let ((group (concat group "")))
(if (string-match ":" group)
(aset group (match-beginning 0) ?/))
(nnheader-replace-chars-in-string group ?. ?/))))
(if (stringp article) article (int-to-string article))))
(defun gnus-cache-possibly-enter-article
(group article headers ticked dormant unread)
(let ((number (mail-header-number headers))
file dir)
(if (or (not (vectorp headers)) ; This might be a dummy article.
(< number 0) ; Reffed article from other group.
(not (gnus-cache-member-of-class
gnus-cache-enter-articles ticked dormant unread))
(file-exists-p (setq file (gnus-cache-file-name group article))))
() ; Do nothing.
;; Possibly create the cache directory.
(or (file-exists-p (setq dir (file-name-directory file)))
(gnus-make-directory dir))
;; Save the article in the cache.
(if (file-exists-p file)
t ; The article already is saved, so we end here.
(let ((gnus-use-cache nil))
(gnus-summary-select-article))
(save-excursion
(set-buffer gnus-article-buffer)
(save-restriction
(widen)
(write-region (point-min) (point-max) file nil 'quiet))
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-max))
(forward-line -1)
(while (condition-case ()
(and (not (bobp))
(> (read (current-buffer)) number))
(error
;; The line was malformed, so we just remove it!!
(gnus-delete-line)
t))
(forward-line -1))
(if (bobp)
(if (not (eobp))
(progn
(beginning-of-line)
(if (< (read (current-buffer)) number)
(forward-line 1)))
(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) ""))))
t))))
(defun gnus-cache-update-article (group article)
"If ARTICLE is in the cache, remove it and re-enter it."
(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)
nil nil nil t))))
(defun gnus-cache-enter-remove-article (article)
(setq gnus-cache-removable-articles
(cons article gnus-cache-removable-articles)))
(defsubst gnus-cache-possibly-remove-article
(article ticked dormant unread)
(let ((file (gnus-cache-file-name gnus-newsgroup-name article)))
(if (or (not (file-exists-p file))
(not (gnus-cache-member-of-class
gnus-cache-remove-articles ticked dormant unread)))
nil
(defun gnus-cache-possibly-remove-article (article ticked dormant unread
&optional force)
"Possibly remove ARTICLE from the cache."
(let ((group gnus-newsgroup-name)
(number article)
file)
;; 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))))
(setq file (gnus-cache-file-name group number))
(when (and (file-exists-p file)
(or force
(gnus-cache-member-of-class
gnus-cache-remove-articles ticked dormant unread)))
(save-excursion
(delete-file file)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-min))
(if (or (looking-at (concat (int-to-string article) "\t"))
(search-forward (concat "\n" (int-to-string article) "\t")
(if (or (looking-at (concat (int-to-string number) "\t"))
(search-forward (concat "\n" (int-to-string number) "\t")
(point-max) t))
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))))))
(defun gnus-cache-possibly-remove-articles ()
(let ((articles gnus-cache-removable-articles)
(cache-articles (gnus-cache-articles-in-group gnus-newsgroup-name))
article)
(gnus-cache-change-buffer gnus-newsgroup-name)
(while articles
(setq article (car articles)
articles (cdr articles))
(if (memq article cache-articles)
;; The article was in the cache, so we see whether we are
;; supposed to remove it from the cache.
(gnus-cache-possibly-remove-article
article (memq article gnus-newsgroup-marked)
(memq article gnus-newsgroup-dormant)
(or (memq article gnus-newsgroup-unreads)
(memq article gnus-newsgroup-unselected))))))
;; the overview file might have been modified, save it
;; safe because we're only called at group exit anyway
(gnus-cache-save-buffers))
(defun gnus-cache-request-article (article group)
(let ((file (gnus-cache-file-name group article)))
(if (not (file-exists-p file))
()
(erase-buffer)
;; There may be some overlays that we have to kill...
(insert "i")
(let ((overlays (overlays-at (point-min))))
(while overlays
(delete-overlay (car overlays))
(setq overlays (cdr overlays))))
(erase-buffer)
(insert-file-contents file)
(progn (forward-line 1) (point)))))
(setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached))
(gnus-summary-update-secondary-mark article)
t)))
(defun gnus-cache-articles-in-group (group)
"Return a sorted list of cached articles in GROUP."
(let ((dir (file-name-directory (gnus-cache-file-name group 1)))
articles)
(if (not (file-exists-p dir))
nil
(setq articles (directory-files dir nil "^[0-9]+$" t))
(if (not articles)
nil
(sort (mapcar (function (lambda (name)
(string-to-int name)))
articles)
'<)))))
(defun gnus-cache-active-articles (group)
(let ((articles (gnus-cache-articles-in-group group)))
(and articles
(cons (car articles) (gnus-last-element articles)))))
(defun gnus-cache-possibly-alter-active (group active)
(let ((cache-active (gnus-cache-active-articles group)))
(and cache-active (< (car cache-active) (car active))
(setcar active (car cache-active)))
(and cache-active (> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active)))))
(defun gnus-cache-retrieve-headers (articles group)
(let* ((cached (gnus-cache-articles-in-group group))
(articles (gnus-sorted-complement articles cached))
(cache-file (gnus-cache-file-name group ".overview"))
type)
(let ((gnus-use-cache nil))
(setq type (and articles (gnus-retrieve-headers articles group))))
(gnus-cache-save-buffers)
(save-excursion
(cond ((not (file-exists-p cache-file))
type)
((null type)
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-file-contents cache-file)
'nov)
((eq type 'nov)
(gnus-cache-braid-nov group cached)
type)
(t
(gnus-cache-braid-heads group cached)
type)))))
(when (file-exists-p dir)
(sort (mapcar (lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))
'<))))
(defun gnus-cache-braid-nov (group cached)
(let ((cache-buf (get-buffer-create " *gnus-cache*"))
@ -331,7 +473,9 @@
(erase-buffer)
(insert-file-contents (gnus-cache-file-name group (car cached)))
(goto-char (point-min))
(insert "220 " (int-to-string (car cached)) " Article retrieved.\n")
(insert "220 ")
(princ (car cached) (current-buffer))
(insert " Article retrieved.\n")
(search-forward "\n\n" nil 'move)
(delete-region (point) (point-max))
(forward-char -1)
@ -340,23 +484,132 @@
(setq cached (cdr cached)))
(kill-buffer cache-buf)))
;;;###autoload
(defun gnus-jog-cache ()
"Go through all groups and put the articles into the cache."
(interactive)
(let ((newsrc (cdr gnus-newsrc-alist))
(gnus-cache-enter-articles '(unread))
(gnus-mark-article-hook nil)
(let ((gnus-mark-article-hook nil)
(gnus-expert-user t)
(nnmail-spool-file nil)
(gnus-use-dribble-file nil)
(gnus-novice-user nil)
(gnus-large-newsgroup nil))
(while newsrc
(gnus-summary-read-group (car (car newsrc)))
(if (not (eq major-mode 'gnus-summary-mode))
()
(while gnus-newsgroup-unreads
(gnus-summary-select-article t t nil (car gnus-newsgroup-unreads))
(setq gnus-newsgroup-unreads (cdr gnus-newsgroup-unreads)))
(kill-buffer (current-buffer)))
(setq newsrc (cdr newsrc)))))
;; Start Gnus.
(gnus)
;; Go through all groups...
(gnus-group-mark-buffer)
(gnus-group-universal-argument
nil nil
(lambda ()
(gnus-summary-read-group nil nil t)
;; ... and enter the articles into the cache.
(when (eq major-mode 'gnus-summary-mode)
(gnus-uu-mark-buffer)
(gnus-cache-enter-article)
(kill-buffer (current-buffer)))))))
(defun gnus-cache-read-active (&optional force)
"Read the cache active file."
(unless (file-exists-p gnus-cache-directory)
(make-directory gnus-cache-directory t))
(if (not (and (file-exists-p gnus-cache-active-file)
(or force (not gnus-cache-active-hashtb))))
;; There is no active file, so we generate one.
(gnus-cache-generate-active)
;; We simply read the active file.
(save-excursion
(gnus-set-work-buffer)
(insert-file-contents gnus-cache-active-file)
(gnus-active-to-gnus-format
nil (setq gnus-cache-active-hashtb
(gnus-make-hashtable
(count-lines (point-min) (point-max)))))
(setq gnus-cache-active-altered nil))))
(defun gnus-cache-write-active (&optional force)
"Write the active hashtb to the active file."
(when (or force
(and gnus-cache-active-hashtb
gnus-cache-active-altered))
(save-excursion
(gnus-set-work-buffer)
(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-make-directory (file-name-directory gnus-cache-active-file))
(write-region
(point-min) (point-max) gnus-cache-active-file nil 'silent))
;; Mark the active hashtb as unaltered.
(setq gnus-cache-active-altered nil)))
(defun gnus-cache-update-active (group number &optional low)
"Update the upper bound of the active info of GROUP to NUMBER.
If LOW, update the lower bound instead."
(let ((active (gnus-gethash group gnus-cache-active-hashtb)))
(if (null active)
;; We just create a new active entry for this group.
(gnus-sethash group (cons number number) gnus-cache-active-hashtb)
;; Update the lower or upper bound.
(if low
(setcar active number)
(setcdr active number))
;; Mark the active hashtb as altered.
(setq gnus-cache-active-altered t))))
;;;###autoload
(defun gnus-cache-generate-active (&optional directory)
"Generate the cache active file."
(interactive)
(let* ((top (null directory))
(directory (expand-file-name (or directory gnus-cache-directory)))
(files (directory-files directory 'full))
(group
(if top
""
(string-match
(concat "^" (file-name-as-directory
(expand-file-name gnus-cache-directory)))
(directory-file-name directory))
(nnheader-replace-chars-in-string
(substring (directory-file-name directory) (match-end 0))
?/ ?.)))
nums alphs)
(when top
(gnus-message 5 "Generating the cache active file...")
(setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
;; Separate articles from all other files and directories.
(while files
(if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
(push (string-to-int (file-name-nondirectory (pop files))) nums)
(push (pop files) alphs)))
;; If we have nums, then this is probably a valid group.
(when (setq nums (sort nums '<))
(gnus-sethash group (cons (car nums) (gnus-last-element nums))
gnus-cache-active-hashtb))
;; Go through all the other files.
(while alphs
(when (and (file-directory-p (car alphs))
(not (string-match "^\\.\\.?$"
(file-name-nondirectory (car alphs)))))
;; We descend directories.
(gnus-cache-generate-active (car alphs)))
(setq alphs (cdr alphs)))
;; Write the new active file.
(when top
(gnus-cache-write-active t)
(gnus-message 5 "Generating the cache active file...done"))))
;;;###autoload
(defun gnus-cache-generate-nov-databases (dir)
"Generate NOV files recursively starting in DIR."
(interactive (list gnus-cache-directory))
(gnus-cache-close)
(let ((nnml-generate-active-function 'identity))
(nnml-generate-nov-databases-1 dir)))
(provide 'gnus-cache)

313
lisp/gnus-cite.el
View File

@ -1,6 +1,5 @@
;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: news, mail
@ -29,13 +28,19 @@
(require 'gnus)
(require 'gnus-msg)
(require 'gnus-ems)
(eval-when-compile (require 'cl))
(eval-and-compile
(autoload 'gnus-article-add-button "gnus-vis")
)
(autoload 'gnus-article-add-button "gnus-vis"))
;;; Customization:
(defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n"
"Format of cited text buttons.")
(defvar gnus-cited-lines-visible nil
"The number of lines of hidden cited text to remain visible.")
(defvar gnus-cite-parse-max-size 25000
"Maximum article size (in bytes) where parsing citations is allowed.
Set it to nil to parse all articles.")
@ -45,20 +50,20 @@ Set it to nil to parse all articles.")
"Regexp matching the longest possible citation prefix on a line.")
(defvar gnus-cite-max-prefix 20
"Maximal possible length for a citation prefix.")
"Maximum possible length for a citation prefix.")
(defvar gnus-supercite-regexp
(concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
">>>>> +\"\\([^\"\n]+\\)\" +==")
"Regexp matching normal SuperCite attribution lines.
The first regexp group should match a prefix added by another package.")
"Regexp matching normal Supercite attribution lines.
The first grouping must match prefixes added by other packages.")
(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
"Regexp matching mangled SuperCite attribution lines.
The first regexp group should match the SuperCite attribution.")
"Regexp matching mangled Supercite attribution lines.
The first regexp group should match the Supercite attribution.")
(defvar gnus-cite-minimum-match-count 2
"Minimal number of identical prefix'es before we believe it is a citation.")
"Minimum number of identical prefixes before we believe it's a citation.")
;see gnus-cus.el
;(defvar gnus-cite-face-list
@ -78,7 +83,7 @@ The first regexp group should match the SuperCite attribution.")
(defvar gnus-cite-attribution-prefix "in article\\|in <"
"Regexp matching the beginning of an attribution line.")
(defvar gnus-cite-attribution-postfix
(defvar gnus-cite-attribution-suffix
"\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
"Regexp matching the end of an attribution line.
The text matching the first grouping will be used as a button.")
@ -112,9 +117,7 @@ The text matching the first grouping will be used as a button.")
;;; Internal Variables:
(defvar gnus-article-length nil)
;; Length of article last time we parsed it.
;; BUG! KLUDGE! UGLY! FIX ME!
(defvar gnus-cite-article nil)
(defvar gnus-cite-prefix-alist nil)
;; Alist of citation prefixes.
@ -135,7 +138,13 @@ The text matching the first grouping will be used as a button.")
;; WROTE: is the attribution line number
;; IN: is the line number of the previous line if part of the same attribution,
;; PREFIX: Is the citation prefix of the attribution line(s), and
;; TAG: Is a SuperCite tag, if any.
;; TAG: Is a Supercite tag, if any.
(defvar gnus-cited-text-button-line-format-alist
`((?b beg ?d)
(?e end ?d)
(?l (- end beg) ?d)))
(defvar gnus-cited-text-button-line-format-spec nil)
;;; Commands:
@ -149,7 +158,7 @@ corresponding citation merged with `gnus-cite-attribution-face'.
Text is considered cited if at least `gnus-cite-minimum-match-count'
lines matches `gnus-cite-prefix-regexp' with the same prefix.
Lines matching `gnus-cite-attribution-postfix' and perhaps
Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
;; Create dark or light faces if necessary.
@ -193,7 +202,7 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
face (cdr (assoc prefix face-alist)))
;; Add attribution button.
(goto-line number)
(if (re-search-forward gnus-cite-attribution-postfix
(if (re-search-forward gnus-cite-attribution-suffix
(save-excursion (end-of-line 1) (point))
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
@ -210,76 +219,203 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
skip (gnus-cite-find-prefix number))
(gnus-cite-add-face number skip gnus-cite-attribution-face)))))
(defun gnus-article-hide-citation (&optional force)
"Hide all cited text except attribution lines.
See the documentation for `gnus-article-highlight-citation'."
(interactive (list 'force))
(defun gnus-dissect-cited-text ()
"Dissect the article buffer looking for cited text."
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
(alist gnus-cite-prefix-alist)
(inhibit-point-motion-hooks t)
numbers number)
(gnus-cite-parse-maybe)
(let ((alist gnus-cite-prefix-alist)
prefix numbers number marks m)
;; Loop through citation prefixes.
(while alist
(setq numbers (cdr (car alist))
alist (cdr alist))
(setq numbers (pop alist)
prefix (pop numbers))
(while numbers
(setq number (car numbers)
numbers (cdr numbers))
(goto-line number)
(or (assq number gnus-cite-attribution-alist)
(add-text-properties (point) (progn (forward-line 1) (point))
gnus-hidden-properties)))))))
(setq number (pop numbers))
(goto-char (point-min))
(forward-line number)
(push (cons (point-marker) "") marks)
(while (and numbers
(= (1- number) (car numbers)))
(setq number (pop numbers)))
(goto-char (point-min))
(forward-line (1- number))
(push (cons (point-marker) prefix) marks)))
(goto-char (point-min))
(search-forward "\n\n" nil t)
(push (cons (point-marker) "") marks)
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(push (cons (point-marker) "") marks)
(setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2)))))
(let* ((omarks marks))
(setq marks nil)
(while (cdr omarks)
(if (= (caar omarks) (caadr omarks))
(progn
(unless (equal (cdar omarks) "")
(push (car omarks) marks))
(unless (equal (cdadr omarks) "")
(push (cadr omarks) marks))
(setq omarks (cdr omarks)))
(push (car omarks) marks))
(setq omarks (cdr omarks)))
(when (car omarks)
(push (car omarks) marks))
(setq marks (setq m (nreverse marks)))
(while (cddr m)
(if (and (equal (cdadr m) "")
(equal (cdar m) (cdaddr m))
(goto-char (caadr m))
(forward-line 1)
(= (point) (caaddr m)))
(setcdr m (cdddr m))
(setq m (cdr m))))
marks))))
(defun gnus-article-hide-citation-maybe (&optional force)
"Hide cited text that has an attribution line.
(defun gnus-article-fill-cited-article (&optional force)
"Do word wrapping in the current article."
(interactive (list t))
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
(marks (gnus-dissect-cited-text))
(adaptive-fill-mode nil))
(save-restriction
(while (cdr marks)
(widen)
(narrow-to-region (caar marks) (caadr marks))
(let ((adaptive-fill-regexp
(concat "^" (regexp-quote (cdar marks)) " *"))
(fill-prefix (cdar marks)))
(fill-region (point-min) (point-max)))
(set-marker (caar marks) nil)
(setq marks (cdr marks)))
(when marks
(set-marker (caar marks) nil))))))
(defun gnus-article-hide-citation (&optional arg force)
"Toggle hiding of all cited text except attribution lines.
See the documentation for `gnus-article-highlight-citation'.
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (append (gnus-hidden-arg) (list 'force)))
(setq gnus-cited-text-button-line-format-spec
(gnus-parse-format gnus-cited-text-button-line-format
gnus-cited-text-button-line-format-alist t))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(marks (gnus-dissect-cited-text))
(inhibit-point-motion-hooks t)
(props (nconc (list 'gnus-type 'cite)
gnus-hidden-properties))
beg end)
(while marks
(setq beg nil
end nil)
(while (and marks (string= (cdar marks) ""))
(setq marks (cdr marks)))
(when marks
(setq beg (caar marks)))
(while (and marks (not (string= (cdar marks) "")))
(setq marks (cdr marks)))
(when marks
(setq end (caar marks)))
;; 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)
(if (>= (point) end)
(setq beg nil)
(setq beg (point-marker))))
(when (and beg end)
(gnus-add-text-properties beg end props)
(goto-char beg)
(unless (save-excursion (search-backward "\n\n" nil t))
(insert "\n"))
(gnus-article-add-button
(point)
(progn (eval gnus-cited-text-button-line-format-spec) (point))
`gnus-article-toggle-cited-text (cons beg end))
(set-marker beg (point))))))))
(defun gnus-article-toggle-cited-text (region)
"Toggle hiding the text in REGION."
(let (buffer-read-only)
(funcall
(if (text-property-any
(car region) (1- (cdr region))
(car gnus-hidden-properties) (cadr gnus-hidden-properties))
'remove-text-properties 'gnus-add-text-properties)
(car region) (cdr region) gnus-hidden-properties)))
(defun gnus-article-hide-citation-maybe (&optional arg force)
"Toggle hiding of cited text that has an attribution line.
If given a negative prefix, always show; if given a positive prefix,
always hide.
This will do nothing unless at least `gnus-cite-hide-percentage'
percent and at least `gnus-cite-hide-absolute' lines of the body is
cited text with attributions. When called interactively, these two
variables are ignored.
See also the documentation for `gnus-article-highlight-citation'."
(interactive (list 'force))
(interactive (append (gnus-hidden-arg) (list 'force)))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(let ((start (point))
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
(inhibit-point-motion-hooks t)
(hiden 0)
total)
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(setq total (count-lines start (point)))
(while atts
(setq hiden (+ hiden (length (cdr (assoc (cdar atts)
gnus-cite-prefix-alist))))
atts (cdr atts)))
(if (or force
(and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
(> hiden gnus-cite-hide-absolute)))
(progn
(setq atts gnus-cite-attribution-alist)
(while atts
(setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
atts (cdr atts))
(while total
(setq hiden (car total)
total (cdr total))
(goto-line hiden)
(or (assq hiden gnus-cite-attribution-alist)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'gnus-type 'cite)
gnus-hidden-properties)))))))))))
(defun gnus-article-hide-citation-in-followups ()
"Hide cited text in non-root articles."
(interactive)
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(let ((start (point))
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
(inhibit-point-motion-hooks t)
(hiden 0)
total)
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(setq total (count-lines start (point)))
(while atts
(setq hiden (+ hiden (length (cdr (assoc (cdr (car atts))
gnus-cite-prefix-alist))))
atts (cdr atts)))
(if (or force
(and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
(> hiden gnus-cite-hide-absolute)))
(progn
(setq atts gnus-cite-attribution-alist)
(while atts
(setq total (cdr (assoc (cdr (car atts)) gnus-cite-prefix-alist))
atts (cdr atts))
(while total
(setq hiden (car total)
total (cdr total))
(goto-line hiden)
(or (assq hiden gnus-cite-attribution-alist)
(add-text-properties (point)
(progn (forward-line 1) (point))
gnus-hidden-properties)))))))))
(let ((article (cdr gnus-article-current)))
(unless (save-excursion
(set-buffer gnus-summary-buffer)
(gnus-article-displayed-root-p article))
(gnus-article-hide-citation)))))
;;; Internal functions:
(defun gnus-cite-parse-maybe (&optional force)
;; Parse if the buffer has changes since last time.
(if (eq gnus-article-length (- (point-max) (point-min)))
(if (equal gnus-cite-article gnus-article-current)
()
;;Reset parser information.
(setq gnus-cite-prefix-alist nil
@ -291,7 +427,8 @@ See also the documentation for `gnus-article-highlight-citation'."
gnus-cite-parse-max-size
(> (buffer-size) gnus-cite-parse-max-size))
()
(setq gnus-article-length (- (point-max) (point-min)))
(setq gnus-cite-article (cons (car gnus-article-current)
(cdr gnus-article-current)))
(gnus-cite-parse))))
(defun gnus-cite-parse ()
@ -315,7 +452,7 @@ See also the documentation for `gnus-article-highlight-citation'."
end (progn (beginning-of-line 2) (point))
start end)
(goto-char begin)
;; Ignore standard SuperCite attribution prefix.
;; Ignore standard Supercite attribution prefix.
(if (looking-at gnus-supercite-regexp)
(if (match-end 1)
(setq end (1+ (match-end 1)))
@ -327,7 +464,7 @@ See also the documentation for `gnus-article-highlight-citation'."
;; Each prefix.
(setq end (match-end 0)
prefix (buffer-substring begin end))
(set-text-properties 0 (length prefix) nil prefix)
(gnus-set-text-properties 0 (length prefix) nil prefix)
(setq entry (assoc prefix alist))
(if entry
(setcdr entry (cons line (cdr entry)))
@ -374,7 +511,7 @@ See also the documentation for `gnus-article-highlight-citation'."
;; Parse current buffer searching for attribution lines.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(while (re-search-forward gnus-cite-attribution-postfix (point-max) t)
(while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
(let* ((start (match-beginning 0))
(end (match-end 0))
(wrote (count-lines (point-min) end))
@ -392,7 +529,7 @@ See also the documentation for `gnus-article-highlight-citation'."
(beginning-of-line 0)
(point))
t)
(not (re-search-forward gnus-cite-attribution-postfix
(not (re-search-forward gnus-cite-attribution-suffix
start t))
(count-lines (point-min) (1+ (point)))))))
(if (eq wrote in)
@ -463,7 +600,7 @@ See also the documentation for `gnus-article-highlight-citation'."
;;
;; WROTE is the attribution line number.
;; PREFIX is the attribution line prefix.
;; TAG is the SuperCite tag on the attribution line.
;; TAG is the Supercite tag on the attribution line.
(let ((atts gnus-cite-loose-attribution-alist)
(case-fold-search t)
att wrote in prefix tag regexp limit smallest best size)
@ -536,18 +673,19 @@ See also the documentation for `gnus-article-highlight-citation'."
(defun gnus-cite-add-face (number prefix face)
;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
(if face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(when face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(unless (eobp) ;; Sometimes things become confused.
(forward-char (length prefix))
(skip-chars-forward " \t")
(setq from (point))
(end-of-line 1)
(skip-chars-backward " \t")
(setq to (point))
(if (< from to)
(gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
(when (< from to)
(gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
(defun gnus-cite-toggle (prefix)
(save-excursion
@ -565,8 +703,10 @@ See also the documentation for `gnus-article-highlight-citation'."
gnus-hidden-properties))
((assq number gnus-cite-attribution-alist))
(t
(add-text-properties (point) (progn (forward-line 1) (point))
gnus-hidden-properties)))))))
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'gnus-type 'cite)
gnus-hidden-properties))))))))
(defun gnus-cite-find-prefix (line)
;; Return citation prefix for LINE.
@ -580,6 +720,11 @@ See also the documentation for `gnus-article-highlight-citation'."
(setq prefix (car entry))))
prefix))
(gnus-add-shutdown 'gnus-cache-close 'gnus)
(defun gnus-cache-close ()
(setq gnus-cite-prefix-alist nil))
(gnus-ems-redefine)
(provide 'gnus-cite)

830
lisp/gnus-cus.el
View File

@ -1,7 +1,6 @@
;;; gnus-cus.el --- User friendly customization of Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: help, news
;; Version: 0.1
@ -29,12 +28,14 @@
(require 'custom)
(require 'gnus-ems)
(require 'browse-url)
(eval-when-compile (require 'cl))
;; The following is just helper functions and data, not ment to be set
;; The following is just helper functions and data, not meant to be set
;; by the user.
(defun gnus-make-face (color)
;; Create entry for face with COLOR.
(custom-face-lookup color nil nil 'custom:asis 'custom:asis 'custom:asis))
(custom-face-lookup color nil nil nil nil nil))
(defvar gnus-face-light-name-list
'("light blue" "light cyan" "light yellow" "light pink"
@ -42,84 +43,107 @@
"turquoise"))
(defvar gnus-face-dark-name-list
'("RoyalBlue" "firebrick"
"dark green" "OrangeRed" "dark khaki" "dark violet"
"SteelBlue4"))
'("dark blue" "firebrick" "dark green" "OrangeRed"
"dark khaki" "dark violet" "SteelBlue4"))
; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3
; DarkOlviveGreen4
(custom-declare '()
'((tag . "GNUS")
'((tag . "Gnus")
(doc . "\
The coffee-brewing, all singing, all dancing, kitchen sink newsreader.")
(type . group)
(data ((tag . "Visual")
(doc . "\
GNUS can be made colorful and fun or grey and dull as you wish.")
(type . group)
(data ((tag . "Visual")
(doc . "Enable visual features.
(data
((tag . "Visual")
(doc . "\
Gnus can be made colorful and fun or grey and dull as you wish.")
(type . group)
(data
((tag . "Visual")
(doc . "Enable visual features.
If `visual' is disabled, there will be no menus and few faces. Most of
the visual customization options below will be ignored. GNUS will use
the visual customization options below will be ignored. Gnus will use
less space and be faster as a result.")
(default . t)
(name . gnus-visual)
(type . toggle))
((tag . "WWW Browser")
(doc . "\
(default .
(summary-highlight group-highlight
article-highlight
mouse-face
summary-menu group-menu article-menu
tree-highlight menu highlight
browse-menu server-menu
page-marker tree-menu binary-menu pick-menu
grouplens-menu))
(name . gnus-visual)
(type . sexp))
((tag . "WWW Browser")
(doc . "\
WWW Browser to call when clicking on an URL button in the article buffer.
You can choose between one of the predefined browsers, or `Other'.")
(name . gnus-button-url)
(calculate . (cond ((boundp 'browse-url-browser-function)
browse-url-browser-function)
((fboundp 'w3-fetch)
'w3-fetch)
((eq window-system 'x)
'gnus-netscape-open-url)))
(type . choice)
(data ((tag . "W3")
(type . const)
(default . w3-fetch))
((tag . "Netscape")
(type . const)
(default . gnus-netscape-open-url))
((prompt . "Other")
(doc . "\
(name . browse-url-browser-function)
(calculate . (cond ((boundp 'browse-url-browser-function)
browse-url-browser-function)
((fboundp 'w3-fetch)
'w3-fetch)
((eq window-system 'x)
'gnus-netscape-open-url)))
(type . choice)
(data
((tag . "W3")
(type . const)
(default . w3-fetch))
((tag . "Netscape")
(type . const)
(default . browse-url-netscape))
((prompt . "Other")
(doc . "\
You must specify the name of a Lisp function here. The lisp function
should open a WWW browser when called with an URL (a string).
")
(default . __uninitialized__)
(type . symbol))))
((tag . "Mouse Face")
(doc . "\
(default . __uninitialized__)
(type . symbol))))
((tag . "Mouse Face")
(doc . "\
Face used for group or summary buffer mouse highlighting.
The line beneath the mouse pointer will be highlighted with this
face.")
(name . gnus-mouse-face)
(calculate . (if (boundp 'gnus-mouse-face)
gnus-mouse-face
'highlight))
(type . face))
((tag . "Article Display")
(doc . "Controls how the article buffer will look.
(name . gnus-mouse-face)
(calculate . (if (gnus-visual-p 'mouse-face 'highlight)
(if (boundp 'gnus-mouse-face)
gnus-mouse-face
'highlight)
'default))
(type . face))
((tag . "Article Display")
(doc . "Controls how the article buffer will look.
The list below contains various filters you can use to change the look
of the article. 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.")
(name . gnus-article-display-hook)
(type . list)
(default . (gnus-article-hide-headers-if-wanted
gnus-article-treat-overstrike
gnus-article-maybe-highlight))
(data ((type . repeat)
(header . nil)
(data (tag . "Filter")
(type . choice)
(data ((tag . "Treat Overstrike")
(doc . "\
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.")
(name . gnus-article-display-hook)
(type . list)
(calculate
. (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)))
(data
((type . repeat)
(header . nil)
(data
(tag . "Filter")
(type . choice)
(data
((tag . "Treat Overstrike")
(doc . "\
Convert use of overstrike into bold and underline.
Two identical letters separated by a backspace are displayed as a
@ -129,178 +153,178 @@ technique was developed for old line printers (think about it), and is
still in use on some newsgroups, in particular the ClariNet
hierarchy.
")
(type . const)
(default .
gnus-article-treat-overstrike))
((tag . "Word Wrap")
(doc . "\
(type . const)
(default .
gnus-article-treat-overstrike))
((tag . "Word Wrap")
(doc . "\
Format too long lines.
")
(type . const)
(default . gnus-article-word-wrap))
((tag . "Remove CR")
(doc . "\
(type . const)
(default . gnus-article-word-wrap))
((tag . "Remove CR")
(doc . "\
Remove carriage returns from an article.
")
(type . const)
(default . gnus-article-remove-cr))
((tag . "Display X-Face")
(doc . "\
(type . const)
(default . gnus-article-remove-cr))
((tag . "Display X-Face")
(doc . "\
Look for an X-Face header and display it if present.
See also `X Face Command' for a definition of the external command
used for decoding and displaying the face.
")
(type . const)
(default . gnus-article-display-x-face))
((tag . "Unquote Printable")
(doc . "\
(type . const)
(default . gnus-article-display-x-face))
((tag . "Unquote Printable")
(doc . "\
Transform MIME quoted printable into 8-bit characters.
Quoted printable is often seen by strings like `=EF' where you would
expect a non-English letter.
")
(type . const)
(default .
gnus-article-de-quoted-unreadable))
((tag . "Universal Time")
(doc . "\
(type . const)
(default .
gnus-article-de-quoted-unreadable))
((tag . "Universal Time")
(doc . "\
Convert date header to universal time.
")
(type . const)
(default . gnus-article-date-ut))
((tag . "Local Time")
(doc . "\
(type . const)
(default . gnus-article-date-ut))
((tag . "Local Time")
(doc . "\
Convert date header to local timezone.
")
(type . const)
(default . gnus-article-date-local))
((tag . "Lapsed Time")
(doc . "\
(type . const)
(default . gnus-article-date-local))
((tag . "Lapsed Time")
(doc . "\
Replace date header with a header showing the articles age.
")
(type . const)
(default . gnus-article-date-lapsed))
((tag . "Highlight")
(doc . "\
(type . const)
(default . gnus-article-date-lapsed))
((tag . "Highlight")
(doc . "\
Highlight headers, citations, signature, and buttons.
")
(type . const)
(default . gnus-article-highlight))
((tag . "Maybe Highlight")
(doc . "\
(type . const)
(default . gnus-article-highlight))
((tag . "Maybe Highlight")
(doc . "\
Highlight headers, signature, and buttons if `Visual' is turned on.
")
(type . const)
(default .
gnus-article-maybe-highlight))
((tag . "Highlight Some")
(doc . "\
(type . const)
(default .
gnus-article-maybe-highlight))
((tag . "Highlight Some")
(doc . "\
Highlight headers, signature, and buttons.
")
(type . const)
(default . gnus-article-highlight-some))
((tag . "Highlight Headers")
(doc . "\
(type . const)
(default . gnus-article-highlight-some))
((tag . "Highlight Headers")
(doc . "\
Highlight headers as specified by `Article Header Highlighting'.
")
(type . const)
(default .
gnus-article-highlight-headers))
((tag . "Highlight Signature")
(doc . "\
(type . const)
(default .
gnus-article-highlight-headers))
((tag . "Highlight Signature")
(doc . "\
Highlight the signature as specified by `Article Signature Face'.
")
(type . const)
(default .
gnus-article-highlight-signature))
((tag . "Citation")
(doc . "\
(type . const)
(default .
gnus-article-highlight-signature))
((tag . "Citation")
(doc . "\
Highlight the citations as specified by `Citation Faces'.
")
(type . const)
(default .
gnus-article-highlight-citation))
((tag . "Hide")
(doc . "\
(type . const)
(default .
gnus-article-highlight-citation))
((tag . "Hide")
(doc . "\
Hide unwanted headers, excess citation, and the signature.
")
(type . const)
(default . gnus-article-hide))
((tag . "Hide Headers If Wanted")
(doc . "\
(type . const)
(default . gnus-article-hide))
((tag . "Hide Headers If Wanted")
(doc . "\
Hide headers, but allow user to display them with `t' or `v'.
")
(type . const)
(default .
gnus-article-hide-headers-if-wanted))
((tag . "Hide Headers")
(doc . "\
(type . const)
(default .
gnus-article-hide-headers-if-wanted))
((tag . "Hide Headers")
(doc . "\
Hide unwanted headers and possibly sort them as well.
Most likely you want to use `Hide Headers If Wanted' instead.
")
(type . const)
(default . gnus-article-hide-headers))
((tag . "Hide Signature")
(doc . "\
(type . const)
(default . gnus-article-hide-headers))
((tag . "Hide Signature")
(doc . "\
Hide the signature.
")
(type . const)
(default . gnus-article-hide-signature))
((tag . "Hide Excess Citations")
(doc . "\
(type . const)
(default . gnus-article-hide-signature))
((tag . "Hide Excess Citations")
(doc . "\
Hide excess citation.
Excess is defined by `Citation Hide Percentage' and `Citation Hide Absolute'.
")
(type . const)
(default .
gnus-article-hide-citation-maybe))
((tag . "Hide Citations")
(doc . "\
(type . const)
(default .
gnus-article-hide-citation-maybe))
((tag . "Hide Citations")
(doc . "\
Hide all cited text.
")
(type . const)
(default . gnus-article-hide-citation))
((tag . "Add Buttons")
(doc . "\
(type . const)
(default . gnus-article-hide-citation))
((tag . "Add Buttons")
(doc . "\
Make URL's into clickable buttons.
")
(type . const)
(default . gnus-article-add-buttons))
((prompt . "Other")
(doc . "\
(type . const)
(default . gnus-article-add-buttons))
((prompt . "Other")
(doc . "\
Name of Lisp function to call.
Push the `Filter' button to select one of the predefined filters.
")
(type . symbol)))))))
((tag . "Article Button Face")
(doc . "\
(type . symbol)))))))
((tag . "Article Button Face")
(doc . "\
Face used for highlighting buttons in the article buffer.
An article button is a piece of text that you can activate by pressing
`RET' or `mouse-2' above it.")
(name . gnus-article-button-face)
(default . bold)
(type . face))
((tag . "Article Mouse Face")
(doc . "\
(name . gnus-article-button-face)
(default . bold)
(type . face))
((tag . "Article Mouse Face")
(doc . "\
Face used for mouse highlighting in the article buffer.
Article buttons will be displayed in this face when the cursor is
above them.")
(name . gnus-article-mouse-face)
(default . highlight)
(type . face))
((tag . "Article Signature Face")
(doc . "\
(name . gnus-article-mouse-face)
(default . highlight)
(type . face))
((tag . "Article Signature Face")
(doc . "\
Face used for highlighting a signature in the article buffer.")
(name . gnus-signature-face)
(default . italic)
(type . face))
((tag . "Article Header Highlighting")
(doc . "\
(name . gnus-signature-face)
(default . italic)
(type . face))
((tag . "Article Header Highlighting")
(doc . "\
Controls highlighting of article header.
Below is a list of article header names, and the faces used for
@ -322,110 +346,106 @@ If you only want to change the display of the name part for a specific
header, specify `None' in the `Content' field. Similarly, specify
`None' in the `Name' field if you only want to leave the name part
alone.")
(name . gnus-header-face-alist)
(type . list)
(calculate . (cond ((not (eq gnus-display-type 'color))
'(("" bold italic)))
((eq gnus-background-mode 'dark)
(list (list "From" nil
(custom-face-lookup
"dark blue" nil nil t t
'custom:asis))
(list "Subject" nil
(custom-face-lookup
"pink" nil nil t t 'custom:asis))
(list "Newsgroups:.*," nil
(custom-face-lookup
"yellow" nil nil t t 'custom:asis))
(list ""
(custom-face-lookup
"cyan" nil nil t 'custom:asis 'custom:asis)
(custom-face-lookup
"forestgreen"
nil nil 'custom:asis t 'custom:asis))))
(t
(list (list "From" nil
(custom-face-lookup
"RoyalBlue"
nil nil t t 'custom:asis))
(list "Subject" nil
(custom-face-lookup
"firebrick"
nil nil t t 'custom:asis))
(list "Newsgroups:.*," nil
(custom-face-lookup
"indianred" nil nil t t 'custom:asis))
(list ""
(custom-face-lookup
"DarkGreen"
nil nil t 'custom:asis 'custom:asis)
(custom-face-lookup
"DarkGreen"
nil nil nil t 'custom:asis))))))
(data ((type . repeat)
(header . nil)
(data (type . list)
(compact . t)
(data ((type . string)
(prompt . "Header")
(tag . "Header "))
"\n "
((type . face)
(prompt . "Name")
(tag . "Name "))
"\n "
((type . face)
(tag . "Content"))
"\n")))))
((tag . "Attribution Face")
(doc . "\
(name . gnus-header-face-alist)
(type . list)
(calculate
. (cond
((not (eq gnus-display-type 'color))
'(("" bold italic)))
((eq gnus-background-mode 'dark)
(list
(list "From" nil
(custom-face-lookup "light blue" nil nil t t nil))
(list "Subject" nil
(custom-face-lookup "pink" nil nil t t nil))
(list "Newsgroups:.*," nil
(custom-face-lookup "yellow" nil nil t t nil))
(list
""
(custom-face-lookup "cyan" nil nil t nil nil)
(custom-face-lookup "forestgreen" nil nil nil t
nil))))
(t
(list
(list "From" nil
(custom-face-lookup "MidnightBlue" nil nil t t nil))
(list "Subject" nil
(custom-face-lookup "firebrick" nil nil t t nil))
(list "Newsgroups:.*," nil
(custom-face-lookup "indianred" nil nil t t nil))
(list ""
(custom-face-lookup
"DarkGreen" nil nil t nil nil)
(custom-face-lookup "DarkGreen" nil nil
nil t nil))))))
(data
((type . repeat)
(header . nil)
(data
(type . list)
(compact . t)
(data
((type . string)
(prompt . "Header")
(tag . "Header "))
"\n "
((type . face)
(prompt . "Name")
(tag . "Name "))
"\n "
((type . face)
(tag . "Content"))
"\n")))))
((tag . "Attribution Face")
(doc . "\
Face used for attribution lines.
It is merged with the face for the cited text belonging to the attribution.")
(name . gnus-cite-attribution-face)
(default . underline)
(type . face))
((tag . "Citation Faces")
(doc . "\
(name . gnus-cite-attribution-face)
(default . underline)
(type . face))
((tag . "Citation Faces")
(doc . "\
List of faces used for highlighting citations.
When there are citations from multiple articles in the same message,
Gnus will try to give each citation from each article its own face.
This should make it easier to see who wrote what.")
(name . gnus-cite-face-list)
(import . gnus-custom-import-cite-face-list)
(type . list)
(calculate . (cond ((not (eq gnus-display-type 'color))
'(italic))
((eq gnus-background-mode 'dark)
(mapcar 'gnus-make-face
gnus-face-light-name-list))
(t
(mapcar 'gnus-make-face
gnus-face-dark-name-list))))
(data ((type . repeat)
(header . nil)
(data (type . face)
(tag . "Face")))))
((tag . "Citation Hide Percentage")
(doc . "\
(name . gnus-cite-face-list)
(import . gnus-custom-import-cite-face-list)
(type . list)
(calculate . (cond ((not (eq gnus-display-type 'color))
'(italic))
((eq gnus-background-mode 'dark)
(mapcar 'gnus-make-face
gnus-face-light-name-list))
(t
(mapcar 'gnus-make-face
gnus-face-dark-name-list))))
(data
((type . repeat)
(header . nil)
(data (type . face)
(tag . "Face")))))
((tag . "Citation Hide Percentage")
(doc . "\
Only hide excess citation if above this percentage of the body.")
(name . gnus-cite-hide-percentage)
(default . 50)
(type . integer))
((tag . "Citation Hide Absolute")
(doc . "\
(name . gnus-cite-hide-percentage)
(default . 50)
(type . integer))
((tag . "Citation Hide Absolute")
(doc . "\
Only hide excess citation if above this number of lines in the body.")
(name . gnus-cite-hide-absolute)
(default . 10)
(type . integer))
((tag . "Summary Selected Face")
(doc . "\
(name . gnus-cite-hide-absolute)
(default . 10)
(type . integer))
((tag . "Summary Selected Face")
(doc . "\
Face used for highlighting the current article in the summary buffer.")
(name . gnus-summary-selected-face)
(default . underline)
(type . face))
((tag . "Summary Line Highlighting")
(doc . "\
(name . gnus-summary-selected-face)
(default . underline)
(type . face))
((tag . "Summary Line Highlighting")
(doc . "\
Controls the highlighting of summary buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
@ -443,87 +463,199 @@ score: The article's score
default: The default article score.
below: The score below which articles are automatically marked as read.
mark: The article's mark.")
(name . gnus-summary-highlight)
(type . list)
(calculate . (cond ((not (eq gnus-display-type 'color))
'(((> score default) . bold)
((< score default) . italic)))
((eq gnus-background-mode 'dark)
(list (cons '(= mark gnus-canceled-mark)
(custom-face-lookup "yellow" "black" nil 'custom:asis 'custom:asis 'custom:asis))
(cons '(and (> score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "pink" nil nil t 'custom:asis 'custom:asis))
(cons '(and (< score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "pink" nil nil 'custom:asis t 'custom:asis))
(cons '(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark))
(custom-face-lookup "pink" nil nil 'custom:asis 'custom:asis 'custom:asis))
(name . gnus-summary-highlight)
(type . list)
(calculate
. (cond
((not (eq gnus-display-type 'color))
'(((> score default) . bold)
((< score default) . italic)))
((eq gnus-background-mode 'dark)
(list
(cons
'(= mark gnus-canceled-mark)
(custom-face-lookup "yellow" "black" nil
nil nil nil))
(cons '(and (> score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup
"pink" nil nil t nil nil))
(cons '(and (< score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "pink" nil nil
nil t nil))
(cons '(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark))
(custom-face-lookup
"pink" nil nil nil nil nil))
(cons '(and (> score default) (= mark gnus-ancient-mark))
(custom-face-lookup "dark blue" nil nil t 'custom:asis 'custom:asis))
(cons '(and (< score default) (= mark gnus-ancient-mark))
(custom-face-lookup "SkyBlue" nil nil 'custom:asis t 'custom:asis))
(cons '(= mark gnus-ancient-mark)
(custom-face-lookup "SkyBlue" nil nil 'custom:asis 'custom:asis 'custom:asis))
(cons
'(and (> score default) (= mark gnus-ancient-mark))
(custom-face-lookup "medium blue" nil nil t
nil nil))
(cons
'(and (< score default) (= mark gnus-ancient-mark))
(custom-face-lookup "SkyBlue" nil nil
nil t nil))
(cons
'(= mark gnus-ancient-mark)
(custom-face-lookup "SkyBlue" nil nil
nil nil nil))
(cons '(and (> score default) (= mark gnus-unread-mark))
(custom-face-lookup "white" nil nil t
nil nil))
(cons '(and (< score default) (= mark gnus-unread-mark))
(custom-face-lookup "white" nil nil
nil t nil))
(cons '(= mark gnus-unread-mark)
(custom-face-lookup
"white" nil nil nil nil nil))
(cons '(and (> score default) (= mark gnus-unread-mark))
(custom-face-lookup "white" nil nil t 'custom:asis 'custom:asis))
(cons '(and (< score default) (= mark gnus-unread-mark))
(custom-face-lookup "white" nil nil 'custom:asis t 'custom:asis))
(cons '(= mark gnus-unread-mark)
(custom-face-lookup "white" nil nil 'custom:asis 'custom:asis 'custom:asis))
(cons '(> score default) 'bold)
(cons '(< score default) 'italic)))
(t
(list
(cons
'(= mark gnus-canceled-mark)
(custom-face-lookup
"yellow" "black" nil nil nil nil))
(cons '(and (> score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "firebrick" nil nil
t nil nil))
(cons '(and (< score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "firebrick" nil nil
nil t nil))
(cons
'(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark))
(custom-face-lookup
"firebrick" nil nil nil nil nil))
(cons '(> score default) 'bold)
(cons '(< score default) 'italic)))
(t
(list (cons '(= mark gnus-canceled-mark)
(custom-face-lookup "yellow" "black" nil 'custom:asis 'custom:asis 'custom:asis))
(cons '(and (> score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "firebrick" nil nil t 'custom:asis 'custom:asis))
(cons '(and (< score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "firebrick" nil nil 'custom:asis t 'custom:asis))
(cons '(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark))
(custom-face-lookup "firebrick" nil nil 'custom:asis 'custom:asis 'custom:asis))
(cons '(and (> score default) (= mark gnus-ancient-mark))
(custom-face-lookup "RoyalBlue" nil nil
t nil nil))
(cons '(and (< score default) (= mark gnus-ancient-mark))
(custom-face-lookup "RoyalBlue" nil nil
nil t nil))
(cons
'(= mark gnus-ancient-mark)
(custom-face-lookup
"RoyalBlue" nil nil nil nil nil))
(cons '(and (> score default) (= mark gnus-ancient-mark))
(custom-face-lookup "RoyalBlue" nil nil t 'custom:asis 'custom:asis))
(cons '(and (< score default) (= mark gnus-ancient-mark))
(custom-face-lookup "RoyalBlue" nil nil 'custom:asis t 'custom:asis))
(cons '(= mark gnus-ancient-mark)
(custom-face-lookup "RoyalBlue" nil nil 'custom:asis 'custom:asis 'custom:asis))
(cons '(and (> score default) (/= mark gnus-unread-mark))
(custom-face-lookup "DarkGreen" nil nil
t nil nil))
(cons '(and (< score default) (/= mark gnus-unread-mark))
(custom-face-lookup "DarkGreen" nil nil
nil t nil))
(cons
'(/= mark gnus-unread-mark)
(custom-face-lookup "DarkGreen" nil nil
nil nil nil))
(cons '(and (> score default) (/= mark gnus-unread-mark))
(custom-face-lookup "DarkGreen" nil nil t 'custom:asis 'custom:asis))
(cons '(and (< score default) (/= mark gnus-unread-mark))
(custom-face-lookup "DarkGreen" nil nil 'custom:asis t 'custom:asis))
(cons '(/= mark gnus-unread-mark)
(custom-face-lookup "DarkGreen" nil nil 'custom:asis 'custom:asis 'custom:asis))
(cons '(> score default) 'bold)
(cons '(< score default) 'italic)))))
(data ((type . repeat)
(header . nil)
(data (type . pair)
(compact . t)
(data ((type . sexp)
(width . 60)
(tag . "Form"))
"\n "
((type . face)
(tag . "Face"))
"\n")))))
;; Do not define `gnus-button-alist' before we have
;; some `complexity' attribute so we can hide it from
;; beginners.
)))))
(cons '(> score default) 'bold)
(cons '(< score default) 'italic)))))
(data
((type . repeat)
(header . nil)
(data (type . pair)
(compact . t)
(data ((type . sexp)
(width . 60)
(tag . "Form"))
"\n "
((type . face)
(tag . "Face"))
"\n")))))
((tag . "Group Line Highlighting")
(doc . "\
Controls the highlighting of group buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
particular group line should be displayed, each form is
evaluated. The content of the face field after the first true form is
used. You can change how those group lines are displayed by
editing the face field.
It is also possible to change and add form fields, but currently that
requires an understanding of Lisp expressions. Hopefully this will
change in a future release. For now, you can use the following
variables in the Lisp expression:
group: The name of the group.
unread: The number of unread articles in the group.
method: The select method used.
mailp: Whether it's a mail group or not.
level: The level of the group.
score: The score of the group.
ticked: The number of ticked articles.")
(name . gnus-group-highlight)
(type . list)
(calculate
. (cond
((not (eq gnus-display-type 'color))
'((mailp . bold)
((= unread 0) . italic)))
((eq gnus-background-mode 'dark)
`(((and (not mailp) (eq level 1)) .
,(custom-face-lookup "PaleTurquoise" nil nil t))
((and (not mailp) (eq level 2)) .
,(custom-face-lookup "turquoise" nil nil t))
((and (not mailp) (eq level 3)) .
,(custom-face-lookup "MediumTurquoise" nil nil t))
((and (not mailp) (>= level 4)) .
,(custom-face-lookup "DarkTurquoise" nil nil t))
((and mailp (eq level 1)) .
,(custom-face-lookup "aquamarine1" nil nil t))
((and mailp (eq level 2)) .
,(custom-face-lookup "aquamarine2" nil nil t))
((and mailp (eq level 3)) .
,(custom-face-lookup "aquamarine3" nil nil t))
((and mailp (>= level 4)) .
,(custom-face-lookup "aquamarine4" nil nil t))
))
(t
`(((and (not mailp) (<= level 3)) .
,(custom-face-lookup "ForestGreen" nil nil t))
((and (not mailp) (eq level 4)) .
,(custom-face-lookup "DarkGreen" nil nil t))
((and (not mailp) (eq level 5)) .
,(custom-face-lookup "CadetBlue4" nil nil t))
((and mailp (eq level 1)) .
,(custom-face-lookup "DeepPink3" nil nil t))
((and mailp (eq level 2)) .
,(custom-face-lookup "HotPink3" nil nil t))
((and mailp (eq level 3)) .
,(custom-face-lookup "dark magenta" nil nil t))
((and mailp (eq level 4)) .
,(custom-face-lookup "DeepPink4" nil nil t))
((and mailp (> level 4)) .
,(custom-face-lookup "DarkOrchid4" nil nil t))
))))
(data
((type . repeat)
(header . nil)
(data (type . pair)
(compact . t)
(data ((type . sexp)
(width . 60)
(tag . "Form"))
"\n "
((type . face)
(tag . "Face"))
"\n")))))
;; Do not define `gnus-button-alist' before we have
;; some `complexity' attribute so we can hide it from
;; beginners.
)))))
(defun gnus-custom-import-cite-face-list (custom alist)
;; Backward compatible grokking of light and dark.
@ -533,16 +665,6 @@ mark: The article's mark.")
(setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list))))
(funcall (custom-super custom 'import) custom alist))
;(defun gnus-custom-import-swap-alist (custom alist)
; ;; Swap key and value in CUSTOM ALIST.
; (let ((swap (mapcar (lambda (e) (cons (cdr e) (car e))) alist)))
; (funcall (custom-super custom 'import) custom swap)))
;(defun gnus-custom-export-swap-alist (custom alist)
; ;; Swap key and value in CUSTOM ALIST.
; (let ((swap (mapcar (lambda (e) (cons (cdr e) (car e))) alist)))
; (funcall (custom-super custom 'export) custom swap)))
(provide 'gnus-cus)
;;; gnus-cus.el ends here

46
lisp/gnus-edit.el
View File

@ -1,36 +1,19 @@
;;; gnus-edit.el --- Gnus SCORE file editing
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: news, help
;; Version: 0.2
;; 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.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; 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.
;;; Commentary:
;;
;; Type `M-x gnus-score-customize RET' to invoke.
;;; Code:
(require 'custom)
(require 'gnus-score)
(eval-when-compile (require 'cl))
(defconst gnus-score-custom-data
'((tag . "Score")
@ -64,7 +47,7 @@ the score file and the value of the global variable
(query . gnus-score-custom-save))
((name . file)
(tag . "File")
(directory . "~/News/")
(directory . gnus-kill-files-directory)
(default-file . "SCORE")
(type . file))))
((name . files)
@ -79,7 +62,7 @@ delete a score file from the list.")
(data ((type . repeat)
(header . nil)
(data (type . file)
(directory . "~/News/")))))
(directory . gnus-kill-files-directory)))))
((name . exclude-files)
(tag . "Exclude Files")
(doc . "\
@ -94,7 +77,7 @@ delete a score file from the list.")
(data ((type . repeat)
(header . nil)
(data (type . file)
(directory . "~/News/")))))
(directory . gnus-kill-files-directory)))))
((name . mark)
(tag . "Mark")
(doc . "\
@ -554,7 +537,8 @@ groups matched by the current score file.")
'gnus-score-custom-get
'gnus-score-custom-save))
(make-local-variable 'gnus-score-custom-file)
(setq gnus-score-custom-file (expand-file-name "SCORE" "~/News"))
(setq gnus-score-custom-file
(expand-file-name "SCORE" gnus-kill-files-directory))
(make-local-variable 'gnus-score-alist)
(setq gnus-score-alist nil)
(custom-reset-all))
@ -566,9 +550,9 @@ groups matched by the current score file.")
(if entry
(mapcar 'gnus-score-custom-sanify (cdr entry))
(setq entry (assoc name gnus-score-alist))
(if (or (memq name '(files exclude-files local))
(and (eq name 'adapt)
(not (symbolp (car (cdr entry))))))
(if (or (memq name '(files exclude-files local))
(and (eq name 'adapt)
(not (symbolp (car (cdr entry))))))
(cdr entry)
(car (cdr entry)))))))
@ -618,11 +602,11 @@ groups matched by the current score file.")
(let ((file (custom-name-value 'file)))
(if (eq file custom-nil)
(error "You must specify a file name"))
(setq file (expand-file-name file "~/News"))
(setq file (expand-file-name file gnus-kill-files-directory))
(gnus-score-load file)
(setq gnus-score-custom-file file)
(custom-reset-all)
(message "Loaded")))
(gnus-message 4 "Loaded")))
(defun gnus-score-custom-save ()
(interactive)
@ -639,7 +623,7 @@ groups matched by the current score file.")
(gnus-make-directory (file-name-directory file))
(write-region (point-min) (point-max) file nil 'silent)
(kill-buffer (current-buffer))))
(message "Saved"))
(gnus-message 4 "Saved"))
(provide 'gnus-edit)

743
lisp/gnus-ems.el
View File

@ -1,6 +1,5 @@
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
@ -24,91 +23,89 @@
;;; Commentary:
;;; This file has been censored by the Communications Decency Act.
;;; That law was passed under the guise of a ban on pornography, but
;;; it bans far more than that. This file did not contain pornography,
;;; but it was censored nonetheless.
;;; For information on US government censorship of the Internet, and
;;; what you can do to bring back freedom of the press, see the web
;;; site http://www.vtw.org/
;;; Code:
(eval-when-compile (require 'cl))
(defvar gnus-mouse-2 [mouse-2])
(defvar gnus-group-mode-hook ())
(defvar gnus-summary-mode-hook ())
(defvar gnus-article-mode-hook ())
(defalias 'gnus-make-overlay 'make-overlay)
(defalias 'gnus-overlay-put 'overlay-put)
(defalias 'gnus-move-overlay 'move-overlay)
(defalias 'gnus-overlay-end 'overlay-end)
(defalias 'gnus-extent-detached-p 'ignore)
(defalias 'gnus-extent-start-open 'ignore)
(defalias 'gnus-set-text-properties 'set-text-properties)
(defalias 'gnus-group-remove-excess-properties 'ignore)
(defalias 'gnus-topic-remove-excess-properties 'ignore)
(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
(defalias 'gnus-make-local-hook 'make-local-hook)
(defalias 'gnus-add-hook 'add-hook)
(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)
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
(autoload 'appt-select-lowest-window "appt.el"))
(or (fboundp 'mail-file-babyl-p)
(fset 'mail-file-babyl-p 'rmail-file-p))
;; Don't warn about these undefined variables.
;defined in gnus.el
(defvar gnus-active-hashtb)
(defvar gnus-article-buffer)
(defvar gnus-auto-center-summary)
(defvar gnus-buffer-list)
(defvar gnus-current-headers)
(defvar gnus-level-killed)
(defvar gnus-level-zombie)
(defvar gnus-newsgroup-bookmarks)
(defvar gnus-newsgroup-dependencies)
(defvar gnus-newsgroup-headers-hashtb-by-number)
(defvar gnus-newsgroup-selected-overlay)
(defvar gnus-newsrc-hashtb)
(defvar gnus-read-mark)
(defvar gnus-refer-article-method)
(defvar gnus-reffed-article-number)
(defvar gnus-unread-mark)
(defvar gnus-version)
(defvar gnus-view-pseudos)
(defvar gnus-view-pseudos-separately)
(defvar gnus-visual)
(defvar gnus-zombie-list)
;defined in gnus-msg.el
(defvar gnus-article-copy)
(defvar gnus-check-before-posting)
;defined in gnus-vis.el
(defvar gnus-article-button-face)
(defvar gnus-article-mouse-face)
(defvar gnus-summary-selected-face)
;;; 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.
(if face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(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))
(if (< from to)
(gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
;; We do not byte-compile this file, because error messages are such a
;; bore.
(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-set-text-properties-xemacs (start end props &optional buffer)
"You should NEVER use this function. It is ideologically blasphemous.
It is provided only to ease porting of broken FSF Emacs programs."
(if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
nil
(map-extents (lambda (extent ignored)
(remove-text-properties
start end
(list (extent-property extent 'text-prop) nil)
buffer))
buffer start end nil nil 'text-prop)
(add-text-properties start end props buffer)))
(eval-and-compile
(if (string-match "XEmacs\\|Lucid" emacs-version)
()
(eval
'(progn
(if (string-match "XEmacs\\|Lucid" emacs-version)
()
;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
(defvar gnus-display-type
(condition-case nil
(let ((display-resource (x-get-resource ".displayType" "DisplayType")))
(cond (display-resource (intern (downcase display-resource)))
((x-display-color-p) 'color)
((x-display-grayscale-p) 'grayscale)
(t 'mono)))
(error 'mono))
"A symbol indicating the display Emacs is running under.
(defvar gnus-mouse-face-prop 'mouse-face
"Property used for highlighting mouse regions.")
(defvar gnus-article-x-face-command
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
"String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command.")
;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
(defvar gnus-display-type
(condition-case nil
(let ((display-resource (x-get-resource ".displayType" "DisplayType")))
(cond (display-resource (intern (downcase display-resource)))
((x-display-color-p) 'color)
((x-display-grayscale-p) 'grayscale)
(t 'mono)))
(error 'mono))
"A symbol indicating the display Emacs is running under.
The symbol should be one of `color', `grayscale' or `mono'. If Emacs
guesses this display attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.displayType' in your
@ -118,20 +115,20 @@ This is a meta-variable that will affect what default values other
variables get. You would normally not change this variable, but
pounce directly on the real variables themselves.")
(defvar gnus-background-mode
(condition-case nil
(let ((bg-resource (x-get-resource ".backgroundMode"
"BackgroundMode"))
(params (frame-parameters)))
(cond (bg-resource (intern (downcase bg-resource)))
((and (cdr (assq 'background-color params))
(< (apply '+ (x-color-values
(cdr (assq 'background-color params))))
(* (apply '+ (x-color-values "white")) .6)))
'dark)
(t 'light)))
(error 'light))
"A symbol indicating the Emacs background brightness.
(defvar gnus-background-mode
(condition-case nil
(let ((bg-resource (x-get-resource ".backgroundMode"
"BackgroundMode"))
(params (frame-parameters)))
(cond (bg-resource (intern (downcase bg-resource)))
((and (cdr (assq 'background-color params))
(< (apply '+ (x-color-values
(cdr (assq 'background-color params))))
(* (apply '+ (x-color-values "white")) .6)))
'dark)
(t 'light)))
(error 'light))
"A symbol indicating the Emacs background brightness.
The symbol should be one of `light' or `dark'.
If Emacs guesses this frame attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
@ -142,95 +139,24 @@ This is a meta-variable that will affect what default values other
variables get. You would normally not change this variable, but
pounce directly on the real variables themselves."))
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
;; XEmacs definitions.
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
(gnus-xmas-define))
(setq gnus-mouse-2 [button2])
(or (memq 'underline (list-faces))
(and (fboundp 'make-face)
(funcall (intern "make-face") 'underline)))
;; Must avoid calling set-face-underline-p directly, because it
;; is a defsubst in emacs19, and will make the .elc files non
;; portable!
(or (face-differs-from-default-p 'underline)
(funcall 'set-face-underline-p 'underline t))
(defalias 'gnus-make-overlay 'make-extent)
(defalias 'gnus-overlay-put 'set-extent-property)
(defun gnus-move-overlay (extent start end &optional buffer)
(set-extent-endpoints extent start end))
(require 'text-props)
(fset 'set-text-properties 'gnus-set-text-properties-xemacs)
(or (boundp 'standard-display-table) (setq standard-display-table nil))
(or (boundp 'read-event) (fset 'read-event 'next-command-event))
;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
(defvar gnus-display-type (device-class)
"A symbol indicating the display Emacs is running under.
The symbol should be one of `color', `grayscale' or `mono'. If Emacs
guesses this display attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.displayType' in your
`~/.Xdefaults'. See also `gnus-background-mode'.
This is a meta-variable that will affect what default values other
variables get. You would normally not change this variable, but
pounce directly on the real variables themselves.")
(or (fboundp 'x-color-values)
(fset 'x-color-values
(lambda (color)
(color-instance-rgb-components
(make-color-instance color)))))
(defvar gnus-background-mode
(let ((bg-resource
(condition-case ()
(x-get-resource ".backgroundMode" "BackgroundMode" 'string)
(error nil)))
(params (frame-parameters)))
(cond (bg-resource (intern (downcase bg-resource)))
((and (assq 'background-color params)
(< (apply '+ (x-color-values
(cdr (assq 'background-color params))))
(/ (apply '+ (x-color-values "white")) 3)))
'dark)
(t 'light)))
"A symbol indicating the Emacs background brightness.
The symbol should be one of `light' or `dark'.
If Emacs guesses this frame attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
`~/.Xdefaults'.
See also `gnus-display-type'.
This is a meta-variable that will affect what default values other
variables get. You would normally not change this variable, but
pounce directly on the real variables themselves.")
(defun gnus-install-mouse-tracker ()
(require 'mode-motion)
(setq mode-motion-hook 'mode-motion-highlight-line)))
((< 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)))
(and props (setcdr props (cdr (cdr (cdr props))))))
(or (fboundp 'buffer-substring-no-properties)
(defun buffer-substring-no-properties (beg end)
(format "%s" (buffer-substring beg end)))))
((or (not (boundp 'emacs-minor-version))
(< 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)))
(and props (setcdr props (cdr (cdr (cdr props))))))
(or (fboundp 'buffer-substring-no-properties)
(defun buffer-substring-no-properties (beg end)
(format "%s" (buffer-substring beg end)))))
((boundp 'MULE)
(provide 'gnusutil))
)))
((boundp 'MULE)
(provide 'gnusutil))))
(eval-and-compile
(cond
@ -248,451 +174,64 @@ pounce directly on the real variables themselves.")
(not (file-symlink-p file))
(file-exists-p file))))
(or (fboundp 'face-list)
(defun face-list (&rest args)))
)
(defun face-list (&rest args))))
(defun gnus-highlight-selected-summary-xemacs ()
;; Highlight selected article in summary buffer
(if gnus-summary-selected-face
(progn
(if gnus-newsgroup-selected-overlay
(delete-extent gnus-newsgroup-selected-overlay))
(setq gnus-newsgroup-selected-overlay
(make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
(set-extent-face gnus-newsgroup-selected-overlay
gnus-summary-selected-face))))
(eval-and-compile
(let ((case-fold-search t))
(cond
((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type))
(setq nnheader-file-name-translation-alist
(append nnheader-file-name-translation-alist
'((?: . ?_)
(?+ . ?-))))))))
(defun gnus-summary-recenter-xemacs ()
(let* ((top (cond ((< (window-height) 4) 0)
((< (window-height) 7) 1)
(t 2)))
(height (- (window-height) 2))
(bottom (save-excursion (goto-char (point-max))
(forward-line (- height))
(point)))
(window (get-buffer-window (current-buffer))))
(and
;; The user has to want it,
gnus-auto-center-summary
;; the article buffer must be displayed,
(get-buffer-window gnus-article-buffer)
;; Set the window start to either `bottom', which is the biggest
;; possible valid number, or the second line from the top,
;; whichever is the least.
(set-window-start
window (min bottom (save-excursion (forward-line (- top))
(point)))))))
(defun gnus-group-insert-group-line-info-xemacs (group)
(let ((entry (gnus-gethash group gnus-newsrc-hashtb))
(beg (point))
active info)
(if entry
(progn
(setq info (nth 2 entry))
(gnus-group-insert-group-line
nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
(setq active (gnus-gethash group gnus-active-hashtb))
(gnus-group-insert-group-line
nil group (if (member group gnus-zombie-list) gnus-level-zombie
gnus-level-killed)
nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
(save-excursion
(goto-char beg)
(remove-text-properties
(1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
'(gnus-group nil)))))
(defun gnus-summary-refer-article-xemacs (message-id)
"Refer article specified by MESSAGE-ID.
NOTE: This command only works with newsgroups that use real or simulated NNTP."
(interactive "sMessage-ID: ")
(if (or (not (stringp message-id))
(zerop (length message-id)))
()
;; Construct the correct Message-ID if necessary.
;; Suggested by tale@pawl.rpi.edu.
(or (string-match "^<" message-id)
(setq message-id (concat "<" message-id)))
(or (string-match ">$" message-id)
(setq message-id (concat message-id ">")))
(let ((header (car (gnus-gethash (downcase message-id)
gnus-newsgroup-dependencies))))
(if header
(or (gnus-summary-goto-article (mail-header-number header))
;; The header has been read, but the article had been
;; expunged, so we insert it again.
(let ((beg (point)))
(gnus-summary-insert-line
nil header 0 nil gnus-read-mark nil nil
(mail-header-subject header))
(save-excursion
(goto-char beg)
(remove-text-properties
(1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
'(gnus-number nil gnus-mark nil gnus-level nil)))
(forward-line -1)
(mail-header-number header)))
(let ((gnus-override-method gnus-refer-article-method)
(gnus-ancient-mark gnus-read-mark)
(tmp-point (window-start
(get-buffer-window gnus-article-buffer)))
number tmp-buf)
(and gnus-refer-article-method
(gnus-check-server gnus-refer-article-method))
;; Save the old article buffer.
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-kill-buffer " *temp Article*")
(setq tmp-buf (rename-buffer " *temp Article*")))
(prog1
(if (gnus-article-prepare
message-id nil (gnus-read-header message-id))
(progn
(setq number (mail-header-number gnus-current-headers))
(gnus-rebuild-thread message-id)
(gnus-summary-goto-subject number)
(gnus-summary-recenter)
(gnus-article-set-window-start
(cdr (assq number gnus-newsgroup-bookmarks)))
message-id)
;; We restore the old article buffer.
(save-excursion
(kill-buffer gnus-article-buffer)
(set-buffer tmp-buf)
(rename-buffer gnus-article-buffer)
(let ((buffer-read-only nil))
(and tmp-point
(set-window-start (get-buffer-window (current-buffer))
tmp-point)))))))))))
(defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
(let ((buffer-read-only nil)
(article (gnus-summary-article-number))
b)
(or (gnus-summary-goto-subject article)
(error "No such article: %d" article))
(or gnus-newsgroup-headers-hashtb-by-number
(gnus-make-headers-hashtable-by-number))
(gnus-summary-position-cursor)
;; If all commands are to be bunched up on one line, we collect
;; them here.
(if gnus-view-pseudos-separately
()
(let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
files action)
(while ps
(setq action (cdr (assq 'action (car ps))))
(setq files (list (cdr (assq 'name (car ps)))))
(while (and ps (cdr ps)
(string= (or action "1")
(or (cdr (assq 'action (car (cdr ps)))) "2")))
(setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
(setcdr ps (cdr (cdr ps))))
(if (not files)
()
(if (not (string-match "%s" action))
(setq files (cons " " files)))
(setq files (cons " " files))
(and (assq 'execute (car ps))
(setcdr (assq 'execute (car ps))
(funcall (if (string-match "%s" action)
'format 'concat)
action
(mapconcat (lambda (f) f) files " ")))))
(setq ps (cdr ps)))))
(if (and gnus-view-pseudos (not not-view))
(while pslist
(and (assq 'execute (car pslist))
(gnus-execute-command (cdr (assq 'execute (car pslist)))
(eq gnus-view-pseudos 'not-confirm)))
(setq pslist (cdr pslist)))
(save-excursion
(while pslist
(gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
(gnus-summary-article-number)))
(forward-line 1)
(setq b (point))
(insert " "
(file-name-nondirectory (cdr (assq 'name (car pslist))))
": " (or (cdr (assq 'execute (car pslist))) "") "\n")
(add-text-properties
b (1+ b) (list 'gnus-number gnus-reffed-article-number
'gnus-mark gnus-unread-mark
'gnus-level 0
'gnus-pseudo (car pslist)))
;; Fire-trucking XEmacs redisplay bug with truncated lines.
(goto-char b)
(sit-for 0)
;; Grumble.. fire-trucking XEmacs stickiness of text properties.
(remove-text-properties
(1+ b) (1+ (gnus-point-at-eol))
'(gnus-number nil gnus-mark nil gnus-level nil))
(forward-line -1)
(gnus-sethash (int-to-string gnus-reffed-article-number)
(car pslist) gnus-newsgroup-headers-hashtb-by-number)
(setq gnus-reffed-article-number (1- gnus-reffed-article-number))
(setq pslist (cdr pslist)))))))
(defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
(setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
(buffer-disable-undo gnus-article-copy)
(or (memq gnus-article-copy gnus-buffer-list)
(setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
(let ((article-buffer (or article-buffer gnus-article-buffer))
buf)
(if (and (get-buffer article-buffer)
(buffer-name (get-buffer article-buffer)))
(save-excursion
(set-buffer article-buffer)
(widen)
(setq buf (buffer-substring (point-min) (point-max)))
(set-buffer gnus-article-copy)
(erase-buffer)
(insert (format "%s" buf))))))
(defun gnus-article-push-button-xemacs (event)
"Check text under the mouse pointer for a callback function.
If the text under the mouse pointer has a `gnus-callback' property,
call it with the value of the `gnus-data' text property."
(interactive "e")
(set-buffer (window-buffer (event-window event)))
(let* ((pos (event-closest-point event))
(data (get-text-property pos 'gnus-data))
(fun (get-text-property pos 'gnus-callback)))
(if fun (funcall fun data))))
;; Re-build the thread containing ID.
(defun gnus-rebuild-thread-xemacs (id)
(let ((dep gnus-newsgroup-dependencies)
(buffer-read-only nil)
parent headers refs thread art)
(while (and id (setq headers
(car (setq art (gnus-gethash (downcase id)
dep)))))
(setq parent art)
(setq id (and (setq refs (mail-header-references headers))
(string-match "\\(<[^>]+>\\) *$" refs)
(substring refs (match-beginning 1) (match-end 1)))))
(setq thread (gnus-make-sub-thread (car parent)))
(gnus-rebuild-remove-articles thread)
(let ((beg (point)))
(gnus-summary-prepare-threads (list thread) 0)
(save-excursion
(while (and (>= (point) beg)
(not (bobp)))
(or (eobp)
(remove-text-properties
(1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
'(gnus-number nil gnus-mark nil gnus-level nil)))
(forward-line -1)))
(gnus-summary-update-lines beg (point)))))
;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
(defun gnus-article-add-button-xemacs (from to fun &optional data)
"Create a button between FROM and TO with callback FUN and data DATA."
(and gnus-article-button-face
(gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
(add-text-properties from to
(append
(and gnus-article-mouse-face
(list 'mouse-face gnus-article-mouse-face))
(list 'gnus-callback fun)
(and data (list 'gnus-data data))
(list 'highlight t))))
(defun gnus-window-top-edge-xemacs (&optional window)
(nth 1 (window-pixel-edges window)))
;; Select the lowest window on the frame.
(defun gnus-appt-select-lowest-window-xemacs ()
(let* ((lowest-window (selected-window))
(bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
(last-window (previous-window))
(window-search t))
(while window-search
(let* ((this-window (next-window))
(next-bottom-edge (car (cdr (cdr (cdr
(window-pixel-edges
this-window)))))))
(if (< bottom-edge next-bottom-edge)
(progn
(setq bottom-edge next-bottom-edge)
(setq lowest-window this-window)))
(select-window this-window)
(if (eq last-window this-window)
(progn
(select-window lowest-window)
(setq window-search nil)))))))
(defvar gnus-tmp-unread)
(defvar gnus-tmp-replied)
(defvar gnus-tmp-score-char)
(defvar gnus-tmp-indentation)
(defvar gnus-tmp-opening-bracket)
(defvar gnus-tmp-lines)
(defvar gnus-tmp-name)
(defvar gnus-tmp-closing-bracket)
(defvar gnus-tmp-subject-or-nil)
(defun gnus-ems-redefine ()
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
;; XEmacs definitions.
(fset 'gnus-mouse-face-function 'identity)
(fset 'gnus-summary-make-display-table (lambda () nil))
(fset 'gnus-visual-turn-off-edit-menu 'identity)
(fset 'gnus-highlight-selected-summary
'gnus-highlight-selected-summary-xemacs)
(fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
(fset 'gnus-group-insert-group-line-info
'gnus-group-insert-group-line-info-xemacs)
(fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
(fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
(fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
(fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
(fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
(fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
(fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
(fset 'set-text-properties 'gnus-set-text-properties-xemacs)
(or (fboundp 'appt-select-lowest-window)
(fset 'appt-select-lowest-window
'gnus-appt-select-lowest-window-xemacs))
(if (not gnus-visual)
()
(setq gnus-group-mode-hook
(cons
'(lambda ()
(easy-menu-add gnus-group-reading-menu)
(easy-menu-add gnus-group-group-menu)
(easy-menu-add gnus-group-misc-menu)
(gnus-install-mouse-tracker))
gnus-group-mode-hook))
(setq gnus-summary-mode-hook
(cons
'(lambda ()
(easy-menu-add gnus-summary-article-menu)
(easy-menu-add gnus-summary-thread-menu)
(easy-menu-add gnus-summary-misc-menu)
(easy-menu-add gnus-summary-post-menu)
(easy-menu-add gnus-summary-kill-menu)
(gnus-install-mouse-tracker))
gnus-summary-mode-hook))
(setq gnus-article-mode-hook
(cons
'(lambda ()
(easy-menu-add gnus-article-article-menu)
(easy-menu-add gnus-article-treatment-menu))
gnus-article-mode-hook)))
(defvar gnus-logo (make-glyph (make-specifier 'image)))
(defun gnus-group-startup-xmessage (&optional x y)
"Insert startup message in current buffer."
;; Insert the message.
(erase-buffer)
(if (featurep 'xpm)
(progn
(set-glyph-property gnus-logo 'image "~/tmp/gnus.xpm")
(set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
(insert " ")
(set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
(insert "
Gnus * A newsreader for Emacsen
A Praxis Release * larsi@ifi.uio.no")
(goto-char (point-min))
(while (not (eobp))
(insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
? ))
(forward-line 1))
(goto-char (point-min))
;; +4 is fuzzy factor.
(insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
(insert
(format "
%s
A newsreader
for GNU Emacs
Based on GNUS
written by
Masanobu UMEDA
A Praxis Release
larsi@ifi.uio.no
"
gnus-version))
;; And then hack it.
;; 18 is the longest line.
(indent-rigidly (point-min) (point-max)
(/ (max (- (window-width) (or x 28)) 0) 2))
(goto-char (point-min))
;; +4 is fuzzy factor.
(insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
;; Fontify some.
(goto-char (point-min))
(search-forward "Praxis")
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
(goto-char (point-min)))
)
(gnus-xmas-redefine))
((boundp 'MULE)
;; Mule definitions
(if (not (fboundp 'truncate-string))
(defun truncate-string (str width)
(let ((w (string-width str))
(col 0) (idx 0) (p-idx 0) chr)
(if (<= w width)
str
(while (< col width)
(setq chr (aref str idx)
col (+ col (char-width chr))
p-idx idx
idx (+ idx (char-bytes chr))
))
(substring str 0 (if (= col width)
idx
p-idx))
)))
)
(defalias 'gnus-truncate-string 'truncate-string)
(defun gnus-cite-add-face (number prefix face)
;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
(if face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(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))
(if (< from to)
(gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
(defun gnus-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))))
(fset 'gnus-summary-make-display-table (lambda () nil))
(fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
(fset 'gnus-max-width-function 'gnus-mule-max-width-function)
(if (boundp 'gnus-check-before-posting)
(setq gnus-check-before-posting
(delq 'long-lines
(delq 'control-chars gnus-check-before-posting)))
)
)
))
(delq 'control-chars gnus-check-before-posting))))
(defun gnus-summary-line-format-spec ()
(insert gnus-tmp-unread gnus-tmp-replied
gnus-tmp-score-char gnus-tmp-indentation)
(put-text-property
(point)
(progn
(insert
gnus-tmp-opening-bracket
(format "%4d: %-20s"
gnus-tmp-lines
(if (> (length gnus-tmp-name) 20)
(truncate-string 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"))
)))
(provide 'gnus-ems)

154
lisp/gnus-kill.el
View File

@ -1,6 +1,5 @@
;;; gnus-kill.el --- kill commands for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
@ -28,6 +27,7 @@
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-kill-file-mode-hook nil
"*A hook for Gnus kill file mode.")
@ -43,12 +43,12 @@
(defmacro gnus-raise (field expression level)
(` (gnus-kill (, field) (, expression)
(function (gnus-summary-raise-score (, level))) t)))
`(gnus-kill ,field ,expression
(function (gnus-summary-raise-score ,level)) t))
(defmacro gnus-lower (field expression level)
(` (gnus-kill (, field) (, expression)
(function (gnus-summary-raise-score (- (, level)))) t)))
`(gnus-kill ,field ,expression
(function (gnus-summary-raise-score (- ,level))) t))
;;;
;;; Gnus Kill File Mode
@ -56,23 +56,16 @@
(defvar gnus-kill-file-mode-map nil)
(if gnus-kill-file-mode-map
nil
(setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map))
(define-key gnus-kill-file-mode-map
"\C-c\C-k\C-s" 'gnus-kill-file-kill-by-subject)
(define-key gnus-kill-file-mode-map
"\C-c\C-k\C-a" 'gnus-kill-file-kill-by-author)
(define-key gnus-kill-file-mode-map
"\C-c\C-k\C-t" 'gnus-kill-file-kill-by-thread)
(define-key gnus-kill-file-mode-map
"\C-c\C-k\C-x" 'gnus-kill-file-kill-by-xref)
(define-key gnus-kill-file-mode-map
"\C-c\C-a" 'gnus-kill-file-apply-buffer)
(define-key gnus-kill-file-mode-map
"\C-c\C-e" 'gnus-kill-file-apply-last-sexp)
(define-key gnus-kill-file-mode-map
"\C-c\C-c" 'gnus-kill-file-exit))
(unless gnus-kill-file-mode-map
(gnus-define-keymap
(setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map))
"\C-c\C-k\C-s" gnus-kill-file-kill-by-subject
"\C-c\C-k\C-a" gnus-kill-file-kill-by-author
"\C-c\C-k\C-t" gnus-kill-file-kill-by-thread
"\C-c\C-k\C-x" gnus-kill-file-kill-by-xref
"\C-c\C-a" gnus-kill-file-apply-buffer
"\C-c\C-e" gnus-kill-file-apply-last-sexp
"\C-c\C-c" gnus-kill-file-exit))
(defun gnus-kill-file-mode ()
"Major mode for editing kill files.
@ -181,7 +174,7 @@ If NEWSGROUP is nil, the global kill file is selected."
(gnus-kill-file-mode)
(bury-buffer buffer)))
(defun gnus-kill-file-enter-kill (field regexp)
(defun gnus-kill-file-enter-kill (field regexp &optional dont-move)
;; Enter kill file entry.
;; FIELD: String containing the name of the header field to kill.
;; REGEXP: The string to kill.
@ -189,8 +182,8 @@ If NEWSGROUP is nil, the global kill file is selected."
(let (string)
(or (eq major-mode 'gnus-kill-file-mode)
(gnus-kill-set-kill-buffer))
(current-buffer)
(goto-char (point-max))
(unless dont-move
(goto-char (point-max)))
(insert (setq string (format "(gnus-kill %S %S)\n" field regexp)))
(gnus-kill-file-apply-string string))))
@ -202,7 +195,7 @@ If NEWSGROUP is nil, the global kill file is selected."
(if (vectorp gnus-current-headers)
(regexp-quote
(gnus-simplify-subject (mail-header-subject gnus-current-headers)))
"")))
"") t))
(defun gnus-kill-file-kill-by-author ()
"Kill by author."
@ -211,7 +204,7 @@ If NEWSGROUP is nil, the global kill file is selected."
"From"
(if (vectorp gnus-current-headers)
(regexp-quote (mail-header-from gnus-current-headers))
"")))
"") t))
(defun gnus-kill-file-kill-by-thread ()
"Kill by author."
@ -237,8 +230,8 @@ If NEWSGROUP is nil, the global kill file is selected."
(substring xref (match-beginning 1) (match-end 1)))
gnus-newsgroup-name))
(gnus-kill-file-enter-kill
"Xref" (concat " " (regexp-quote group) ":"))))
(gnus-kill-file-enter-kill "Xref" ""))))
"Xref" (concat " " (regexp-quote group) ":") t)))
(gnus-kill-file-enter-kill "Xref" "" t))))
(defun gnus-kill-file-raise-followups-to-author (level)
"Raise score for all followups to the current author."
@ -258,7 +251,8 @@ If NEWSGROUP is nil, the global kill file is selected."
"From" name level))
(insert string)
(gnus-kill-file-apply-string string))
(message "Added temporary score file entry for followups to %s." name)))
(gnus-message
6 "Added temporary score file entry for followups to %s." name)))
(defun gnus-kill-file-apply-buffer ()
"Apply current buffer to current newsgroup."
@ -267,7 +261,7 @@ If NEWSGROUP is nil, the global kill file is selected."
(get-buffer gnus-summary-buffer))
;; Assume newsgroup is selected.
(gnus-kill-file-apply-string (buffer-string))
(ding) (message "No newsgroup is selected.")))
(ding) (gnus-message 2 "No newsgroup is selected.")))
(defun gnus-kill-file-apply-string (string)
"Apply STRING to current newsgroup."
@ -291,7 +285,7 @@ If NEWSGROUP is nil, the global kill file is selected."
(save-window-excursion
(pop-to-buffer gnus-summary-buffer)
(eval (car (read-from-string string))))))
(ding) (message "No newsgroup is selected.")))
(ding) (gnus-message 2 "No newsgroup is selected.")))
(defun gnus-kill-file-exit ()
"Save a kill file, then return to the previous buffer."
@ -318,24 +312,37 @@ If NEWSGROUP is nil, return the global kill file instead."
(cond ((or (null newsgroup)
(string-equal newsgroup ""))
;; The global kill file is placed at top of the directory.
(expand-file-name gnus-kill-file-name
(or gnus-kill-files-directory "~/News")))
(expand-file-name gnus-kill-file-name gnus-kill-files-directory))
(gnus-use-long-file-name
;; Append ".KILL" to capitalized newsgroup name.
(expand-file-name (concat (gnus-capitalize-newsgroup newsgroup)
"." gnus-kill-file-name)
(or gnus-kill-files-directory "~/News")))
gnus-kill-files-directory))
(t
;; Place "KILL" under the hierarchical directory.
(expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
"/" gnus-kill-file-name)
(or gnus-kill-files-directory "~/News")))))
gnus-kill-files-directory))))
(defun gnus-expunge (marks)
"Remove lines marked with MARKS."
(save-excursion
(set-buffer gnus-summary-buffer)
(gnus-summary-remove-lines-marked-with marks)))
(gnus-summary-limit-to-marks marks 'reverse)))
(defun gnus-apply-kill-file-unless-scored ()
"Apply .KILL file, unless a .SCORE file for the same newsgroup exists."
(cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name))
;; Ignores global KILL.
(if (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))
(gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE"
gnus-newsgroup-name))
0)
((or (file-exists-p (gnus-newsgroup-kill-file nil))
(file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
(gnus-apply-kill-file-internal))
(t
0)))
(defun gnus-apply-kill-file-internal ()
"Apply a kill file to the current newsgroup.
@ -346,8 +353,6 @@ Returns the number of articles marked as read."
(gnus-summary-inhibit-highlight t)
beg)
(setq gnus-newsgroup-kill-headers nil)
(or gnus-newsgroup-headers-hashtb-by-number
(gnus-make-headers-hashtable-by-number))
;; If there are any previously scored articles, we remove these
;; from the `gnus-newsgroup-headers' list that the score functions
;; will see. This is probably pretty wasteful when it comes to
@ -378,7 +383,7 @@ Returns the number of articles marked as read."
(while kill-files
(if (not (file-exists-p (car kill-files)))
()
(message "Processing kill file %s..." (car kill-files))
(gnus-message 6 "Processing kill file %s..." (car kill-files))
(find-file (car kill-files))
(gnus-add-current-to-buffer-list)
(goto-char (point-min))
@ -388,7 +393,8 @@ Returns the number of articles marked as read."
(gnus-kill-parse-gnus-kill-file)
(gnus-kill-parse-rn-kill-file))
(message "Processing kill file %s...done" (car kill-files)))
(gnus-message
6 "Processing kill file %s...done" (car kill-files)))
(setq kill-files (cdr kill-files)))))
(gnus-set-mode-line 'summary)
@ -396,7 +402,7 @@ Returns the number of articles marked as read."
(if beg
(let ((nunreads (- unreads (length gnus-newsgroup-unreads))))
(or (eq nunreads 0)
(message "Marked %d articles as read" nunreads))
(gnus-message 6 "Marked %d articles as read" nunreads))
nunreads)
0))))
@ -408,7 +414,7 @@ Returns the number of articles marked as read."
(erase-buffer)
(insert string ":\n\n")
(while alist
(insert (format " %c: %s\n" (car (car alist)) (nth idx (car alist))))
(insert (format " %c: %s\n" (caar alist) (nth idx (car alist))))
(setq alist (cdr alist)))))
(defun gnus-kill-parse-gnus-kill-file ()
@ -538,14 +544,14 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(if (or (not (consp (nth 2 object)))
(not (consp (cdr (nth 2 object))))
(and (eq 'quote (car (nth 2 object)))
(not (consp (cdr (car (cdr (nth 2 object))))))))
(not (consp (cdadr (nth 2 object))))))
(concat "\n" (prin1-to-string object))
(save-excursion
(set-buffer (get-buffer-create "*Gnus PP*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
(let ((klist (car (cdr (nth 2 object))))
(let ((klist (cadr (nth 2 object)))
(first t))
(while klist
(insert (if first (progn (setq first nil) "") "\n ")
@ -580,15 +586,19 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(or (stringp value)
(setq value (prin1-to-string value)))
(setq did-kill (string-match regexp value)))
(if (stringp form) ;Keyboard macro.
(execute-kbd-macro form)
(funcall form))))
(cond ((stringp form) ;Keyboard macro.
(execute-kbd-macro form))
((gnus-functionp form)
(funcall form))
(t
(eval form)))))
;; Search article body.
(let ((gnus-current-article nil) ;Save article pointer.
(gnus-last-article nil)
(gnus-break-pages nil) ;No need to break pages.
(gnus-mark-article-hook nil)) ;Inhibit marking as read.
(message "Searching for article: %d..." (mail-header-number header))
(gnus-message
6 "Searching for article: %d..." (mail-header-number header))
(gnus-article-setup-buffer)
(gnus-article-prepare (mail-header-number header) t)
(if (save-excursion
@ -609,27 +619,37 @@ marked as read or ticked are ignored."
(save-excursion
(let ((killed-no 0)
function article header)
(if (or (null field) (string-equal field ""))
(setq function nil)
;; Get access function of header filed.
(setq function (intern-soft (concat "gnus-header-" (downcase field))))
(if (and function (fboundp function))
(setq function (symbol-function function))
(error "Unknown header field: \"%s\"" field))
;; Make FORM funcallable.
(if (and (listp form) (not (eq (car form) 'lambda)))
(setq form (list 'lambda nil form))))
(cond
;; Search body.
((or (null field)
(string-equal field ""))
(setq function nil))
;; Get access function of header field.
((fboundp
(setq function
(intern-soft
(concat "mail-header-" (downcase field)))))
(setq function `(lambda (h) (,function h))))
;; Signal error.
(t
(error "Unknown header field: \"%s\"" field)))
;; Starting from the current article.
(while (or (and (not article)
(setq article (gnus-summary-article-number))
t)
(setq article
(gnus-summary-search-subject
backward (not ignore-marked))))
(while (or
;; First article.
(and (not article)
(setq article (gnus-summary-article-number)))
;; Find later articles.
(setq article
(gnus-summary-search-forward
(not ignore-marked) nil backward)))
(and (or (null gnus-newsgroup-kill-headers)
(memq article gnus-newsgroup-kill-headers))
(vectorp (setq header (gnus-get-header-by-number article)))
(vectorp (setq header (gnus-summary-article-header article)))
(gnus-execute-1 function regexp form header)
(setq killed-no (1+ killed-no))))
;; Return the number of killed articles.
killed-no)))
(provide 'gnus-kill)
;;; gnus-kill.el ends here

177
lisp/gnus-mh.el
View File

@ -1,6 +1,5 @@
;;; gnus-mh.el --- mh-e interface for Gnus
;; Copyright (C) 1994,95 Free Software Foundation, Inc.
;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
@ -38,6 +37,7 @@
(require 'mh-comp)
(require 'gnus)
(require 'gnus-msg)
(eval-when-compile (require 'cl))
(defun gnus-summary-save-article-folder (&optional arg)
"Append the current article to an mh folder.
@ -55,155 +55,30 @@ Optional argument FOLDER specifies folder name."
;; Thanks to yuki@flab.Fujitsu.JUNET and ohm@kaba.junet.
(mh-find-path)
(let ((folder
(or folder
(mh-prompt-for-folder
"Save article in"
(funcall gnus-folder-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-folder)
t)))
(errbuf (get-buffer-create " *Gnus rcvstore*")))
(gnus-eval-in-buffer-window
gnus-article-buffer
(save-restriction
(widen)
(unwind-protect
(call-process-region (point-min) (point-max)
(expand-file-name "rcvstore" mh-lib)
nil errbuf nil folder)
(set-buffer errbuf)
(if (zerop (buffer-size))
(message "Article saved in folder: %s" folder)
(message "%s" (buffer-string)))
(kill-buffer errbuf))))
(setq gnus-newsgroup-last-folder folder)))
(defun gnus-mail-reply-using-mhe (&optional yank)
"Compose reply mail using mh-e.
Optional argument YANK means yank original article.
The command \\[mh-yank-cur-msg] yank the original message into current buffer."
(let (from cc subject date to reply-to to-userid orig-to
references message-id
(config (current-window-configuration))
buffer)
(pop-to-buffer gnus-article-buffer)
(setq buffer (current-buffer))
(save-excursion
(cond ((and (eq folder 'default)
gnus-newsgroup-last-folder)
gnus-newsgroup-last-folder)
(folder folder)
(t (mh-prompt-for-folder
"Save article in"
(funcall gnus-folder-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-folder)
t))))
(errbuf (get-buffer-create " *Gnus rcvstore*"))
;; Find the rcvstore program.
(exec-path (if mh-lib (cons mh-lib exec-path) exec-path)))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(save-restriction
(or gnus-user-login-name ; we need this
(setq gnus-user-login-name (or (getenv "USER")
(getenv "LOGNAME"))))
(gnus-article-show-all-headers);; so colors are happy
;; lots of junk to avoid mh-send deleting other windows
(setq from (or (gnus-fetch-field "from") "")
subject (let ((subject (or (gnus-fetch-field "subject")
"(None)")))
(if (and subject
(not (string-match "^[Rr][Ee]:.+$" subject)))
(concat "Re: " subject) subject))
reply-to (gnus-fetch-field "reply-to")
cc (gnus-fetch-field "cc")
orig-to (or (gnus-fetch-field "to") "")
date (gnus-fetch-field "date")
references (gnus-fetch-field "references")
message-id (gnus-fetch-field "message-id"))
(setq to (or reply-to from))
(setq to-userid (mail-strip-quoted-names orig-to))
(if (or (string-match "," orig-to)
(not (string-match (substring to-userid 0
(string-match "@" to-userid))
gnus-user-login-name)))
(setq cc (concat (if cc (concat cc ", ") "") orig-to)))
;; mh-yank-cur-msg needs to have mh-show-buffer set in the
;; *Article* buffer
(setq mh-show-buffer buffer)))
(mh-find-path)
(mh-send-sub (or to "") (or cc "")
(or subject "(None)") config);; Erik Selberg 1/23/94
(let ((draft (current-buffer))
(gnus-mail-buffer (current-buffer))
mail-buf)
(if (not yank)
(gnus-configure-windows 'reply 'force)
(gnus-configure-windows 'reply-yank 'force))
(setq mail-buf gnus-mail-buffer)
(pop-to-buffer mail-buf);; always in the display, so won't have window probs
(switch-to-buffer draft))
;; (mh-send to (or cc "") subject);; shouldn't use according to mhe
;; note - current buffer is now draft!
(save-excursion
(mh-insert-fields
"In-reply-to:"
(concat
(substring from 0 (string-match " *at \\| *@ \\| *(\\| *<" from))
"'s message of " date))
(nnheader-insert-references references message-id))
;; need this for mh-yank-cur-msg
(setq mh-sent-from-folder buffer)
(setq mh-sent-from-msg 1)
(setq mh-show-buffer buffer)
(setq mh-previous-window-config config))
;; Then, yank original article if requested.
(if yank
(let ((last (point)))
(mh-yank-cur-msg)
(goto-char last)))
(run-hooks 'gnus-mail-hook))
;; gnus-mail-forward-using-mhe is contributed by Jun-ichiro Itoh
;; <itojun@ingram.mt.cs.keio.ac.jp>
(defun gnus-mail-forward-using-mhe (&optional buffer)
"Forward the current message to another user using mh-e."
;; First of all, prepare mhe mail buffer.
(let* ((to (read-string "To: "))
(cc (read-string "Cc: "))
(buffer (or buffer gnus-article-buffer))
(config (current-window-configuration));; need to add this - erik
(subject (gnus-forward-make-subject buffer)))
(setq mh-show-buffer buffer)
(mh-find-path)
(mh-send-sub to (or cc "") (or subject "(None)") config);; Erik Selberg 1/23/94
(let ((draft (current-buffer))
(gnus-mail-buffer (current-buffer))
mail-buf)
(gnus-configure-windows 'reply-yank 'force)
(setq mail-buf (eval (cdr (assq 'mail gnus-window-to-buffer))))
(pop-to-buffer mail-buf);; always in the display, so won't have window probs
(switch-to-buffer draft)
)
(save-excursion
(goto-char (point-max))
(insert "\n------- Forwarded Message\n\n")
(insert-buffer buffer)
(goto-char (point-max))
(insert "\n------- End of Forwarded Message\n")
(setq mh-sent-from-folder buffer)
(setq mh-sent-from-msg 1)
(setq mh-previous-window-config config)
(run-hooks 'gnus-mail-hook)
)))
(defun gnus-mail-other-window-using-mhe ()
"Compose mail other window using mh-e."
(let ((to (read-string "To: "))
(cc (read-string "Cc: "))
(subject (read-string "Subject: ")))
(gnus-article-show-all-headers) ;I don't think this is really needed.
(setq mh-show-buffer (current-buffer))
(mh-find-path)
(mh-send-other-window to cc subject)
(setq mh-sent-from-folder (current-buffer))
(setq mh-sent-from-msg 1)
(run-hooks 'gnus-mail-hook)))
(widen)
(unwind-protect
(call-process-region
(point-min) (point-max) "rcvstore" nil errbuf nil folder)
(set-buffer errbuf)
(if (zerop (buffer-size))
(message "Article saved in folder: %s" folder)
(message "%s" (buffer-string)))
(kill-buffer errbuf))))
(setq gnus-newsgroup-last-folder folder)))
(defun gnus-Folder-save-name (newsgroup headers &optional last-folder)
"Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
@ -225,4 +100,6 @@ Otherwise, it is like +news/group."
newsgroup
(gnus-newsgroup-directory-form newsgroup)))))
(provide 'gnus-mh)
;;; gnus-mh.el ends here

2238
lisp/gnus-msg.el
View File

File diff suppressed because it is too large Load Diff

1886
lisp/gnus-score.el
View File

File diff suppressed because it is too large Load Diff

966
lisp/gnus-uu.el
View File

File diff suppressed because it is too large Load Diff

1493
lisp/gnus-vis.el
View File

File diff suppressed because it is too large Load Diff

166
lisp/gnus-vm.el
View File

@ -1,6 +1,5 @@
;;; gnus-vm.el --- vm interface for Gnus
;; Copyright (C) 1994,95 Free Software Foundation, Inc.
;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
;; Author: Per Persson <pp@solace.mh.se>
;; Keywords: news, mail
@ -32,6 +31,7 @@
;;; Code:
(require 'sendmail)
(require 'message)
(require 'gnus)
(require 'gnus-msg)
@ -90,19 +90,13 @@ save those articles instead."
(let ((default-name
(funcall gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-mail)))
(or folder
(setq folder
(read-file-name
(concat "Save article in VM folder: (default "
(file-name-nondirectory default-name) ") ")
(file-name-directory default-name)
default-name)))
(setq folder
(expand-file-name folder
(and default-name
(file-name-directory default-name))))
(cond ((eq folder 'default) default-name)
(folder folder)
(t (gnus-read-save-file-name
"Save article in VM folder:" default-name))))
(gnus-make-directory (file-name-directory folder))
(set-buffer gnus-article-buffer)
(set-buffer gnus-original-article-buffer)
(save-excursion
(save-restriction
(widen)
@ -111,152 +105,6 @@ save those articles instead."
(kill-buffer vm-folder))))
;; Remember the directory name to save articles.
(setq gnus-newsgroup-last-mail folder)))
(defun gnus-mail-forward-using-vm (&optional buffer)
"Forward the current message to another user using vm."
(let* ((gnus-buffer (or buffer (current-buffer)))
(subject (gnus-forward-make-subject gnus-buffer)))
(or (featurep 'win-vm)
(if gnus-use-full-window
(pop-to-buffer gnus-article-buffer)
(switch-to-buffer gnus-article-buffer)))
(gnus-copy-article-buffer)
(set-buffer gnus-article-copy)
(save-excursion
(save-restriction
(widen)
(let ((vm-folder (gnus-vm-make-folder))
(vm-forward-message-hook
(append (symbol-value 'vm-forward-message-hook)
'((lambda ()
(save-excursion
(mail-position-on-field "Subject")
(beginning-of-line)
(looking-at "^\\(Subject: \\).*$")
(replace-match (concat "\\1" subject))))))))
(vm-forward-message)
(gnus-vm-init-reply-buffer gnus-buffer)
(run-hooks 'gnus-mail-hook)
(kill-buffer vm-folder))))))
(defun gnus-vm-init-reply-buffer (buffer)
(make-local-variable 'gnus-summary-buffer)
(setq gnus-summary-buffer buffer)
(set 'vm-mail-buffer nil)
(use-local-map (copy-keymap (current-local-map)))
(local-set-key "\C-c\C-y" 'gnus-yank-article))
(defun gnus-mail-reply-using-vm (&optional yank)
"Compose reply mail using vm.
Optional argument YANK means yank original article.
The command \\[vm-yank-message] yank the original message into current buffer."
(let ((gnus-buffer (current-buffer)))
(gnus-copy-article-buffer)
(set-buffer gnus-article-copy)
(save-excursion
(save-restriction
(widen)
(let ((vm-folder (gnus-vm-make-folder gnus-article-copy)))
(vm-reply 1)
(gnus-vm-init-reply-buffer gnus-buffer)
(setq gnus-buffer (current-buffer))
(and yank
;; nil will (magically :-)) yank the current article
(gnus-yank-article nil))
(kill-buffer vm-folder))))
(if (featurep 'win-vm) nil
(pop-to-buffer gnus-buffer))
(run-hooks 'gnus-mail-hook)))
(defun gnus-mail-other-window-using-vm ()
"Compose mail in the other window using VM."
(interactive)
(let ((gnus-buffer (current-buffer)))
(vm-mail)
(gnus-vm-init-reply-buffer gnus-buffer))
(run-hooks 'gnus-mail-hook))
(defun gnus-yank-article (article &optional prefix)
;; Based on vm-yank-message by Kyle Jones.
"Yank article number N into the current buffer at point.
When called interactively N is read from the minibuffer.
This command is meant to be used in GNUS created Mail mode buffers;
the yanked article comes from the newsgroup containing the article
you are replying to or forwarding.
All article headers are yanked along with the text. Point is left
before the inserted text, the mark after. Any hook functions bound to
`mail-citation-hook' are run, after inserting the text and setting
point and mark.
Prefix arg means to ignore `mail-citation-hook', don't set the mark,
prepend the value of `vm-included-text-prefix' to every yanked line.
For backwards compatibility, if `mail-citation-hook' is set to nil,
`mail-yank-hooks' is run instead. If that is also nil, a default
action is taken."
(interactive
(list
(let ((result 0)
default prompt)
(setq default (and gnus-summary-buffer
(save-excursion
(set-buffer gnus-summary-buffer)
(and gnus-current-article
(int-to-string gnus-current-article))))
prompt (if default
(format "Yank article number: (default %s) " default)
"Yank article number: "))
(while (and (not (stringp result)) (zerop result))
(setq result (read-string prompt))
(and (string= result "") default (setq result default))
(or (string-match "^<.*>$" result)
(setq result (string-to-int result))))
result)
current-prefix-arg))
(if gnus-summary-buffer
(save-excursion
(let ((message (current-buffer))
(start (point)) end
(tmp (generate-new-buffer " *tmp-yank*")))
(set-buffer gnus-summary-buffer)
;; Make sure the connection to the server is alive.
(or (gnus-server-opened (gnus-find-method-for-group
gnus-newsgroup-name))
(progn
(gnus-check-server
(gnus-find-method-for-group gnus-newsgroup-name))
(gnus-request-group gnus-newsgroup-name t)))
(and (stringp article)
(let ((gnus-override-method gnus-refer-article-method))
(gnus-read-header article)))
(gnus-request-article (or article
gnus-current-article)
gnus-newsgroup-name tmp)
(set-buffer tmp)
(run-hooks 'gnus-article-prepare-hook)
;; Decode MIME message.
(if (and gnus-show-mime
(gnus-fetch-field "Mime-Version"))
(funcall gnus-show-mime-method))
;; Perform the article display hooks.
(let ((buffer-read-only nil))
(run-hooks 'gnus-article-display-hook))
(append-to-buffer message (point-min) (point-max))
(kill-buffer tmp)
(set-buffer message)
(setq end (point))
(goto-char start)
(if (or prefix
(not (or mail-citation-hook mail-yank-hooks)))
(save-excursion
(while (< (point) end)
(insert (symbol-value 'vm-included-text-prefix))
(forward-line 1)))
(push-mark end)
(cond
(mail-citation-hook (run-hooks 'mail-citation-hook))
(mail-yank-hooks (run-hooks 'mail-yank-hooks))))))))
(provide 'gnus-vm)

18045
lisp/gnus.el
View File

File diff suppressed because it is too large Load Diff

152
lisp/nndir.el
View File

@ -1,9 +1,7 @@
;;; nndir.el --- single directory newsgroup access for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
;; This file is part of GNU Emacs.
@ -30,113 +28,71 @@
(require 'nnheader)
(require 'nnmh)
(require 'nnml)
(require 'nnoo)
(eval-when-compile (require 'cl))
(eval-and-compile
(autoload 'mail-send-and-exit "sendmail"))
(nnoo-declare nndir
nnml nnmh)
(defvoo nndir-directory nil
"Where nndir will look for groups."
nnml-current-directory nnmh-current-directory)
(defvoo nndir-nov-is-evil nil
"*Non-nil means that nndir will never retrieve NOV headers."
nnml-nov-is-evil)
(defvoo nndir-current-group "" nil nnml-current-group nnmh-current-group)
(defvoo nndir-top-directory nil nil nnml-directory nnmh-directory)
(defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail)
(defvoo nndir-status-string "" nil nnmh-status-string)
(defconst nndir-version "nndir 1.0")
(defvar nndir-current-directory nil
"Current news group directory.")
(defvar nndir-status-string "")
(defvar nndir-nov-is-evil nil
"*Non-nil means that nndir will never retrieve NOV headers.")
;;; Interface functions.
(nnoo-define-basics nndir)
(defun nndir-retrieve-headers (sequence &optional newsgroup server)
(nndir-execute-nnml-command
'(nnml-retrieve-headers sequence group server) server))
(deffoo nndir-open-server (server &optional defs)
(setq nndir-directory
(or (cadr (assq 'nndir-directory defs))
server))
(unless (assq 'nndir-directory defs)
(push `(nndir-directory ,server) defs))
(push `(nndir-current-group
,(file-name-nondirectory (directory-file-name nndir-directory)))
defs)
(push `(nndir-top-directory
,(file-name-directory (directory-file-name nndir-directory)))
defs)
(nnoo-change-server 'nndir server defs)
(let (err)
(cond
((not (condition-case arg
(file-exists-p nndir-directory)
(ftp-error (setq err (format "%s" arg)))))
(nndir-close-server)
(nnheader-report
'nndir (or err "No such file or directory: %s" nndir-directory)))
((not (file-directory-p (file-truename nndir-directory)))
(nndir-close-server)
(nnheader-report 'nndir "Not a directory: %s" nndir-directory))
(t
(nnheader-report 'nndir "Opened server %s using directory %s"
server nndir-directory)
t))))
(defun nndir-open-server (host &optional service)
"Open nndir backend."
(setq nndir-status-string "")
(nnheader-init-server-buffer))
(defun nndir-close-server (&optional server)
"Close news server."
t)
(defun nndir-server-opened (&optional server)
"Return server process status, T or NIL.
If the stream is opened, return T, otherwise return NIL."
(and nntp-server-buffer
(get-buffer nntp-server-buffer)))
(defun nndir-status-message (&optional server)
"Return server status response as string."
nndir-status-string)
(defun nndir-request-article (id &optional newsgroup server buffer)
(nndir-execute-nnmh-command
'(nnmh-request-article id group server buffer) server))
(defun nndir-request-group (group &optional server dont-check)
"Select news GROUP."
(nndir-execute-nnmh-command
'(nnmh-request-group group "" dont-check) server))
(defun nndir-request-list (&optional server dir)
"Get list of active articles in all newsgroups."
(nndir-execute-nnmh-command
'(nnmh-request-list nil dir) server))
(defun nndir-request-newgroups (date &optional server)
(nndir-execute-nnmh-command
'(nnmh-request-newgroups date server) server))
(defun nndir-request-post (&optional server)
"Post a new news in current buffer."
(mail-send-and-exit nil))
(defalias 'nndir-request-post-buffer 'nnmail-request-post-buffer)
(defun nndir-request-expire-articles (articles newsgroup &optional server force)
"Expire all articles in the ARTICLES list in group GROUP."
(setq nndir-status-string "nndir: expire not possible")
nil)
(defun nndir-close-group (group &optional server)
t)
(defun nndir-request-move-article (article group server accept-form)
(setq nndir-status-string "nndir: move not possible")
nil)
(defun nndir-request-accept-article (group)
(setq nndir-status-string "nndir: accept not possible")
nil)
;;; Low-Level Interface
(defun nndir-execute-nnmh-command (command server)
(let ((dir (expand-file-name server)))
(and (string-match "/$" dir)
(setq dir (substring dir 0 (match-beginning 0))))
(string-match "/[^/]+$" dir)
(let ((group (substring dir (1+ (match-beginning 0))))
(nnmh-directory (substring dir 0 (1+ (match-beginning 0))))
(nnmh-get-new-mail nil))
(eval command))))
(defun nndir-execute-nnml-command (command server)
(let ((dir (expand-file-name server)))
(and (string-match "/$" dir)
(setq dir (substring dir 0 (match-beginning 0))))
(string-match "/[^/]+$" dir)
(let ((group (substring dir (1+ (match-beginning 0))))
(nnml-directory (substring dir 0 (1+ (match-beginning 0))))
(nnml-nov-is-evil nndir-nov-is-evil)
(nnml-get-new-mail nil))
(eval command))))
(nnoo-map-functions nndir
(nnml-retrieve-headers 0 nndir-current-group 0 0)
(nnmh-request-article 0 nndir-current-group 0 0)
(nnmh-request-group nndir-current-group 0 0)
(nnmh-close-group nndir-current-group 0)
(nnmh-request-list (nnoo-current-server 'nndir) nndir-directory)
(nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory))
(provide 'nndir)

660
lisp/nndoc.el
View File

@ -1,6 +1,5 @@
;;; nndoc.el --- single file access for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -28,239 +27,203 @@
;;; Code:
(require 'nnheader)
(require 'rmail)
(require 'message)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(defvar nndoc-article-type 'mbox
"*Type of the file - one of `mbox', `babyl' or `digest'.")
(nnoo-declare nndoc)
(defvar nndoc-digest-type 'traditional
"Type of the last digest. Auto-detected from the article header.
Possible values:
`traditional' -- the \"lots of dashes\" (30+) rules used;
we currently also do unconditional RFC 934 unquoting.
`rfc1341' -- RFC 1341 digest (MIME, unique boundary, no quoting).")
(defvoo nndoc-article-type 'guess
"*Type of the file.
One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
`mime-digest', `standard-digest', `slack-digest', `clari-briefs' or
`guess'.")
(defconst nndoc-type-to-regexp
(list (list 'mbox
(concat "^" rmail-unix-mail-delimiter)
(concat "^" rmail-unix-mail-delimiter)
nil "^$" nil nil nil)
(list 'babyl "\^_\^L *\n" "\^_" "^[0-9].*\n" "^$" nil nil
"\\*\\*\\* EOOH \\*\\*\\*\n\\(^.+\n\\)*")
(list 'digest
"^------------------------------*[\n \t]+"
"^------------------------------*[\n \t]+"
nil "^ ?$"
"^------------------------------*[\n \t]+"
"^End of" nil))
"Regular expressions for articles of the various types.")
(defvoo nndoc-post-type 'mail
"*Whether the nndoc group is `mail' or `post'.")
(defvar nndoc-type-alist
`((mmdf
(article-begin . "^\^A\^A\^A\^A\n")
(body-end . "^\^A\^A\^A\^A\n"))
(news
(article-begin . "^Path:"))
(rnews
(article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
(body-end-function . nndoc-rnews-body-end))
(mbox
(article-begin .
,(let ((delim (concat "^" message-unix-mail-delimiter)))
(if (string-match "\n\\'" delim)
(substring delim 0 (match-beginning 0))
delim)))
(body-end-function . nndoc-mbox-body-end))
(babyl
(article-begin . "\^_\^L *\n")
(body-end . "\^_")
(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 -+$")
(prepare-body . nndoc-unquote-dashes))
(clari-briefs
(article-begin . "^ \\*")
(body-end . "^\t------*[ \t]^*\n^ \\*")
(body-begin . "^\t")
(head-end . "^\t")
(generate-head . nndoc-generate-clari-briefs-head)
(article-transform . nndoc-transform-clari-briefs))
(slack-digest
(article-begin . "^------------------------------*[\n \t]+")
(head-end . "^ ?$")
(body-end-function . nndoc-digest-body-end)
(body-begin . "^ ?$")
(file-end . "^End of")
(prepare-body . nndoc-unquote-dashes))
(mime-digest
(article-begin . "")
(head-end . "^ ?$")
(body-end . "")
(file-end . ""))
(standard-digest
(first-article . ,(concat "^" (make-string 70 ?-) "\n\n+"))
(article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+"))
(prepare-body . nndoc-unquote-dashes)
(body-end-function . nndoc-digest-body-end)
(head-end . "^ ?$")
(body-begin . "^ ?\n")
(file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$"))
(guess
(guess . nndoc-guess-type))
(digest
(guess . nndoc-guess-digest-type))
))
(defvar nndoc-article-begin nil)
(defvar nndoc-article-end nil)
(defvar nndoc-head-begin nil)
(defvar nndoc-head-end nil)
(defvar nndoc-first-article nil)
(defvar nndoc-end-of-file nil)
(defvar nndoc-body-begin nil)
(defvoo nndoc-file-begin nil)
(defvoo nndoc-first-article nil)
(defvoo nndoc-article-end nil)
(defvoo nndoc-article-begin nil)
(defvoo nndoc-head-begin nil)
(defvoo nndoc-head-end nil)
(defvoo nndoc-file-end nil)
(defvoo nndoc-body-begin nil)
(defvoo nndoc-body-end-function nil)
(defvoo nndoc-body-begin-function nil)
(defvoo nndoc-head-begin-function nil)
(defvoo nndoc-body-end nil)
(defvoo nndoc-dissection-alist nil)
(defvoo nndoc-prepare-body nil)
(defvoo nndoc-generate-head nil)
(defvoo nndoc-article-transform nil)
(defvar nndoc-current-server nil)
(defvar nndoc-server-alist nil)
(defvar nndoc-server-variables
(list
(list 'nndoc-article-type nndoc-article-type)
'(nndoc-article-begin nil)
'(nndoc-article-end nil)
'(nndoc-head-begin nil)
'(nndoc-head-end nil)
'(nndoc-first-article nil)
'(nndoc-current-buffer nil)
'(nndoc-group-alist nil)
'(nndoc-end-of-file nil)
'(nndoc-body-begin nil)
'(nndoc-address nil)))
(defvoo nndoc-status-string "")
(defvoo nndoc-group-alist nil)
(defvoo nndoc-current-buffer nil
"Current nndoc news buffer.")
(defvoo nndoc-address nil)
(defconst nndoc-version "nndoc 1.0"
"nndoc version.")
(defvar nndoc-current-buffer nil
"Current nndoc news buffer.")
(defvar nndoc-address nil)
(defvar nndoc-status-string "")
(defvar nndoc-group-alist nil)
;;; Interface functions
(defun nndoc-retrieve-headers (sequence &optional newsgroup server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((prev 2)
article p beg lines)
(nndoc-possibly-change-buffer newsgroup server)
(if (stringp (car sequence))
'headers
(set-buffer nndoc-current-buffer)
(widen)
(goto-char (point-min))
(re-search-forward (or nndoc-first-article
nndoc-article-begin) nil t)
(or (not nndoc-head-begin)
(re-search-forward nndoc-head-begin nil t))
(re-search-forward nndoc-head-end nil t)
(while sequence
(setq article (car sequence))
(set-buffer nndoc-current-buffer)
(if (not (nndoc-forward-article (max 0 (- article prev))))
()
(setq p (point))
(setq beg (or (and
(re-search-backward nndoc-article-begin nil t)
(match-end 0))
(point-min)))
(goto-char p)
(setq lines (count-lines
(point)
(or
(and (re-search-forward nndoc-article-end nil t)
(goto-char (match-beginning 0)))
(goto-char (point-max)))))
(nnoo-define-basics nndoc)
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nndoc-current-buffer beg p)
(goto-char (point-max))
(or (= (char-after (1- (point))) ?\n) (insert "\n"))
(insert (format "Lines: %d\n" lines))
(insert ".\n"))
(deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
(when (nndoc-possibly-change-buffer newsgroup server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let (article entry)
(if (stringp (car articles))
'headers
(while articles
(when (setq entry (cdr (assq (setq article (pop articles))
nndoc-dissection-alist)))
(insert (format "221 %d Article retrieved.\n" article))
(if nndoc-generate-head
(funcall nndoc-generate-head article)
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry)))
(goto-char (point-max))
(or (= (char-after (1- (point))) ?\n) (insert "\n"))
(insert (format "Lines: %d\n" (nth 4 entry)))
(insert ".\n")))
(setq prev article
sequence (cdr sequence)))
(nnheader-fold-continuation-lines)
'headers)))))
;; Fold continuation lines.
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t))
'headers))))
(defun nndoc-open-server (server &optional defs)
(nnheader-init-server-buffer)
(if (equal server nndoc-current-server)
t
(if nndoc-current-server
(setq nndoc-server-alist
(cons (list nndoc-current-server
(nnheader-save-variables nndoc-server-variables))
nndoc-server-alist)))
(let ((state (assoc server nndoc-server-alist)))
(if state
(progn
(nnheader-restore-variables (nth 1 state))
(setq nndoc-server-alist (delq state nndoc-server-alist)))
(nnheader-set-init-variables nndoc-server-variables defs)))
(setq nndoc-current-server server)
(let ((defs (cdr (assq nndoc-article-type nndoc-type-to-regexp))))
(setq nndoc-article-begin (nth 0 defs))
(setq nndoc-article-end (nth 1 defs))
(setq nndoc-head-begin (nth 2 defs))
(setq nndoc-head-end (nth 3 defs))
(setq nndoc-first-article (nth 4 defs))
(setq nndoc-end-of-file (nth 5 defs))
(setq nndoc-body-begin (nth 6 defs)))
t))
(defun nndoc-close-server (&optional server)
t)
(defun nndoc-server-opened (&optional server)
(and (equal server nndoc-current-server)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(defun nndoc-status-message (&optional server)
nndoc-status-string)
(defun nndoc-request-article (article &optional newsgroup server buffer)
(deffoo nndoc-request-article (article &optional newsgroup server buffer)
(nndoc-possibly-change-buffer newsgroup server)
(save-excursion
(let ((buffer (or buffer nntp-server-buffer)))
(let ((buffer (or buffer nntp-server-buffer))
(entry (cdr (assq article nndoc-dissection-alist)))
beg)
(set-buffer buffer)
(erase-buffer)
(if (stringp article)
nil
(nndoc-insert-article article)
;; Unquote quoted non-separators in digests.
(if (and (eq nndoc-article-type 'digest)
(eq nndoc-digest-type 'traditional))
(progn
(goto-char (point-min))
(while (re-search-forward "^- -"nil t)
(replace-match "-" t t))))
;; Some assholish digests do not have a blank line after the
;; headers. Aargh!
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
() ; We let this one pass.
(if (re-search-forward "^[ \t]+$" nil t)
(replace-match "" t t) ; We nix out a line of blanks.
(while (and (looking-at "[^ ]+:")
(zerop (forward-line 1))))
;; We just insert a couple of lines. If you read digests
;; that are so badly formatted, you don't deserve any
;; better. Blphphpht!
(insert "\n\n")))
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry))
(insert "\n")
(setq beg (point))
(insert-buffer-substring
nndoc-current-buffer (nth 2 entry) (nth 3 entry))
(goto-char beg)
(when nndoc-prepare-body
(funcall nndoc-prepare-body))
(when nndoc-article-transform
(funcall nndoc-article-transform article))
t))))
(defun nndoc-request-group (group &optional server dont-check)
(deffoo nndoc-request-group (group &optional server dont-check)
"Select news GROUP."
(save-excursion
(if (not (nndoc-possibly-change-buffer group server))
(progn
(setq nndoc-status-string "No such file or buffer")
nil)
(nndoc-set-header-dependent-regexps) ; hack for MIME digests
(if dont-check
t
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((number (nndoc-number-of-articles)))
(if (zerop number)
(progn
(nndoc-close-group group)
nil)
(insert (format "211 %d %d %d %s\n" number 1 number group))
t)))))))
(let (number)
(cond
((not (nndoc-possibly-change-buffer group server))
(nnheader-report 'nndoc "No such file or buffer: %s"
nndoc-address))
(dont-check
(nnheader-report 'nndoc "Selected group %s" group)
t)
((zerop (setq number (length nndoc-dissection-alist)))
(nndoc-close-group group)
(nnheader-report 'nndoc "No articles in group %s" group))
(t
(nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
(defun nndoc-close-group (group &optional server)
(deffoo nndoc-request-type (group &optional article)
(cond ((not article) 'unknown)
(nndoc-post-type nndoc-post-type)
(t 'unknown)))
(deffoo nndoc-close-group (group &optional server)
(nndoc-possibly-change-buffer group server)
(kill-buffer nndoc-current-buffer)
(and nndoc-current-buffer
(buffer-name nndoc-current-buffer)
(kill-buffer nndoc-current-buffer))
(setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
nndoc-group-alist))
(setq nndoc-current-buffer nil)
(setq nndoc-current-server nil)
(nnoo-close-server 'nndoc server)
(setq nndoc-dissection-alist nil)
t)
(defun nndoc-request-list (&optional server)
(deffoo nndoc-request-list (&optional server)
nil)
(defun nndoc-request-newgroups (date &optional server)
(deffoo nndoc-request-newgroups (date &optional server)
nil)
(defun nndoc-request-list-newsgroups (&optional server)
(deffoo nndoc-request-list-newsgroups (&optional server)
nil)
(defalias 'nndoc-request-post 'nnmail-request-post)
(defalias 'nndoc-request-post-buffer 'nnmail-request-post-buffer)
;;; Internal functions.
@ -269,6 +232,7 @@ Possible values:
(cond
;; The current buffer is this group's buffer.
((and nndoc-current-buffer
(buffer-name nndoc-current-buffer)
(eq nndoc-current-buffer
(setq buf (cdr (assoc group nndoc-group-alist))))))
;; We change buffers by taking an old from the group alist.
@ -281,121 +245,231 @@ Possible values:
(and (stringp nndoc-address)
(file-exists-p nndoc-address)
(not (file-directory-p nndoc-address))))
(setq nndoc-group-alist
(cons (cons group (setq nndoc-current-buffer
(get-buffer-create
(concat " *nndoc " group "*"))))
nndoc-group-alist))
(push (cons group (setq nndoc-current-buffer
(get-buffer-create
(concat " *nndoc " group "*"))))
nndoc-group-alist)
(setq nndoc-dissection-alist nil)
(save-excursion
(set-buffer nndoc-current-buffer)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(if (stringp nndoc-address)
(insert-file-contents nndoc-address)
(save-excursion
(set-buffer nndoc-address)
(widen))
(insert-buffer-substring nndoc-address))
t)))))
;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
(defun nndoc-set-header-dependent-regexps ()
(if (not (eq nndoc-article-type 'digest))
()
(let ((case-fold-search t) ; We match a bit too much, keep it simple.
(boundary-id) (b-delimiter))
(insert-buffer-substring nndoc-address)))))
;; Initialize the nndoc structures according to this new document.
(when (and nndoc-current-buffer
(not nndoc-dissection-alist))
(save-excursion
(set-buffer nndoc-current-buffer)
(goto-char (point-min))
(if (and
(re-search-forward
(concat "\n\n\\|^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
"boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
nil t)
(match-beginning 1))
(setq nndoc-digest-type 'rfc1341
boundary-id (format "%s"
(buffer-substring
(match-beginning 1) (match-end 1)))
b-delimiter (concat "\n--" boundary-id "[\n \t]+")
nndoc-article-begin b-delimiter ; Too strict: "[ \t]*$"
nndoc-article-end (concat "\n--" boundary-id
"\\(--\\)?[\n \t]+")
nndoc-first-article b-delimiter ; ^eof ends article too.
nndoc-end-of-file (concat "\n--" boundary-id "--[ \t]*$"))
(setq nndoc-digest-type 'traditional))))))
(nndoc-set-delims)
(nndoc-dissect-buffer)))
(unless nndoc-current-buffer
(nndoc-close-server))
;; Return whether we managed to select a file.
nndoc-current-buffer))
(defun nndoc-forward-article (n)
(while (and (> n 0)
(re-search-forward nndoc-article-begin nil t)
(or (not nndoc-head-begin)
(re-search-forward nndoc-head-begin nil t))
(re-search-forward nndoc-head-end nil t))
(setq n (1- n)))
(zerop n))
(defun nndoc-number-of-articles ()
(save-excursion
(set-buffer nndoc-current-buffer)
(widen)
;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
(defun nndoc-guess-digest-type ()
"Guess what digest type the current document is."
(let ((case-fold-search t) ; We match a bit too much, keep it simple.
boundary-id b-delimiter entry)
(goto-char (point-min))
(let ((num 0))
(if (re-search-forward (or nndoc-first-article
nndoc-article-begin) nil t)
(progn
(setq num 1)
(while (and (re-search-forward nndoc-article-begin nil t)
(or (not nndoc-end-of-file)
(not (looking-at nndoc-end-of-file)))
(or (not nndoc-head-begin)
(re-search-forward nndoc-head-begin nil t))
(re-search-forward nndoc-head-end nil t))
(setq num (1+ num)))))
num)))
(cond
;; MIME digest.
((and
(re-search-forward
(concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
"boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
nil t)
(match-beginning 1))
(setq boundary-id (match-string 1)
b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
(setq entry (assq 'mime-digest nndoc-type-alist))
(setcdr entry
(list
(cons 'head-end "^ ?$")
(cons 'body-begin "^ ?\n")
(cons 'article-begin b-delimiter)
(cons 'body-end-function 'nndoc-digest-body-end)
; (cons 'body-end
; (concat "\n--" boundary-id "\\(--\\)?[\n \t]+"))
(cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
'mime-digest)
;; Standard digest.
((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
(re-search-forward
(concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
'standard-digest)
;; Stupid digest.
(t
'slack-digest))))
(defun nndoc-narrow-to-article (article)
(save-excursion
(set-buffer nndoc-current-buffer)
(widen)
(goto-char (point-min))
(while (and (re-search-forward nndoc-article-begin nil t)
(not (zerop (setq article (1- article))))))
(if (not (zerop article))
()
(narrow-to-region
(match-end 0)
(or (and (re-search-forward nndoc-article-end nil t)
(match-beginning 0))
(point-max)))
t)))
(defun nndoc-guess-type ()
"Guess what document type is in the current buffer."
(goto-char (point-min))
(cond
((looking-at message-unix-mail-delimiter)
'mbox)
((looking-at "\^A\^A\^A\^A$")
'mmdf)
((looking-at "^Path:.*\n")
'news)
((looking-at "#! *rnews")
'rnews)
((re-search-forward "\^_\^L *\n" nil t)
'babyl)
((save-excursion
(and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
(not (re-search-forward "^Subject:.*digest" nil t))))
'forward)
((let ((case-fold-search nil))
(re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
'clari-briefs)
(t
'digest)))
;; Insert article ARTICLE in the current buffer.
(defun nndoc-insert-article (article)
(let ((ibuf (current-buffer)))
(defun nndoc-set-delims ()
"Set the nndoc delimiter variables according to the type of the document."
(let ((vars '(nndoc-file-begin
nndoc-first-article
nndoc-article-end nndoc-head-begin nndoc-head-end
nndoc-file-end nndoc-article-begin
nndoc-body-begin nndoc-body-end-function nndoc-body-end
nndoc-prepare-body nndoc-article-transform
nndoc-generate-head nndoc-body-begin-function
nndoc-head-begin-function)))
(while vars
(set (pop vars) nil)))
(let* (defs guess)
;; Guess away until we find the real file type.
(while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist))
guess (assq 'guess defs))
(setq nndoc-article-type (funcall (cdr guess))))
;; Set the nndoc variables.
(while defs
(set (intern (format "nndoc-%s" (caar defs)))
(cdr (pop defs))))))
(defun nndoc-search (regexp)
(prog1
(re-search-forward regexp nil t)
(beginning-of-line)))
(defun nndoc-dissect-buffer ()
"Go through the document and partition it into heads/bodies/articles."
(let ((i 0)
(first t)
head-begin head-end body-begin body-end)
(setq nndoc-dissection-alist nil)
(save-excursion
(set-buffer nndoc-current-buffer)
(widen)
(goto-char (point-min))
(while (and (re-search-forward nndoc-article-begin nil t)
(not (zerop (setq article (1- article))))))
(if (not (zerop article))
()
(narrow-to-region
(match-end 0)
(or (and (re-search-forward nndoc-article-end nil t)
(match-beginning 0))
(point-max)))
;; Find the beginning of the file.
(when nndoc-file-begin
(nndoc-search nndoc-file-begin))
;; Go through the file.
(while (if (and first nndoc-first-article)
(nndoc-search nndoc-first-article)
(nndoc-search nndoc-article-begin))
(setq first nil)
(cond (nndoc-head-begin-function
(funcall nndoc-head-begin-function))
(nndoc-head-begin
(nndoc-search nndoc-head-begin)))
(if (and nndoc-file-end
(looking-at nndoc-file-end))
(goto-char (point-max))
(setq head-begin (point))
(nndoc-search (or nndoc-head-end "^$"))
(setq head-end (point))
(if nndoc-body-begin-function
(funcall nndoc-body-begin-function)
(nndoc-search (or nndoc-body-begin "^\n")))
(setq body-begin (point))
(or (and nndoc-body-end-function
(funcall nndoc-body-end-function))
(and nndoc-body-end
(nndoc-search nndoc-body-end))
(nndoc-search nndoc-article-begin)
(progn
(goto-char (point-max))
(when nndoc-file-end
(and (re-search-backward nndoc-file-end nil t)
(beginning-of-line)))))
(setq body-end (point))
(push (list (incf i) head-begin head-end body-begin body-end
(count-lines body-begin body-end))
nndoc-dissection-alist))))))
(defun nndoc-unquote-dashes ()
"Unquote quoted non-separators in digests."
(while (re-search-forward "^- -"nil t)
(replace-match "-" t t)))
(defun nndoc-digest-body-end ()
(and (re-search-forward nndoc-article-begin nil t)
(goto-char (match-beginning 0))))
(defun nndoc-mbox-body-end ()
(let ((beg (point))
len end)
(when
(save-excursion
(and (re-search-backward nndoc-article-begin nil t)
(setq end (point))
(search-forward "\n\n" beg t)
(re-search-backward
"^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
(setq len (string-to-int (match-string 1)))
(search-forward "\n\n" beg t)
(or (= (setq len (+ (point) len)) (point-max))
(and (< len (point-max))
(goto-char len)
(looking-at nndoc-article-begin)))))
(goto-char len))))
(defun nndoc-rnews-body-end ()
(and (re-search-backward nndoc-article-begin nil t)
(forward-line 1)
(goto-char (+ (point) (string-to-int (match-string 1))))))
(defun nndoc-transform-clari-briefs (article)
(goto-char (point-min))
(when (looking-at " *\\*\\(.*\\)\n")
(replace-match "" t t))
(nndoc-generate-clari-briefs-head article))
(defun nndoc-generate-clari-briefs-head (article)
(let ((entry (cdr (assq article nndoc-dissection-alist)))
subject from)
(save-excursion
(set-buffer nndoc-current-buffer)
(save-restriction
(narrow-to-region (car entry) (nth 3 entry))
(goto-char (point-min))
(and nndoc-head-begin
(re-search-forward nndoc-head-begin nil t)
(narrow-to-region (point) (point-max)))
(or (re-search-forward nndoc-head-end nil t)
(goto-char (point-max)))
(append-to-buffer ibuf (point-min) (point))
(and nndoc-body-begin
(re-search-forward nndoc-body-begin nil t))
(append-to-buffer ibuf (point) (point-max))
t))))
(when (looking-at " *\\*\\(.*\\)$")
(setq subject (match-string 1))
(when (string-match "[ \t]+$" subject)
(setq subject (substring subject 0 (match-beginning 0)))))
(when
(let ((case-fold-search nil))
(re-search-forward
"^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
(setq from (match-string 1)))))
(insert "From: " "clari@clari.net (" (or from "unknown") ")"
"\nSubject: " (or subject "(no subject)") "\n")))
(defun nndoc-babyl-body-begin ()
(re-search-forward "^\n" nil t)
(when (looking-at "\*\*\* EOOH \*\*\*")
(re-search-forward "^\n" nil t)))
(defun nndoc-babyl-head-begin ()
(when (re-search-forward "^[0-9].*\n" nil t)
(when (looking-at "\*\*\* EOOH \*\*\*")
(forward-line 1))
t))
(provide 'nndoc)

318
lisp/nneething.el
View File

@ -1,6 +1,5 @@
;;; nneething.el --- random file access for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -33,103 +32,90 @@
(require 'nnheader)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(defvar nneething-map-file-directory "~/.nneething/"
"*Map files directory.")
(nnoo-declare nneething)
(defvar nneething-exclude-files "~$"
"*Regexp saying what files to exclude from the group.")
(defvoo nneething-map-file-directory "~/.nneething/"
"*Where nneething stores the map files.")
(defvar nneething-map-file ".nneething"
"*Name of map files.")
(defvoo nneething-map-file ".nneething"
"*Name of the map files.")
(defvoo nneething-exclude-files nil
"*Regexp saying what files to exclude from the group.
If this variable is nil, no files will be excluded.")
;;; Internal variables.
(defconst nneething-version "nneething 1.0"
"nneething version.")
(defvar nneething-current-directory nil
(defvoo nneething-current-directory nil
"Current news group directory.")
(defvar nneething-status-string "")
(defvar nneething-group-alist nil)
(defvoo nneething-status-string "")
(defvoo nneething-group-alist nil)
(defvoo nneething-message-id-number 0)
(defvoo nneething-work-buffer " *nneething work*")
(defvar nneething-directory nil)
(defvar nneething-group nil)
(defvar nneething-map nil)
(defvar nneething-read-only nil)
(defvar nneething-active nil)
(defvar nneething-server-variables
(list
(list 'nneething-directory nneething-directory)
'(nneething-current-directory nil)
'(nneething-status-string "")
'(nneething-group-alist)))
(defvoo nneething-directory nil)
(defvoo nneething-group nil)
(defvoo nneething-map nil)
(defvoo nneething-read-only nil)
(defvoo nneething-active nil)
;;; Interface functions.
(defun nneething-retrieve-headers (sequence &optional newsgroup server)
(nneething-possibly-change-directory newsgroup)
(nnoo-define-basics nneething)
(deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
(nneething-possibly-change-directory group)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let* ((number (length sequence))
(let* ((number (length articles))
(count 0)
(large (and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)))
article file)
(if (stringp (car sequence))
(if (stringp (car articles))
'headers
(while sequence
(setq article (car sequence))
(while (setq article (pop articles))
(setq file (nneething-file-name article))
(if (and (file-exists-p file)
(not (zerop (nth 7 (file-attributes file)))))
(progn
(insert (format "221 %d Article retrieved.\n" article))
(nneething-insert-head file)
(insert ".\n")))
(when (and (file-exists-p file)
(or (file-directory-p file)
(not (zerop (nth 7 (file-attributes file))))))
(insert (format "221 %d Article retrieved.\n" article))
(nneething-insert-head file)
(insert ".\n"))
(setq sequence (cdr sequence)
count (1+ count))
(incf count)
(and large
(zerop (% count 20))
(message "nneething: Receiving headers... %d%%"
(/ (* count 100) number))))
(and large (message "nneething: Receiving headers...done"))
(when large
(message "nneething: Receiving headers...done"))
;; Fold continuation lines.
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t))
(nnheader-fold-continuation-lines)
'headers))))
(defun nneething-open-server (server &optional defs)
(setq nneething-status-string "")
(nnheader-init-server-buffer))
(defun nneething-close-server (&optional server)
t)
(defun nneething-server-opened (&optional server)
t)
(defun nneething-status-message (&optional server)
nneething-status-string)
(defun nneething-request-article (id &optional newsgroup server buffer)
(nneething-possibly-change-directory newsgroup)
(let ((file (if (stringp id) nil (nneething-file-name id)))
(deffoo nneething-request-article (id &optional group server buffer)
(nneething-possibly-change-directory group)
(let ((file (unless (stringp id) (nneething-file-name id)))
(nntp-server-buffer (or buffer nntp-server-buffer)))
(and (stringp file) ; We did not request by Message-ID.
(file-exists-p file) ; The file exists.
@ -139,50 +125,41 @@
(or (nnheader-article-p) ; Either it's a real article...
(progn
(goto-char (point-min))
(nneething-make-head file) ; ... or we fake some headers.
(nneething-make-head file (current-buffer)) ; ... or we fake some headers.
(insert "\n")))
t))))
(defun nneething-request-group (group &optional dir dont-check)
(deffoo nneething-request-group (group &optional dir dont-check)
(nneething-possibly-change-directory group dir)
(or dont-check (nneething-create-mapping))
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(unless dont-check
(nneething-create-mapping)
(if (> (car nneething-active) (cdr nneething-active))
(insert (format "211 0 1 0 %s\n" group))
(insert (format "211 %d %d %d %s\n"
(- (1+ (cdr nneething-active)) (car nneething-active))
(car nneething-active) (cdr nneething-active)
group)))
t))
(nnheader-insert "211 0 1 0 %s\n" group)
(nnheader-insert
"211 %d %d %d %s\n"
(- (1+ (cdr nneething-active)) (car nneething-active))
(car nneething-active) (cdr nneething-active)
group)))
t)
(defun nneething-request-list (&optional server dir)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer))
nil)
(deffoo nneething-request-list (&optional server dir)
(nnheader-report 'nneething "LIST is not implemented."))
(defun nneething-request-newgroups (date &optional server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer))
nil)
(deffoo nneething-request-newgroups (date &optional server)
(nnheader-report 'nneething "NEWSGROUPS is not implemented."))
(defun nneething-request-post (&optional server)
(mail-send-and-exit nil))
(deffoo nneething-request-type (group &optional article)
'unknown)
(defalias 'nneething-request-post-buffer 'nnmail-request-post-buffer)
(defun nneething-close-group (group &optional server)
(deffoo nneething-close-group (group &optional server)
(setq nneething-current-directory nil)
t)
;;; Internal functions.
(defun nneething-possibly-change-directory (group &optional dir)
(if (not group)
()
(when group
(if (and nneething-group
(string= group nneething-group))
t
@ -198,42 +175,58 @@
(setq nneething-map nil)
(setq nneething-active (cons 1 0))
(nneething-create-mapping)
(setq nneething-group-alist
(cons (list group dir nneething-map nneething-active)
nneething-group-alist)))))))
(push (list group dir nneething-map nneething-active)
nneething-group-alist))))))
(defun nneething-map-file ()
;; We make sure that the .nneething directory exists.
(make-directory nneething-map-file-directory 'parents)
(unless (file-exists-p nneething-map-file-directory)
(make-directory nneething-map-file-directory 'parents))
;; We store it in a special directory under the user's home dir.
(concat (file-name-as-directory nneething-map-file-directory)
nneething-group nneething-map-file))
(defun nneething-create-mapping ()
;; Read nneething-active and nneething-map
;; Read nneething-active and nneething-map.
(let ((map-file (nneething-map-file))
(files (directory-files nneething-directory))
touched)
touched map-files)
(if (file-exists-p map-file)
(condition-case nil
(load map-file nil t t)
(error nil)))
(or nneething-active (setq nneething-active (cons 1 0)))
;; Remove files matching that regexp.
(let ((f files)
prev)
(while f
(if (string-match nneething-exclude-files (car f))
(if prev (setcdr prev (cdr f))
(setq files (cdr files)))
(setq prev f))
(setq f (cdr f))))
;; Remove files that have disappeared from the map.
;; Old nneething had a different map format.
(when (and (cdar nneething-map)
(atom (cdar nneething-map)))
(setq nneething-map
(mapcar (lambda (n)
(list (cdr n) (car n)
(nth 5 (file-attributes
(nneething-file-name (car n))))))
nneething-map)))
;; Remove files matching the exclusion regexp.
(when nneething-exclude-files
(let ((f files)
prev)
(while f
(if (string-match nneething-exclude-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 (member (car (car map)) files)
(setq prev map)
(if (and (member (cadar map) files)
;; We also remove files that have changed mod times.
(equal (nth 5 (file-attributes
(nneething-file-name (cadar map))))
(caddar map)))
(progn
(push (cadar map) map-files)
(setq prev map))
(setq touched t)
(if prev
(setcdr prev (cdr map))
@ -241,60 +234,87 @@
(setq map (cdr map))))
;; Find all new files and enter them into the map.
(while files
(or (assoc (car files) nneething-map) ; If already in the map, ignore.
(progn
(setq touched t)
(setcdr nneething-active (1+ (cdr nneething-active)))
(setq nneething-map
(cons (cons (car files) (cdr nneething-active)) nneething-map))))
(unless (member (car files) map-files)
;; This file is not in the map, so we enter it.
(setq touched t)
(setcdr nneething-active (1+ (cdr nneething-active)))
(push (list (cdr nneething-active) (car files)
(nth 5 (file-attributes
(nneething-file-name (car files)))))
nneething-map))
(setq files (cdr files)))
(if (or (not touched) nneething-read-only)
()
(when (and touched
(not nneething-read-only))
(save-excursion
(set-buffer (get-buffer-create " *nneething map*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(nnheader-set-temp-buffer " *nneething map*")
(insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
"(setq nneething-active '" (prin1-to-string nneething-active)
")\n")
(write-region (point-min) (point-max) map-file nil 'nomesg)
(kill-buffer (current-buffer))))))
(defvar nneething-message-id-number 0)
(defvar nneething-work-buffer " *nneething work*")
(defun nneething-insert-head (file)
(and (nneething-get-head file)
(insert-buffer-substring nneething-work-buffer)))
"Insert the head of FILE."
(when (nneething-get-head file)
(insert-buffer-substring nneething-work-buffer)
(goto-char (point-max))))
(defun nneething-make-head (file)
(defun nneething-make-head (file &optional buffer)
"Create a head by looking at the file attributes of FILE."
(let ((atts (file-attributes file)))
(insert "Subject: " (file-name-nondirectory file) "\n"
"Message-ID: <nneething-"
(int-to-string
(setq nneething-message-id-number
(1+ nneething-message-id-number)))
"@" (system-name) ">\n"
"Date: " (current-time-string (nth 5 atts)) "\n"
(nneething-from-line (nth 2 atts))
"Chars: " (int-to-string (nth 7 atts)) "\n")))
(insert
"Subject: " (file-name-nondirectory file) "\n"
"Message-ID: <nneething-"
(int-to-string (incf nneething-message-id-number))
"@" (system-name) ">\n"
(if (equal '(0 0) (nth 5 atts)) ""
(concat "Date: " (current-time-string (nth 5 atts)) "\n"))
(or (if buffer
(save-excursion
(set-buffer buffer)
(if (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
(concat "From: " (match-string 0) "\n"))))
(nneething-from-line (nth 2 atts) file))
(if (> (string-to-int (int-to-string (nth 7 atts))) 0)
(concat "Chars: " (int-to-string (nth 7 atts)) "\n")
"")
(if buffer
(save-excursion
(set-buffer buffer)
(concat "Lines: " (int-to-string
(count-lines (point-min) (point-max))) "\n"))
"")
)))
(defun nneething-from-line (uid)
(let ((login (condition-case nil
(user-login-name uid)
(defun nneething-from-line (uid &optional file)
"Return a From header based of UID."
(let* ((login (condition-case nil
(user-login-name uid)
(error
(cond ((= uid (user-uid)) (user-login-name))
((zerop uid) "root")
(t (int-to-string uid))))))
(name (condition-case nil
(user-full-name uid)
(error
(cond ((= uid (user-uid)) (user-login-name))
((zerop uid) "root")
(t (int-to-string uid))))))
(name (condition-case nil
(user-full-name uid)
(error
(cond ((= uid (user-uid)) (user-full-name))
((zerop uid) "Ms. Root"))))))
(concat "From: " login "@" (system-name)
(cond ((= uid (user-uid)) (user-full-name))
((zerop uid) "Ms. Root")))))
(host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
(prog1
(substring file
(match-beginning 1)
(match-end 1))
(if (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
(setq login (substring file
(match-beginning 2)
(match-end 2))
name nil)))
(system-name))))
(concat "From: " login "@" host
(if name (concat " (" name ")") "") "\n")))
(defun nneething-get-head (file)
"Either find the head in FILE or make a head for FILE."
(save-excursion
(set-buffer (get-buffer-create nneething-work-buffer))
(setq case-fold-search nil)
@ -319,16 +339,16 @@
(1- (point)))
(point-max)))
(point-max))
(erase-buffer)
(nneething-make-head file))
(goto-char (point-min))
(nneething-make-head file (current-buffer))
(delete-region (point) (point-max)))
t))))
(defun nneething-number-to-file (number)
(car (rassq number nneething-map)))
(defun nneething-file-name (article)
"Return the file name of ARTICLE."
(concat (file-name-as-directory nneething-directory)
(if (numberp article) (nneething-number-to-file article)
(if (numberp article)
(cadr (assq article nneething-map))
article)))
(provide 'nneething)

941
lisp/nnfolder.el
View File

File diff suppressed because it is too large Load Diff

671
lisp/nnheader.el
View File

@ -1,6 +1,5 @@
;;; nnheader.el --- header access macros for Gnus and its backends
;; Copyright (C) 1987,88,89,90,93,94,95 Free Software Foundation, Inc.
;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
@ -25,10 +24,10 @@
;;; Commentary:
;; These macros may look very much like the ones in GNUS 4.1. They
;; 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. Makes
;; it possible to read headers from XOVER much faster.
;; 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]
@ -38,110 +37,237 @@
;;; Code:
(defalias 'nntp-header-number 'mail-header-number)
(require 'mail-utils)
(eval-when-compile (require 'cl))
(defvar nnheader-max-head-length 4096
"*Max length of the head of articles.")
(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
on your system, you could say something like:
\(setq nnheader-file-name-translation-alist '((?: . ?_)))")
;;; Header access macros.
(defmacro mail-header-number (header)
"Return article number in HEADER."
(` (aref (, header) 0)))
`(aref ,header 0))
(defalias 'nntp-set-header-number 'mail-header-set-number)
(defmacro mail-header-set-number (header number)
"Set article number of HEADER to NUMBER."
(` (aset (, header) 0 (, number))))
`(aset ,header 0 ,number))
(defalias 'nntp-header-subject 'mail-header-subject)
(defmacro mail-header-subject (header)
"Return subject string in HEADER."
(` (aref (, header) 1)))
`(aref ,header 1))
(defalias 'nntp-set-header-subject 'mail-header-set-subject)
(defmacro mail-header-set-subject (header subject)
"Set article subject of HEADER to SUBJECT."
(` (aset (, header) 1 (, subject))))
`(aset ,header 1 ,subject))
(defalias 'nntp-header-from 'mail-header-from)
(defmacro mail-header-from (header)
"Return author string in HEADER."
(` (aref (, header) 2)))
`(aref ,header 2))
(defalias 'nntp-set-header-from 'mail-header-set-from)
(defmacro mail-header-set-from (header from)
"Set article author of HEADER to FROM."
(` (aset (, header) 2 (, from))))
`(aset ,header 2 ,from))
(defalias 'nntp-header-date 'mail-header-date)
(defmacro mail-header-date (header)
"Return date in HEADER."
(` (aref (, header) 3)))
`(aref ,header 3))
(defalias 'nntp-set-header-date 'mail-header-set-date)
(defmacro mail-header-set-date (header date)
"Set article date of HEADER to DATE."
(` (aset (, header) 3 (, date))))
`(aset ,header 3 ,date))
(defalias 'nntp-header-id 'mail-header-id)
(defalias 'mail-header-message-id 'mail-header-id)
(defmacro mail-header-id (header)
"Return Id in HEADER."
(` (aref (, header) 4)))
`(aref ,header 4))
(defalias 'nntp-set-header-id 'mail-header-set-id)
(defalias 'mail-header-set-message-id 'mail-header-set-id)
(defmacro mail-header-set-id (header id)
"Set article Id of HEADER to ID."
(` (aset (, header) 4 (, id))))
`(aset ,header 4 ,id))
(defalias 'nntp-header-references 'mail-header-references)
(defmacro mail-header-references (header)
"Return references in HEADER."
(` (aref (, header) 5)))
`(aref ,header 5))
(defalias 'nntp-set-header-references 'mail-header-set-references)
(defmacro mail-header-set-references (header ref)
"Set article references of HEADER to REF."
(` (aset (, header) 5 (, ref))))
`(aset ,header 5 ,ref))
(defalias 'nntp-header-chars 'mail-header-chars)
(defmacro mail-header-chars (header)
"Return number of chars of article in HEADER."
(` (aref (, header) 6)))
`(aref ,header 6))
(defalias 'nntp-set-header-chars 'mail-header-set-chars)
(defmacro mail-header-set-chars (header chars)
"Set number of chars in article of HEADER to CHARS."
(` (aset (, header) 6 (, chars))))
`(aset ,header 6 ,chars))
(defalias 'nntp-header-lines 'mail-header-lines)
(defmacro mail-header-lines (header)
"Return lines in HEADER."
(` (aref (, header) 7)))
`(aref ,header 7))
(defalias 'nntp-set-header-lines 'mail-header-set-lines)
(defmacro mail-header-set-lines (header lines)
"Set article lines of HEADER to LINES."
(` (aset (, header) 7 (, lines))))
`(aset ,header 7 ,lines))
(defalias 'nntp-header-xref 'mail-header-xref)
(defmacro mail-header-xref (header)
"Return xref string in HEADER."
(` (aref (, header) 8)))
`(aref ,header 8))
(defalias 'nntp-set-header-xref 'mail-header-set-xref)
(defmacro mail-header-set-xref (header xref)
"Set article xref of HEADER to xref."
(` (aset (, header) 8 (, xref))))
`(aset ,header 8 ,xref))
(defun make-mail-header (&optional init)
"Create a new mail header structure initialized with INIT."
(make-vector 9 init))
;; Parsing headers and NOV lines.
(defsubst nnheader-header-value ()
(buffer-substring (match-end 0) (gnus-point-at-eol)))
(defvar nnheader-newsgroup-none-id 1)
(defun nnheader-parse-head (&optional naked)
(let ((case-fold-search t)
(cur (current-buffer))
(buffer-read-only nil)
end ref in-reply-to lines p)
(goto-char (point-min))
(when naked
(insert "\n"))
;; Search to the beginning of the next header. Error messages
;; do not begin with 2 or 3.
(prog1
(when (or naked (re-search-forward "^[23][0-9]+ " nil t))
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and
;; a case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance
;; doesn't always go hand in hand.
(vector
;; Number.
(if naked
(progn
(setq p (point-min))
0)
(prog1
(read cur)
(end-of-line)
(setq p (point))
(narrow-to-region (point)
(or (and (search-forward "\n.\n" nil t)
(- (point) 2))
(point)))))
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject: " nil t)
(nnheader-header-value) "(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom: " nil t)
(nnheader-header-value) "(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate: " nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(if (search-forward "\nmessage-id: " nil t)
(nnheader-header-value)
;; If there was no message-id, we just fake one to make
;; subsequent routines simpler.
(concat "none+"
(int-to-string
(incf nnheader-newsgroup-none-id)))))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences: " nil t)
(nnheader-header-value)
;; Get the references from the in-reply-to header if there
;; were no references and the in-reply-to header looks
;; promising.
(if (and (search-forward "\nin-reply-to: " nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^>]+>" in-reply-to))
(substring in-reply-to (match-beginning 0)
(match-end 0))
"")))
;; Chars.
0
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (read cur)))
lines 0)
0))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref: " nil t)
(nnheader-header-value)))))
(when naked
(goto-char (point-min))
(delete-char 1)))))
(defun nnheader-insert-nov (header)
(princ (mail-header-number header) (current-buffer))
(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) "\t"))
(insert "\n"))
(defun nnheader-insert-article-line (article)
(goto-char (point-min))
(insert "220 ")
(princ article (current-buffer))
(insert " Article retrieved.\n")
(search-forward "\n\n" nil 'move)
(delete-region (point) (point-max))
(forward-char -1)
(insert "."))
;; Various cruft the backends and Gnus need to communicate.
(defvar nntp-server-buffer nil)
(defvar gnus-verbose-backends t
"*If non-nil, Gnus backends will generate lots of comments.")
(defvar gnus-verbose-backends 7
"*A number that says how talkative the Gnus backends should be.")
(defvar gnus-nov-is-evil nil
"If non-nil, Gnus backends will never output headers in the NOV format.")
(defvar news-reply-yank-from nil)
(defvar news-reply-yank-message-id nil)
;; All backends use this function, so I moved it to this file.
(defvar nnheader-callback-function nil)
(defun nnheader-init-server-buffer ()
"Initialize the Gnus-backend communication buffer."
(save-excursion
(setq nntp-server-buffer (get-buffer-create " *nntpd*"))
(set-buffer nntp-server-buffer)
@ -151,62 +277,41 @@
(setq case-fold-search t) ;Should ignore case.
t))
(defun nnheader-set-init-variables (server defs)
(let ((s server)
val)
;; First we set the server variables in the sequence required. We
;; use the definitions from the `defs' list where that is
;; possible.
(while s
(set (car (car s))
(if (setq val (assq (car (car s)) defs))
(nth 1 val)
(nth 1 (car s))))
(setq s (cdr s)))
;; The we go through the defs list and set any variables that were
;; not set in the first sweep.
(while defs
(if (not (assq (car (car defs)) server))
(set (car (car defs))
(if (and (symbolp (nth 1 (car defs)))
(not (boundp (nth 1 (car defs)))))
(nth 1 (car defs))
(eval (nth 1 (car defs))))))
(setq defs (cdr defs)))))
(defun nnheader-save-variables (server)
(let (out)
(while server
(setq out (cons (list (car (car server))
(symbol-value (car (car server))))
out))
(setq server (cdr server)))
(nreverse out)))
;;; Various functions the backends use.
(defun nnheader-restore-variables (state)
(while state
(set (car (car state)) (nth 1 (car state)))
(setq state (cdr state))))
(defvar nnheader-max-head-length 4096
"The maximum length of a HEAD.")
(defun nnheader-file-error (file)
"Return a string that says what is wrong with FILE."
(format
(cond
((not (file-exists-p file))
"%s does not exist")
((file-directory-p file)
"%s is a directory")
((not (file-readable-p file))
"%s is not readable"))
file))
(defun nnheader-insert-head (file)
"Insert the head of the article."
(if (eq nnheader-max-head-length t)
;; Just read the entire file.
(insert-file-contents-literally file)
;; Read 1K blocks until we find a separator.
(let ((beg 0)
(chop 1024))
(while (and (eq chop (nth 1 (insert-file-contents-literally
file nil beg (setq beg (+ beg chop)))))
(prog1 (not (search-forward "\n\n" nil t))
(goto-char (point-max)))
(or (null nnheader-max-head-length)
(< beg nnheader-max-head-length)))))))
(when (file-exists-p file)
(if (eq nnheader-max-head-length t)
;; Just read the entire file.
(nnheader-insert-file-contents-literally file)
;; Read 1K blocks until we find a separator.
(let ((beg 0)
format-alist
(chop 1024))
(while (and (eq chop (nth 1 (insert-file-contents
file nil beg (incf beg chop))))
(prog1 (not (search-forward "\n\n" nil t))
(goto-char (point-max)))
(or (null nnheader-max-head-length)
(< beg nnheader-max-head-length))))))
t))
(defun nnheader-article-p ()
"Say whether the current buffer looks like an article."
(goto-char (point-min))
(if (not (search-forward "\n\n" nil t))
nil
@ -218,152 +323,264 @@
(eobp)
(widen))))
;; Written by Erik Naggum <erik@naggum.no>.
(defun nnheader-insert-file-contents-literally (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 ( ; (file-name-handler-alist nil)
(format-alist nil)
(after-insert-file-functions nil)
(find-buffer-file-type-function
(if (fboundp 'find-buffer-file-type)
(symbol-function 'find-buffer-file-type)
nil)))
(unwind-protect
(progn
(fset 'find-buffer-file-type (lambda (filename) t))
(insert-file-contents filename visit beg end replace))
(if find-buffer-file-type-function
(fset 'find-buffer-file-type find-buffer-file-type-function)
(fmakunbound 'find-buffer-file-type)))))
(defun nnheader-find-file-noselect (filename &optional nowarn rawfile)
"Read file FILENAME into a buffer and return the buffer.
If a buffer exists visiting FILENAME, return that one, but
verify that the file has not changed since visited or saved.
The buffer is not selected, just returned to the caller."
(setq filename
(abbreviate-file-name
(expand-file-name filename)))
(if (file-directory-p filename)
(if find-file-run-dired
(dired-noselect filename)
(error "%s is a directory." filename))
(let* ((buf (get-file-buffer filename))
(truename (abbreviate-file-name (file-truename filename)))
(number (nthcdr 10 (file-attributes truename)))
;; Find any buffer for a file which has same truename.
(other (and (not buf)
(if (fboundp 'find-buffer-visiting)
(find-buffer-visiting filename)
(get-file-buffer filename))))
error)
;; Let user know if there is a buffer with the same truename.
(if other
(progn
(or nowarn
(string-equal filename (buffer-file-name other))
(message "%s and %s are the same file"
filename (buffer-file-name other)))
;; Optionally also find that buffer.
(if (or (and (boundp 'find-file-existing-other-name)
find-file-existing-other-name)
find-file-visit-truename)
(setq buf other))))
(if buf
(or nowarn
(verify-visited-file-modtime buf)
(cond ((not (file-exists-p filename))
(error "File %s no longer exists!" filename))
((yes-or-no-p
(if (string= (file-name-nondirectory filename)
(buffer-name buf))
(format
(if (buffer-modified-p buf)
"File %s changed on disk. Discard your edits? "
"File %s changed on disk. Reread from disk? ")
(file-name-nondirectory filename))
(format
(if (buffer-modified-p buf)
"File %s changed on disk. Discard your edits in %s? "
"File %s changed on disk. Reread from disk into %s? ")
(file-name-nondirectory filename)
(buffer-name buf))))
(save-excursion
(set-buffer buf)
(revert-buffer t t)))))
(save-excursion
;;; The truename stuff makes this obsolete.
;;; (let* ((link-name (car (file-attributes filename)))
;;; (linked-buf (and (stringp link-name)
;;; (get-file-buffer link-name))))
;;; (if (bufferp linked-buf)
;;; (message "Symbolic link to file in buffer %s"
;;; (buffer-name linked-buf))))
(setq buf (create-file-buffer filename))
;; (set-buffer-major-mode buf)
(set-buffer buf)
(erase-buffer)
(if rawfile
(condition-case ()
(nnheader-insert-file-contents-literally filename t)
(file-error
;; Unconditionally set error
(setq error t)))
(condition-case ()
(insert-file-contents filename t)
(file-error
;; Run find-file-not-found-hooks until one returns non-nil.
(or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks)
;; If they fail too, set error.
(setq error t)))))
;; Find the file's truename, and maybe use that as visited name.
(setq buffer-file-truename truename)
(setq buffer-file-number number)
;; On VMS, we may want to remember which directory in a search list
;; the file was found in.
(and (eq system-type 'vax-vms)
(let (logical)
(if (string-match ":" (file-name-directory filename))
(setq logical (substring (file-name-directory filename)
0 (match-beginning 0))))
(not (member logical find-file-not-true-dirname-list)))
(setq buffer-file-name buffer-file-truename))
(if find-file-visit-truename
(setq buffer-file-name
(setq filename
(expand-file-name buffer-file-truename))))
;; Set buffer's default directory to that of the file.
(setq default-directory (file-name-directory filename))
;; Turn off backup files for certain file names. Since
;; this is a permanent local, the major mode won't eliminate it.
(and (not (funcall backup-enable-predicate buffer-file-name))
(progn
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
(if rawfile
nil
(after-find-file error (not nowarn)))))
buf)))
(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 illegal, but not all articles have Message-IDs.
(mail-position-on-field "References")
;; Fold long references line to follow RFC1036.
(let ((begin (gnus-point-at-bol))
(let ((begin (save-excursion (beginning-of-line) (point)))
(fill-column 78)
(fill-prefix "\t"))
(if references (insert references))
(if (and references message-id) (insert " "))
(if message-id (insert message-id))
;; Fold long References lines to conform to RFC1036 (sort of).
;; The region must end with a newline to fill the region
;; without inserting extra newline.
(fill-region-as-paragraph begin (1+ (point))))))
(defun nnheader-replace-header (header new-value)
"Remove HEADER and insert the NEW-VALUE."
(save-excursion
(save-restriction
(nnheader-narrow-to-headers)
(prog1
(message-remove-header header)
(goto-char (point-max))
(insert header ": " new-value "\n")))))
(defun nnheader-narrow-to-headers ()
"Narrow to the head of an article."
(widen)
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(1- (point))
(point-max)))
(goto-char (point-min)))
(defun nnheader-set-temp-buffer (name)
"Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
(set-buffer (get-buffer-create name))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(current-buffer))
(defmacro nnheader-temp-write (file &rest forms)
"Create a new buffer, evaluate FORM there, and write the buffer to FILE."
`(save-excursion
(let ((nnheader-temp-file ,file)
(nnheader-temp-cur-buffer
(nnheader-set-temp-buffer
(generate-new-buffer-name " *nnheader temp*"))))
(when (and nnheader-temp-file
(not (file-directory-p (file-name-directory
nnheader-temp-file))))
(make-directory (file-name-directory nnheader-temp-file) t))
(unwind-protect
(prog1
(progn
,@forms)
(when nnheader-temp-file
(set-buffer nnheader-temp-cur-buffer)
(write-region (point-min) (point-max)
nnheader-temp-file nil 'nomesg)))
(when (buffer-name nnheader-temp-cur-buffer)
(kill-buffer nnheader-temp-cur-buffer))))))
(put 'nnheader-temp-write 'lisp-indent-function 1)
(put 'nnheader-temp-write 'lisp-indent-hook 1)
(put 'nnheader-temp-write 'edebug-form-spec '(form body))
(defvar jka-compr-compression-info-list)
(defvar nnheader-numerical-files
(if (boundp 'jka-compr-compression-info-list)
(concat "\\([0-9]+\\)\\("
(mapconcat (lambda (i) (aref i 0))
jka-compr-compression-info-list "\\|")
"\\)?")
"[0-9]+$")
"Regexp that match numerical files.")
(defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
"Regexp that matches numerical file names.")
(defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
"Regexp that matches numerical full file paths.")
(defsubst nnheader-file-to-number (file)
"Take a file name and return the article number."
(if (not (boundp 'jka-compr-compression-info-list))
(string-to-int file)
(string-match nnheader-numerical-short-files file)
(string-to-int (match-string 0 file))))
(defun nnheader-directory-files-safe (&rest args)
;; It has been reported numerous times that `directory-files'
;; fails with an alarming frequency on NFS mounted file systems.
;; This function executes that function twice and returns
;; the longest result.
(let ((first (apply 'directory-files args))
(second (apply 'directory-files args)))
(if (> (length first) (length second))
first
second)))
(defun nnheader-directory-articles (dir)
"Return a list of all article files in a directory."
(mapcar 'nnheader-file-to-number
(nnheader-directory-files-safe
dir nil nnheader-numerical-short-files t)))
(defun nnheader-article-to-file-alist (dir)
"Return an alist of article/file pairs in DIR."
(mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
(nnheader-directory-files-safe
dir nil nnheader-numerical-short-files t)))
(defun nnheader-fold-continuation-lines ()
"Fold continuation lines in the current buffer."
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t)))
(defun nnheader-translate-file-chars (file)
(if (null nnheader-file-name-translation-alist)
;; No translation is necessary.
file
;; We translate -- but only the file name. We leave the directory
;; alone.
(let* ((i 0)
trans leaf path len)
(if (string-match "/[^/]+\\'" file)
;; This is needed on NT's and stuff.
(setq leaf (substring file (1+ (match-beginning 0)))
path (substring file 0 (1+ (match-beginning 0))))
;; Fall back on this.
(setq leaf (file-name-nondirectory file)
path (file-name-directory file)))
(setq len (length leaf))
(while (< i len)
(when (setq trans (cdr (assq (aref leaf i)
nnheader-file-name-translation-alist)))
(aset leaf i trans))
(incf i))
(concat path leaf))))
(defun nnheader-report (backend &rest args)
"Report an error from the BACKEND.
The first string in ARGS can be a format string."
(set (intern (format "%s-status-string" backend))
(if (< (length args) 2)
(car args)
(apply 'format args)))
nil)
(defun nnheader-get-report (backend)
(message "%s" (symbol-value (intern (format "%s-status-string" backend)))))
(defun nnheader-insert (format &rest args)
"Clear the communicaton buffer and insert FORMAT and ARGS into the buffer.
If FORMAT isn't a format string, it and all ARGS will be inserted
without formatting."
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if (string-match "%" format)
(insert (apply 'format format args))
(apply 'insert format args))
t))
(defun nnheader-mail-file-mbox-p (file)
"Say whether FILE looks like an Unix mbox file."
(when (and (file-exists-p file)
(file-readable-p file)
(file-regular-p file))
(save-excursion
(nnheader-set-temp-buffer " *mail-file-mbox-p*")
(nnheader-insert-file-contents-literally file)
(goto-char (point-min))
(prog1
(looking-at message-unix-mail-delimiter)
(kill-buffer (current-buffer))))))
(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)
(if (= (aref string idx) from)
(aset string idx to))
(setq idx (1+ idx)))
string))
(defun nnheader-file-to-group (file &optional top)
"Return a group name based on FILE and TOP."
(nnheader-replace-chars-in-string
(if (not top)
file
(condition-case ()
(substring (expand-file-name file)
(length
(expand-file-name
(file-name-as-directory top))))
(error "")))
?/ ?.))
(defun nnheader-message (level &rest args)
"Message if the Gnus backends are talkative."
(if (or (not (numberp gnus-verbose-backends))
(<= level gnus-verbose-backends))
(apply 'message args)
(apply 'format args)))
(defun nnheader-be-verbose (level)
"Return whether the backends should be verbose on LEVEL."
(or (not (numberp gnus-verbose-backends))
(<= level gnus-verbose-backends)))
(defun nnheader-group-pathname (group dir &optional file)
"Make pathname for GROUP."
(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 (nnheader-replace-chars-in-string group ?. ?/) "/")))
(cond ((null file) "")
((numberp file) (int-to-string file))
(t file))))
(defun nnheader-functionp (form)
"Return non-nil if FORM is funcallable."
(or (and (symbolp form) (fboundp form))
(and (listp form) (eq (car form) 'lambda))))
(defun nnheader-concat (dir file)
"Concat DIR as directory to FILE."
(concat (file-name-as-directory dir) file))
(defun nnheader-ms-strip-cr ()
"Strip ^M from the end of all lines."
(save-excursion
(goto-char (point-min))
(while (re-search-forward "\r$" nil t)
(delete-backward-char 1))))
(fset 'nnheader-run-at-time 'run-at-time)
(fset 'nnheader-cancel-timer 'cancel-timer)
(fset 'nnheader-find-file-noselect 'find-file-noselect)
(fset 'nnheader-insert-file-contents-literally
'insert-file-contents-literally)
(when (string-match "XEmacs\\|Lucid" emacs-version)
(require 'nnheaderxm))
(run-hooks 'nnheader-load-hook)
(provide 'nnheader)
;;; nnheader.el ends here

180
lisp/nnkiboze.el
View File

@ -1,6 +1,5 @@
;;; nnkiboze.el --- select virtual news access for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
@ -34,25 +33,35 @@
(require 'nnheader)
(require 'gnus)
(require 'gnus-score)
(require 'nnoo)
(eval-when-compile (require 'cl))
(defvar nnkiboze-directory
(expand-file-name (or gnus-article-save-directory "~/News/"))
(nnoo-declare nnkiboze)
(defvoo nnkiboze-directory gnus-directory
"nnkiboze will put its files in this directory.")
(defvoo nnkiboze-level 9
"*The maximum level to be searched for articles.")
(defvoo nnkiboze-remove-read-articles t
"*If non-nil, nnkiboze will remove read articles from the kiboze group.")
(defconst nnkiboze-version "nnkiboze 1.0"
"Version numbers of this version of nnkiboze.")
(defvar nnkiboze-current-group nil)
(defvar nnkiboze-current-score-group "")
(defvar nnkiboze-status-string "")
(defvoo nnkiboze-current-group nil)
(defvoo nnkiboze-current-score-group "")
(defvoo nnkiboze-status-string "")
;;; Interface functions.
(defun nnkiboze-retrieve-headers (articles &optional group server)
(nnoo-define-basics nnkiboze)
(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old)
(nnkiboze-possibly-change-newsgroups group)
(if gnus-nov-is-evil
nil
@ -78,36 +87,22 @@
(if (not (eobp)) (delete-region (point) (point-max)))
'nov))))))
(defun nnkiboze-open-server (newsgroups &optional something)
"Open a virtual newsgroup that contains NEWSGROUPS."
(deffoo nnkiboze-open-server (newsgroups &optional something)
(gnus-make-directory nnkiboze-directory)
(nnheader-init-server-buffer))
(defun nnkiboze-close-server (&rest dum)
"Close news server."
t)
(defalias 'nnkiboze-request-quit (symbol-function 'nnkiboze-close-server))
(defun nnkiboze-server-opened (&optional server)
"Return server process status, T or NIL.
If the stream is opened, return T, otherwise return NIL."
(deffoo nnkiboze-server-opened (&optional server)
(and nntp-server-buffer
(get-buffer nntp-server-buffer)))
(defun nnkiboze-status-message (&optional server)
"Return server status response as string."
nnkiboze-status-string)
(defun nnkiboze-request-article (article &optional newsgroup server buffer)
"Select article by message number."
(deffoo nnkiboze-request-article (article &optional newsgroup server buffer)
(nnkiboze-possibly-change-newsgroups newsgroup)
(if (not (numberp article))
;; This is a real kludge. It might not work at times, but it
;; does no harm I think. The only alternative is to offer no
;; article fetching by message-id at all.
(nntp-request-article article newsgroup gnus-nntp-server buffer)
(let* ((header (gnus-get-header-by-number article))
(let* ((header (gnus-summary-article-header article))
(xref (mail-header-xref header))
igroup iarticle)
(or xref (error "nnkiboze: No xref"))
@ -119,7 +114,7 @@ If the stream is opened, return T, otherwise return NIL."
(and (gnus-request-group igroup t)
(gnus-request-article iarticle igroup buffer)))))
(defun nnkiboze-request-group (group &optional server dont-check)
(deffoo nnkiboze-request-group (group &optional server dont-check)
"Make GROUP the current newsgroup."
(nnkiboze-possibly-change-newsgroups group)
(if dont-check
@ -144,15 +139,16 @@ If the stream is opened, return T, otherwise return NIL."
(insert (format "211 %d %d %d %s\n" total beg end group)))))))
t)
(defun nnkiboze-close-group (group &optional server)
(deffoo nnkiboze-close-group (group &optional server)
(nnkiboze-possibly-change-newsgroups group)
;; Remove NOV lines of articles that are marked as read.
(if (or (not (file-exists-p (nnkiboze-nov-file-name)))
(not (eq major-mode 'gnus-summary-mode)))
()
(when (and (file-exists-p (nnkiboze-nov-file-name))
nnkiboze-remove-read-articles
(eq major-mode 'gnus-summary-mode))
(save-excursion
(let ((unreads gnus-newsgroup-unreads)
(unselected gnus-newsgroup-unselected))
(unselected gnus-newsgroup-unselected)
(version-control 'never))
(set-buffer (get-buffer-create "*nnkiboze work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
@ -170,22 +166,28 @@ If the stream is opened, return T, otherwise return NIL."
(kill-buffer (current-buffer)))))
(setq nnkiboze-current-group nil)))
(defun nnkiboze-request-list (&optional server)
(setq nnkiboze-status-string "nnkiboze: LIST is not implemented.")
nil)
(deffoo nnkiboze-request-list (&optional server)
(nnheader-report 'nnkiboze "LIST is not implemented."))
(defun nnkiboze-request-newgroups (date &optional server)
(deffoo nnkiboze-request-newgroups (date &optional server)
"List new groups."
(setq nnkiboze-status-string "NEWGROUPS is not supported.")
nil)
(nnheader-report 'nnkiboze "NEWGROUPS is not supported."))
(defun nnkiboze-request-list-newsgroups (&optional server)
(setq nnkiboze-status-string "nnkiboze: LIST NEWSGROUPS is not implemented.")
nil)
(deffoo nnkiboze-request-list-newsgroups (&optional server)
(nnheader-report 'nnkiboze "LIST NEWSGROUPS is not implemented."))
(defalias 'nnkiboze-request-post 'nntp-request-post)
(defalias 'nnkiboze-request-post-buffer 'nntp-request-post-buffer)
(deffoo nnkiboze-request-delete-group (group &optional force server)
(nnkiboze-possibly-change-newsgroups group)
(when force
(let ((files (list (nnkiboze-nov-file-name)
(concat nnkiboze-directory group ".newsrc")
(nnkiboze-score-file group))))
(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))
;;; Internal functions.
@ -207,16 +209,24 @@ Finds out what articles are to be part of the nnkiboze groups."
(gnus-expert-user t))
(gnus))
(let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
(newsrc gnus-newsrc-alist))
(newsrc gnus-newsrc-alist)
gnus-newsrc-hashtb)
(gnus-make-hashtable-from-newsrc-alist)
;; We have copied all the newsrc alist info over to local copies
;; so that we can mess all we want with these lists.
(while newsrc
(if (string-match "nnkiboze" (car (car newsrc)))
(nnkiboze-generate-group (car (car newsrc))))
(if (string-match "nnkiboze" (caar newsrc))
;; For each kiboze group, we call this function to generate
;; it.
(nnkiboze-generate-group (caar newsrc)))
(setq newsrc (cdr newsrc)))))
(defun nnkiboze-score-file (group)
(list (expand-file-name
(concat gnus-kill-files-directory nnkiboze-current-score-group
"." gnus-score-file-suffix))))
(concat (file-name-as-directory gnus-kill-files-directory)
(nnheader-translate-file-chars
(concat nnkiboze-current-score-group
"." gnus-score-file-suffix))))))
(defun nnkiboze-generate-group (group)
(let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
@ -225,15 +235,18 @@ Finds out what articles are to be part of the nnkiboze groups."
(regexp (nth 1 (nth 4 info)))
(gnus-expert-user t)
(gnus-large-newsgroup nil)
(version-control 'never)
(gnus-score-find-score-files-function 'nnkiboze-score-file)
gnus-select-group-hook gnus-summary-prepare-hook
gnus-thread-sort-functions gnus-show-threads
gnus-visual
method nnkiboze-newsrc nov-buffer gname newsrc active
ginfo lowest)
ginfo lowest glevel)
(setq nnkiboze-current-score-group group)
(or info (error "No such group: %s" group))
;; Load the kiboze newsrc file for this group.
(and (file-exists-p newsrc-file) (load newsrc-file))
;; We also load the nov file for this group.
(save-excursion
(set-buffer (setq nov-buffer (find-file-noselect nov-file)))
(buffer-disable-undo (current-buffer)))
@ -241,50 +254,76 @@ Finds out what articles are to be part of the nnkiboze groups."
;; kiboze regexp.
(mapatoms
(lambda (group)
(if (and (string-match regexp (setq gname (symbol-name group))) ; Match
(not (assoc gname nnkiboze-newsrc)) ; It isn't registered
(numberp (car (symbol-value group))) ; It is active
(not (string-match "^nnkiboze:" gname))) ; Exclude kibozes
(setq nnkiboze-newsrc
(cons (cons gname (1- (car (symbol-value group))))
nnkiboze-newsrc))))
(and (string-match regexp (setq gname (symbol-name group))) ; Match
(not (assoc gname nnkiboze-newsrc)) ; It isn't registered
(numberp (car (symbol-value group))) ; It is active
(or (> nnkiboze-level 7)
(and (setq glevel (nth 1 (nth 2 (gnus-gethash
gname gnus-newsrc-hashtb))))
(>= nnkiboze-level glevel)))
(not (string-match "^nnkiboze:" gname)) ; Exclude kibozes
(setq nnkiboze-newsrc
(cons (cons gname (1- (car (symbol-value group))))
nnkiboze-newsrc))))
gnus-active-hashtb)
;; `newsrc' is set to the list of groups that possibly are
;; component groups to this kiboze group. This list has elements
;; on the form `(GROUP . NUMBER)', where NUMBER is the highest
;; number that has been kibozed in GROUP in this kiboze group.
(setq newsrc nnkiboze-newsrc)
(while newsrc
(if (not (setq active (gnus-gethash
(car (car newsrc)) gnus-active-hashtb)))
(caar newsrc) gnus-active-hashtb)))
;; This group isn't active after all, so we remove it from
;; the list of component groups.
(setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
(setq lowest (cdar newsrc))
;; Ok, we have a valid component group, so we jump to it.
(switch-to-buffer gnus-group-buffer)
(gnus-group-jump-to-group (car (car newsrc)))
(if (and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name)
gnus-newsrc-hashtb)))
(nth 3 ginfo))
(setcar (nthcdr 3 ginfo) nil))
(gnus-group-jump-to-group (caar newsrc))
;; We set all list of article marks to nil. Since we operate
;; on copies of the real lists, we can destroy anything we
;; want here.
(and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name)
gnus-newsrc-hashtb)))
(nth 3 ginfo)
(setcar (nthcdr 3 ginfo) nil))
;; We set the list of read articles to be what we expect for
;; this kiboze group -- either nil or `(1 . LOWEST)'.
(and ginfo (setcar (nthcdr 2 ginfo)
(and (not (= lowest 1)) (cons 1 lowest))))
(if (not (and (or (not ginfo)
(> (length (gnus-list-of-unread-articles
(car ginfo))) 0))
(progn
(gnus-group-select-group nil)
(eq major-mode 'gnus-summary-mode))))
()
(setq lowest (cdr (car newsrc)))
() ; No unread articles, or we couldn't enter this group.
;; We are now in the group where we want to be.
(setq method (gnus-find-method-for-group gnus-newsgroup-name))
(and (eq method gnus-select-method) (setq method nil))
;; We go through the list of scored articles.
(while gnus-newsgroup-scored
(if (> (car (car gnus-newsgroup-scored)) lowest)
(if (> (caar gnus-newsgroup-scored) lowest)
;; If it has a good score, then we enter this article
;; into the kiboze group.
(nnkiboze-enter-nov
nov-buffer
(gnus-get-header-by-number (car (car gnus-newsgroup-scored)))
(gnus-summary-article-header
(caar gnus-newsgroup-scored))
(if method
(gnus-group-prefixed-name gnus-newsgroup-name method)
gnus-newsgroup-name)))
(setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
(gnus-summary-quit)))
;; That's it. We exit this group.
(gnus-summary-exit-no-update)))
(setcdr (car newsrc) (car active))
(setq newsrc (cdr newsrc)))
;; We save the nov file.
(set-buffer nov-buffer)
(save-buffer)
(kill-buffer (current-buffer))
;; We save the kiboze newsrc for this group.
(set-buffer (get-buffer-create "*nnkiboze work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
@ -340,8 +379,9 @@ Finds out what articles are to be part of the nnkiboze groups."
(insert prefix)))))))
(defun nnkiboze-nov-file-name ()
(concat nnkiboze-directory
(nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))
(concat (file-name-as-directory nnkiboze-directory)
(nnheader-translate-file-chars
(concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))))
(provide 'nnkiboze)

1188
lisp/nnmail.el
View File

File diff suppressed because it is too large Load Diff

475
lisp/nnmbox.el
View File

@ -1,6 +1,5 @@
;;; nnmbox.el --- mail mbox access for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -31,19 +30,23 @@
;;; Code:
(require 'nnheader)
(require 'rmail)
(require 'message)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(defvar nnmbox-mbox-file (expand-file-name "~/mbox")
(nnoo-declare nnmbox)
(defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
"The name of the mail box file in the user's home directory.")
(defvar nnmbox-active-file (expand-file-name "~/.mbox-active")
(defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
"The name of the active file for the mail box.")
(defvar nnmbox-get-new-mail t
(defvoo nnmbox-get-new-mail t
"If non-nil, nnmbox will check the incoming mail file and split the mail.")
(defvar nnmbox-prepare-save-mail-hook nil
(defvoo nnmbox-prepare-save-mail-hook nil
"Hook run narrowed to an article before saving.")
@ -51,191 +54,172 @@
(defconst nnmbox-version "nnmbox 1.0"
"nnmbox version.")
(defvar nnmbox-current-group nil
(defvoo nnmbox-current-group nil
"Current nnmbox news group directory.")
(defconst nnmbox-mbox-buffer nil)
(defvar nnmbox-status-string "")
(defvoo nnmbox-status-string "")
(defvar nnmbox-group-alist nil)
(defvar nnmbox-active-timestamp nil)
(defvar nnmbox-current-server nil)
(defvar nnmbox-server-alist nil)
(defvar nnmbox-server-variables
(list
(list 'nnmbox-mbox-file nnmbox-mbox-file)
(list 'nnmbox-active-file nnmbox-active-file)
(list 'nnmbox-get-new-mail nnmbox-get-new-mail)
'(nnmbox-current-group nil)
'(nnmbox-status-string "")
'(nnmbox-group-alist nil)))
(defvoo nnmbox-group-alist nil)
(defvoo nnmbox-active-timestamp nil)
;;; Interface functions
(defun nnmbox-retrieve-headers (sequence &optional newsgroup server)
(nnoo-define-basics nnmbox)
(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((number (length sequence))
(count 0)
article art-string start stop)
(nnmbox-possibly-change-newsgroup newsgroup)
(if (stringp (car sequence))
'headers
(while sequence
(setq article (car sequence))
(setq art-string (nnmbox-article-string article))
(set-buffer nnmbox-mbox-buffer)
(if (or (search-forward art-string nil t)
(progn (goto-char (point-min))
(search-forward art-string nil t)))
(progn
(setq start
(save-excursion
(re-search-backward
(concat "^" rmail-unix-mail-delimiter) nil t)
(point)))
(search-forward "\n\n" nil t)
(setq stop (1- (point)))
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nnmbox-mbox-buffer start stop)
(goto-char (point-max))
(insert ".\n")))
(setq sequence (cdr sequence))
(setq count (1+ count))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(zerop (% count 20))
gnus-verbose-backends
(message "nnmbox: Receiving headers... %d%%"
(/ (* count 100) number))))
(nnmbox-possibly-change-newsgroup newsgroup server)
(while sequence
(setq article (car sequence))
(setq art-string (nnmbox-article-string article))
(set-buffer nnmbox-mbox-buffer)
(if (or (search-forward art-string nil t)
(progn (goto-char (point-min))
(search-forward art-string nil t)))
(progn
(setq start
(save-excursion
(re-search-backward
(concat "^" message-unix-mail-delimiter) nil t)
(point)))
(search-forward "\n\n" nil t)
(setq stop (1- (point)))
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nnmbox-mbox-buffer start stop)
(goto-char (point-max))
(insert ".\n")))
(setq sequence (cdr sequence))
(setq count (1+ count))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
gnus-verbose-backends
(message "nnmbox: Receiving headers...done"))
(zerop (% count 20))
(nnheader-message 5 "nnmbox: Receiving headers... %d%%"
(/ (* count 100) number))))
;; Fold continuation lines.
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t))
'headers))))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(nnheader-message 5 "nnmbox: Receiving headers...done"))
(defun nnmbox-open-server (server &optional defs)
(nnheader-init-server-buffer)
(if (equal server nnmbox-current-server)
t
(if nnmbox-current-server
(setq nnmbox-server-alist
(cons (list nnmbox-current-server
(nnheader-save-variables nnmbox-server-variables))
nnmbox-server-alist)))
(let ((state (assoc server nnmbox-server-alist)))
(if state
(progn
(nnheader-restore-variables (nth 1 state))
(setq nnmbox-server-alist (delq state nnmbox-server-alist)))
(nnheader-set-init-variables nnmbox-server-variables defs)))
(setq nnmbox-current-server server)))
(set-buffer nntp-server-buffer)
(nnheader-fold-continuation-lines)
'headers)))
(defun nnmbox-close-server (&optional server)
(deffoo nnmbox-open-server (server &optional defs)
(nnoo-change-server 'nnmbox server defs)
(cond
((not (file-exists-p nnmbox-mbox-file))
(nnmbox-close-server)
(nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
((file-directory-p nnmbox-mbox-file)
(nnmbox-close-server)
(nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
(t
(nnheader-report 'nnmbox "Opened server %s using mbox %s" server
nnmbox-mbox-file)
t)))
(deffoo nnmbox-close-server (&optional server)
(when (and nnmbox-mbox-buffer
(buffer-name nnmbox-mbox-buffer))
(kill-buffer nnmbox-mbox-buffer))
(nnoo-close-server 'nnmbox server)
t)
(defun nnmbox-server-opened (&optional server)
(and (equal server nnmbox-current-server)
(deffoo nnmbox-server-opened (&optional server)
(and (nnoo-current-server-p 'nnmbox server)
nnmbox-mbox-buffer
(buffer-name nnmbox-mbox-buffer)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(defun nnmbox-status-message (&optional server)
nnmbox-status-string)
(defun nnmbox-request-article (article &optional newsgroup server buffer)
(nnmbox-possibly-change-newsgroup newsgroup)
(if (stringp article)
nil
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(if (search-forward (nnmbox-article-string article) nil t)
(let (start stop)
(re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
(setq start (point))
(forward-line 1)
(or (and (re-search-forward
(concat "^" rmail-unix-mail-delimiter) nil t)
(forward-line -1))
(goto-char (point-max)))
(setq stop (point))
(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring nnmbox-mbox-buffer start stop)
(goto-char (point-min))
(while (looking-at "From ")
(delete-char 5)
(insert "X-From-Line: ")
(forward-line 1))
t))))))
(defun nnmbox-request-group (group &optional server dont-check)
(deffoo nnmbox-request-article (article &optional newsgroup server buffer)
(nnmbox-possibly-change-newsgroup newsgroup server)
(save-excursion
(if (nnmbox-possibly-change-newsgroup group)
(if dont-check
t
(nnmbox-get-new-mail group)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(if (search-forward (nnmbox-article-string article) nil t)
(let (start stop)
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
(setq start (point))
(forward-line 1)
(or (and (re-search-forward
(concat "^" message-unix-mail-delimiter) nil t)
(forward-line -1))
(goto-char (point-max)))
(setq stop (point))
(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((active (assoc group nnmbox-group-alist)))
(insert (format "211 %d %d %d %s\n"
(1+ (- (cdr (car (cdr active)))
(car (car (cdr active)))))
(car (car (cdr active)))
(cdr (car (cdr active)))
(car active))))
t)))))
(insert-buffer-substring nnmbox-mbox-buffer start stop)
(goto-char (point-min))
(while (looking-at "From ")
(delete-char 5)
(insert "X-From-Line: ")
(forward-line 1))
(if (numberp article)
(cons nnmbox-current-group article)
(nnmbox-article-group-number)))))))
(defun nnmbox-close-group (group &optional server)
(deffoo nnmbox-request-group (group &optional server dont-check)
(let ((active (cadr (assoc group nnmbox-group-alist))))
(cond
((or (null active)
(null (nnmbox-possibly-change-newsgroup group server)))
(nnheader-report 'nnmbox "No such group: %s" group))
(dont-check
(nnheader-report 'nnmbox "Selected group %s" group)
(nnheader-insert ""))
(t
(nnheader-report 'nnmbox "Selected group %s" group)
(nnheader-insert "211 %d %d %d %s\n"
(1+ (- (cdr active) (car active)))
(car active) (cdr active) group)))))
(deffoo nnmbox-request-scan (&optional group server)
(nnmbox-read-mbox)
(nnmail-get-new-mail
'nnmbox
(lambda ()
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(save-buffer)))
nnmbox-mbox-file group
(lambda ()
(save-excursion
(let ((in-buf (current-buffer)))
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-max))
(insert-buffer-substring in-buf)))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
(deffoo nnmbox-close-group (group &optional server)
t)
(defun nnmbox-request-list (&optional server)
(if server (nnmbox-get-new-mail))
(deffoo nnmbox-request-list (&optional server)
(save-excursion
(or (nnmail-find-file nnmbox-active-file)
(progn
(setq nnmbox-group-alist (nnmail-get-active))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(nnmail-find-file nnmbox-active-file)))))
(nnmail-find-file nnmbox-active-file)
(setq nnmbox-group-alist (nnmail-get-active))))
(defun nnmbox-request-newgroups (date &optional server)
(deffoo nnmbox-request-newgroups (date &optional server)
(nnmbox-request-list server))
(defun nnmbox-request-list-newsgroups (&optional server)
(setq nnmbox-status-string "nnmbox: LIST NEWSGROUPS is not implemented.")
nil)
(deffoo nnmbox-request-list-newsgroups (&optional server)
(nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
(defun nnmbox-request-post (&optional server)
(mail-send-and-exit nil))
(defalias 'nnmbox-request-post-buffer 'nnmail-request-post-buffer)
(defun nnmbox-request-expire-articles
(deffoo nnmbox-request-expire-articles
(articles newsgroup &optional server force)
(nnmbox-possibly-change-newsgroup newsgroup)
(let* ((days (or (and nnmail-expiry-wait-function
(funcall nnmail-expiry-wait-function newsgroup))
nnmail-expiry-wait))
(is-old t)
(nnmbox-possibly-change-newsgroup newsgroup server)
(let* ((is-old t)
rest)
(nnmail-activate 'nnmbox)
@ -244,16 +228,14 @@
(while (and articles is-old)
(goto-char (point-min))
(if (search-forward (nnmbox-article-string (car articles)) nil t)
(if (or force
(setq is-old
(> (nnmail-days-between
(current-time-string)
(buffer-substring
(point) (progn (end-of-line) (point))))
days)))
(if (setq is-old
(nnmail-expired-article-p
newsgroup
(buffer-substring
(point) (progn (end-of-line) (point))) force))
(progn
(and gnus-verbose-backends
(message "Deleting article %s..." (car articles)))
(nnheader-message 5 "Deleting article %d in %s..."
(car articles) newsgroup)
(nnmbox-delete-mail))
(setq rest (cons (car articles) rest))))
(setq articles (cdr articles)))
@ -269,9 +251,9 @@
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(nconc rest articles))))
(defun nnmbox-request-move-article
(deffoo nnmbox-request-move-article
(article group server accept-form &optional last)
(nnmbox-possibly-change-newsgroup group)
(nnmbox-possibly-change-newsgroup group server)
(let ((buf (get-buffer-create " *nnmbox move*"))
result)
(and
@ -298,7 +280,9 @@
(and last (save-buffer))))
result))
(defun nnmbox-request-accept-article (group &optional last)
(deffoo nnmbox-request-accept-article (group &optional server last)
(nnmbox-possibly-change-newsgroup group server)
(nnmail-check-syntax)
(let ((buf (current-buffer))
result)
(goto-char (point-min))
@ -317,13 +301,14 @@
(setq result (nnmbox-save-mail (and (stringp group) group))))
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-max))
(insert-buffer-substring buf)
(and last (save-buffer))
result)
(nnmail-save-active nnmbox-group-alist nnmbox-active-file))
(car result)))
(defun nnmbox-request-replace-article (article group buffer)
(deffoo nnmbox-request-replace-article (article group buffer)
(nnmbox-possibly-change-newsgroup group)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
@ -335,6 +320,48 @@
(save-buffer)
t)))
(deffoo nnmbox-request-delete-group (group &optional force server)
(nnmbox-possibly-change-newsgroup group server)
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
;; Delete all articles in this group.
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
found)
(while (search-forward ident nil t)
(setq found t)
(nnmbox-delete-mail))
(and found (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)
t)
(deffoo nnmbox-request-rename-group (group new-name &optional server)
(nnmbox-possibly-change-newsgroup group server)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
(new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
found)
(while (search-forward ident nil t)
(replace-match new-ident t t)
(setq found t))
(and found (save-buffer))))
(let ((entry (assoc group nnmbox-group-alist)))
(and entry (setcar entry new-name))
(setq nnmbox-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
t))
;;; Internal functions.
@ -352,12 +379,12 @@
(save-restriction
(narrow-to-region
(save-excursion
(re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
(if leave-delim (progn (forward-line 1) (point))
(match-beginning 0)))
(progn
(forward-line 1)
(or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter)
(or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
nil t)
(if (and (not (bobp)) leave-delim)
(progn (forward-line -2) (point))
@ -368,7 +395,10 @@
(if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
(delete-region (point-min) (point-max))))))
(defun nnmbox-possibly-change-newsgroup (newsgroup)
(defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
(when (and server
(not (nnmbox-server-opened server)))
(nnmbox-open-server server))
(if (or (not nnmbox-mbox-buffer)
(not (buffer-name nnmbox-mbox-buffer)))
(save-excursion
@ -380,21 +410,45 @@
(nnmail-activate 'nnmbox))
(if newsgroup
(if (assoc newsgroup nnmbox-group-alist)
(setq nnmbox-current-group newsgroup))))
(setq nnmbox-current-group newsgroup))
t))
(defun nnmbox-article-string (article)
(concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
(int-to-string article) " "))
(if (numberp article)
(concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
(int-to-string article) " ")
(concat "\nMessage-ID: " article)))
(defun nnmbox-article-group-number ()
(save-excursion
(goto-char (point-min))
(and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
nil t)
(cons (buffer-substring (match-beginning 1) (match-end 1))
(string-to-int
(buffer-substring (match-beginning 2) (match-end 2)))))))
(defun nnmbox-save-mail (&optional group)
"Called narrowed to an article."
(let* ((nnmail-split-methods
(if group (list (list group "")) nnmail-split-methods))
(group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
(group-art (nreverse (nnmail-article-group 'nnmbox-active-number)))
(delim (concat "^" message-unix-mail-delimiter)))
(goto-char (point-min))
;; This might come from somewhere else.
(unless (looking-at delim)
(insert "From nobody " (current-time-string) "\n")
(goto-char (point-min)))
;; Quote all "From " lines in the article.
(forward-line 1)
(while (re-search-forward delim nil t)
(beginning-of-line)
(insert "> "))
(nnmail-insert-lines)
(nnmail-insert-xref group-art)
(nnmbox-insert-newsgroup-line group-art)
(run-hooks 'nnml-prepare-save-mail-hook)
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnmbox-prepare-save-mail-hook)
group-art))
(defun nnmbox-insert-newsgroup-line (group-art)
@ -405,14 +459,14 @@
(forward-char -1)
(while group-art
(insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
(car (car group-art)) (cdr (car group-art))
(caar group-art) (cdar group-art)
(current-time-string)))
(setq group-art (cdr group-art)))))
t))
(defun nnmbox-active-number (group)
;; Find the next article number in GROUP.
(let ((active (car (cdr (assoc group nnmbox-group-alist)))))
(let ((active (cadr (assoc group nnmbox-group-alist))))
(if active
(setcdr active (1+ (cdr active)))
;; This group is new, so we create a new entry for it.
@ -433,12 +487,29 @@
(= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file)))))
()
(save-excursion
(let ((delim (concat "^" rmail-unix-mail-delimiter))
start end)
(let ((delim (concat "^" message-unix-mail-delimiter))
(alist nnmbox-group-alist)
start end number)
(set-buffer (setq nnmbox-mbox-buffer
(nnheader-find-file-noselect
(nnheader-find-file-noselect
nnmbox-mbox-file nil 'raw)))
(buffer-disable-undo (current-buffer))
;; Go through the group alist and compare against
;; the mbox file.
(while alist
(goto-char (point-max))
(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 alist (cdr alist)))
(goto-char (point-min))
(while (re-search-forward delim nil t)
(setq start (match-beginning 0))
@ -457,54 +528,6 @@
(nnmbox-save-mail))))
(goto-char end))))))
(defun nnmbox-get-new-mail (&optional group)
"Read new incoming mail."
(let* ((spools (nnmail-get-spool-files group))
(group-in group)
incoming incomings)
(nnmbox-read-mbox)
(if (or (not nnmbox-get-new-mail) (not nnmail-spool-file))
()
;; We go through all the existing spool files and split the
;; mail from each.
(while spools
(and
(file-exists-p (car spools))
(> (nth 7 (file-attributes (car spools))) 0)
(progn
(and gnus-verbose-backends
(message "nnmbox: Reading incoming mail..."))
(if (not (setq incoming
(nnmail-move-inbox
(car spools)
(concat nnmbox-mbox-file "-Incoming"))))
()
(setq incomings (cons incoming incomings))
(save-excursion
(setq group (nnmail-get-split-group (car spools) group-in))
(let ((in-buf (nnmail-split-incoming
incoming 'nnmbox-save-mail t group)))
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-max))
(insert-buffer-substring in-buf)
(kill-buffer in-buf))))))
(setq spools (cdr spools)))
;; If we did indeed read any incoming spools, we save all info.
(and (buffer-modified-p nnmbox-mbox-buffer)
(save-excursion
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(set-buffer nnmbox-mbox-buffer)
(save-buffer)))
(if incomings (run-hooks 'nnmail-read-incoming-hook))
(while incomings
(setq incoming (car incomings))
(and nnmail-delete-incoming
(file-exists-p incoming)
(file-writable-p incoming)
(delete-file incoming))
(setq incomings (cdr incomings))))))
(provide 'nnmbox)
;;; nnmbox.el ends here

504
lisp/nnmh.el
View File

@ -1,6 +1,5 @@
;;; nnmh.el --- mhspool access for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -32,20 +31,23 @@
;;; Code:
(require 'nnheader)
(require 'rmail)
(require 'nnmail)
(require 'gnus)
(require 'nnoo)
(eval-and-compile (require 'cl))
(defvar nnmh-directory "~/Mail/"
(nnoo-declare nnmh)
(defvoo nnmh-directory message-directory
"*Mail spool directory.")
(defvar nnmh-get-new-mail t
(defvoo nnmh-get-new-mail t
"*If non-nil, nnmh will check the incoming mail file and split the mail.")
(defvar nnmh-prepare-save-mail-hook nil
(defvoo nnmh-prepare-save-mail-hook nil
"*Hook run narrowed to an article before saving.")
(defvar nnmh-be-safe nil
(defvoo nnmh-be-safe nil
"*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
@ -53,59 +55,49 @@
(defconst nnmh-version "nnmh 1.0"
"nnmh version.")
(defvar nnmh-current-directory nil
(defvoo nnmh-current-directory nil
"Current news group directory.")
(defvar nnmh-status-string "")
(defvar nnmh-group-alist nil)
(defvar nnmh-current-server nil)
(defvar nnmh-server-alist nil)
(defvar nnmh-server-variables
(list
(list 'nnmh-directory nnmh-directory)
(list 'nnmh-get-new-mail nnmh-get-new-mail)
'(nnmh-current-directory nil)
'(nnmh-status-string "")
'(nnmh-group-alist)))
(defvoo nnmh-status-string "")
(defvoo nnmh-group-alist nil)
;;; Interface functions.
(defun nnmh-retrieve-headers (sequence &optional newsgroup server)
(nnoo-define-basics nnmh)
(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let* ((file nil)
(number (length sequence))
(number (length articles))
(large (and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)))
(count 0)
beg article)
(nnmh-possibly-change-directory newsgroup)
(if (stringp (car sequence))
(nnmh-possibly-change-directory newsgroup server)
;; We don't support fetching by Message-ID.
(if (stringp (car articles))
'headers
(while sequence
(setq article (car sequence))
(setq file
(concat nnmh-current-directory (int-to-string article)))
(if (and (file-exists-p file)
(not (file-directory-p file)))
(progn
(insert (format "221 %d Article retrieved.\n" article))
(setq beg (point))
(nnheader-insert-head file)
(goto-char beg)
(if (search-forward "\n\n" nil t)
(forward-char -1)
(goto-char (point-max))
(insert "\n\n"))
(insert ".\n")
(delete-region (point) (point-max))))
(setq sequence (cdr sequence))
(while articles
(when (and (file-exists-p
(setq file (concat (file-name-as-directory
nnmh-current-directory)
(int-to-string
(setq article (pop articles))))))
(not (file-directory-p file)))
(insert (format "221 %d Article retrieved.\n" article))
(setq beg (point))
(nnheader-insert-head file)
(goto-char beg)
(if (search-forward "\n\n" nil t)
(forward-char -1)
(goto-char (point-max))
(insert "\n\n"))
(insert ".\n")
(delete-region (point) (point-max)))
(setq count (1+ count))
(and large
@ -115,42 +107,29 @@
(and large (message "nnmh: Receiving headers...done"))
;; Fold continuation lines.
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t))
(nnheader-fold-continuation-lines)
'headers))))
(defun nnmh-open-server (server &optional defs)
(nnheader-init-server-buffer)
(if (equal server nnmh-current-server)
t
(if nnmh-current-server
(setq nnmh-server-alist
(cons (list nnmh-current-server
(nnheader-save-variables nnmh-server-variables))
nnmh-server-alist)))
(let ((state (assoc server nnmh-server-alist)))
(if state
(progn
(nnheader-restore-variables (nth 1 state))
(setq nnmh-server-alist (delq state nnmh-server-alist)))
(nnheader-set-init-variables nnmh-server-variables defs)))
(setq nnmh-current-server server)))
(deffoo nnmh-open-server (server &optional defs)
(nnoo-change-server 'nnmh server defs)
(when (not (file-exists-p nnmh-directory))
(condition-case ()
(make-directory nnmh-directory t)
(error t)))
(cond
((not (file-exists-p nnmh-directory))
(nnmh-close-server)
(nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
((not (file-directory-p (file-truename nnmh-directory)))
(nnmh-close-server)
(nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))
(t
(nnheader-report 'nnmh "Opened server %s using directory %s"
server nnmh-directory)
t)))
(defun nnmh-close-server (&optional server)
t)
(defun nnmh-server-opened (&optional server)
(and (equal server nnmh-current-server)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(defun nnmh-status-message (&optional server)
nnmh-status-string)
(defun nnmh-request-article (id &optional newsgroup server buffer)
(nnmh-possibly-change-directory newsgroup)
(deffoo nnmh-request-article (id &optional newsgroup server buffer)
(nnmh-possibly-change-directory newsgroup server)
(let ((file (if (stringp id)
nil
(concat nnmh-current-directory (int-to-string id))))
@ -158,105 +137,101 @@
(and (stringp file)
(file-exists-p file)
(not (file-directory-p file))
(save-excursion (nnmail-find-file file)))))
(save-excursion (nnmail-find-file file))
(string-to-int (file-name-nondirectory file)))))
(defun nnmh-request-group (group &optional server dont-check)
(and nnmh-get-new-mail (or dont-check (nnmh-get-new-mail group)))
(let ((pathname (nnmh-article-pathname group nnmh-directory))
(deffoo nnmh-request-group (group &optional server dont-check)
(let ((pathname (nnmail-group-pathname group nnmh-directory))
dir)
(if (file-directory-p pathname)
(progn
(setq nnmh-current-directory pathname)
(and nnmh-get-new-mail
nnmh-be-safe
(nnmh-update-gnus-unreads group))
(or dont-check
(progn
(setq dir
(sort
(mapcar
(function
(lambda (name)
(string-to-int name)))
(directory-files pathname nil "^[0-9]+$" t))
'<))
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if dir
(insert (format "211 %d %d %d %s\n" (length dir)
(car dir)
(progn (while (cdr dir)
(setq dir (cdr dir)))
(car dir))
group))
(insert (format "211 0 1 0 %s\n" group))))))
t)
(setq nnmh-status-string "No such group")
nil)))
(cond
((not (file-directory-p pathname))
(nnheader-report
'nnmh "Can't select group (no such directory): %s" group))
(t
(setq nnmh-current-directory pathname)
(and nnmh-get-new-mail
nnmh-be-safe
(nnmh-update-gnus-unreads group))
(cond
(dont-check
(nnheader-report 'nnmh "Selected group %s" group)
t)
(t
(setq dir
(sort
(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))))))))))
(defun nnmh-request-list (&optional server dir)
(or dir
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(setq dir (file-truename (file-name-as-directory nnmh-directory)))))
(deffoo nnmh-request-scan (&optional group server)
(nnmail-get-new-mail 'nnmh nil nnmh-directory group))
(deffoo nnmh-request-list (&optional server dir)
(nnheader-insert "")
(let ((nnmh-toplev
(or dir (file-truename (file-name-as-directory nnmh-directory)))))
(nnmh-request-list-1 nnmh-toplev))
(setq nnmh-group-alist (nnmail-get-active))
t)
(defvar nnmh-toplev)
(defun nnmh-request-list-1 (dir)
(setq dir (expand-file-name dir))
;; Recurse down all directories.
(let ((dirs (and (file-readable-p dir)
(> (nth 1 (file-attributes (file-chase-links dir))) 2)
(directory-files dir t nil t))))
(while dirs
(if (and (not (string-match "/\\.\\.?$" (car dirs)))
(file-directory-p (car dirs))
(file-readable-p (car dirs)))
(nnmh-request-list nil (car dirs)))
(setq dirs (cdr dirs))))
(directory-files dir t nil t)))
dir)
;; Recurse down directories.
(while (setq dir (pop dirs))
(when (and (not (member (file-name-nondirectory dir) '("." "..")))
(file-directory-p dir)
(file-readable-p dir))
(nnmh-request-list-1 dir))))
;; For each directory, generate an active file line.
(if (not (string= (expand-file-name nnmh-directory) dir))
(let ((files (mapcar
(lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))))
(if (null files)
()
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-max))
(insert
(format
"%s %d %d y\n"
(progn
(string-match
(file-truename (file-name-as-directory
(expand-file-name nnmh-directory))) dir)
(nnmail-replace-chars-in-string
(substring dir (match-end 0)) ?/ ?.))
(apply (function max) files)
(apply (function min) files)))))))
(setq nnmh-group-alist (nnmail-get-active))
(and server nnmh-get-new-mail (nnmh-get-new-mail))
(unless (string= (expand-file-name nnmh-toplev) dir)
(let ((files (mapcar
(lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))))
(when files
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-max))
(insert
(format
"%s %d %d y\n"
(progn
(string-match
(regexp-quote
(file-truename (file-name-as-directory
(expand-file-name nnmh-toplev)))) dir)
(nnheader-replace-chars-in-string
(substring dir (match-end 0)) ?/ ?.))
(apply 'max files)
(apply 'min files)))))))
t)
(defun nnmh-request-newgroups (date &optional server)
(deffoo nnmh-request-newgroups (date &optional server)
(nnmh-request-list server))
(defun nnmh-request-post (&optional server)
(mail-send-and-exit nil))
(defalias 'nnmh-request-post-buffer 'nnmail-request-post-buffer)
(defun nnmh-request-expire-articles (articles newsgroup &optional server force)
(nnmh-possibly-change-directory newsgroup)
(let* ((days (or (and nnmail-expiry-wait-function
(funcall nnmail-expiry-wait-function newsgroup))
nnmail-expiry-wait))
(active-articles
(deffoo nnmh-request-expire-articles (articles newsgroup &optional server force)
(nnmh-possibly-change-directory newsgroup server)
(let* ((active-articles
(mapcar
(function
(lambda (name)
(string-to-int name)))
(directory-files nnmh-current-directory nil "^[0-9]+$" t)))
(max-article (and active-articles (apply 'max active-articles)))
(is-old t)
article rest mod-time)
(nnmail-activate 'nnmh)
@ -265,36 +240,32 @@
(setq article (concat nnmh-current-directory
(int-to-string (car articles))))
(if (setq mod-time (nth 5 (file-attributes article)))
(if (and (or (not nnmail-keep-last-article)
(not max-article)
(not (= (car articles) max-article)))
(not (equal mod-time '(0 0)))
(or force
(setq is-old
(> (nnmail-days-between
(current-time-string)
(current-time-string mod-time))
days))))
(if (and (nnmh-deletable-article-p newsgroup (car articles))
(setq is-old
(nnmail-expired-article-p newsgroup mod-time force)))
(progn
(and gnus-verbose-backends
(message "Deleting article %s..." article))
(nnheader-message 5 "Deleting article %s in %s..."
article newsgroup)
(condition-case ()
(delete-file article)
(funcall nnmail-delete-file-function article)
(file-error
(nnheader-message 1 "Couldn't delete article %s in %s"
article newsgroup)
(setq rest (cons (car articles) rest)))))
(setq rest (cons (car articles) rest))))
(setq articles (cdr articles)))
(message "")
(nconc rest articles)))
(defun nnmh-close-group (group &optional server)
(deffoo nnmh-close-group (group &optional server)
t)
(defun nnmh-request-move-article
(deffoo nnmh-request-move-article
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnmh move*"))
result)
(and
(nnmh-deletable-article-p group article)
(nnmh-request-article article group server)
(save-excursion
(set-buffer buf)
@ -302,65 +273,134 @@
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
(condition-case ()
(delete-file (concat nnmh-current-directory
(int-to-string article)))
(file-error nil)))
(progn
(nnmh-possibly-change-directory group server)
(condition-case ()
(funcall nnmail-delete-file-function
(concat nnmh-current-directory (int-to-string article)))
(file-error nil))))
result))
(defun nnmh-request-accept-article (group &optional last)
(deffoo nnmh-request-accept-article (group &optional server last noinsert)
(nnmh-possibly-change-directory group server)
(nnmail-check-syntax)
(if (stringp group)
(and
(nnmail-activate 'nnmh)
;; We trick the choosing function into believing that only one
;; group is available.
(let ((nnmail-split-methods (list (list group ""))))
(car (nnmh-save-mail))))
(car (nnmh-save-mail noinsert))))
(and
(nnmail-activate 'nnmh)
(car (nnmh-save-mail)))))
(car (nnmh-save-mail noinsert)))))
(defun nnmh-request-replace-article (article group buffer)
(deffoo nnmh-request-replace-article (article group buffer)
(nnmh-possibly-change-directory group)
(save-excursion
(set-buffer buffer)
(nnmh-possibly-create-directory group)
(condition-case ()
(progn
(write-region (point-min) (point-max)
(concat nnmh-current-directory (int-to-string article))
nil (if gnus-verbose-backends nil 'nomesg))
(write-region
(point-min) (point-max)
(concat nnmh-current-directory (int-to-string article))
nil (if (nnheader-be-verbose 5) nil 'nomesg))
t)
(error nil))))
(deffoo nnmh-request-create-group (group &optional server)
(nnmail-activate 'nnmh)
(or (assoc group nnmh-group-alist)
(let (active)
(setq nnmh-group-alist (cons (list group (setq active (cons 1 0)))
nnmh-group-alist))
(nnmh-possibly-create-directory group)
(nnmh-possibly-change-directory group server)
(let ((articles (mapcar
(lambda (file)
(string-to-int file))
(directory-files
nnmh-current-directory nil "^[0-9]+$"))))
(and articles
(progn
(setcar active (apply 'min articles))
(setcdr active (apply 'max articles)))))))
t)
(deffoo nnmh-request-delete-group (group &optional force server)
(nnmh-possibly-change-directory group server)
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
(let ((articles (directory-files nnmh-current-directory t "^[0-9]+$")))
(while articles
(and (file-writable-p (car articles))
(progn
(nnheader-message 5 "Deleting article %s in %s..."
(car articles) group)
(funcall nnmail-delete-file-function (car articles))))
(setq articles (cdr articles))))
;; Try to delete the directory itself.
(condition-case ()
(delete-directory nnmh-current-directory)
(error nil)))
;; Remove the group from all structures.
(setq nnmh-group-alist
(delq (assoc group nnmh-group-alist) nnmh-group-alist)
nnmh-current-directory nil)
t)
(deffoo nnmh-request-rename-group (group new-name &optional server)
(nnmh-possibly-change-directory group server)
;; Rename directory.
(and (file-writable-p nnmh-current-directory)
(condition-case ()
(progn
(rename-file
(directory-file-name nnmh-current-directory)
(directory-file-name
(nnmail-group-pathname new-name nnmh-directory)))
t)
(error nil))
;; That went ok, so we change the internal structures.
(let ((entry (assoc group nnmh-group-alist)))
(and entry (setcar entry new-name))
(setq nnmh-current-directory nil)
t)))
;;; Internal functions.
(defun nnmh-possibly-change-directory (newsgroup)
(defun nnmh-possibly-change-directory (newsgroup &optional server)
(when (and server
(not (nnmh-server-opened server)))
(nnmh-open-server server))
(if newsgroup
(let ((pathname (nnmh-article-pathname newsgroup nnmh-directory)))
(let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)))
(if (file-directory-p pathname)
(setq nnmh-current-directory pathname)
(error "No such newsgroup: %s" newsgroup)))))
(defun nnmh-possibly-create-directory (group)
(let (dir dirs)
(setq dir (nnmh-article-pathname group nnmh-directory))
(setq dir (nnmail-group-pathname group nnmh-directory))
(while (not (file-directory-p dir))
(setq dirs (cons dir dirs))
(setq dir (file-name-directory (directory-file-name dir))))
(while dirs
(if (make-directory (directory-file-name (car dirs)))
(error "Could not create directory %s" (car dirs)))
(and gnus-verbose-backends
(message "Creating mail directory %s" (car dirs)))
(nnheader-message 5 "Creating mail directory %s" (car dirs))
(setq dirs (cdr dirs)))))
(defun nnmh-save-mail ()
(defun nnmh-save-mail (&optional noinsert)
"Called narrowed to an article."
(let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number))))
(nnmail-insert-lines)
(nnmail-insert-xref group-art)
(unless noinsert
(nnmail-insert-lines)
(nnmail-insert-xref group-art))
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnmh-prepare-save-mail-hook)
(goto-char (point-min))
(while (looking-at "From ")
@ -370,13 +410,13 @@
(let ((ga group-art)
first)
(while ga
(nnmh-possibly-create-directory (car (car ga)))
(let ((file (concat (nnmh-article-pathname
(car (car ga)) nnmh-directory)
(int-to-string (cdr (car ga))))))
(nnmh-possibly-create-directory (caar ga))
(let ((file (concat (nnmail-group-pathname
(caar ga) nnmh-directory)
(int-to-string (cdar ga)))))
(if first
;; It was already saved, so we just make a hard link.
(add-name-to-file first file t)
(funcall nnmail-crosspost-link-function first file t)
;; Save the article.
(write-region (point-min) (point-max) file nil nil)
(setq first file)))
@ -385,7 +425,7 @@
(defun nnmh-active-number (group)
"Compute the next article number in GROUP."
(let ((active (car (cdr (assoc group nnmh-group-alist)))))
(let ((active (cadr (assoc group nnmh-group-alist))))
;; The group wasn't known to nnmh, so we just create an active
;; entry for it.
(or active
@ -394,59 +434,11 @@
(setq nnmh-group-alist (cons (list group active) nnmh-group-alist))))
(setcdr active (1+ (cdr active)))
(while (file-exists-p
(concat (nnmh-article-pathname group nnmh-directory)
(concat (nnmail-group-pathname group nnmh-directory)
(int-to-string (cdr active))))
(setcdr active (1+ (cdr active))))
(cdr active)))
(defun nnmh-article-pathname (group mail-dir)
"Make pathname for GROUP."
(let ((mail-dir (file-name-as-directory (expand-file-name mail-dir))))
(if (file-directory-p (concat mail-dir group))
(concat mail-dir group "/")
(concat mail-dir (nnmail-replace-chars-in-string group ?. ?/) "/"))))
(defun nnmh-get-new-mail (&optional group)
"Read new incoming mail."
(let* ((spools (nnmail-get-spool-files group))
(group-in group)
incoming incomings)
(if (or (not nnmh-get-new-mail) (not nnmail-spool-file))
()
;; We first activate all the groups.
(or nnmh-group-alist
(nnmh-request-list))
;; The we go through all the existing spool files and split the
;; mail from each.
(while spools
(and
(file-exists-p (car spools))
(> (nth 7 (file-attributes (car spools))) 0)
(progn
(and gnus-verbose-backends
(message "nnmh: Reading incoming mail..."))
(if (not (setq incoming
(nnmail-move-inbox
(car spools)
(concat (file-name-as-directory nnmh-directory)
"Incoming"))))
()
(setq incomings (cons incoming incomings))
(setq group (nnmail-get-split-group (car spools) group-in))
(nnmail-split-incoming incoming 'nnmh-save-mail nil group))))
(setq spools (cdr spools)))
;; If we did indeed read any incoming spools, we save all info.
(if incoming
(message "nnmh: Reading incoming mail...done"))
(while incomings
(setq incoming (car incomings))
(and nnmail-delete-incoming
(file-exists-p incoming)
(file-writable-p incoming)
(delete-file incoming))
(setq incomings (cdr incomings))))))
(defun nnmh-update-gnus-unreads (group)
;; Go through the .nnmh-articles file and compare with the actual
;; articles in this folder. The articles that are "new" will be
@ -471,7 +463,7 @@
;; Remove all deleted articles.
(let ((art articles))
(while art
(if (not (memq (car (car art)) files))
(if (not (memq (caar art) files))
(setq articles (delq (car art) articles)))
(setq art (cdr art))))
;; Check whether the highest-numbered articles really are the ones
@ -480,10 +472,10 @@
(while (and art
(not (equal
(nth 5 (file-attributes
(concat dir (int-to-string (car (car art))))))
(cdr (car art)))))
(concat dir (int-to-string (caar art)))))
(cdar art))))
(setq articles (delq (car art) articles))
(setq new (cons (car (car art)) new))
(setq new (cons (caar art) new))
(setq art (cdr art))))
;; Go through all the new articles and add them, and their
;; time-stamps to the list.
@ -513,6 +505,14 @@
(write-region (point-min) (point-max) nnmh-file nil 'nomesg)
(kill-buffer (current-buffer)))))
(defun nnmh-deletable-article-p (group article)
"Say whether ARTICLE in GROUP can be deleted."
(let ((path (concat nnmh-current-directory (int-to-string article))))
(and (file-writable-p path)
(or (not nnmail-keep-last-article)
(not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
article))))))
(provide 'nnmh)
;;; nnmh.el ends here

853
lisp/nnml.el
View File

File diff suppressed because it is too large Load Diff

603
lisp/nnspool.el
View File

@ -1,6 +1,5 @@
;;; nnspool.el --- spool access for GNU Emacs
;; Copyright (C) 1988,89,90,93,94,95 Free Software Foundation, Inc.
;; Copyright (C) 1988,89,90,93,94,95,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
@ -30,45 +29,49 @@
(require 'nnheader)
(require 'nntp)
(require 'timezone)
(require 'nnoo)
(eval-when-compile (require 'cl))
(defvar nnspool-inews-program news-inews-program
(nnoo-declare nnspool)
(defvoo nnspool-inews-program news-inews-program
"Program to post news.
This is most commonly `inews' or `injnews'.")
(defvar nnspool-inews-switches '("-h")
(defvoo nnspool-inews-switches '("-h" "-S")
"Switches for nnspool-request-post to pass to `inews' for posting news.
If you are using Cnews, you probably should set this variable to nil.")
(defvar nnspool-spool-directory news-path
(defvoo nnspool-spool-directory (file-name-as-directory news-path)
"Local news spool directory.")
(defvar nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
(defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
"Local news nov directory.")
(defvar nnspool-lib-dir "/usr/lib/news/"
(defvoo nnspool-lib-dir "/usr/lib/news/"
"Where the local news library files are stored.")
(defvar nnspool-active-file (concat nnspool-lib-dir "active")
(defvoo nnspool-active-file (concat nnspool-lib-dir "active")
"Local news active file.")
(defvar nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
(defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
"Local news newsgroups file.")
(defvar nnspool-distributions-file (concat nnspool-lib-dir "distributions")
(defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat")
"Local news distributions file.")
(defvar nnspool-history-file (concat nnspool-lib-dir "history")
(defvoo nnspool-history-file (concat nnspool-lib-dir "history")
"Local news history file.")
(defvar nnspool-active-times-file (concat nnspool-lib-dir "active.times")
(defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times")
"Local news active date file.")
(defvar nnspool-large-newsgroup 50
(defvoo nnspool-large-newsgroup 50
"The number of the articles which indicates a large newsgroup.
If the number of the articles is greater than the value, verbose
messages will be shown to indicate the current status.")
(defvar nnspool-nov-is-evil nil
(defvoo nnspool-nov-is-evil nil
"Non-nil means that nnspool will never return NOV lines instead of headers.")
(defconst nnspool-sift-nov-with-sed nil
@ -76,214 +79,195 @@ messages will be shown to indicate the current status.")
If nil, nnspool will load the entire file into a buffer and process it
there.")
(defvoo nnspool-rejected-article-hook nil
"*A hook that will be run when an article has been rejected by the server.")
(defconst nnspool-version "nnspool 2.0"
"Version numbers of this version of NNSPOOL.")
(defvar nnspool-current-directory nil
(defvoo nnspool-current-directory nil
"Current news group directory.")
(defvar nnspool-current-group nil)
(defvar nnspool-status-string "")
(defvar nnspool-current-server nil)
(defvar nnspool-server-alist nil)
(defvar nnspool-server-variables
(list
(list 'nnspool-inews-program nnspool-inews-program)
(list 'nnspool-inews-switches nnspool-inews-switches)
(list 'nnspool-spool-directory nnspool-spool-directory)
(list 'nnspool-nov-directory nnspool-nov-directory)
(list 'nnspool-lib-dir nnspool-lib-dir)
(list 'nnspool-active-file nnspool-active-file)
(list 'nnspool-newsgroups-file nnspool-newsgroups-file)
(list 'nnspool-distributions-file nnspool-distributions-file)
(list 'nnspool-history-file nnspool-history-file)
(list 'nnspool-active-times-file nnspool-active-times-file)
(list 'nnspool-large-newsgroup nnspool-large-newsgroup)
(list 'nnspool-nov-is-evil nnspool-nov-is-evil)
(list 'nnspool-sift-nov-with-sed nnspool-sift-nov-with-sed)
'(nnspool-current-directory nil)
'(nnspool-current-group nil)
'(nnspool-status-string "")))
(defvoo nnspool-current-group nil)
(defvoo nnspool-status-string "")
;;; Interface functions.
(defun nnspool-retrieve-headers (sequence &optional newsgroup server)
"Retrieve the headers for the articles in SEQUENCE.
Newsgroup must be selected before calling this function."
(nnoo-define-basics nnspool)
(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
"Retrieve the headers of ARTICLES."
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let* ((number (length sequence))
(count 0)
(do-message (and (numberp nnspool-large-newsgroup)
(> number nnspool-large-newsgroup)))
file beg article)
(if (not (nnspool-possibly-change-directory newsgroup))
()
(if (and (numberp (car sequence))
(nnspool-retrieve-headers-with-nov sequence))
(when (nnspool-possibly-change-directory group)
(let* ((number (length articles))
(count 0)
(default-directory nnspool-current-directory)
(do-message (and (numberp nnspool-large-newsgroup)
(> number nnspool-large-newsgroup)))
file beg article ag)
(if (and (numberp (car articles))
(nnspool-retrieve-headers-with-nov articles fetch-old))
;; We successfully retrieved the NOV headers.
'nov
(while sequence
(setq article (car sequence))
;; No NOV headers here, so we do it the hard way.
(while (setq article (pop articles))
(if (stringp article)
(progn
(setq file (nnspool-find-article-by-message-id article))
(setq article 0))
(setq file (concat nnspool-current-directory
(int-to-string article))))
(and file (file-exists-p file)
(progn
(insert (format "221 %d Article retrieved.\n" article))
(setq beg (point))
(nnheader-insert-head file)
(goto-char beg)
(search-forward "\n\n" nil t)
(forward-char -1)
(insert ".\n")
(delete-region (point) (point-max))))
(setq sequence (cdr sequence))
;; This is a Message-ID.
(setq ag (nnspool-find-id article)
file (and ag (nnspool-article-pathname
(car ag) (cdr ag)))
article (cdr ag))
;; This is an article in the current group.
(setq file (int-to-string article)))
;; Insert the head of the article.
(when (and file
(file-exists-p file))
(insert "221 ")
(princ article (current-buffer))
(insert " Article retrieved.\n")
(setq beg (point))
(inline (nnheader-insert-head file))
(goto-char beg)
(search-forward "\n\n" nil t)
(forward-char -1)
(insert ".\n")
(delete-region (point) (point-max)))
(and do-message
(zerop (% (setq count (1+ count)) 20))
(message "NNSPOOL: Receiving headers... %d%%"
(zerop (% (incf count) 20))
(message "nnspool: Receiving headers... %d%%"
(/ (* count 100) number))))
(and do-message (message "NNSPOOL: Receiving headers...done"))
(and do-message
(message "nnspool: Receiving headers...done"))
;; Fold continuation lines.
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t))
(nnheader-fold-continuation-lines)
'headers)))))
(defun nnspool-open-server (server &optional defs)
(nnheader-init-server-buffer)
(if (equal server nnspool-current-server)
t
(if nnspool-current-server
(setq nnspool-server-alist
(cons (list nnspool-current-server
(nnheader-save-variables nnspool-server-variables))
nnspool-server-alist)))
(let ((state (assoc server nnspool-server-alist)))
(if state
(progn
(nnheader-restore-variables (nth 1 state))
(setq nnspool-server-alist (delq state nnspool-server-alist)))
(nnheader-set-init-variables nnspool-server-variables defs)))
(setq nnspool-current-server server)))
(deffoo nnspool-open-server (server &optional defs)
(nnoo-change-server 'nnspool server defs)
(cond
((not (file-exists-p nnspool-spool-directory))
(nnspool-close-server)
(nnheader-report 'nnspool "Spool directory doesn't exist: %s"
nnspool-spool-directory))
((not (file-directory-p
(directory-file-name
(file-truename nnspool-spool-directory))))
(nnspool-close-server)
(nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory))
((not (file-exists-p nnspool-active-file))
(nnheader-report 'nnspool "The active file doesn't exist: %s"
nnspool-active-file))
(t
(nnheader-report 'nnspool "Opened server %s using directory %s"
server nnspool-spool-directory)
t)))
(defun nnspool-close-server (&optional server)
t)
(defun nnspool-server-opened (&optional server)
(and (equal server nnspool-current-server)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(defun nnspool-status-message (&optional server)
"Return server status response as string."
nnspool-status-string)
(defun nnspool-request-article (id &optional newsgroup server buffer)
(deffoo nnspool-request-article (id &optional group server buffer)
"Select article by message ID (or number)."
(nnspool-possibly-change-directory newsgroup)
(let ((file (if (stringp id)
(nnspool-find-article-by-message-id id)
(concat nnspool-current-directory (prin1-to-string id))))
(nntp-server-buffer (or buffer nntp-server-buffer)))
(if (and (stringp file)
(file-exists-p file)
(not (file-directory-p file)))
(save-excursion
(nnspool-find-file file)))))
(defun nnspool-request-body (id &optional newsgroup server)
(nnspool-possibly-change-directory group)
(let ((nntp-server-buffer (or buffer nntp-server-buffer))
file ag)
(if (stringp id)
;; This is a Message-ID.
(when (setq ag (nnspool-find-id id))
(setq file (nnspool-article-pathname (car ag) (cdr ag))))
(setq file (nnspool-article-pathname nnspool-current-group id)))
(and file
(file-exists-p file)
(not (file-directory-p file))
(save-excursion (nnspool-find-file file))
;; We return the article number and group name.
(if (numberp id)
(cons nnspool-current-group id)
ag))))
(deffoo nnspool-request-body (id &optional group server)
"Select article body by message ID (or number)."
(nnspool-possibly-change-directory newsgroup)
(if (nnspool-request-article id)
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
(when res
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(delete-region (point-min) (point)))
t)))
(when (search-forward "\n\n" nil t)
(delete-region (point-min) (point)))
res))))
(defun nnspool-request-head (id &optional newsgroup server)
(deffoo nnspool-request-head (id &optional group server)
"Select article head by message ID (or number)."
(nnspool-possibly-change-directory newsgroup)
(if (nnspool-request-article id)
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
(when res
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(delete-region (1- (point)) (point-max)))
t)))
(when (search-forward "\n\n" nil t)
(delete-region (1- (point)) (point-max)))
(nnheader-fold-continuation-lines)))
res))
(defun nnspool-request-group (group &optional server dont-check)
(deffoo nnspool-request-group (group &optional server dont-check)
"Select news GROUP."
(let ((pathname (nnspool-article-pathname
(nnspool-replace-chars-in-string group ?. ?/)))
(let ((pathname (nnspool-article-pathname group))
dir)
(if (not (file-directory-p pathname))
(progn
(setq nnspool-status-string
"Invalid group name (no such directory)")
nil)
(nnheader-report
'nnspool "Invalid group name (no such directory): %s" group)
(setq nnspool-current-directory pathname)
(setq nnspool-status-string "")
(if (not dont-check)
(nnheader-report 'nnspool "Selected group %s" group)
(if dont-check
(progn
(setq dir (directory-files pathname nil "^[0-9]+$" t))
;; yes, completely empty spool directories *are* possible
;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
(and dir
(setq dir
(sort
(mapcar
(function
(lambda (name)
(string-to-int name)))
dir)
'<)))
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if dir
(insert
(format "211 %d %d %d %s\n" (length dir) (car dir)
(progn (while (cdr dir) (setq dir (cdr dir)))
(car dir))
group))
(insert (format "211 0 0 0 %s\n" group))))))
t)))
(nnheader-report 'nnspool "Selected group %s" group)
t)
;; Yes, completely empty spool directories *are* possible.
;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
(when (setq dir (directory-files pathname nil "^[0-9]+$" t))
(setq dir
(sort (mapcar (lambda (name) (string-to-int name)) dir) '<)))
(if dir
(nnheader-insert
"211 %d %d %d %s\n" (length dir) (car dir)
(progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
group)
(nnheader-report 'nnspool "Empty group %s" group)
(nnheader-insert "211 0 0 0 %s\n" group))))))
(defun nnspool-close-group (group &optional server)
(deffoo nnspool-request-type (group &optional article)
'news)
(deffoo nnspool-close-group (group &optional server)
t)
(defun nnspool-request-list (&optional server)
(deffoo nnspool-request-list (&optional server)
"List active newsgroups."
(save-excursion
(nnspool-find-file nnspool-active-file)))
(or (nnspool-find-file nnspool-active-file)
(nnheader-report 'nnspool (nnheader-file-error nnspool-active-file)))))
(defun nnspool-request-list-newsgroups (&optional server)
(deffoo nnspool-request-list-newsgroups (&optional server)
"List newsgroups (defined in NNTP2)."
(save-excursion
(nnspool-find-file nnspool-newsgroups-file)))
(or (nnspool-find-file nnspool-newsgroups-file)
(nnheader-report 'nnspool (nnheader-file-error
nnspool-newsgroups-file)))))
(defun nnspool-request-list-distributions (&optional server)
(deffoo nnspool-request-list-distributions (&optional server)
"List distributions (defined in NNTP2)."
(save-excursion
(nnspool-find-file nnspool-distributions-file)))
(or (nnspool-find-file nnspool-distributions-file)
(nnheader-report 'nnspool (nnheader-file-error
nnspool-distributions-file)))))
;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
(defun nnspool-request-newgroups (date &optional server)
(deffoo nnspool-request-newgroups (date &optional server)
"List groups created after DATE."
(if (nnspool-find-file nnspool-active-times-file)
(save-excursion
@ -317,21 +301,33 @@ Newsgroup must be selected before calling this function."
t)
nil))
(defun nnspool-request-post (&optional server)
(deffoo nnspool-request-post (&optional server)
"Post a new news in current buffer."
(save-excursion
(let* ((process-connection-type nil) ; t bugs out on Solaris
(inews-buffer (generate-new-buffer " *nnspool post*"))
(proc (apply 'start-process "*nnspool inews*" inews-buffer
nnspool-inews-program nnspool-inews-switches)))
(set-process-sentinel proc 'nnspool-inews-sentinel)
(process-send-region proc (point-min) (point-max))
;; We slap a condition-case around this, because the process may
;; have exited already...
(condition-case nil
(process-send-eof proc)
(error nil))
t)))
(proc
(condition-case err
(apply 'start-process "*nnspool inews*" inews-buffer
nnspool-inews-program nnspool-inews-switches)
(error
(nnheader-report 'nnspool "inews error: %S" err)))))
(if (not proc)
;; The inews program failed.
()
(nnheader-report 'nnspool "")
(set-process-sentinel proc 'nnspool-inews-sentinel)
(process-send-region proc (point-min) (point-max))
;; We slap a condition-case around this, because the process may
;; have exited already...
(condition-case nil
(process-send-eof proc)
(error nil))
t))))
;;; Internal functions.
(defun nnspool-inews-sentinel (proc status)
(save-excursion
@ -340,69 +336,118 @@ Newsgroup must be selected before calling this function."
(if (or (zerop (buffer-size))
(search-forward "spooled" nil t))
(kill-buffer (current-buffer))
;; Make status message by unfolding lines.
(subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
(setq nnspool-status-string (buffer-string))
;; Make status message by folding lines.
(while (re-search-forward "[ \t\n]+" nil t)
(replace-match " " t t))
(nnheader-report 'nnspool "%s" (buffer-string))
(message "nnspool: %s" nnspool-status-string)
;(kill-buffer (current-buffer))
)))
(ding)
(run-hooks 'nnspool-rejected-article-hook))))
(defalias 'nnspool-request-post-buffer 'nntp-request-post-buffer)
;;; Internal functions.
(defun nnspool-retrieve-headers-with-nov (articles)
(defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old)
(if (or gnus-nov-is-evil nnspool-nov-is-evil)
nil
(let ((nov (concat (file-name-as-directory nnspool-nov-directory)
(nnspool-replace-chars-in-string
nnspool-current-group ?. ?/)
"/.overview"))
article)
(if (file-exists-p nov)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if nnspool-sift-nov-with-sed
(nnspool-sift-nov-with-sed articles nov)
(insert-file-contents nov)
;; First we find the first wanted line. We issue a number
;; of search-forwards - the first article we are looking
;; for may be expired, so we have to go on searching until
;; we find one of the articles we want.
(while (and articles
(setq article (concat (int-to-string
(car articles)) "\t"))
(not (or (looking-at article)
(search-forward (concat "\n" article)
nil t))))
(setq articles (cdr articles)))
(if (not articles)
()
(beginning-of-line)
(delete-region (point-min) (point))
;; Then we find the last wanted line. We go to the end
;; of the buffer and search backward much the same way
;; we did to find the first article.
;; !!! Perhaps it would be better just to do a (last articles),
;; and go forward successively over each line and
;; compare to avoid this (reverse), like this:
;; (while (and (>= last (read nntp-server-buffer)))
;; (zerop (forward-line 1))))
(setq articles (reverse articles))
(goto-char (point-max))
(while (and articles
(not (search-backward
(concat "\n" (int-to-string (car articles))
"\t") nil t)))
(setq articles (cdr articles)))
(if articles
(progn
(forward-line 2)
(delete-region (point) (point-max)))))
(or articles (progn (erase-buffer) nil))))))))
(let ((nov (nnheader-group-pathname
nnspool-current-group nnspool-nov-directory ".overview"))
(arts articles)
last)
(if (not (file-exists-p nov))
()
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if nnspool-sift-nov-with-sed
(nnspool-sift-nov-with-sed articles nov)
(insert-file-contents nov)
(if (and fetch-old
(not (numberp fetch-old)))
t ; We want all the headers.
(condition-case ()
(progn
;; First we find the first wanted line.
(nnspool-find-nov-line
(if fetch-old (max 1 (- (car articles) fetch-old))
(car articles)))
(delete-region (point-min) (point))
;; Then we find the last wanted line.
(if (nnspool-find-nov-line
(progn (while (cdr articles)
(setq articles (cdr articles)))
(car articles)))
(forward-line 1))
(delete-region (point) (point-max))
;; If the buffer is empty, this wasn't very successful.
(unless (zerop (buffer-size))
;; We check what the last article number was.
;; The NOV file may be out of sync with the articles
;; in the group.
(forward-line -1)
(setq last (read (current-buffer)))
(if (= last (car articles))
;; Yup, it's all there.
t
;; Perhaps not. We try to find the missing articles.
(while (and arts
(<= last (car arts)))
(pop arts))
;; The articles in `arts' are missing from the buffer.
(while arts
(nnspool-insert-nov-head (pop arts)))
t)))
;; The NOV file was corrupted.
(error nil)))))))))
(defun nnspool-insert-nov-head (article)
"Read the head of ARTICLE, convert to NOV headers, and insert."
(save-excursion
(let ((cur (current-buffer))
buf)
(setq buf (nnheader-set-temp-buffer " *nnspool head*"))
(when (nnheader-insert-head
(nnspool-article-pathname nnspool-current-group article))
(nnheader-insert-article-line article)
(let ((headers (nnheader-parse-head)))
(set-buffer cur)
(goto-char (point-max))
(nnheader-insert-nov headers)))
(kill-buffer buf))))
(defun nnspool-find-nov-line (article)
(let ((max (point-max))
(min (goto-char (point-min)))
(cur (current-buffer))
(prev (point-min))
num found)
(while (not found)
(goto-char (/ (+ max min) 2))
(beginning-of-line)
(if (or (= (point) prev)
(eobp))
(setq found t)
(setq prev (point))
(cond ((> (setq num (read cur)) article)
(setq max (point)))
((< num article)
(setq min (point)))
(t
(setq found 'yes)))))
;; Now we may have found the article we're looking for, or we
;; may be somewhere near it.
(when (and (not (eq found 'yes))
(not (eq num article)))
(setq found (point))
(while (and (< (point) max)
(or (not (numberp num))
(< num article)))
(forward-line 1)
(setq found (point))
(or (eobp)
(= (setq num (read cur)) article)))
(unless (eq num article)
(goto-char found)))
(beginning-of-line)
(eq num article)))
(defun nnspool-sift-nov-with-sed (articles file)
(let ((first (car articles))
(last (progn (while (cdr articles) (setq articles (cdr articles)))
@ -413,70 +458,41 @@ Newsgroup must be selected before calling this function."
file)))
;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle).
(defun nnspool-find-article-by-message-id (id)
"Return full pathname of an article identified by message-ID."
;; Find out what group an article identified by a Message-ID is in.
(defun nnspool-find-id (id)
(save-excursion
(let ((buf (get-buffer-create " *nnspool work*")))
(set-buffer buf)
(erase-buffer)
(call-process "grep" nil t nil id nnspool-history-file)
(goto-char (point-min))
(if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ \t\n]*\\)")
(concat nnspool-spool-directory
(nnspool-replace-chars-in-string
(buffer-substring (match-beginning 1) (match-end 1))
?. ?/))))))
(set-buffer (get-buffer-create " *nnspool work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(condition-case ()
(call-process "grep" nil t nil id nnspool-history-file)
(error nil))
(goto-char (point-min))
(prog1
(if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]")
(cons (match-string 1) (string-to-int (match-string 2))))
(kill-buffer (current-buffer)))))
(defun nnspool-find-file (file)
"Insert FILE in server buffer safely."
(set-buffer nntp-server-buffer)
(erase-buffer)
(condition-case ()
(progn (insert-file-contents file) t)
(progn (nnheader-insert-file-contents-literally file) t)
(file-error nil)))
(defun nnspool-possibly-change-directory (newsgroup)
(if newsgroup
(let ((pathname (nnspool-article-pathname
(nnspool-replace-chars-in-string newsgroup ?. ?/))))
(if (file-directory-p pathname)
(progn
(setq nnspool-current-directory pathname)
(setq nnspool-current-group newsgroup))
(setq nnspool-status-string
(format "No such newsgroup: %s" newsgroup))
nil))
t))
(defun nnspool-possibly-change-directory (group)
(if (not group)
t
(let ((pathname (nnspool-article-pathname group)))
(if (file-directory-p pathname)
(setq nnspool-current-directory pathname
nnspool-current-group group)
(nnheader-report 'nnspool "No such newsgroup: %s" group)))))
(defun nnspool-article-pathname (group)
"Make pathname for GROUP."
(concat (file-name-as-directory nnspool-spool-directory) group "/"))
(defun nnspool-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)
(if (= (aref string idx) from)
(aset string idx to))
(setq idx (1+ idx)))
string))
(defun nnspool-number-base-10 (num pos)
(if (<= pos 0) ""
(setcdr num (+ (* (% (car num) 10) 65536) (cdr num)))
(apply
'concat
(reverse
(list
(char-to-string
(aref "0123456789" (% (cdr num) 10)))
(progn
(setcdr num (/ (cdr num) 10))
(setcar num (/ (car num) 10))
(nnspool-number-base-10 num (1- pos))))))))
(defun nnspool-article-pathname (group &optional article)
"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)))
@ -485,9 +501,10 @@ Newsgroup must be selected before calling this function."
(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))))
(nth 2 tdate) (nth 1 tdate) (nth 0 tdate)
(nth 4 tdate))))
(+ (* (car unix) 65536.0)
(car (cdr unix)))))
(cadr unix))))
(provide 'nnspool)

1187
lisp/nntp.el
View File

File diff suppressed because it is too large Load Diff

757
lisp/nnvirtual.el
View File

@ -1,6 +1,5 @@
;;; nnvirtual.el --- virtual newsgroups access for Gnus
;; Copyright (C) 1994,95 Free Software Foundation, Inc.
;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -34,445 +33,377 @@
(require 'nntp)
(require 'nnheader)
(require 'gnus)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnvirtual)
(defvoo nnvirtual-always-rescan nil
"*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.")
(defvoo nnvirtual-component-regexp nil
"*Regexp to match component groups.")
(defconst nnvirtual-version "nnvirtual 1.0"
"Version number of this version of nnvirtual.")
(defconst nnvirtual-version "nnvirtual 1.0")
(defvar nnvirtual-group-alist nil)
(defvar nnvirtual-current-group nil)
(defvar nnvirtual-current-groups nil)
(defvar nnvirtual-current-mapping nil)
(defvoo nnvirtual-current-group nil)
(defvoo nnvirtual-component-groups nil)
(defvoo nnvirtual-mapping nil)
(defvar nnvirtual-do-not-open nil)
(defvoo nnvirtual-status-string "")
(defvar nnvirtual-status-string "")
(eval-and-compile
(autoload 'gnus-cache-articles-in-group "gnus-cache"))
;;; Interface functions.
(defun nnvirtual-retrieve-headers (sequence &optional newsgroup server)
"Retrieve the headers for the articles in SEQUENCE."
(nnvirtual-possibly-change-newsgroups newsgroup server t)
(save-excursion
(set-buffer (get-buffer-create "*virtual headers*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(if (stringp (car sequence))
'headers
(let ((map nnvirtual-current-mapping)
(offset 0)
articles beg group active top article result prefix
fetched-articles group-method)
(while sequence
(while (< (car (car map)) (car sequence))
(setq offset (car (car map)))
(setq map (cdr map)))
(setq top (car (car map)))
(setq group (nth 1 (car map)))
(setq prefix (gnus-group-real-prefix group))
(setq active (nth 2 (car map)))
(setq articles nil)
(while (and sequence (<= (car sequence) top))
(setq articles (cons (- (+ active (car sequence)) offset)
articles))
(setq sequence (cdr sequence)))
(setq articles (nreverse articles))
(if (and articles
(setq result
(progn
(setq group-method
(gnus-find-method-for-group group))
(and (or (gnus-server-opened group-method)
(gnus-open-server group-method))
(gnus-request-group group t)
(gnus-retrieve-headers articles group)))))
(save-excursion
(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.
(and (eq result 'headers) (nnvirtual-convert-headers))
(goto-char (point-min))
(setq fetched-articles nil)
(while (not (eobp))
(setq beg (point)
article (read nntp-server-buffer)
fetched-articles (cons article fetched-articles))
(delete-region beg (point))
(insert (int-to-string (+ (- article active) offset)))
(beginning-of-line)
(looking-at
"[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
(goto-char (match-end 0))
(or (search-forward
"\t" (save-excursion (end-of-line) (point)) t)
(end-of-line))
(while (= (char-after (1- (point))) ? )
(forward-char -1)
(delete-char 1))
(if (eolp)
(progn
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(insert ?\t))
(insert (format "Xref: %s %s:%d\t" (system-name)
group article)))
(if (not (string= "" prefix))
(while (re-search-forward
"[^ ]+:[0-9]+"
(save-excursion (end-of-line) (point)) t)
(save-excursion
(goto-char (match-beginning 0))
(insert prefix))))
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(insert ?\t)))
(forward-line 1))))
(goto-char (point-max))
(insert-buffer-substring nntp-server-buffer)
;; We have now massaged and inserted the headers from one
;; group. In case some of the articles have expired or been
;; cancelled, we have to mark them as read in the component
;; group.
(let ((unfetched (gnus-sorted-complement
articles (nreverse fetched-articles))))
(and unfetched
(gnus-group-make-articles-read group unfetched nil))))
;; The headers are ready for reading, so they are inserted into
;; the nntp-server-buffer, which is where Gnus expects to find
;; them.
(prog1
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring "*virtual headers*")
'nov)
(kill-buffer (current-buffer)))))))
(nnoo-define-basics nnvirtual)
(defun nnvirtual-open-server (newsgroups &optional something)
"Open a virtual newsgroup that contains NEWSGROUPS."
(nnheader-init-server-buffer))
(defun nnvirtual-close-server (&rest dum)
"Close news server."
t)
(defun nnvirtual-request-close ()
(setq nnvirtual-current-group nil
nnvirtual-current-groups nil
nnvirtual-current-mapping nil
nnvirtual-group-alist nil)
t)
(defun nnvirtual-server-opened (&optional server)
"Return server process status, T or NIL.
If the stream is opened, return T, otherwise return NIL."
(and nntp-server-buffer
(get-buffer nntp-server-buffer)))
(defun nnvirtual-status-message (&optional server)
"Return server status response as string."
nnvirtual-status-string)
(defun nnvirtual-request-article (article &optional newsgroup server buffer)
"Select article by message number."
(nnvirtual-possibly-change-newsgroups newsgroup server t)
(and (numberp article)
(let ((map nnvirtual-current-mapping)
(offset 0)
group-method)
(while (< (car (car map)) article)
(setq offset (car (car map)))
(setq map (cdr map)))
(setq group-method (gnus-find-method-for-group (nth 1 (car map))))
(or (gnus-server-opened group-method)
(gnus-open-server group-method))
(gnus-request-group (nth 1 (car map)) t)
(gnus-request-article (- (+ (nth 2 (car map)) article) offset)
(nth 1 (car map)) buffer))))
(defun nnvirtual-request-group (group &optional server dont-check)
"Make GROUP the current newsgroup."
(nnvirtual-possibly-change-newsgroups group server dont-check)
(let ((map nnvirtual-current-mapping))
(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
server fetch-old)
(when (nnvirtual-possibly-change-server server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if map
(progn
(while (cdr map)
(setq map (cdr map)))
(insert (format "211 %d 1 %d %s\n" (car (car map))
(car (car map)) group))
t)
(setq nnvirtual-status-string "No component groups")
(setq nnvirtual-current-group nil)
nil))))
(if (stringp (car articles))
'headers
(let ((vbuf (nnheader-set-temp-buffer
(get-buffer-create " *virtual headers*")))
(unfetched (mapcar (lambda (g) (list g))
nnvirtual-component-groups))
(system-name (system-name))
cgroup article result prefix)
(while articles
(setq article (assq (pop articles) nnvirtual-mapping))
(when (and (setq cgroup (cadr article))
(gnus-check-server
(gnus-find-method-for-group cgroup) t)
(gnus-request-group cgroup t))
(setq prefix (gnus-group-real-prefix cgroup))
(when (setq result (gnus-retrieve-headers
(list (caddr article)) cgroup nil))
(set-buffer nntp-server-buffer)
(if (zerop (buffer-size))
(nconc (assq cgroup unfetched) (list (caddr article)))
;; 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 (read nntp-server-buffer) (point)))
(princ (car article) (current-buffer))
(beginning-of-line)
(looking-at
"[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
(goto-char (match-end 0))
(or (search-forward
"\t" (save-excursion (end-of-line) (point)) t)
(end-of-line))
(while (= (char-after (1- (point))) ? )
(forward-char -1)
(delete-char 1))
(if (eolp)
(progn
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(insert ?\t))
(insert "Xref: " system-name " " cgroup ":")
(princ (caddr article) (current-buffer))
(insert "\t"))
(insert "Xref: " system-name " " cgroup ":")
(princ (caddr article) (current-buffer))
(insert " ")
(if (not (string= "" prefix))
(while (re-search-forward
"[^ ]+:[0-9]+"
(save-excursion (end-of-line) (point)) t)
(save-excursion
(goto-char (match-beginning 0))
(insert prefix))))
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(insert ?\t)))
(forward-line 1))
(set-buffer vbuf)
(goto-char (point-max))
(insert-buffer-substring nntp-server-buffer)))))
;; In case some of the articles have expired or been
;; cancelled, we have to mark them as read in the
;; component group.
(while unfetched
(when (cdar unfetched)
(gnus-group-make-articles-read
(caar unfetched) (sort (cdar unfetched) '<)))
(setq unfetched (cdr unfetched)))
;; The headers are ready for reading, so they are inserted into
;; the nntp-server-buffer, which is where Gnus expects to find
;; them.
(prog1
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring vbuf)
'nov)
(kill-buffer vbuf)))))))
(deffoo nnvirtual-request-article (article &optional group server buffer)
(when (and (nnvirtual-possibly-change-server server)
(numberp article))
(let* ((amap (assq article nnvirtual-mapping))
(cgroup (cadr amap)))
(cond
((not amap)
(nnheader-report 'nnvirtual "No such article: %s" article))
((not (gnus-check-group cgroup))
(nnheader-report
'nnvirtual "Can't open server where %s exists" cgroup))
((not (gnus-request-group cgroup t))
(nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
(t
(if buffer
(save-excursion
(set-buffer buffer)
(gnus-request-article-this-buffer (caddr amap) cgroup))
(gnus-request-article (caddr amap) cgroup)))))))
(deffoo nnvirtual-open-server (server &optional defs)
(unless (assq 'nnvirtual-component-regexp defs)
(push `(nnvirtual-component-regexp ,server)
defs))
(nnoo-change-server 'nnvirtual server defs)
(if nnvirtual-component-groups
t
(setq nnvirtual-mapping nil)
;; Go through the newsrc alist and find all component groups.
(let ((newsrc (cdr gnus-newsrc-alist))
group)
(while (setq group (car (pop newsrc)))
(when (string-match nnvirtual-component-regexp group) ; Match
;; Add this group to the list of component groups.
(setq nnvirtual-component-groups
(cons group (delete group nnvirtual-component-groups))))))
(if (not nnvirtual-component-groups)
(nnheader-report 'nnvirtual "No component groups: %s" server)
t)))
(deffoo nnvirtual-request-group (group &optional server dont-check)
(nnvirtual-possibly-change-server server)
(setq nnvirtual-component-groups
(delete (nnvirtual-current-group) nnvirtual-component-groups))
(cond
((null nnvirtual-component-groups)
(setq nnvirtual-current-group nil)
(nnheader-report 'nnvirtual "No component groups in %s" group))
(t
(unless dont-check
(nnvirtual-create-mapping))
(setq nnvirtual-current-group group)
(let ((len (length nnvirtual-mapping)))
(nnheader-insert "211 %d 1 %d %s\n" len len group)))))
(deffoo nnvirtual-request-type (group &optional article)
(if (not article)
'unknown
(let ((mart (assq article nnvirtual-mapping)))
(when mart
(gnus-request-type (cadr mart) (car mart))))))
(deffoo nnvirtual-request-update-mark (group article mark)
(let* ((nart (assq article nnvirtual-mapping))
(cgroup (cadr nart))
;; The component group might be a virtual group.
(nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
(when (and nart
(= mark nmark)
(gnus-group-auto-expirable-p cgroup))
(setq mark gnus-expirable-mark)))
mark)
(defun nnvirtual-close-group (group &optional server)
(if (not nnvirtual-current-group)
()
(nnvirtual-possibly-change-newsgroups group server t)
(nnvirtual-update-marked)
(setq nnvirtual-current-group nil
nnvirtual-current-groups nil
nnvirtual-current-mapping nil)
(setq nnvirtual-group-alist
(delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist))))
(deffoo nnvirtual-close-group (group &optional server)
(when (nnvirtual-possibly-change-server server)
;; Copy (un)read articles.
(nnvirtual-update-reads)
;; We copy the marks from this group to the component
;; groups here.
(nnvirtual-update-marked))
t)
(deffoo nnvirtual-request-list (&optional server)
(nnheader-report 'nnvirtual "LIST is not implemented."))
(defun nnvirtual-request-list (&optional server)
(setq nnvirtual-status-string "nnvirtual: LIST is not implemented.")
nil)
(deffoo nnvirtual-request-newgroups (date &optional server)
(nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
(defun nnvirtual-request-newgroups (date &optional server)
"List new groups."
(setq nnvirtual-status-string "NEWGROUPS is not supported.")
nil)
(deffoo nnvirtual-request-list-newsgroups (&optional server)
(nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
(defun nnvirtual-request-list-newsgroups (&optional server)
(setq nnvirtual-status-string
"nnvirtual: LIST NEWSGROUPS is not implemented.")
nil)
(defalias 'nnvirtual-request-post 'nntp-request-post)
(defun nnvirtual-request-post-buffer
(post group subject header article-buffer info follow-to respect-poster)
(nntp-request-post-buffer post "" subject header article-buffer
info follow-to respect-poster))
;;; Internal functions.
;; Convert HEAD headers into NOV headers.
(defun nnvirtual-convert-headers ()
(save-excursion
(set-buffer nntp-server-buffer)
(let* ((gnus-newsgroup-dependencies (make-vector 100 0))
(headers (gnus-get-newsgroup-headers))
header)
(erase-buffer)
(while headers
(setq header (car headers)
headers (cdr headers))
(insert (int-to-string (mail-header-number header)) "\t"
(or (mail-header-subject header) "") "\t"
(or (mail-header-from header) "") "\t"
(or (mail-header-date header) "") "\t"
(or (mail-header-id header) "") "\t"
(or (mail-header-references header) "") "\t"
(int-to-string (or (mail-header-chars header) 0)) "\t"
(int-to-string (or (mail-header-lines header) 0)) "\t"
(if (mail-header-xref header)
(concat "Xref: " (mail-header-xref header) "\t")
"") "\n")))))
(defun nnvirtual-possibly-change-newsgroups (group regexp &optional check)
(let ((inf t))
(or (not group)
(and nnvirtual-current-group
(string= group nnvirtual-current-group))
(and (setq inf (assoc group nnvirtual-group-alist))
(string= (nth 3 inf) regexp)
(progn
(setq nnvirtual-current-group (car inf))
(setq nnvirtual-current-groups (nth 1 inf))
(setq nnvirtual-current-mapping (nth 2 inf)))))
(if (or (not check) (not inf))
(progn
(and inf (setq nnvirtual-group-alist
(delq inf nnvirtual-group-alist)))
(setq nnvirtual-current-mapping nil)
(setq nnvirtual-current-group group)
(let ((newsrc gnus-newsrc-alist)
(virt-group (gnus-group-prefixed-name
nnvirtual-current-group '(nnvirtual ""))))
(setq nnvirtual-current-groups nil)
(while newsrc
(and (string-match regexp (car (car newsrc)))
(not (string= (car (car newsrc)) virt-group))
(setq nnvirtual-current-groups
(cons (car (car newsrc)) nnvirtual-current-groups)))
(setq newsrc (cdr newsrc))))
(if nnvirtual-current-groups
(progn
(nnvirtual-create-mapping group)
(setq nnvirtual-group-alist
(cons (list group nnvirtual-current-groups
nnvirtual-current-mapping regexp)
nnvirtual-group-alist)))
(setq nnvirtual-status-string
(format
"nnvirtual: No newsgroups for this virtual newsgroup"))))))
nnvirtual-current-groups)
(defun nnvirtual-create-mapping (group)
(let* ((group (gnus-group-prefixed-name group (list 'nnvirtual "")))
(info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
(groups nnvirtual-current-groups)
(offset 0)
reads unread igroup itotal ireads)
;; The virtual group doesn't exist. (?)
(or info (error "No such group: %s" group))
(setq nnvirtual-current-mapping nil)
(while groups
;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
(setq igroup (car groups))
(let ((info (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb)))
(active (gnus-gethash igroup gnus-active-hashtb)))
;; See if the group has had its active list read this session
;; if not, we do it now.
(if (null active)
(if (gnus-activate-group igroup)
(progn
(gnus-get-unread-articles-in-group
info (gnus-gethash igroup gnus-active-hashtb))
(setq active (gnus-gethash igroup gnus-active-hashtb)))
(message "Couldn't open component group %s" igroup)))
(if (null active)
()
;; And then we do the mapping for this component group. If
;; you feel tempted to cast your eyes to the soup below -
;; don't. It'll hurt your soul. Suffice to say that it
;; assigns ranges of nnvirtual article numbers to the
;; different component groups. To get the article number
;; from the nnvirtual number, one does something like
;; (+ (- number offset) (car active)), where `offset' is the
;; slice the mess below assigns, and active is the lowest
;; active article in the component group.
(setq itotal (1+ (- (cdr active) (car active))))
(if (setq ireads (nth 2 info))
(let ((itreads
(if (not (listp (cdr ireads)))
(setq ireads (list (cons (car ireads) (cdr ireads))))
(setq ireads (copy-alist ireads)))))
(if (< (or (and (numberp (car ireads)) (car ireads))
(cdr (car ireads))) (car active))
(setq ireads (setq itreads (cdr ireads))))
(if (and ireads (< (or (and (numberp (car ireads))
(car ireads))
(car (car ireads))) (car active)))
(setcar (or (and (numberp (car ireads)) ireads)
(car ireads)) (1+ (car active))))
(while itreads
(setcar (or (and (numberp (car itreads)) itreads)
(car itreads))
(+ (max
1 (- (if (numberp (car itreads))
(car itreads)
(car (car itreads)))
(car active)))
offset))
(if (not (numberp (car itreads)))
(setcdr (car itreads)
(+ (- (cdr (car itreads)) (car active)) offset)))
(setq itreads (cdr itreads)))
(setq reads (nconc reads ireads))))
(setq offset (+ offset (1- itotal)))
(setq nnvirtual-current-mapping
(cons (list offset igroup (car active))
nnvirtual-current-mapping)))
(setq groups (cdr groups))))
(setq nnvirtual-current-mapping
(nreverse nnvirtual-current-mapping))
;; Set Gnus active info.
(gnus-sethash group (cons 1 (1- offset)) gnus-active-hashtb)
;; Set Gnus read info.
(setcar (nthcdr 2 info) reads)
;; Then we deal with the marks.
(let ((map nnvirtual-current-mapping)
(marks '(tick dormant reply expire score))
(offset 0)
tick dormant reply expire score marked active)
(deffoo nnvirtual-request-update-info (group info &optional server)
(when (nnvirtual-possibly-change-server server)
(let ((map nnvirtual-mapping)
(marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
reads mr m op)
;; Go through the mapping.
(while map
(setq igroup (nth 1 (car map)))
(setq active (nth 2 (car map)))
(setq marked (nth 3 (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb))))
(let ((m marks))
(while m
(and (assq (car m) marked)
(set (car m)
(nconc (mapcar
(lambda (art)
(if (numberp art)
(if (< art active)
0 (+ (- art active) offset))
(cons (+ (- (car art) active) offset)
(cdr art))))
(cdr (assq (car m) marked)))
(symbol-value (car m)))))
(setq m (cdr m))))
(setq offset (car (car map)))
(setq map (cdr map)))
;; Put the list of marked articles in the info of the virtual group.
(let ((m marks)
marked)
(while m
(and (symbol-value (car m))
(setq marked (cons (cons (car m) (symbol-value (car m)))
marked)))
(setq m (cdr m)))
(if (nthcdr 3 info)
(setcar (nthcdr 3 info) marked)
(setcdr (nthcdr 2 info) (list marked)))))))
(defun nnvirtual-update-marked ()
(let ((mark-lists '((gnus-newsgroup-marked . tick)
(gnus-newsgroup-dormant . dormant)
(gnus-newsgroup-expirable . expire)
(gnus-newsgroup-replied . reply)))
marks art-group group-alist g)
(while mark-lists
(setq marks (symbol-value (car (car mark-lists))))
;; Find out what groups the mark belong to.
(while marks
(setq art-group (nnvirtual-art-group (car marks)))
(if (setq g (assoc (car art-group) group-alist))
(nconc g (list (cdr art-group)))
(setq group-alist (cons (list (car art-group) (cdr art-group))
group-alist)))
(unless (nth 3 (setq m (pop map)))
;; Read article.
(push (car m) reads))
;; Copy marks.
(when (setq mr (nth 4 m))
(while mr
(setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
;; Compress the marks and the reads.
(setq mr marks)
(while mr
(setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
(setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
;; Remove empty marks lists.
(while (and marks (not (cdar marks)))
(setq marks (cdr marks)))
;; The groups that don't have marks must have no marks. (Yup.)
(let ((groups nnvirtual-current-groups))
(while groups
(or (assoc (car groups) group-alist)
(setq group-alist (cons (list (car groups)) group-alist)))
(setq groups (cdr groups))))
;; The we update the list of marks.
(while group-alist
(gnus-add-marked-articles
(car (car group-alist)) (cdr (car mark-lists))
(cdr (car group-alist)) nil t)
(gnus-group-update-group (car (car group-alist)) t)
(setq group-alist (cdr group-alist)))
(setq mark-lists (cdr mark-lists)))))
(setq mr marks)
(while (cdr mr)
(if (cdadr mr)
(setq mr (cdr mr))
(setcdr mr (cddr mr))))
(defun nnvirtual-art-group (article)
(let ((map nnvirtual-current-mapping)
(offset 0))
(while (< (car (car map)) (if (numberp article) article (car article)))
(setq offset (car (car map))
map (cdr map)))
(cons (nth 1 (car map))
(if (numberp article)
(- (+ article (nth 2 (car map))) offset)
(cons (- (+ (car article) (nth 2 (car map))) offset)
(cdr article))))))
;; Enter these new marks into the info of the group.
(if (nthcdr 3 info)
(setcar (nthcdr 3 info) marks)
;; Add the marks lists to the end of the info.
(when marks
(setcdr (nthcdr 2 info) (list marks))))
t)))
(defun nnvirtual-catchup-group (group &optional server all)
(nnvirtual-possibly-change-newsgroups group server)
(let ((gnus-group-marked nnvirtual-current-groups)
(deffoo nnvirtual-catchup-group (group &optional server all)
(nnvirtual-possibly-change-server server)
(let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
(gnus-expert-user t))
;; Make sure all groups are activated.
(mapcar
(lambda (g)
(when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
(gnus-activate-group g)))
nnvirtual-component-groups)
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-catchup-current nil all))))
(deffoo nnvirtual-find-group-art (group article)
"Return the real group and article for virtual GROUP and ARTICLE."
(let ((mart (assq article nnvirtual-mapping)))
(when mart
(cons (cadr mart) (caddr mart)))))
;;; Internal functions.
(defun nnvirtual-convert-headers ()
"Convert HEAD headers into NOV headers."
(save-excursion
(set-buffer nntp-server-buffer)
(let* ((dependencies (make-vector 100 0))
(headers (gnus-get-newsgroup-headers dependencies))
header)
(erase-buffer)
(while (setq header (pop headers))
(nnheader-insert-nov header)))))
(defun nnvirtual-possibly-change-server (server)
(or (not server)
(nnoo-current-server-p 'nnvirtual server)
(nnvirtual-open-server server)))
(defun nnvirtual-update-marked ()
"Copy marks from the virtual group to the component groups."
(let ((mark-lists gnus-article-mark-lists)
(marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group))))
type list mart cgroups)
(while (setq type (cdr (pop mark-lists)))
(setq list (gnus-uncompress-range (cdr (assq type marks))))
(setq cgroups
(mapcar (lambda (g) (list g)) nnvirtual-component-groups))
(while list
(nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
cgroups)
(list (caddr mart))))
(while cgroups
(gnus-add-marked-articles
(caar cgroups) type (cdar cgroups) nil t)
(gnus-group-update-group (car (pop cgroups)) t)))))
(defun nnvirtual-update-reads ()
"Copy (un)reads from the current group to the component groups."
(let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
(articles (gnus-list-of-unread-articles
(nnvirtual-current-group)))
m)
(while articles
(setq m (assq (pop articles) nnvirtual-mapping))
(nconc (assoc (nth 1 m) groups) (list (nth 2 m))))
(while groups
(gnus-update-read-articles (caar groups) (cdr (pop groups))))))
(defun nnvirtual-current-group ()
"Return the prefixed name of the current nnvirtual group."
(concat "nnvirtual:" nnvirtual-current-group))
(defsubst nnvirtual-marks (article marks)
"Return a list of mark types for ARTICLE."
(let (out)
(while marks
(when (memq article (cdar marks))
(push (caar marks) out))
(setq marks (cdr marks)))
out))
(defun nnvirtual-create-mapping ()
"Create an article mapping for the current group."
(let* ((div nil)
m marks list article unreads marks active
(map (sort
(apply
'nconc
(mapcar
(lambda (g)
(when (and (setq active (gnus-activate-group g))
(> (cdr active) (car active)))
(setq unreads (gnus-list-of-unread-articles g)
marks (gnus-uncompress-marks
(gnus-info-marks (gnus-get-info g))))
(when gnus-use-cache
(push (cons 'cache (gnus-cache-articles-in-group g))
marks))
(setq div (/ (float (car active))
(if (zerop (cdr active))
1 (cdr active))))
(mapcar (lambda (n)
(list (* div (- n (car active)))
g n (and (memq n unreads) t)
(inline (nnvirtual-marks n marks))))
(gnus-uncompress-range active))))
nnvirtual-component-groups))
(lambda (m1 m2)
(< (car m1) (car m2)))))
(i 0))
(setq nnvirtual-mapping map)
;; Set the virtual article numbers.
(while (setq m (pop map))
(setcar m (setq article (incf i))))))
(provide 'nnvirtual)
;;; nnvirtual.el ends here