Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

*** empty log message ***

  • Loading branch information...
commit 5512f5d5e241d7780d96c43ac2a21a52744171ba 1 parent c343b50
@larsmagne larsmagne authored
Showing with 2,621 additions and 806 deletions.
  1. +180 −0 lisp/ChangeLog
  2. +4 −2 lisp/article.el
  3. +30 −4 lisp/custom-edit.el
  4. +31 −17 lisp/custom.el
  5. +95 −23 lisp/gnus-art.el
  6. +7 −8 lisp/gnus-async.el
  7. +8 −7 lisp/gnus-cache.el
  8. +17 −13 lisp/gnus-demon.el
  9. +3 −2 lisp/gnus-ems.el
  10. +3 −0  lisp/gnus-group.el
  11. +3 −4 lisp/gnus-kill.el
  12. +11 −8 lisp/gnus-msg.el
  13. +18 −13 lisp/gnus-nocem.el
  14. +17 −14 lisp/gnus-score.el
  15. +10 −8 lisp/gnus-setup.el
  16. +4 −0 lisp/gnus-soup.el
  17. +19 −6 lisp/gnus-sum.el
  18. +5 −3 lisp/gnus-topic.el
  19. +0 −1  lisp/gnus-undo.el
  20. +15 −8 lisp/gnus-util.el
  21. +17 −13 lisp/gnus-xmas.el
  22. +50 −55 lisp/gnus.el
  23. +319 −289 lisp/message.el
  24. +0 −3  lisp/messcompat.el
  25. +9 −4 lisp/nnbabyl.el
  26. +2 −1  lisp/nnfolder.el
  27. +0 −1  lisp/nnheader.el
  28. +41 −29 lisp/nnmail.el
  29. +8 −3 lisp/nnmbox.el
  30. +2 −2 lisp/nnmh.el
  31. +3 −2 lisp/nnml.el
  32. +0 −5 lisp/nnoo.el
  33. +42 −36 lisp/nnsoup.el
  34. +7 −2 lisp/nntp.el
  35. +3 −0  lisp/nnweb.el
  36. +15 −18 lisp/widget-edit.el
  37. +1 −1  lisp/widget.el
  38. +26 −0 texi/ChangeLog
  39. +339 −99 texi/custom.texi
  40. +70 −9 texi/gnus.texi
  41. +1,025 −0 texi/message.texi
  42. +162 −93 texi/widget.texi
View
180 lisp/ChangeLog
@@ -1,3 +1,183 @@
+Tue Oct 29 20:42:07 1996 Lars Magne Ingebrigtsen <larsi@ylfing.ifi.uio.no>
+
+ * gnus-topic.el (gnus-topic-remove-topic): Fold properly.
+
+Tue Oct 29 19:45:25 1996 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+ * message.el (message-generate-new-buffer-clone-locals): Bugged
+ out under XEmacs.
+
+Tue Oct 29 19:21:47 1996 David Moore <dmoore@ucsd.edu>
+
+ * gnus.el: Fixed autoloads.
+
+Tue Oct 29 17:21:42 1996 Lars Magne Ingebrigtsen <larsi@ylfing.ifi.uio.no>
+
+ * gnus-art.el (gnus-url-mailto): `message-goto-subject' takes no
+ args.
+
+Mon Oct 28 15:42:21 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus.el: Autoload gnus-score-followup-thread.
+ (gnus-inhibit-startup-message): Doc fix.
+
+Sat Oct 26 15:48:28 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus-xmas.el (gnus-xmas-topic-menu-add): Add menu.
+
+ * gnus-topic.el (gnus-topic-kill-group): Enter into dribble.
+
+ * gnus-sum.el (gnus-summary-universal-argument): Bind
+ `gnus-newsgroup-process-marked' to nil before calling functions.
+
+Sat Oct 26 15:31:18 1996 David Moore <dmoore@ucsd.edu>
+
+ * nnmail.el (nnmail-activate): Faster version.
+
+Fri Oct 25 09:02:08 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * nnsoup.el (nnsoup-pack-replies): Error empty dirs.
+
+ * gnus-msg.el (gnus-summary-mail-forward): Allow prefix to forward
+ full headers.
+
+Thu Oct 24 07:20:30 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus-nocem.el (gnus-nocem-enter-article): Would enter unbound
+ symbols into hashtb.
+
+Thu Oct 24 07:12:23 1996 Michael R. Cook <mcook@cognex.com>
+
+ * nnmh.el (nnmh-active-number): Misplaced paren.
+
+Thu Oct 24 07:02:54 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus-group.el (gnus-group-list-groups): Clear inboxes.
+
+ * gnus-async.el (gnus-make-async-article-function): Use the
+ success param.
+
+ * nntp.el (nntp-after-change-function-callback): Pass along the
+ right success param.
+
+Wed Oct 23 18:33:15 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus-score.el (gnus-summary-increase-score): Spud.
+
+Wed Oct 23 07:55:42 1996 William Perry <wmperry@aventail.com>
+
+ * gnus-art.el (gnus-url-mailto): New function.
+
+Wed Oct 23 06:57:10 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * nnbabyl.el (nnbabyl-create-mbox): New function.
+ (nnbabyl-open-server): Create mbox.
+
+ * nnmbox.el (nnmbox-create-mbox): New function.
+
+Tue Oct 22 07:30:12 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * nnml.el (nnml-request-list): Always return t.
+
+Tue Oct 22 03:16:27 1996 Felix Lee <flee@teleport.com>
+
+ * gnus-score.el (gnus-score-adaptive): Use the right syntax
+ table.
+
+Tue Oct 22 03:08:30 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * message.el (message-generate-headers): Rename Original-Sender as
+ well.
+ (message-send-news): Typo.
+ (message-send-news): Don't message.
+
+Tue Oct 22 03:06:49 1996 Felix Lee <flee@teleport.com>
+
+ * gnus-score.el (gnus-score-adaptive): gnus-score-adaptive will do
+ line scoring or word scoring, but not both.
+
+Tue Oct 22 02:48:08 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * message.el (message-send-news): Use it.
+ (message-send-mail): Ditto.
+
+Tue Oct 22 02:40:14 1996 Joev Dubach <dubach1@husc.harvard.edu>
+
+ * message.el (message-generate-new-buffer-clone-locals): New
+ function.
+
+Tue Oct 22 01:19:47 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * message.el: Removed `lisp-indent-hook' throughout all files.
+
+ * gnus.el (gnus-sethash): Fix edebug form spec.
+
+ * gnus-cache.el (gnus-cache-file-name): Translate file chars.
+
+Sun Oct 20 03:41:47 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * nntp.el (nntp-read-server-type): Fold case.
+
+Sat Oct 19 08:03:17 1996 Michael Ernst <mernst@cs.washington.edu>
+
+ * article.el (article-hide-headers): Do the right thing on
+ articles with no bodies.
+ (article-narrow-to-signature): Doc fix.
+
+Sat Oct 19 07:53:49 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * nnsoup.el (nnsoup-pack-replies): Refuse to pack when there is
+ nothing to pack.
+ (nnsoup-read-areas): Don't bug out on empty packets.
+
+ * gnus-soup.el (gnus-soup-pack-packet): Refuse to pack empty
+ packets.
+
+Sat Oct 19 07:43:33 1996 Kees de Bruin <kees_de_bruin@tasking.nl>
+
+ * gnus-sum.el (gnus-auto-center-summary): Fix.
+
+Sat Oct 19 07:32:27 1996 Marc Horowitz <marc@cygnus.com>
+
+ * gnus-topic.el (gnus-topic-remove-topic): Would clobber
+ duplicates.
+
+Sat Oct 19 07:01:14 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * message.el (message-send-mail-hook): New hook.
+ (message-send-news-hook): Ditto.
+
+ * gnus-art.el (gnus-summary-write-to-file): New function.
+
+Sat Oct 19 06:56:34 1996 Kees de Bruin <kees_de_bruin@tasking.nl>
+
+ * gnus-sum.el (gnus-summary-save-article-mail-overwrite): New
+ command and keystroke.
+
+Thu Oct 17 06:25:55 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus-sum.el (gnus-article-sort-by-date): Use faster
+ implementation.
+
+ * gnus-util.el (gnus-string-get-time): New macro.
+
+ * message.el (message-check-news-syntax): Check more thorougly the
+ From header.
+ (message-check): New macro.
+
+Thu Oct 17 06:03:56 1996 Carsten Leonhardt <leo@arioch.tng.oche.de>
+
+ * gnus-ems.el (gnus-xemacs): Avoid clobbering functions.
+
+Thu Oct 17 05:34:15 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * message.el (message-cite-function): Initialize from
+ mail-citation-hook.
+
+Thu Oct 17 02:45:47 1996 Lars Magne Ingebrigtsen <larsi@hrym.ifi.uio.no>
+
+ * gnus.el: Red Gnus v0.52 is released.
+
Wed Oct 16 21:01:41 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
* gnus-sum.el (gnus-summary-catchup): Return t.
View
6 lisp/article.el
@@ -252,7 +252,9 @@ always hide."
;; Then treat the rest of the header lines.
(narrow-to-region
(point)
- (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
+ (if (search-forward "\n\n" nil t) ; if there's a body
+ (progn (forward-line -1) (point))
+ (point-max)))
;; Then we use the two regular expressions
;; `gnus-ignored-headers' and `gnus-visible-headers' to
;; select which header lines is to remain visible in the
@@ -632,7 +634,7 @@ always hide."
(defvar mime::preview/content-list)
(defvar mime::preview-content-info/point-min)
(defun article-narrow-to-signature ()
- "Narrow to the signature."
+ "Narrow to the signature; return t if a signature is found, else nil."
(widen)
(when (and (boundp 'mime::preview/content-list)
mime::preview/content-list)
View
34 lisp/custom-edit.el
@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 0.993
+;; Version: 0.995
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
@@ -15,6 +15,7 @@
(require 'custom)
(require 'widget-edit)
+(require 'easymenu)
(define-widget-keywords :custom-show :custom-magic
:custom-state :custom-level :custom-form
@@ -285,10 +286,14 @@ The list should be sorted most significant first."
(form (widget-get widget :custom-form))
(state (widget-get widget :custom-state))
(symbol (widget-get widget :value))
+ (options (get symbol 'custom-options))
(child-type (or (get symbol 'custom-type) 'sexp))
- (type (if (listp child-type)
- child-type
- (list child-type)))
+ (type (let ((tmp (if (listp child-type)
+ child-type
+ (list child-type))))
+ (when options
+ (widget-put tmp :options options))
+ tmp))
(conv (widget-convert type))
(value (if (boundp symbol)
(symbol-value symbol)
@@ -669,6 +674,27 @@ Optional EVENT is the location for the menu."
(widget-apply widget :notify widget event)
(widget-setup))))
+;;; The `hook' Widget.
+
+(define-widget 'hook 'list
+ "A emacs lisp hook"
+ :convert-widget 'custom-hook-convert-widget
+ :tag "Hook")
+
+(defun custom-hook-convert-widget (widget)
+ ;; Handle `:custom-options'.
+ (let* ((options (widget-get widget :options))
+ (other `(editable-list :inline t (function :format "%v")))
+ (args (if options
+ (list `(checklist :inline t
+ ,@(mapcar (lambda (entry)
+ `(function-item ,entry))
+ options))
+ other)
+ (list other))))
+ (widget-put widget :args args)
+ widget))
+
;;; The `custom-group' Widget.
(define-widget 'custom-group 'custom
View
48 lisp/custom.el
@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 0.993
+;; Version: 0.995
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
@@ -19,7 +19,7 @@
(require 'widget)
-(define-widget-keywords :type :group)
+(define-widget-keywords :options :type :group)
;; These autoloads should be deleted when the file is added to Emacs
(autoload 'customize "custom-edit" nil t)
@@ -48,13 +48,21 @@
(color-instance-name
(specifier-instance
(face-background 'default))))
- (error nil))))
- (cond (bg-resource (intern (downcase bg-resource)))
- ((and color
- (< (apply '+ (custom-x-color-values color))
- (/ (apply '+ (custom-x-color-values "white")) 3)))
- 'dark)
- (t 'light))))
+ (error nil)))
+ (mode (cond (bg-resource (intern (downcase bg-resource)))
+ ((and color
+ (< (apply '+ (custom-x-color-values color))
+ (/ (apply '+ (custom-x-color-values "white"))
+ 3)))
+ 'dark)
+ (t 'light))))
+ (if (fboundp 'set-frame-property)
+ ;; `modify-frame-properties' is borken on XEmacs 19.14.
+ (set-frame-property (selected-frame) 'background-mode mode)
+ ;; `set-frame-property' is unimplemented in Emacs 19.34.
+ (modify-frame-parameters (selected-frame)
+ (cons (cons 'background-mode mode) params)))
+ mode))
;;; The `defcustom' Macro.
@@ -80,6 +88,9 @@
(setq args (cdr args))
(cond ((eq keyword :type)
(put symbol 'custom-type value))
+ ((eq keyword :options)
+ (put symbol 'custom-options
+ (append value (get symbol 'custom-options))))
((eq keyword :group)
(custom-add-to-group value symbol 'custom-variable))
(t
@@ -98,7 +109,8 @@ The remaining arguments should have the form
The following KEYWORD's are defined:
-:type VALUE should be a sexp widget.
+:type VALUE should be a widget type.
+:options VALUE should be a list of valid members of the widget type.
:group VALUE should be a customization group.
Add SYMBOL to that group.
@@ -113,10 +125,11 @@ information."
(defun custom-declare-face (face spec doc &rest args)
"Like `defface', but FACE is evaluated as a normal argument."
(put face 'factory-face spec)
- (unless (facep face)
- ;; If the user has already created the face, respect that.
- (let ((value (or (get face 'saved-face) spec)))
- (custom-face-display-set face value)))
+ (when (fboundp 'facep)
+ (unless (facep face)
+ ;; If the user has already created the face, respect that.
+ (let ((value (or (get face 'saved-face) spec)))
+ (custom-face-display-set face value))))
(when doc
(put face 'face-documentation doc))
(while args
@@ -274,7 +287,7 @@ examine the brightness for you."
(defun custom-display-match-frame (display frame)
"Non-nil iff DISPLAY matches FRAME.
If FRAME is nil, the current FRAME is used."
- ;; This is a kludge to get started, we realle should use specifiers!
+ ;; This is a kludge to get started, we really should use specifiers!
(unless frame
(setq frame (selected-frame)))
(if (eq display t)
@@ -287,9 +300,10 @@ If FRAME is nil, the current FRAME is used."
(options (cdr entry)))
(setq display (cdr display))
(cond ((eq req 'type)
- (setq match (if (fboundp 'device-type)
+ (let ((type (if (fboundp 'device-type)
(device-type frame)
- (memq window-system options))))
+ window-system)))
+ (setq match (memq type options))))
((eq req 'class)
(let ((class (if (fboundp 'device-class)
(device-class frame)
View
118 lisp/gnus-art.el
@@ -73,14 +73,16 @@ Gnus provides the following functions:
* gnus-summary-save-in-rmail (Rmail format)
* gnus-summary-save-in-mail (Unix mail format)
* gnus-summary-save-in-folder (MH folder)
-* gnus-summary-save-in-file (article format).
-* gnus-summary-save-in-vm (use VM's folder format)."
+* gnus-summary-save-in-file (article format)
+* gnus-summary-save-in-vm (use VM's folder format)
+* gnus-summary-write-to-file (article format -- overwrite)."
:group 'article
:type '(radio (function-item gnus-summary-save-in-rmail)
(function-item gnus-summary-save-in-mail)
(function-item gnus-summary-save-in-folder)
(function-item gnus-summary-save-in-file)
- (function-item gnus-summary-save-in-vm)))
+ (function-item gnus-summary-save-in-vm)
+ (function-item gnus-summary-write-to-file)))
(defcustom gnus-rmail-save-name 'gnus-plain-save-name
"A function generating a file name to save articles in Rmail format.
@@ -473,7 +475,7 @@ Directory to save to is default to `gnus-article-save-directory'."
;; Remember the directory name to save articles.
(setq gnus-newsgroup-last-mail filename)))
-(defun gnus-summary-save-in-file (&optional filename)
+(defun gnus-summary-save-in-file (&optional filename overwrite)
"Append this article to file.
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
@@ -489,32 +491,19 @@ Directory to save to is default to `gnus-article-save-directory'."
(save-excursion
(save-restriction
(widen)
+ (when (and overwrite
+ (file-exists-p filename))
+ (delete-file filename))
(gnus-output-to-file filename))))
;; Remember the directory name to save articles.
(setq gnus-newsgroup-last-file filename)))
-(defun gnus-summary-save-body-in-file (&optional filename)
+(defun gnus-summary-write-to-file (&optional filename)
"Append this article body to a file.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(interactive)
- (gnus-set-global-variables)
- (let ((default-name
- (funcall gnus-file-save-name gnus-newsgroup-name
- gnus-current-headers gnus-newsgroup-last-file)))
- (setq filename (gnus-read-save-file-name
- "Save %s body in file:" default-name filename))
- (gnus-make-directory (file-name-directory filename))
- (gnus-eval-in-buffer-window gnus-original-article-buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (narrow-to-region (point) (point-max)))
- (gnus-output-to-file filename))))
- ;; Remember the directory name to save articles.
- (setq gnus-newsgroup-last-file filename)))
+ (gnus-summary-save-in-file nil t))
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
@@ -1472,7 +1461,7 @@ groups."
gnus-button-fetch-group 3)
("\\(<?\\(url: ?\\)?news:\\([^>\n\t ]*\\)>?\\)" 1 t
gnus-button-message-id 3)
- ("\\(<URL: *\\)?mailto: *\\([^> \n\t]+\\)>?" 0 t gnus-button-reply 2)
+ ("\\(<URL: *\\)?mailto: *\\([^> \n\t]+\\)>?" 0 t gnus-url-mailto 2)
;; This is how URLs _should_ be embedded in text...
("<URL: *\\([^\n\r>]*\\)>" 0 t gnus-button-url 1)
;; Next regexp stolen from highlight-headers.el.
@@ -1832,6 +1821,89 @@ specified by `gnus-button-alist'."
(match-string 3 address)
"nntp"))))))
+(defun gnus-split-string (string pattern)
+ "Return a list of substrings of STRING which are separated by PATTERN."
+ (let (parts (start 0))
+ (while (string-match pattern string start)
+ (setq parts (cons (substring string start (match-beginning 0)) parts)
+ start (match-end 0)))
+ (nreverse (cons (substring string start) parts))))
+
+(defun gnus-url-parse-query-string (query &optional downcase)
+ (let (retval pairs cur key val)
+ (setq pairs (gnus-split-string query "&"))
+ (while pairs
+ (setq cur (car pairs)
+ pairs (cdr pairs))
+ (if (not (string-match "=" cur))
+ nil ; Grace
+ (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
+ (if downcase
+ (setq key (downcase key)))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
+ retval))
+
+(defun gnus-url-unhex (x)
+ (if (> x ?9)
+ (if (>= x ?a)
+ (+ 10 (- x ?a))
+ (+ 10 (- x ?A)))
+ (- x ?0)))
+
+(defun gnus-url-unhex-string (str &optional allow-newlines)
+ "Remove %XXX embedded spaces, etc in a url.
+If optional second argument ALLOW-NEWLINES is non-nil, then allow the
+decoding of carriage returns and line feeds in the string, which is normally
+forbidden in URL encoding."
+ (setq str (or str ""))
+ (let ((tmp "")
+ (case-fold-search t))
+ (while (string-match "%[0-9a-f][0-9a-f]" str)
+ (let* ((start (match-beginning 0))
+ (ch1 (gnus-url-unhex (elt str (+ start 1))))
+ (code (+ (* 16 ch1)
+ (gnus-url-unhex (elt str (+ start 2))))))
+ (setq tmp (concat
+ tmp (substring str 0 start)
+ (cond
+ (allow-newlines
+ (char-to-string code))
+ ((or (= code ?\n) (= code ?\r))
+ " ")
+ (t (char-to-string code))))
+ str (substring str (match-end 0)))))
+ (setq tmp (concat tmp str))
+ tmp))
+
+(defun gnus-url-mailto (url)
+ ;; Send mail to someone
+ (if (not (string-match "mailto:/*\\(.*\\)" url))
+ (error "Malformed mailto link: %s" url))
+ (setq url (substring url (match-beginning 1) nil))
+ (let (to args source-url subject func)
+ (if (string-match (regexp-quote "?") url)
+ (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
+ args (gnus-url-parse-query-string
+ (substring url (match-end 0) nil) t))
+ (setq to (gnus-url-unhex-string url)))
+ (setq args (cons (list "to" to) args)
+ subject (cdr-safe (assoc "subject" args)))
+ (message-mail)
+ (while args
+ (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
+ (if (fboundp func)
+ (funcall func)
+ (message-position-on-field (caar args)))
+ (insert (mapconcat 'identity (cdar args) ", "))
+ (setq args (cdr args)))
+ (if subject
+ (message-goto-body)
+ (message-goto-subject))))
+
(defun gnus-button-mailto (address)
;; Mail to ADDRESS.
(set-buffer (gnus-copy-article-buffer))
View
15 lisp/gnus-async.el
@@ -104,7 +104,6 @@ It should return non-nil if the article is to be prefetched."
(gnus-async-release-semaphore 'gnus-async-article-semaphore)))
(put 'gnus-asynch-with-semaphore 'lisp-indent-function 0)
-(put 'gnus-asynch-with-semaphore 'lisp-indent-hook 0)
(put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body))
;;;
@@ -199,13 +198,13 @@ It should return non-nil if the article is to be prefetched."
"Return a callback function."
`(lambda (arg)
(save-excursion
- (gnus-async-set-buffer)
- (gnus-async-with-semaphore
- (push (list ',(intern (format "%s-%d" group article))
- ,mark (set-marker (make-marker)
- (point-max))
- ,group ,article)
- gnus-async-article-alist))
+ (when arg
+ (gnus-async-set-buffer)
+ (gnus-async-with-semaphore
+ (push (list ',(intern (format "%s-%d" group article))
+ ,mark (set-marker (make-marker) (point-max))
+ ,group ,article)
+ gnus-async-article-alist)))
(if (not (gnus-buffer-live-p ,summary))
(gnus-async-with-semaphore
(setq gnus-async-fetch-list nil))
View
15 lisp/gnus-cache.el
@@ -397,13 +397,14 @@ Returns the list of articles removed."
(defun gnus-cache-file-name (group article)
(concat (file-name-as-directory gnus-cache-directory)
(file-name-as-directory
- (if (gnus-use-long-file-name 'not-cache)
- group
- (let ((group (nnheader-replace-chars-in-string group ?/ ?_)))
- ;; Translate the first colon into a slash.
- (when (string-match ":" group)
- (aset group (match-beginning 0) ?/))
- (nnheader-replace-chars-in-string group ?. ?/))))
+ (nnheader-translate-file-chars
+ (if (gnus-use-long-file-name 'not-cache)
+ group
+ (let ((group (nnheader-replace-chars-in-string group ?/ ?_)))
+ ;; Translate the first colon into a slash.
+ (when (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-update-article (group article)
View
30 lisp/gnus-demon.el
@@ -220,37 +220,41 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(defun gnus-demon-scan-nocem ()
"Scan NoCeM groups for NoCeM messages."
- (gnus-nocem-scan-groups))
+ (save-window-excursion
+ (gnus-nocem-scan-groups)))
(defun gnus-demon-add-disconnection ()
"Add daemonic server disconnection to Gnus."
(gnus-demon-add-handler 'gnus-demon-close-connections nil 30))
(defun gnus-demon-close-connections ()
- (gnus-close-backends))
+ (save-window-excursion
+ (gnus-close-backends)))
(defun gnus-demon-add-scanmail ()
"Add daemonic scanning of mail from the mail backends."
(gnus-demon-add-handler 'gnus-demon-scan-mail 120 60))
(defun gnus-demon-scan-mail ()
- (let ((servers gnus-opened-servers)
- server)
- (while (setq server (car (pop servers)))
- (and (gnus-check-backend-function 'request-scan (car server))
- (or (gnus-server-opened server)
- (gnus-open-server server))
- (gnus-request-scan nil server)))))
+ (save-window-excursion
+ (let ((servers gnus-opened-servers)
+ server)
+ (while (setq server (car (pop servers)))
+ (and (gnus-check-backend-function 'request-scan (car server))
+ (or (gnus-server-opened server)
+ (gnus-open-server server))
+ (gnus-request-scan nil server))))))
(defun gnus-demon-add-rescan ()
"Add daemonic scanning of new articles from all backends."
(gnus-demon-add-handler 'gnus-demon-scan-news 120 60))
(defun gnus-demon-scan-news ()
- (when (gnus-alive-p)
- (save-excursion
- (set-buffer gnus-group-buffer)
- (gnus-group-get-new-news))))
+ (save-window-excursion
+ (when (gnus-alive-p)
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (gnus-group-get-new-news)))))
(provide 'gnus-demon)
View
5 lisp/gnus-ems.el
@@ -27,6 +27,8 @@
(eval-when-compile (require 'cl))
+;;; Function aliases later to be redefined for XEmacs usage.
+
(defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
"Non-nil if running under XEmacs.")
@@ -79,8 +81,7 @@
"{ 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.")
-)
+asynchronously. The compressed face will be piped to this command."))
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
View
3  lisp/gnus-group.el
@@ -872,6 +872,7 @@ ticked: The number of ticked articles."
gnus-group-misc-menu gnus-group-mode-map ""
'("Misc"
["Send a bug report" gnus-bug t]
+ ["Customize" gnus-group-customize t]
["Send a mail" gnus-group-mail t]
["Post an article..." gnus-group-post-news t]
["Check for new news" gnus-group-get-new-news t]
@@ -1004,6 +1005,8 @@ listed."
(gnus-group-default-level nil t)
gnus-group-default-list-level
gnus-level-subscribed))))
+ ;; Just do this here, for no particular good reason.
+ (gnus-clear-inboxes-moved)
(unless level
(setq level (car gnus-group-list-mode)
unread (cdr gnus-group-list-mode)))
View
7 lisp/gnus-kill.el
@@ -628,11 +628,11 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(eval form))))))
did-kill)))
-(defun gnus-execute (field regexp form &optional backward ignore-marked)
+(defun gnus-execute (field regexp form &optional backward unread)
"If FIELD of article header matches REGEXP, execute lisp FORM (or a string).
If FIELD is an empty string (or nil), entire article body is searched for.
If optional 1st argument BACKWARD is non-nil, do backward instead.
-If optional 2nd argument IGNORE-MARKED is non-nil, articles which are
+If optional 2nd argument UNREAD is non-nil, articles which are
marked as read or ticked are ignored."
(save-excursion
(let ((killed-no 0)
@@ -658,8 +658,7 @@ marked as read or ticked are ignored."
(setq article (gnus-summary-article-number)))
;; Find later articles.
(setq article
- (gnus-summary-search-forward
- ignore-marked nil backward)))
+ (gnus-summary-search-forward unread nil backward)))
(and (or (null gnus-newsgroup-kill-headers)
(memq article gnus-newsgroup-kill-headers))
(vectorp (setq header (gnus-summary-article-header article)))
View
19 lisp/gnus-msg.el
@@ -183,7 +183,6 @@ Thank you for your help in stamping out bugs.
'send))
(put 'gnus-setup-message 'lisp-indent-function 1)
-(put 'gnus-setup-message 'lisp-indent-hook 1)
(put 'gnus-setup-message 'edebug-form-spec '(form body))
;;; Post news commands of Gnus group mode and summary mode
@@ -563,14 +562,17 @@ If prefix argument YANK is non-nil, original article is yanked automatically."
(interactive "P")
(gnus-summary-reply (gnus-summary-work-articles n)))
-(defun gnus-summary-mail-forward (&optional post)
- "Forward the current message to another user."
+(defun gnus-summary-mail-forward (&optional full-headers post)
+ "Forward the current message to another user.
+If FULL-HEADERS (the prefix), include full headers when forwarding."
(interactive "P")
(gnus-set-global-variables)
(gnus-setup-message 'forward
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
- (message-forward post)))
+ (let ((message-included-forward-headers
+ (if full-headers "" message-included-forward-headers)))
+ (message-forward post))))
(defun gnus-summary-resend-message (address)
"Resend the current article to ADDRESS."
@@ -580,10 +582,11 @@ If prefix argument YANK is non-nil, original article is yanked automatically."
(set-buffer gnus-original-article-buffer)
(message-resend address)))
-(defun gnus-summary-post-forward ()
- "Forward the current article to a newsgroup."
- (interactive)
- (gnus-summary-mail-forward t))
+(defun gnus-summary-post-forward (&optional full-headers)
+ "Forward the current article to a newsgroup.
+If FULL-HEADERS (the prefix), include full headers when forwarding."
+ (interactive "P")
+ (gnus-summary-mail-forward full-headers t))
(defvar gnus-nastygram-message
"The following article was inappropriately posted to %s.\n\n"
View
31 lisp/gnus-nocem.el
@@ -185,23 +185,28 @@ isn't bound, the message will be used unconditionally."
(let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
(e (search-forward "\n@@END NCM BODY\n" nil t))
(buf (current-buffer))
- ncm id)
+ ncm id group)
(when (and b e)
(narrow-to-region b (1+ (match-beginning 0)))
(goto-char (point-min))
(while (search-forward "\t" nil t)
- (when (condition-case nil
- (boundp (let ((obarray gnus-active-hashtb)) (read buf)))
- (error nil))
- (beginning-of-line)
- (while (= (following-char) ?\t)
- (forward-line -1))
- (setq id (buffer-substring (point) (1- (search-forward "\t"))))
- (push id ncm)
- (gnus-sethash id t gnus-nocem-hashtb)
- (forward-line 1)
- (while (= (following-char) ?\t)
- (forward-line 1))))
+ (condition-case nil
+ (setq group (let ((obarray gnus-active-hashtb)) (read buf)))
+ (error nil))
+ (if (not (boundp group))
+ ;; Make sure all entries in the hashtb are bound.
+ (set group nil)
+ (when (gnus-gethash (symbol-name group) gnus-newsrc-hashtb)
+ ;; Valid group.
+ (beginning-of-line)
+ (while (= (following-char) ?\t)
+ (forward-line -1))
+ (setq id (buffer-substring (point) (1- (search-forward "\t"))))
+ (push id ncm)
+ (gnus-sethash id t gnus-nocem-hashtb)
+ (forward-line 1)
+ (while (= (following-char) ?\t)
+ (forward-line 1)))))
(when ncm
(setq gnus-nocem-touched-alist t)
(push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
View
31 lisp/gnus-score.el
@@ -323,9 +323,6 @@ of the last successful match.")
("followup" 2 gnus-score-followup)
("thread" 5 gnus-score-thread)))
-(eval-and-compile
- (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap))
-
;;; Summary mode score maps.
(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map)
@@ -469,7 +466,7 @@ used as score."
(if (eq (nth 4 entry)
(nth 3 s))
s nil))
- char-to-type ))
+ char-to-type))
2)))
(gnus-score-kill-help-buffer)
@@ -499,6 +496,12 @@ used as score."
(if mimic (message "%c %c %c" prefix hchar tchar pchar)
(message ""))
(unless (setq temporary (cadr (assq pchar char-to-perm)))
+ ;; Deal with der(r)ided superannuated paradigms.
+ (when (and (eq (1+ prefix) 77)
+ (eq (+ hchar 12) 109)
+ (eq tchar 114)
+ (eq (- pchar 4) 111))
+ (error "You rang?"))
(if mimic
(error "%c %c %c %c" prefix hchar tchar pchar)
(error ""))))
@@ -524,8 +527,8 @@ used as score."
(nth 1 entry) ; Header
match ; Match
type ; Type
- (if (eq 's score) nil score) ; Score
- (if (eq 'perm temporary) ; Temp
+ (if (eq score 's) nil score) ; Score
+ (if (eq temporary 'perm) ; Temp
nil
temporary)
(not (nth 3 entry))) ; Prompt
@@ -1962,10 +1965,9 @@ SCORE is the score to add."
(or gnus-newsgroup-adaptive-score-file
(gnus-score-file-name
gnus-newsgroup-name gnus-adaptive-file-suffix))))
- (cond
- ;; Perform ordinary line scoring.
- ((or (not (listp gnus-use-adaptive-scoring))
- (memq 'line gnus-use-adaptive-scoring))
+ ;; Perform ordinary line scoring.
+ (when (or (not (listp gnus-use-adaptive-scoring))
+ (memq 'line gnus-use-adaptive-scoring))
(save-excursion
(let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
(alist malist)
@@ -2023,8 +2025,9 @@ SCORE is the score to add."
(setq elem (cdr elem)))))
(setq data (cdr data))))))
- ;; Perform adaptive word scoring.
- ((memq 'word gnus-use-adaptive-scoring)
+ ;; Perform adaptive word scoring.
+ (when (and (listp gnus-use-adaptive-scoring)
+ (memq 'word gnus-use-adaptive-scoring))
(nnheader-temp-write nil
(let* ((hashtb (gnus-make-hashtable 1000))
(date (gnus-day-number (current-time-string)))
@@ -2033,7 +2036,7 @@ SCORE is the score to add."
word d score val)
(unwind-protect
(progn
- (set-syntax-table syntab)
+ (set-syntax-table gnus-adaptive-word-syntax-table)
;; Go through all articles.
(while (setq d (pop data))
(when (and
@@ -2069,7 +2072,7 @@ SCORE is the score to add."
(gnus-summary-score-entry
"subject" (symbol-name word) 'w (symbol-value word)
date nil t)))
- hashtb)))))))
+ hashtb))))))
(defun gnus-score-edit-done ()
(let ((bufnam (buffer-file-name (current-buffer)))
View
18 lisp/gnus-setup.el
@@ -158,12 +158,9 @@
(setq message-cite-function 'sc-cite-original)
(autoload 'sc-cite-original "supercite"))
-;;;### (autoloads (gnus-batch-score gnus-fetch-group gnus gnus-slave gnus-no-server gnus-update-format) "gnus" "lisp/gnus.el" (12473 2137))
+;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137))
;;; Generated autoloads from lisp/gnus.el
-(autoload 'gnus-update-format "gnus" "\
-Update the format specification near point." t nil)
-
(autoload 'gnus-slave-no-server "gnus" "\
Read network news as a slave without connecting to local server." t nil)
@@ -184,21 +181,26 @@ If ARG is non-nil and a positive number, Gnus will use that as the
startup level. If ARG is non-nil and not a positive number, Gnus will
prompt the user for the name of an NNTP server to use." t nil)
-(autoload 'gnus-fetch-group "gnus" "\
+;;;***
+
+;;; These have moved out of gnus.el into other files.
+;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it?
+(autoload 'gnus-update-format "gnus-spec" "\
+Update the format specification near point." t nil)
+
+(autoload 'gnus-fetch-group "gnus-group" "\
Start Gnus if necessary and enter GROUP.
Returns whether the fetching was successful or not." t nil)
(defalias 'gnus-batch-kill 'gnus-batch-score)
-(autoload 'gnus-batch-score "gnus" "\
+(autoload 'gnus-batch-score "gnus-kill" "\
Run batched scoring.
Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ...
Newsgroups is a list of strings in Bnews format. If you want to score
the comp hierarchy, you'd say \"comp.all\". If you would not like to
score the alt hierarchy, you'd say \"!alt.all\"." t nil)
-;;;***
-
(provide 'gnus-setup)
(run-hooks 'gnus-setup-load-hook)
View
4 lisp/gnus-soup.el
@@ -165,6 +165,10 @@ move those articles instead."
"Make a SOUP packet from the SOUP areas."
(interactive)
(gnus-soup-read-areas)
+ (unless (file-exists-p gnus-soup-directory)
+ (message "No such directory: %s" gnus-soup-directory))
+ (when (null (directory-files gnus-soup-directory nil "\\.MSG$"))
+ (message "No files to pack."))
(gnus-soup-pack gnus-soup-directory gnus-soup-packer))
(defun gnus-group-brew-soup (n)
View
25 lisp/gnus-sum.el
@@ -278,7 +278,7 @@ current article is unread."
In particular, if `vertical' do only vertical recentering. If non-nil
and non-`vertical', do both horizontal and vertical recentering."
:group 'gnus-summary
- :type '(choice (const "none" nil)
+ :type '(choice (const :tag "none" nil)
(const vertical)
(sexp :menu-tag "both" t)))
@@ -1494,6 +1494,7 @@ increase the score of each group you read."
(gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map)
"o" gnus-summary-save-article
"m" gnus-summary-save-article-mail
+ "F" gnus-summary-write-article-file
"r" gnus-summary-save-article-rmail
"f" gnus-summary-save-article-file
"b" gnus-summary-save-article-body-file
@@ -1685,6 +1686,7 @@ increase the score of each group you read."
["Save in default format" gnus-summary-save-article t]
["Save in file" gnus-summary-save-article-file t]
["Save in Unix mail format" gnus-summary-save-article-mail t]
+ ["Write to file" gnus-summary-write-article-mail t]
["Save in MH folder" gnus-summary-save-article-folder t]
["Save in VM folder" gnus-summary-save-article-vm t]
["Save in RMAIL mbox" gnus-summary-save-article-rmail t]
@@ -2293,7 +2295,6 @@ This is all marks except unread, ticked, dormant, and expirable."
;; Saving hidden threads.
(put 'gnus-save-hidden-threads 'lisp-indent-function 0)
-(put 'gnus-save-hidden-threads 'lisp-indent-hook 0)
(put 'gnus-save-hidden-threads 'edebug-form-spec '(body))
(defmacro gnus-save-hidden-threads (&rest forms)
@@ -3269,9 +3270,9 @@ If NO-DISPLAY, don't generate a summary buffer."
(defsubst gnus-article-sort-by-date (h1 h2)
"Sort articles by root article date."
- (string-lessp
- (inline (gnus-sortable-date (mail-header-date h1)))
- (inline (gnus-sortable-date (mail-header-date h2)))))
+ (gnus-time-less
+ (gnus-date-get-time (mail-header-date h1))
+ (gnus-date-get-time (mail-header-date h2))))
(defun gnus-thread-sort-by-date (h1 h2)
"Sort threads by root article date."
@@ -4713,7 +4714,8 @@ displayed, no centering will be performed."
(save-excursion
(while articles
(gnus-summary-goto-subject (setq article (pop articles)))
- (command-execute func)
+ (let (gnus-newsgroup-processable)
+ (command-execute func))
(gnus-summary-remove-process-mark article)))))
(gnus-summary-position-point))
@@ -7983,6 +7985,17 @@ save those articles instead."
(let ((gnus-default-article-saver 'gnus-summary-save-in-file))
(gnus-summary-save-article arg)))
+(defun gnus-summary-write-article-file (&optional arg)
+ "Write the current article to a file, deleting the previous file.
+If N is a positive number, save the N next articles.
+If N is a negative number, save the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+save those articles instead."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((gnus-default-article-saver 'gnus-summary-write-to-file))
+ (gnus-summary-save-article arg)))
+
(defun gnus-summary-save-article-body-file (&optional arg)
"Append the current article body to a file.
If N is a positive number, save the N next articles.
View
8 lisp/gnus-topic.el
@@ -437,8 +437,8 @@ articles in the topic and its subtopics."
(while (and (zerop (forward-line 1))
(> (or (gnus-group-topic-level) (1+ level)) level)))
(delete-region beg (point))
- (setcar (cdadr (gnus-topic-find-topology topic))
- (if insert 'visible 'invisible))
+ (setcdr (cadr (gnus-topic-find-topology topic))
+ (if insert (list 'visible) (list 'invisible)))
(when hide
(setcdr (cdadr (gnus-topic-find-topology topic))
(list hide)))
@@ -1033,7 +1033,8 @@ If COPYP, copy the groups instead."
(let ((topic (gnus-group-topic-name)))
(gnus-topic-remove-topic nil t)
(push (gnus-topic-find-topology topic nil nil gnus-topic-topology)
- gnus-topic-killed-topics))
+ gnus-topic-killed-topics)
+ (gnus-topic-enter-dribble))
(gnus-group-kill-group n discard)
(gnus-topic-update-topic)))
@@ -1048,6 +1049,7 @@ If COPYP, copy the groups instead."
(gnus-topic-create-topic
(caar item) (gnus-topic-parent-topic previous) previous
item)
+ (gnus-topic-enter-dribble)
(gnus-topic-goto-topic (caar item)))
(let* ((prev (gnus-group-group-name))
(gnus-topic-inhibit-change-level t)
View
1  lisp/gnus-undo.el
@@ -128,7 +128,6 @@ FORMS may use backtick quote syntax."
,@form))))
(put 'gnus-undo-register 'lisp-indent-function 0)
-(put 'gnus-undo-register 'lisp-indent-hook 0)
(put 'gnus-undo-register 'edebug-form-spec '(body))
(defun gnus-undo-register-1 (function)
View
23 lisp/gnus-util.el
@@ -52,7 +52,6 @@
(select-window ,tempvar)))))
(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
-(put 'gnus-eval-in-buffer-window 'lisp-indent-hook 1)
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
(defmacro gnus-intern-safe (string hashtable)
@@ -275,18 +274,14 @@
`(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
(put 'gnus-define-keys 'lisp-indent-function 1)
-(put 'gnus-define-keys 'lisp-indent-hook 1)
(put 'gnus-define-keys-safe 'lisp-indent-function 1)
-(put 'gnus-define-keys-safe 'lisp-indent-hook 1)
(put 'gnus-local-set-keys 'lisp-indent-function 1)
-(put 'gnus-local-set-keys 'lisp-indent-hook 1)
(defmacro gnus-define-keymap (keymap &rest plist)
"Define all keys in PLIST in KEYMAP."
`(gnus-define-keys-1 ,keymap (quote ,plist)))
(put 'gnus-define-keymap 'lisp-indent-function 1)
-(put 'gnus-define-keymap 'lisp-indent-hook 1)
(defun gnus-define-keys-1 (keymap plist &optional safe)
(when (null keymap)
@@ -349,18 +344,30 @@
timezone-months-assoc))
"???"))))))
-(defun gnus-time-iso8601 (time)
+(defmacro gnus-date-get-time (date)
+ "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+ ;; Either return the cached value...
+ `(let ((d ,date))
+ (or (get-text-property 0 'gnus-time d)
+ ;; or compute the value...
+ (let ((time (nnmail-date-to-time d)))
+ ;; and store it back in the string.
+ (put-text-property 0 1 'gnus-time time d)
+ time))))
+
+(defsubst gnus-time-iso8601 (time)
"Return a string of TIME in YYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
(defun gnus-date-iso8601 (header)
"Convert the date field in HEADER to YYMMDDTHHMMSS"
(condition-case ()
- (gnus-time-iso8601 (nnmail-date-to-time (mail-header-date header)))
+ (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header)))
(error "")))
(defun gnus-mode-string-quote (string)
- "Quote all \"%\" in STRING."
+ "Quote all \"%\"'s in STRING."
(save-excursion
(gnus-set-work-buffer)
(insert string)
View
30 lisp/gnus-xmas.el
@@ -260,7 +260,6 @@ call it with the value of the `gnus-data' text property."
(defmacro gnus-xmas-menu-add (type &rest menus)
`(gnus-xmas-menu-add-1 ',type ',menus))
(put 'gnus-xmas-menu-add 'lisp-indent-function 1)
-(put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
(defun gnus-xmas-menu-add-1 (type menus)
(when (and menu-bar-mode
@@ -270,45 +269,49 @@ call it with the value of the `gnus-data' text property."
(defun gnus-xmas-group-menu-add ()
(gnus-xmas-menu-add group
- gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
+ gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
(defun gnus-xmas-summary-menu-add ()
(gnus-xmas-menu-add summary
- gnus-summary-misc-menu gnus-summary-kill-menu
- gnus-summary-article-menu gnus-summary-thread-menu
- gnus-summary-post-menu ))
+ gnus-summary-misc-menu gnus-summary-kill-menu
+ gnus-summary-article-menu gnus-summary-thread-menu
+ gnus-summary-post-menu ))
(defun gnus-xmas-article-menu-add ()
(gnus-xmas-menu-add article
- gnus-article-article-menu gnus-article-treatment-menu))
+ gnus-article-article-menu gnus-article-treatment-menu))
(defun gnus-xmas-score-menu-add ()
(gnus-xmas-menu-add score
- gnus-score-menu))
+ gnus-score-menu))
(defun gnus-xmas-pick-menu-add ()
(gnus-xmas-menu-add pick
- gnus-pick-menu))
+ gnus-pick-menu))
+
+(defun gnus-xmas-topic-menu-add ()
+ (gnus-xmas-menu-add topic
+ gnus-topic-menu))
(defun gnus-xmas-binary-menu-add ()
(gnus-xmas-menu-add binary
- gnus-binary-menu))
+ gnus-binary-menu))
(defun gnus-xmas-tree-menu-add ()
(gnus-xmas-menu-add tree
- gnus-tree-menu))
+ gnus-tree-menu))
(defun gnus-xmas-server-menu-add ()
(gnus-xmas-menu-add menu
- gnus-server-server-menu gnus-server-connections-menu))
+ gnus-server-server-menu gnus-server-connections-menu))
(defun gnus-xmas-browse-menu-add ()
(gnus-xmas-menu-add browse
- gnus-browse-menu))
+ gnus-browse-menu))
(defun gnus-xmas-grouplens-menu-add ()
(gnus-xmas-menu-add grouplens
- gnus-grouplens-menu))
+ gnus-grouplens-menu))
(defun gnus-xmas-read-event-char ()
"Get the next event."
@@ -440,6 +443,7 @@ call it with the value of the `gnus-data' text property."
(add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
(add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
+ (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)
(add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
(add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
(add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
View
105 lisp/gnus.el
@@ -42,14 +42,16 @@
"Score and kill file handling."
:group 'gnus )
-(defconst gnus-version-number "0.52"
+(defconst gnus-version-number "0.53"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Red Gnus v%s" gnus-version-number)
"Version string for this version of Gnus.")
(defcustom gnus-inhibit-startup-message nil
- "*If non-nil, the startup message will not be displayed."
+ "*If non-nil, the startup message will not be displayed.
+This variable is used before `.gnus.el' is loaded, so it should
+be set in `.emacs' instead."
:group 'gnus-start
:type 'boolean)
@@ -69,6 +71,24 @@
(t
'ignore)))
+(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)
+
;; The XEmacs people think this is evil, so it must go.
(defun custom-face-lookup (&optional fg bg stipple bold italic underline)
"Lookup or create a face with specified attributes."
@@ -810,6 +830,8 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
("hexl" hexl-hex-string-to-integer)
("pp" pp pp-to-string pp-eval-expression)
("mail-extr" mail-extract-address-components)
+ ("message" :interactive t
+ message-send-and-exit message-yank-original)
("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time)
("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers)
("timezone" timezone-make-date-arpa-standard timezone-fix-time
@@ -823,7 +845,7 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-soup-send-replies gnus-soup-save-areas gnus-soup-pack-packet)
("nnsoup" nnsoup-pack-replies)
("score-mode" :interactive t gnus-score-mode)
- ("gnus-mh" gnus-mh-mail-setup gnus-summary-save-article-folder
+ ("gnus-mh" gnus-summary-save-article-folder
gnus-Folder-save-name gnus-folder-save-name)
("gnus-mh" :interactive t gnus-summary-save-in-folder)
("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail
@@ -849,20 +871,20 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-cache-retrieve-headers gnus-cache-possibly-alter-active
gnus-cache-enter-remove-article gnus-cached-article-p
gnus-cache-open gnus-cache-close gnus-cache-update-article)
- ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
- gnus-cache-remove-article gnus-summary-insert-cached-articles)
- ("gnus-score" :interactive t
- gnus-summary-increase-score gnus-summary-lower-score
- gnus-score-flush-cache gnus-score-close
- gnus-score-raise-same-subject-and-select
- gnus-score-raise-same-subject gnus-score-default
- gnus-score-raise-thread gnus-score-lower-same-subject-and-select
- gnus-score-lower-same-subject gnus-score-lower-thread
- gnus-possibly-score-headers gnus-summary-raise-score
- gnus-summary-set-score gnus-summary-current-score
- gnus-score-followup-article)
- ("gnus-score"
- (gnus-summary-score-map keymap) gnus-score-save gnus-score-headers
+ ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article
+ gnus-cache-remove-article gnus-summary-insert-cached-articles)
+ ("gnus-score" :interactive t
+ gnus-summary-increase-score gnus-summary-set-score
+ gnus-summary-raise-thread gnus-summary-raise-same-subject
+ gnus-summary-raise-score gnus-summary-raise-same-subject-and-select
+ gnus-summary-lower-thread gnus-summary-lower-same-subject
+ gnus-summary-lower-score gnus-summary-lower-same-subject-and-select
+ gnus-summary-current-score gnus-score-default
+ gnus-score-flush-cache gnus-score-close
+ gnus-possibly-score-headers gnus-score-followup-article
+ gnus-score-followup-thread)
+ ("gnus-score"
+ (gnus-summary-score-map keymap) gnus-score-save gnus-score-headers
gnus-current-score-file-nondirectory gnus-score-adaptive
gnus-score-find-trace gnus-score-file-name)
("gnus-cus" :interactive t gnus-group-customize gnus-score-customize)
@@ -882,17 +904,14 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view
gnus-uu-decode-binhex-view)
("gnus-msg" (gnus-summary-send-map keymap)
- gnus-mail-yank-original gnus-mail-send-and-exit
- gnus-article-mail gnus-new-mail gnus-mail-reply
- gnus-copy-article-buffer gnus-extended-version)
+ gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
("gnus-msg" :interactive t
gnus-group-post-news gnus-group-mail gnus-summary-post-news
gnus-summary-followup gnus-summary-followup-with-original
gnus-summary-cancel-article gnus-summary-supersede-article
- gnus-post-news gnus-inews-news
- gnus-summary-reply gnus-summary-reply-with-original
+ gnus-post-news gnus-summary-reply gnus-summary-reply-with-original
gnus-summary-mail-forward gnus-summary-mail-other-window
- gnus-summary-resend-message gnus-summary-bounced-mail
+ gnus-summary-resend-message gnus-summary-resend-bounced-mail
gnus-bug)
("gnus-picon" :interactive t gnus-article-display-picons
gnus-group-display-picons gnus-picons-article-display-x-face
@@ -900,7 +919,6 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p
gnus-grouplens-mode)
("smiley" :interactive t gnus-smiley-display)
- ("gnus" gnus-add-current-to-buffer-list gnus-add-shutdown)
("gnus-win" gnus-configure-windows)
("gnus-sum" gnus-summary-insert-line gnus-summary-read-group
gnus-list-of-unread-articles gnus-list-of-read-articles
@@ -915,9 +933,9 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
gnus-backlog-remove-article)
("gnus-art" gnus-article-read-summary-keys gnus-article-save
gnus-article-prepare gnus-article-set-window-start
- gnus-article-show-all-headers gnus-article-next-page
- gnus-article-prev-page gnus-request-article-this-buffer
- gnus-article-mode gnus-article-setup-buffer gnus-narrow-to-page)
+ gnus-article-next-page gnus-article-prev-page
+ gnus-request-article-this-buffer gnus-article-mode
+ gnus-article-setup-buffer gnus-narrow-to-page)
("gnus-art" :interactive t
gnus-article-hide-headers gnus-article-hide-boring-headers
gnus-article-treat-overstrike gnus-article-word-wrap
@@ -933,15 +951,14 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.")
("gnus-int" gnus-request-type)
("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1
gnus-dribble-enter)
- ("gnus-dup" gnus-dup-suppress-articles gnus-dup-enter-articles)
+ ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article
+ gnus-dup-enter-articles)
("gnus-range" gnus-copy-sequence)
- ("gnus-vm" gnus-vm-mail-setup)
("gnus-eform" gnus-edit-form)
("gnus-move" :interactive t
gnus-group-move-group-to-server gnus-change-server)
("gnus-logic" gnus-score-advanced)
- ("gnus-undo" gnus-undo-mode gnus-undo-register
- gnus-dup-unsuppress-article)
+ ("gnus-undo" gnus-undo-mode gnus-undo-register)
("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next
gnus-async-prefetch-article gnus-async-prefetch-remove-group)
("article" article-decode-rfc1522)
@@ -1026,26 +1043,6 @@ This restriction may disappear in later versions of Gnus.")
(defvar gnus-group-mode-map (make-keymap))
(gnus-suppress-keymap gnus-group-mode-map)
-;;; Function aliases later to be redefined for XEmacs usage.
-
-(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)
-
;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
@@ -1066,7 +1063,7 @@ This restriction may disappear in later versions of Gnus.")
(defmacro gnus-sethash (string value hashtable)
"Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
`(set (intern ,string ,hashtable) ,value))
-(put 'nnheader-temp-write 'edebug-form-spec '(form form form))
+(put 'gnus-sethash 'edebug-form-spec '(form form form))
(defmacro gnus-group-unread (group)
"Get the currently computed number of unread articles in GROUP."
@@ -1583,8 +1580,7 @@ just the host name."
((< colon dot) colon)
((< dot colon) dot)))
":")
- group (substring group (+ 1 colon))
- )))
+ group (substring group (+ 1 colon)))))
(t
(let* ((colon (string-match ":" group)))
(setq foreign (concat (substring group 0 (+ 1 colon)))
@@ -1600,7 +1596,6 @@ just the host name."
group nil)))
name))
-
;;;
;;; Kill file handling.
View
608 lisp/message.el
@@ -301,7 +301,11 @@ nil means use indentation.")
Used by `message-yank-original' via `message-yank-cite'.")
;;;###autoload
-(defvar message-cite-function 'message-cite-original
+(defvar message-cite-function
+ (if (and (boundp 'mail-citation-hook)
+ mail-citation-hook)
+ mail-citation-hook
+ 'message-cite-original)
"*Function for citing an original message.")
;;;###autoload
@@ -429,6 +433,12 @@ The cdr of ech entry is a function for applying the face to a region.")
(defvar message-send-hook nil
"Hook run before sending messages.")
+(defvar message-send-mail-hook nil
+ "Hook run before sending mail messages.")
+
+(defvar message-send-news-hook nil
+ "Hook run before sending news messages.")
+
(defvar message-sent-hook nil
"Hook run after sending messages.")
@@ -545,34 +555,36 @@ The cdr of ech entry is a function for applying the face to a region.")
(defun message-tokenize-header (header &optional separator)
"Split HEADER into a list of header elements.
\",\" is used as the separator."
- (let ((regexp (format "[%s]+" (or separator ",")))
- (beg 1)
- (first t)
- quoted elems paren)
- (save-excursion
- (message-set-work-buffer)
- (insert header)
- (goto-char (point-min))
- (while (not (eobp))
- (if first
- (setq first nil)
- (forward-char 1))
- (cond ((and (> (point) beg)
- (or (eobp)
- (and (looking-at regexp)
- (not quoted)
- (not paren))))
- (push (buffer-substring beg (point)) elems)
- (setq beg (match-end 0)))
- ((= (following-char) ?\")
- (setq quoted (not quoted)))
- ((and (= (following-char) ?\()
- (not quoted))
- (setq paren t))
- ((and (= (following-char) ?\))
- (not quoted))
- (setq paren nil))))
- (nreverse elems))))
+ (if (not header)
+ nil
+ (let ((regexp (format "[%s]+" (or separator ",")))
+ (beg 1)
+ (first t)
+ quoted elems paren)
+ (save-excursion
+ (message-set-work-buffer)
+ (insert header)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if first
+ (setq first nil)
+ (forward-char 1))
+ (cond ((and (> (point) beg)
+ (or (eobp)
+ (and (looking-at regexp)
+ (not quoted)
+ (not paren))))
+ (push (buffer-substring beg (point)) elems)
+ (setq beg (match-end 0)))
+ ((= (following-char) ?\")
+ (setq quoted (not quoted)))
+ ((and (= (following-char) ?\()
+ (not quoted))
+ (setq paren t))
+ ((and (= (following-char) ?\))
+ (not quoted))
+ (setq paren nil))))
+ (nreverse elems)))))
(defun message-fetch-field (header)
"The same as `mail-fetch-field', only remove all newlines."
@@ -981,20 +993,21 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)."
"Insert a signature. See documentation for the `message-signature' variable."
(interactive (list 0))
(let* ((signature
- (cond ((and (null message-signature)
- (eq force 0))
- (save-excursion
- (goto-char (point-max))
- (not (re-search-backward
- message-signature-separator nil t))))
- ((and (null message-signature)
- force)
- t)
- ((message-functionp message-signature)
- (funcall message-signature))
- ((listp message-signature)
- (eval message-signature))
- (t message-signature)))
+ (cond
+ ((and (null message-signature)
+ (eq force 0))
+ (save-excursion
+ (goto-char (point-max))
+ (not (re-search-backward
+ message-signature-separator nil t))))
+ ((and (null message-signature)
+ force)
+ t)
+ ((message-functionp message-signature)
+ (funcall message-signature))
+ ((listp message-signature)
+ (eval message-signature))
+ (t message-signature)))
(signature
(cond ((stringp signature)
signature)
@@ -1356,7 +1369,7 @@ the user from the mailer."
(defun message-send-mail (&optional arg)
(require 'mail-utils)
- (let ((tembuf (generate-new-buffer " message temp"))
+ (let ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
(case-fold-search nil)
(news (message-news-p))
(mailbuf (current-buffer)))
@@ -1412,6 +1425,7 @@ the user from the mailer."
(replace-match "\n")
(backward-char 1)
(setq delimline (point-marker))
+ (run-hooks 'message-send-mail-hook)
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
@@ -1463,6 +1477,7 @@ to find out how to use this."
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
+ (run-hooks 'message-send-mail-hook)
;; send the message
(case
(apply
@@ -1494,7 +1509,6 @@ to find out how to use this."
;; should never happen
(t (error "qmail-inject reported unknown failure."))))
-
(defun message-send-mail-with-mh ()
"Send the prepared message buffer with mh."
(let ((mh-previous-window-config nil)
@@ -1511,11 +1525,12 @@ to find out how to use this."
(concat "^" (symbol-name (car headers)) ": *") nil t)
(message-delete-line))
(pop headers)))
+ (run-hooks 'message-send-mail-hook)
;; Pass it on to mh.
(mh-send-letter)))
(defun message-send-news (&optional arg)
- (let ((tembuf (generate-new-buffer " *message temp*"))
+ (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
(case-fold-search nil)
(method (if (message-functionp message-post-method)
(funcall message-post-method arg)
@@ -1536,7 +1551,7 @@ to find out how to use this."
(message-cleanup-headers)
(if (not (message-check-news-syntax))
(progn
- (message "Posting nor performed")
+ ;;(message "Posting not performed")
nil)
(unwind-protect
(save-excursion
@@ -1564,6 +1579,7 @@ to find out how to use this."
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(backward-char 1))
+ (run-hooks 'message-send-news-hook)
(require (car method))
(funcall (intern (format "%s-open-server" (car method)))
(cadr method) (cddr method))
@@ -1581,257 +1597,252 @@ to find out how to use this."
;;; Header generation & syntax checking.
;;;
+(defmacro message-check (type &rest forms)
+ "Eval FORMS if TYPE is to be checked."
+ `(or (message-check-element ,type)
+ (save-excursion
+ ,@forms)))
+
+(put 'message-check 'lisp-indent-function 1)
+(put 'message-check 'edebug-form-spec '(form body))
+
+(defun message-check-element (type)
+ "Returns non-nil if this type is not to be checked."
+ (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
+ t
+ (let ((able (assq type message-syntax-checks)))
+ (and (consp able)
+ (eq (cdr able) 'disabled)))))
+
(defun message-check-news-syntax ()
"Check the syntax of the message."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (and
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-check-news-header-syntax)))
+ ;; Check the body.
+ (message-check-news-body-syntax)))))
+
+(defun message-check-news-header-syntax ()
(and
- ;; We narrow to the headers and check them first.
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (and
- ;; Check for commands in Subject.
- (or
- (message-check-element 'subject-cmsg)
+ ;; Check for commands in Subject.
+ (message-check 'subject-cmsg
+ (if (string-match "^cmsg " (message-fetch-field "subject"))
+ (y-or-n-p
+ "The control code \"cmsg\" is in the subject. Really post? ")
+ t))
+ ;; Check for multiple identical headers.
+ (message-check 'multiple-headers
+ (let (found)
+ (while (and (not found)
+ (re-search-forward "^[^ \t:]+: " nil t))
(save-excursion
- (if (string-match "^cmsg " (message-fetch-field "subject"))
- (y-or-n-p
- "The control code \"cmsg \" is in the subject. Really post? ")
- t)))
- ;; Check for multiple identical headers.
- (or (message-check-element 'multiple-headers)
- (save-excursion
- (let (found)
- (while (and (not found)
- (re-search-forward "^[^ \t:]+: " nil t))
- (save-excursion
- (or (re-search-forward
- (concat "^" (setq found
- (buffer-substring
- (match-beginning 0)
- (- (match-end 0) 2))))
- nil t)
- (setq found nil))))
- (if found
- (y-or-n-p
- (format "Multiple %s headers. Really post? " found))
- t))))
- ;; Check for Version and Sendsys.
- (or (message-check-element 'sendsys)
- (save-excursion
- (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
- (y-or-n-p
- (format "The article contains a %s command. Really post? "
- (buffer-substring (match-beginning 0)
- (1- (match-end 0)))))
- t)))
- ;; See whether we can shorten Followup-To.
- (or (message-check-element 'shorten-followup-to)
- (let ((newsgroups (message-fetch-field "newsgroups"))
- (followup-to (message-fetch-field "followup-to"))
- to)
- (when (and newsgroups (string-match "," newsgroups)
- (not followup-to)
- (not
- (zerop
- (length
- (setq to (completing-read
- "Followups to: (default all groups) "
- (mapcar (lambda (g) (list g))
- (cons "poster"
- (message-tokenize-header
- newsgroups)))))))))
- (goto-char (point-min))
- (insert "Followup-To: " to "\n"))
- t))
- ;; Check "Shoot me".
- (or (message-check-element 'shoot)
- (save-excursion
- (if (re-search-forward
- "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me"
- nil t)
- (y-or-n-p
- "You appear to have a misconfigured system. Really post? ")
- t)))
- ;; Check for Approved.
- (or (message-check-element 'approved)
- (save-excursion
- (if (re-search-forward "^Approved:" nil t)
- (y-or-n-p
- "The article contains an Approved header. Really post? ")
- t)))
- ;; Check the Message-ID header.
- (or (message-check-element 'message-id)
- (save-excursion
- (let* ((case-fold-search t)
- (message-id (message-fetch-field "message-id")))
- (or (not message-id)
- (and (string-match "@" message-id)
- (string-match "@[^\\.]*\\." message-id))
- (y-or-n-p
- (format
- "The Message-ID looks strange: \"%s\". Really post? "
- message-id))))))
- ;; Check the Subject header.
- (or
- (message-check-element 'subject)
- (save-excursion
- (let* ((case-fold-search t)
- (subject (message-fetch-field "subject")))
- (or
- (and subject
- (not (string-match "\\`[ \t]*\\'" subject)))
- (progn
- (message
- "The subject field is empty or missing. Posting is denied.")
- nil)))))
- ;; Check the Newsgroups & Followup-To headers.
- (or
- (message-check-element 'existing-newsgroups)
- (let* ((case-fold-search t)
- (newsgroups (message-fetch-field "newsgroups"))
- (followup-to (message-fetch-field "followup-to"))
- (groups (message-tokenize-header
- (if followup-to
- (concat newsgroups "," followup-to)
- newsgroups)))
- (hashtb (and (boundp 'gnus-active-hashtb)
- gnus-active-hashtb))
- errors)
- (if (not hashtb)
- t
- (while groups
- (when (and (not (boundp (intern (car groups) hashtb)))
- (not (equal (car groups) "poster")))
- (push (car groups) errors))
- (pop groups))
- (if (not errors)
- t
- (y-or-n-p
- (format
- "Really post to %s unknown group%s: %s "
- (if (= (length errors) 1) "this" "these")
- (if (= (length errors) 1) "" "s")
- (mapconcat 'identity errors ", ")))))))
- ;; Check the Newsgroups & Followup-To headers for syntax errors.
- (or
- (message-check-element 'valid-newsgroups)
- (let ((case-fold-search t)
- (headers '("Newsgroups" "Followup-To"))
- header error)
- (while (and headers (not error))
- (when (setq header (mail-fetch-field (car headers)))
- (if (or
- (not
- (string-match
- "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
- header))
- (memq
- nil (mapcar
- (lambda (g)
- (not (string-match "\\.\\'\\|\\.\\." g)))
- (message-tokenize-header header ","))))
- (setq error t)))
- (unless error
- (pop headers)))
- (if (not error)
- t
- (y-or-n-p
- (format "The %s header looks odd: \"%s\". Really post? "
- (car headers) header)))))
- ;; Check the From header.
- (or
- (save-excursion
- (let* ((case-fold-search t)
- (from (message-fetch-field "from")))
- (cond
- ((not from)
- (message "There is no From line. Posting is denied.")
- nil)
- ((not (string-match "@[^\\.]*\\." from))
- (message
- "Denied posting -- the From looks strange: \"%s\"." from)
- nil)
- ((string-match "@[^@]*@" from)
- (message
- "Denied posting -- two \"@\"'s in the From header: %s." from)
- nil)
- ((string-match "(.*).*(.*)" from)
- (message
- "Denied posting -- the From header looks strange: \"%s\"."
- from)
- nil)
- (t t))))))))
- ;; Check for long lines.
- (or (message-check-element 'long-lines)
- (save-excursion
+ (or (re-search-forward
+ (concat "^" (setq found
+ (buffer-substring
+ (match-beginning 0) (- (match-end 0) 2))))
+ nil t)
+ (setq found nil))))
+ (if found
+ (y-or-n-p (format "Multiple %s headers. Really post? " found))
+ t)))
+ ;; Check for Version and Sendsys.
+ (message-check 'sendsys
+ (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
+ (y-or-n-p
+ (format "The article contains a %s command. Really post? "
+ (buffer-substring (match-beginning 0)
+ (1- (match-end 0)))))
+ t))
+ ;; See whether we can shorten Followup-To.
+ (message-check 'shorten-followup-to
+ (let ((newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
+ to)
+ (when (and newsgroups
+ (string-match "," newsgroups)
+ (not followup-to)
+ (not
+ (zerop
+ (length
+ (setq to (completing-read
+ "Followups to: (default all groups) "
+ (mapcar (lambda (g) (list g))
+ (cons "poster"
+ (message-tokenize-header
+ newsgroups)))))))))
(goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (while (and
- (progn
- (end-of-line)
- (< (current-column) 80))
- (zerop (forward-line 1))))
- (or (bolp)
- (eobp)
- (y-or-n-p
- "You have lines longer than 79 characters. Really post? "))))
+ (insert "Followup-To: " to "\n"))
+ t))
+ ;; Check "Shoot me".
+ (message-check 'shoot
+ (if (re-search-forward
+ "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me" nil t)
+ (y-or-n-p "You appear to have a misconfigured system. Really post? ")
+ t))
+ ;; Check for Approved.
+ (message-check 'approved
+ (if (re-search-forward "^Approved:" nil t)
+ (y-or-n-p "The article contains an Approved header. Really post? ")
+ t))
+ ;; Check the Message-ID header.
+ (message-check 'message-id
+ (let* ((case-fold-search t)
+ (message-id (message-fetch-field "message-id")))
+ (or (not message-id)
+ (and (string-match "@" message-id)
+ (string-match "@[^\\.]*\\." message-id))
+ (y-or-n-p
+ (format "The Message-ID looks strange: \"%s\". Really post? "
+ message-id)))))
+ ;; Check the Subject header.
+ (message-check 'subject
+ (let* ((case-fold-search t)
+ (subject (message-fetch-field "subject")))
+ (or
+ (and subject
+ (not (string-match "\\`[ \t]*\\'" subject)))
+ (ignore
+ (message
+ "The subject field is empty or missing. Posting is denied.")))))
+ ;; Check the Newsgroups & Followup-To headers.
+ (message-check 'existing-newsgroups
+ (let* ((case-fold-search t)
+ (newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
+ (groups (message-tokenize-header
+ (if followup-to
+ (concat newsgroups "," followup-to)
+ newsgroups)))
+ (hashtb (and (boundp 'gnus-active-hashtb)
+ gnus-active-hashtb))
+ errors)
+ (if (not hashtb)
+ t
+ (while groups
+ (when (and (not (boundp (intern (car groups) hashtb)))
+ (not (equal (car groups) "poster")))
+ (push (car groups) errors))
+ (pop groups))
+ (if (not errors)
+ t
+ (y-or-n-p
+ (format
+ "Really post to %s unknown group%s: %s "
+ (if (= (length errors) 1) "this" "these")
+ (if (= (length errors) 1) "" "s")
+ (mapconcat 'identity errors ", ")))))))
+ ;; Check the Newsgroups & Followup-To headers for syntax errors.
+ (message-check 'valid-newsgroups
+ (let ((case-fold-search t)
+ (headers '("Newsgroups" "Followup-To"))
+ header error)
+ (while (and headers (not error))
+ (when (setq header (mail-fetch-field (car headers)))
+ (if (or
+ (not
+ (string-match
+ "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'"
+ header))
+ (memq
+ nil (mapcar
+ (lambda (g)
+ (not (string-match "\\.\\'\\|\\.\\." g)))
+ (message-tokenize-header header ","))))
+ (setq error t)))
+ (unless error
+ (pop headers)))
+ (if (not error)
+ t
+ (y-or-n-p
+ (format "The %s header looks odd: \"%s\". Really post? "
+ (car headers) header)))))
+ ;; Check the From header.
+ (message-check 'from
+ (let* ((case-fold-search t)
+ (from (message-fetch-field "from"))
+ (ad (nth 1 (mail-extract-address-components from))))
+ (cond
+ ((not from)
+ (message "There is no From line. Posting is denied.")
+ nil)
+ ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi
+ (string-match "\\.\\." ad) ;larsi@ifi..uio
+ (string-match "@\\." ad) ;larsi@.ifi.uio
+ (string-match "\\.$" ad) ;larsi@ifi.uio.
+ (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
+ (string-match "(.*).*(.*)" from)) ;(lars) (lars)
+ (message
+ "Denied posting -- the From looks strange: \"%s\"." from)
+ nil)
+ (t t))))))
+
+(defun message-check-news-body-syntax ()
+ (and
+ ;; Check for long lines.
+ (message-check 'long-lines
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (while (and
+ (progn
+ (end-of-line)
+ (< (current-column) 80))
+ (zerop (forward-line 1))))
+ (or (bolp)
+ (eobp)
+ (y-or-n-p
+ "You have lines longer than 79 characters. Really post? ")))
;; Check whether the article is empty.
- (or (message-check-element 'empty)
- (save-excursion
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "$"))
- (forward-line 1)
- (let ((b (point)))
- (goto-char (point-max))
- (re-search-backward message-signature-separator nil t)
- (beginning-of-line)
- (or (re-search-backward "[^ \n\t]" b t)
- (y-or-n-p "Empty article. Really post? ")))))
+ (message-check 'empty
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (let ((b (point)))
+ (goto-char (point-max))
+ (re-search-backward message-signature-separator nil t)
+ (beginning-of-line)
+ (or (re-search-backward "[^ \n\t]" b t)
+ (y-or-n-p "Empty article. Really post? "))))
;; Check for control characters.
- (or (message-check-element 'control-chars)
- (save-excursion
- (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
- (y-or-n-p
- "The article contains control characters. Really post? ")
- t)))
+ (message-check 'control-chars
+ (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (y-or-n-p
+ "The article contains control characters. Really post? ")
+ t))
;; Check excessive size.
- (or (message-check-element 'size)
- (if (> (buffer-size) 60000)
- (y-or-n-p
- (format "The article is %d octets long. Really post? "
- (buffer-size)))
- t))
+ (message-check 'size
+ (if (> (buffer-size) 60000)
+ (y-or-n-p
+ (format "The article is %d octets long. Really post? "
+ (buffer-size)))
+ t))
;; Check whether any new text has been added.
- (or (message-check-element 'new-text)
- (not message-checksum)
- (not (and (eq (message-checksum) (car message-checksum))
- (eq (buffer-size) (cdr message-checksum))))
- (y-or-n-p
- "It looks like no new text has been added. Really post? "))
+ (message-check 'new-text
+ (or
+ (not message-checksum)
+ (not (and (eq (message-checksum) (car message-checksum))
+ (eq (buffer-size) (cdr message-checksum))))
+ (y-or-n-p
+ "It looks like no new text has been added. Really post? ")))
;; Check the length of the signature.
- (or
- (message-check-element 'signature)
- (progn
- (goto-char (point-max))
- (if (or (not (re-search-backward message-signature-separator nil t))
- (search-forward message-forward-end-separator nil t))
- t
- (if (> (count-lines (point) (point-max)) 5)
- (y-or-n-p
- (format
- "Your .sig is %d lines; it should be max 4. Really post? "
- (1- (count-lines (point) (point-max)))))
- t))))))
-
-(defun message-check-element (type)
- "Returns non-nil if this type is not to be checked."
- (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
- t
- (let ((able (assq type message-syntax-checks)))
- (and (consp able)
- (eq (cdr able) 'disabled)))))
+ (message-check 'signature
+ (goto-char (point-max))
+ (if (or (not (re-search-backward message-signature-separator nil t))
+ (search-forward message-forward-end-separator nil t))
+ t
+ (if (> (count-lines (point) (point-max)) 5)
+ (y-or-n-p
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (1- (count-lines (point) (point-max)))))
+ t)))))
(defun message-checksum ()
"Return a \"checksum\" for the current buffer."
@@ -2272,7 +2283,7 @@ Headers already prepared in the buffer are not modified."
(downcase secure-sender)))))
(goto-char (point-min))
;; Rename any old Sender headers to Original-Sender.
- (when (re-search-forward "^Sender:" nil t)
+ (when (re-search-forward "^\\(Original-\\)*Sender:" nil t)
(beginning-of-line)
(insert "Original-")
(beginning-of-line))
@@ -3118,6 +3129,25 @@ The following arguments may contain lists of values."
(list
(list list))))
+(defun message-generate-new-buffer-clone-locals (name &optional varstr)
+ "Create and return a buffer with a name based on NAME using generate-new-buffer.
+Then clone the local variables and values from the old buffer to the
+new one, cloning only the locals having a substring matching the
+regexp varstr."
+ (let ((oldlocals (buffer-local-variables)))
+ (save-excursion
+ (set-buffer (generate-new-buffer name))
+ (mapcar (lambda (dude)
+ (when (and (car dude)
+ (or (not varstr)
+ (string-match varstr (symbol-name (car dude)))))
+ (condition-case ()
+ (set (make-local-variable (car dude))
+ (cdr dude))
+ (error))))
+ oldlocals)
+ (current-buffer))))
+
(run-hooks 'message-load-hook)
(provide 'message)