From ee39f8f0b7ba9a8454cb8b9bc93e9bad001a1498 Mon Sep 17 00:00:00 2001 From: Lars Magne Ingebrigtsen Date: Wed, 5 Mar 1997 01:31:59 +0000 Subject: [PATCH] *** empty log message *** --- lisp/ChangeLog | 129 ++++++ lisp/article.el | 964 ---------------------------------------- lisp/custom-edit.el | 445 ++++++++++++------- lisp/custom-opt.el | 2 +- lisp/custom.el | 2 +- lisp/gnus-art.el | 1015 ++++++++++++++++++++++++++++++++++++++++--- lisp/gnus-async.el | 11 +- lisp/gnus-cache.el | 3 +- lisp/gnus-cite.el | 18 +- lisp/gnus-demon.el | 3 +- lisp/gnus-group.el | 201 +-------- lisp/gnus-msg.el | 9 +- lisp/gnus-nocem.el | 1 - lisp/gnus-salt.el | 13 +- lisp/gnus-start.el | 1 + lisp/gnus-sum.el | 163 ++----- lisp/gnus-undo.el | 10 +- lisp/gnus-util.el | 1 + lisp/gnus-win.el | 3 +- lisp/gnus-xmas.el | 5 +- lisp/gnus.el | 321 +++++++++++++- lisp/message.el | 16 +- lisp/nnmail.el | 2 +- lisp/nnml.el | 3 +- lisp/pop3.el | 34 +- lisp/widget-edit.el | 39 +- lisp/widget.el | 2 +- texi/ChangeLog | 8 + texi/custom.texi | 178 ++++---- texi/gnus.texi | 17 +- texi/message.texi | 7 + texi/widget.texi | 4 +- 32 files changed, 1941 insertions(+), 1689 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0b005f25a..4fb3f88e2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,132 @@ +Sat Jan 4 08:35:06 1997 Lars Magne Ingebrigtsen + + * gnus-cache.el (gnus-start): Don't require gnus-sum. + + * gnus-art.el: All article functions moved here. + + * article.el: Elided. + + * gnus-async.el (gnus-async-prefetched-article-entry): Check for + empty articles. + + * gnus-art.el (gnus-read-save-file-name): Expand file name in + article save dir. + +Fri Jan 3 21:22:21 1997 Paul Stodghill + + * gnus-demon.el (gnus-demon): Use `gnus-demon-idle-time'. + +Tue Dec 31 10:38:43 1996 + + * pop3.el: version 1.3 + + * pop3.el: (pop3-retr): added bill@attmail.com's big buffer sleeps + to save wear and tear on he heap. + +Thu Aug 01 11:53:48 1996 + + * pop3.el: version 1.2 + + * pop3.el: (pop3-apop): minor changes to support XEmacs built-in + md5, or William Perry's modified md5.el. + + * pop3.el: (pop3-movemail): changed to use + pop3-authentication-scheme instead of pop3-use-apop. + + * pop3.el: pop3-use-appop: transformed into + pop3-authentication-scheme. + + * pop3.el: version 1.1 + + * pop3.el: (pop3-apop): new function. Send alternate + authentication information to the server. Requires md5.el. + + * pop3.el: (pop3-open-server): set pop3-timestamp if server + returns one. + + * pop3.el: (pop3-movemail): use APOP authentication if + pop3-use-apop non-nil. + + * pop3.el: pop3-timestamp: added variable + + * pop3.el: pop3-use-apop: added variable + +Fri Jan 3 18:52:23 1997 Wesley Hardaker + + * gnus-group.el (gnus-group-get-new-news): Pass the ARG on to the + listing function. + +Fri Jan 3 18:32:24 1997 Lars Magne Ingebrigtsen + + * article.el (article-hide-boring-headers): Respect + gnus-show-all-headers. + + * gnus-sum.el (gnus-summary-save-article): Update the mode line. + +Fri Jan 3 18:30:50 1997 Erik Toubro Nielsen + + * nnmail.el (nnmail-remove-leading-whitespace): Replacing should + be non-literal. + +Fri Jan 3 18:18:30 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-expire-articles-now): Use + "yes-or-no". + (gnus-summary-delete-article): Ditto. + +Fri Jan 3 18:16:27 1997 Peter Skov Knudsen + + * gnus-win.el (gnus-buffer-configuration): Don't create picons + frame unless needed. + +Fri Jan 3 17:21:30 1997 Lars Magne Ingebrigtsen + + * message.el (message-elide-region): New command and keystroke. + + * gnus-salt.el (gnus-generate-vertical-tree): Check whether we can + go backwards. + + * gnus-group.el (gnus-group-catchup-current): Prompt better. + + * gnus-undo.el (gnus-undo-make-menu-bar): Nonsense. + +Fri Jan 3 16:52:22 1997 Rajappa Iyer + + * gnus-salt.el (gnus-pick-start-reading): Possibly catch up all + unpicked articles. + +Fri Jan 3 12:12:22 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Try to get the + few last headers using HEAD in any case to work around a bug in + inn. + + * gnus-xmas.el (gnus-xmas-define): Redefined. + + * gnus.el (gnus-characterp): Made into func. + +Thu Jan 2 16:21:47 1997 Sudish Joseph + + * gnus-util.el (gnus-characterp): New function. + +Wed Dec 18 18:15:39 1996 Jan Vroonhof + + * gnus-start.el (gnus-dribble-enter): Make sure we write at the + end of the dribble file + +Thu Jan 2 16:01:58 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-limit-children): Make NoCeM'ed + articles read. + +Tue Dec 17 20:24:40 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-save-newsrc): Respect the prefix. + +Mon Dec 16 23:47:30 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.76 is released. + Mon Dec 16 14:33:58 1996 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-bug): Insert nntp server type. diff --git a/lisp/article.el b/lisp/article.el index 805f5ab91..e69de29bb 100644 --- a/lisp/article.el +++ b/lisp/article.el @@ -1,964 +0,0 @@ -;;; article.el --- article treatment functions -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Keywords: news - -;; 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: - -;;; Code: - -(require 'custom) -(require 'nnheader) -(require 'gnus-util) -(require 'message) -(require 'gnus-sum) - -(defgroup article nil - "Article display." - :group 'gnus) - -(defcustom gnus-ignored-headers - '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" - "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" - "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" - "^Approved:" "^Sender:" "^Received:" "^Mail-from:") - "All headers that match this regexp will be hidden. -This variable can also be a list of regexps of headers to be ignored. -If `gnus-visible-headers' is non-nil, this variable will be ignored." - :type '(choice :custom-show nil - regexp - (repeat regexp)) - :group 'article) - -(defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-" - "All headers that do not match this regexp will be hidden. -This variable can also be a list of regexp of headers to remain visible. -If this variable is non-nil, `gnus-ignored-headers' will be ignored." - :type '(repeat :value-to-internal (lambda (widget value) - (custom-split-regexp-maybe value)) - :match (lambda (widget value) - (or (stringp value) - (widget-editable-list-match widget value))) - regexp) - :group 'article) - -(defcustom gnus-sorted-header-list - '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:" - "^Cc:" "^Date:" "^Organization:") - "This variable is a list of regular expressions. -If it is non-nil, headers that match the regular expressions will -be placed first in the article buffer in the sequence specified by -this list." - :type '(repeat regexp) - :group 'article) - -(defcustom gnus-boring-article-headers '(empty followup-to reply-to) - "Headers that are only to be displayed if they have interesting data. -Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', and `date'." - :type '(set (const :tag "Headers with no content." empty) - (const :tag "Newsgroups with only one group." newsgroups) - (const :tag "Followup-to identical to newsgroups." followup-to) - (const :tag "Reply-to identical to from." reply-to) - (const :tag "Date less than four days old." date)) - :group 'article) - -(defcustom gnus-signature-separator '("^-- $" "^-- *$") - "Regexp matching signature separator. -This can also be a list of regexps. In that case, it will be checked -from head to tail looking for a separator. Searches will be done from -the end of the buffer." - :type '(repeat string) - :group 'article) - -(defcustom gnus-signature-limit nil - "Provide a limit to what is considered a signature. -If it is a number, no signature may not be longer (in characters) than -that number. If it is a floating point number, no signature may be -longer (in lines) than that number. If it is a function, the function -will be called without any parameters, and if it returns nil, there is -no signature in the buffer. If it is a string, it will be used as a -regexp. If it matches, the text in question is not a signature." - :type '(choice integer number function regexp) - :group 'article) - -(defcustom gnus-hidden-properties '(invisible t intangible t) - "Property list to use for hiding text." - :type 'sexp - :group 'article) - -(defcustom 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." - :type 'string ;Leave function case to Lisp. - :group 'article) - -(defcustom gnus-article-x-face-too-ugly nil - "Regexp matching posters whose face shouldn't be shown automatically." - :type 'regexp - :group 'article) - -(defcustom gnus-emphasis-alist - (let ((format - "\\(\\s-\\|^\\|[-\"\(]\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*\\)%s\\)\\(\\s-\\|[-?!.,;:\"\)]\\)") - (types - '(("_" "_" underline) - ("/" "/" italic) - ("\\*" "\\*" bold) - ("_/" "/_" underline-italic) - ("_\\*" "\\*_" underline-bold) - ("\\*/" "/\\*" bold-italic) - ("_\\*/" "/\\*_" underline-bold-italic)))) - `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" - 2 3 gnus-emphasis-underline) - ,@(mapcar - (lambda (spec) - (list - (format format (car spec) (cadr spec)) - 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) - types))) - "Alist that says how to fontify certain phrases. -Each item looks like this: - - (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) - -The first element is a regular expression to be matched. The second -is a number that says what regular expression grouping used to find -the entire emphasized word. The third is a number that says what -regexp grouping should be displayed and highlighted. The fourth -is the face used for highlighting." - :type '(repeat (list :value ("" 0 0 default) - regexp - (integer :tag "Match group") - (integer :tag "Emphasize group") - face)) - :group 'article) - -(defface gnus-emphasis-bold '((t (:bold t))) - "Face used for displaying strong emphasized text (*word*)." - :group 'article) - -(defface gnus-emphasis-italic '((t (:italic t))) - "Face used for displaying italic emphasized text (/word/)." - :group 'article) - -(defface gnus-emphasis-underline '((t (:underline t))) - "Face used for displaying underlined emphasized text (_word_)." - :group 'article) - -(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) - "Face used for displaying underlined bold emphasized text (_*word*_)." - :group 'article) - -(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) - "Face used for displaying underlined italic emphasized text (_*word*_)." - :group 'article) - -(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) - "Face used for displaying bold italic emphasized text (/*word*/)." - :group 'article) - -(defface gnus-emphasis-underline-bold-italic - '((t (:bold t :italic t :underline t))) - "Face used for displaying underlined bold italic emphasized text (_/*word*/_)." - :group 'article) - -(eval-and-compile - (autoload 'hexl-hex-string-to-integer "hexl") - (autoload 'timezone-make-date-arpa-standard "timezone") - (autoload 'mail-extract-address-components "mail-extr")) - -;;; Internal variables. - -(defvar gnus-inhibit-hiding nil) -(defvar gnus-newsgroup-name) - -(defsubst article-hide-text (b e props) - "Set text PROPS on the B to E region, extending `intangible' 1 past B." - (add-text-properties b e props) - (when (memq 'intangible props) - (put-text-property - (max (1- b) (point-min)) - b 'intangible (cddr (memq 'intangible props))))) - -(defsubst article-unhide-text (b e) - "Remove hidden text properties from region between B and E." - (remove-text-properties b e gnus-hidden-properties) - (when (memq 'intangible gnus-hidden-properties) - (put-text-property (max (1- b) (point-min)) - b 'intangible nil))) - -(defun article-hide-text-type (b e type) - "Hide text of TYPE between B and E." - (article-hide-text - b e (cons 'article-type (cons type gnus-hidden-properties)))) - -(defun article-unhide-text-type (b e type) - "Hide text of TYPE between B and E." - (remove-text-properties - b e (cons 'article-type (cons type gnus-hidden-properties))) - (when (memq 'intangible gnus-hidden-properties) - (put-text-property (max (1- b) (point-min)) - b 'intangible nil))) - -(defun article-hide-text-of-type (type) - "Hide text of TYPE in the current buffer." - (save-excursion - (let ((b (point-min)) - (e (point-max))) - (while (setq b (text-property-any b e 'article-type type)) - (add-text-properties b (incf b) gnus-hidden-properties))))) - -(defun article-delete-text-of-type (type) - "Delete text of TYPE in the current buffer." - (save-excursion - (let ((b (point-min))) - (while (setq b (text-property-any b (point-max) 'article-type type)) - (delete-region b (incf b)))))) - -(defun article-delete-invisible-text () - "Delete all invisible text in the current buffer." - (save-excursion - (let ((b (point-min))) - (while (setq b (text-property-any b (point-max) 'invisible t)) - (delete-region b (incf b)))))) - -(defun article-text-type-exists-p (type) - "Say whether any text of type TYPE exists in the buffer." - (text-property-any (point-min) (point-max) 'article-type type)) - -(defsubst article-header-rank () - "Give the rank of the string HEADER as given by `article-sorted-header-list'." - (let ((list gnus-sorted-header-list) - (i 0)) - (while list - (when (looking-at (car list)) - (setq list nil)) - (setq list (cdr list)) - (incf i)) - i)) - -(defun article-hide-headers (&optional arg delete) - "Toggle whether to hide unwanted headers and possibly sort them as well. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (article-hidden-arg)) - (if (article-check-hidden-text 'headers arg) - ;; Show boring headers as well. - (article-show-hidden-text 'boring-headers) - ;; This function might be inhibited. - (unless gnus-inhibit-hiding - (save-excursion - (save-restriction - (let ((buffer-read-only nil) - (props (nconc (list 'article-type 'headers) - gnus-hidden-properties)) - (max (1+ (length gnus-sorted-header-list))) - (ignored (when (not gnus-visible-headers) - (cond ((stringp gnus-ignored-headers) - gnus-ignored-headers) - ((listp gnus-ignored-headers) - (mapconcat 'identity gnus-ignored-headers - "\\|"))))) - (visible - (cond ((stringp gnus-visible-headers) - gnus-visible-headers) - ((and gnus-visible-headers - (listp gnus-visible-headers)) - (mapconcat 'identity gnus-visible-headers "\\|")))) - (inhibit-point-motion-hooks t) - want-list beg) - ;; First we narrow to just the headers. - (widen) - (goto-char (point-min)) - ;; Hide any "From " lines at the beginning of (mail) articles. - (while (looking-at "From ") - (forward-line 1)) - (unless (bobp) - (if delete - (delete-region (point-min) (point)) - (article-hide-text (point-min) (point) props))) - ;; Then treat the rest of the header lines. - (narrow-to-region - (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 - ;; article buffer. - (goto-char (point-min)) - (while (re-search-forward "^[^ \t]*:" nil t) - (beginning-of-line) - ;; Mark the rank of the header. - (put-text-property - (point) (1+ (point)) 'message-rank - (if (or (and visible (looking-at visible)) - (and ignored - (not (looking-at ignored)))) - (article-header-rank) - (+ 2 max))) - (forward-line 1)) - (message-sort-headers-1) - (when (setq beg (text-property-any - (point-min) (point-max) 'message-rank (+ 2 max))) - ;; We make the unwanted headers invisible. - (if delete - (delete-region beg (point-max)) - ;; Suggested by Sudish Joseph . - (article-hide-text-type beg (point-max) 'headers)) - ;; Work around XEmacs lossage. - (put-text-property (point-min) beg 'invisible nil)))))))) - -(defun article-hide-boring-headers (&optional arg) - "Toggle hiding of headers that aren't very interesting. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (article-hidden-arg)) - (unless (article-check-hidden-text 'boring-headers arg) - (save-excursion - (save-restriction - (let ((buffer-read-only nil) - (list gnus-boring-article-headers) - (inhibit-point-motion-hooks t) - elem) - (nnheader-narrow-to-headers) - (while list - (setq elem (pop list)) - (goto-char (point-min)) - (cond - ;; Hide empty headers. - ((eq elem 'empty) - (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) - (forward-line -1) - (article-hide-text-type - (progn (beginning-of-line) (point)) - (progn - (end-of-line) - (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max))) - 'boring-headers))) - ;; Hide boring Newsgroups header. - ((eq elem 'newsgroups) - (when (equal (gnus-fetch-field "newsgroups") - (gnus-group-real-name - (if (boundp 'gnus-newsgroup-name) - gnus-newsgroup-name - ""))) - (article-hide-header "newsgroups"))) - ((eq elem 'followup-to) - (when (equal (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) - (article-hide-header "followup-to"))) - ((eq elem 'reply-to) - (let ((from (message-fetch-field "from")) - (reply-to (message-fetch-field "reply-to"))) - (when (and - from reply-to - (equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to)))) - (article-hide-header "reply-to")))) - ((eq elem 'date) - (let ((date (message-fetch-field "date"))) - (when (and date - (< (gnus-days-between (current-time-string) date) - 4)) - (article-hide-header "date"))))))))))) - -(defun article-hide-header (header) - (save-excursion - (goto-char (point-min)) - (when (re-search-forward (concat "^" header ":") nil t) - (article-hide-text-type - (progn (beginning-of-line) (point)) - (progn - (end-of-line) - (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max))) - 'boring-headers)))) - -;; Written by Per Abrahamsen . -(defun article-treat-overstrike () - "Translate overstrikes into bold text." - (interactive) - (save-excursion - (let ((buffer-read-only nil)) - (while (search-forward "\b" nil t) - (let ((next (following-char)) - (previous (char-after (- (point) 2)))) - ;; We do the boldification/underlining by hiding the - ;; overstrikes and putting the proper text property - ;; on the letters. - (cond - ((eq next previous) - (article-hide-text-type (- (point) 2) (point) 'overstrike) - (put-text-property (point) (1+ (point)) 'face 'bold)) - ((eq next ?_) - (article-hide-text-type (1- (point)) (1+ (point)) 'overstrike) - (put-text-property - (- (point) 2) (1- (point)) 'face 'underline)) - ((eq previous ?_) - (article-hide-text-type (- (point) 2) (point) 'overstrike) - (put-text-property - (point) (1+ (point)) 'face 'underline)))))))) - -(defun article-fill () - "Format too long lines." - (interactive) - (save-excursion - (let ((buffer-read-only nil)) - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (end-of-line 1) - (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") - (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") - (adaptive-fill-mode t)) - (while (not (eobp)) - (and (>= (current-column) (min fill-column (window-width))) - (/= (preceding-char) ?:) - (fill-paragraph nil)) - (end-of-line 2)))))) - -(defun article-remove-cr () - "Remove carriage returns from an article." - (interactive) - (save-excursion - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (replace-match "" t t))))) - -(defun article-remove-trailing-blank-lines () - "Remove all trailing blank lines from the article." - (interactive) - (save-excursion - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (delete-region - (point) - (progn - (while (and (not (bobp)) - (looking-at "^[ \t]*$")) - (forward-line -1)) - (forward-line 1) - (point)))))) - -(defun article-display-x-face (&optional force) - "Look for an X-Face header and display it if present." - (interactive (list 'force)) - (save-excursion - ;; Delete the old process, if any. - (when (process-status "article-x-face") - (delete-process "article-x-face")) - (let ((inhibit-point-motion-hooks t) - (case-fold-search nil) - from) - (save-restriction - (nnheader-narrow-to-headers) - (setq from (message-fetch-field "from")) - (goto-char (point-min)) - (when (and gnus-article-x-face-command - (or force - ;; Check whether this face is censored. - (not gnus-article-x-face-too-ugly) - (and gnus-article-x-face-too-ugly from - (not (string-match gnus-article-x-face-too-ugly - from)))) - ;; Has to be present. - (re-search-forward "^X-Face: " nil t)) - ;; We now have the area of the buffer where the X-Face is stored. - (let ((beg (point)) - (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) - ;; We display the face. - (if (symbolp gnus-article-x-face-command) - ;; The command is a lisp function, so we call it. - (if (gnus-functionp gnus-article-x-face-command) - (funcall gnus-article-x-face-command beg end) - (error "%s is not a function" gnus-article-x-face-command)) - ;; The command is a string, so we interpret the command - ;; as a, well, command, and fork it off. - (let ((process-connection-type nil)) - (process-kill-without-query - (start-process - "article-x-face" nil shell-file-name shell-command-switch - gnus-article-x-face-command)) - (process-send-region "article-x-face" beg end) - (process-send-eof "article-x-face"))))))))) - -(defun article-decode-rfc1522 () - "Hack to remove QP encoding from headers." - (let ((case-fold-search t) - (inhibit-point-motion-hooks t) - (buffer-read-only nil) - string) - (save-restriction - (narrow-to-region - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - (goto-char (point-min)) - (while (re-search-forward - "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) - (setq string (match-string 1)) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (insert string) - (article-mime-decode-quoted-printable - (goto-char (point-min)) (point-max)) - (subst-char-in-region (point-min) (point-max) ?_ ? ) - (goto-char (point-max))) - (goto-char (point-min)))))) - -(defun article-de-quoted-unreadable (&optional force) - "Do a naive translation of a quoted-printable-encoded article. -This is in no way, shape or form meant as a replacement for real MIME -processing, but is simply a stop-gap measure until MIME support is -written. -If FORCE, decode the article whether it is marked as quoted-printable -or not." - (interactive (list 'force)) - (save-excursion - (let ((case-fold-search t) - (buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding"))) - (article-decode-rfc1522) - (when (or force - (and type (string-match "quoted-printable" (downcase type)))) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (article-mime-decode-quoted-printable (point) (point-max)))))) - -(defun article-mime-decode-quoted-printable-buffer () - "Decode Quoted-Printable in the current buffer." - (article-mime-decode-quoted-printable (point-min) (point-max))) - -(defun article-mime-decode-quoted-printable (from to) - "Decode Quoted-Printable in the region between FROM and TO." - (interactive "r") - (goto-char from) - (while (search-forward "=" to t) - (cond ((eq (following-char) ?\n) - (delete-char -1) - (delete-char 1)) - ((looking-at "[0-9A-F][0-9A-F]") - (subst-char-in-region - (1- (point)) (point) ?= - (hexl-hex-string-to-integer - (buffer-substring (point) (+ 2 (point))))) - (delete-char 2)) - ((looking-at "=") - (delete-char 1)) - ((gnus-message 3 "Malformed MIME quoted-printable message"))))) - -(defun article-hide-pgp (&optional arg) - "Toggle hiding of any PGP headers and signatures in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (article-hidden-arg)) - (unless (article-check-hidden-text 'pgp arg) - (save-excursion - (let (buffer-read-only beg end) - (widen) - (goto-char (point-min)) - ;; Hide the "header". - (and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) - (setq beg (point)) - ;; Hide the actual signature. - (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) - (setq end (1+ (match-beginning 0))) - (article-hide-text-type - end - (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) - (match-end 0) - ;; Perhaps we shouldn't hide to the end of the buffer - ;; if there is no end to the signature? - (point-max)) - 'pgp)) - ;; Hide "- " PGP quotation markers. - (when (and beg end) - (narrow-to-region beg end) - (goto-char (point-min)) - (while (re-search-forward "^- " nil t) - (article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) - (widen)))))) - -(defun article-hide-pem (&optional arg) - "Toggle hiding of any PEM headers and signatures in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (article-hidden-arg)) - (unless (article-check-hidden-text 'pem arg) - (save-excursion - (let (buffer-read-only end) - (widen) - (goto-char (point-min)) - ;; hide the horrendously ugly "header". - (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (setq end (1+ (match-beginning 0))) - (article-hide-text-type - end - (if (search-forward "\n\n" nil t) - (match-end 0) - (point-max)) - 'pem)) - ;; hide the trailer as well - (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (article-hide-text-type - (match-beginning 0) (match-end 0) 'pem)))))) - -(defun article-hide-signature (&optional arg) - "Hide the signature in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (article-hidden-arg)) - (unless (article-check-hidden-text 'signature arg) - (save-excursion - (save-restriction - (let ((buffer-read-only nil)) - (when (article-narrow-to-signature) - (article-hide-text-type (point-min) (point-max) 'signature))))))) - -(defun article-strip-leading-blank-lines () - "Remove all blank lines from the beginning of the article." - (interactive) - (save-excursion - (let ((inhibit-point-motion-hooks t) - buffer-read-only) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (while (and (not (eobp)) - (looking-at "[ \t]*$")) - (gnus-delete-line)))))) - -(defun article-strip-multiple-blank-lines () - "Replace consecutive blank lines with one empty line." - (interactive) - (save-excursion - (let (buffer-read-only) - ;; First make all blank lines empty. - (goto-char (point-min)) - (while (re-search-forward "^[ \t]+$" nil t) - (replace-match "" nil t)) - ;; Then replace multiple empty lines with a single empty line. - (goto-char (point-min)) - (while (re-search-forward "\n\n\n+" nil t) - (replace-match "\n\n" t t))))) - -(defun article-strip-blank-lines () - "Strip leading, trailing and multiple blank lines." - (interactive) - (article-strip-leading-blank-lines) - (article-remove-trailing-blank-lines) - (article-strip-multiple-blank-lines)) - -(defvar mime::preview/content-list) -(defvar mime::preview-content-info/point-min) -(defun article-narrow-to-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) - ;; We have a MIMEish article, so we use the MIME data to narrow. - (let ((pcinfo (car (last mime::preview/content-list)))) - (ignore-errors - (narrow-to-region - (funcall (intern "mime::preview-content-info/point-min") pcinfo) - (point-max))))) - - (when (article-search-signature) - (forward-line 1) - ;; Check whether we have some limits to what we consider - ;; to be a signature. - (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit - (list gnus-signature-limit))) - limit limited) - (while (setq limit (pop limits)) - (if (or (and (integerp limit) - (< (- (point-max) (point)) limit)) - (and (floatp limit) - (< (count-lines (point) (point-max)) limit)) - (and (gnus-functionp limit) - (funcall limit)) - (and (stringp limit) - (not (re-search-forward limit nil t)))) - () ; This limit did not succeed. - (setq limited t - limits nil))) - (unless limited - (narrow-to-region (point) (point-max)) - t)))) - -(defun article-search-signature () - "Search the current buffer for the signature separator. -Put point at the beginning of the signature separator." - (let ((cur (point))) - (goto-char (point-max)) - (if (if (stringp gnus-signature-separator) - (re-search-backward gnus-signature-separator nil t) - (let ((seps gnus-signature-separator)) - (while (and seps - (not (re-search-backward (car seps) nil t))) - (pop seps)) - seps)) - t - (goto-char cur) - nil))) - -(defun article-hidden-arg () - "Return the current prefix arg as a number, or 0 if no prefix." - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - 0))) - -(defun article-check-hidden-text (type arg) - "Return nil if hiding is necessary. -Arg can be nil or a number. Nil and positive means hide, negative -means show, 0 means toggle." - (save-excursion - (let ((hide (article-hidden-text-p type))) - (cond - ((or (null arg) - (> arg 0)) - nil) - ((< arg 0) - (article-show-hidden-text type)) - (t - (if (eq hide 'hidden) - (article-show-hidden-text type) - nil)))))) - -(defun article-hidden-text-p (type) - "Say whether the current buffer contains hidden text of type TYPE." - (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) - (when pos - (if (get-text-property pos 'invisible) - 'hidden - 'shown)))) - -(defun article-show-hidden-text (type &optional hide) - "Show all hidden text of type TYPE. -If HIDE, hide the text instead." - (save-excursion - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (beg (point-min))) - (while (gnus-goto-char (text-property-any - beg (point-max) 'article-type type)) - (setq beg (point)) - (forward-char) - (if hide - (article-hide-text beg (point) gnus-hidden-properties) - (article-unhide-text beg (point))) - (setq beg (point))) - t))) - -(defconst article-time-units - `((year . ,(* 365.25 24 60 60)) - (week . ,(* 7 24 60 60)) - (day . ,(* 24 60 60)) - (hour . ,(* 60 60)) - (minute . 60) - (second . 1)) - "Mapping from time units to seconds.") - -(defun article-date-ut (&optional type highlight header) - "Convert DATE date to universal time in the current article. -If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE." - (interactive (list 'ut t)) - (let* ((header (or header - (mail-header-date gnus-current-headers) - (message-fetch-field "date") - "")) - (date (if (vectorp header) (mail-header-date header) - header)) - (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") - (inhibit-point-motion-hooks t) - bface eface) - (when (and date (not (string= date ""))) - (save-excursion - (save-restriction - (nnheader-narrow-to-headers) - (let ((buffer-read-only nil)) - ;; Delete any old Date headers. - (if (re-search-forward date-regexp nil t) - (progn - (setq bface (get-text-property (gnus-point-at-bol) 'face) - eface (get-text-property (1- (gnus-point-at-eol)) - 'face)) - (message-remove-header date-regexp t) - (beginning-of-line)) - (goto-char (point-max))) - (insert (article-make-date-line date type)) - ;; Do highlighting. - (forward-line -1) - (when (looking-at "\\([^:]+\\): *\\(.*\\)$") - (put-text-property (match-beginning 1) (match-end 1) - 'face bface) - (put-text-property (match-beginning 2) (match-end 2) - 'face eface)))))))) - -(defun article-make-date-line (date type) - "Return a DATE line of TYPE." - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (concat "Date: " (condition-case () - (timezone-make-date-arpa-standard date) - (error date)) - "\n")) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (condition-case () - (timezone-make-date-arpa-standard date nil "UT") - (error date)) - "\n")) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " date "\n")) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time - (ignore-errors - (gnus-time-minus - (gnus-encode-date - (timezone-make-date-arpa-standard - (current-time-string now) - (current-time-zone now) "UT")) - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))))) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) - (cond - ((null real-time) - "X-Sent: Unknown\n") - ((zerop sec) - "X-Sent: Now\n") - (t - (concat - "X-Sent: " - ;; This is a bit convoluted, but basically we go - ;; through the time units for years, weeks, etc, - ;; and divide things to see whether that results - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago\n" - " in the future\n")))))) - (t - (error "Unknown conversion type: %s" type)))) - -(defun article-date-local (&optional highlight) - "Convert the current article date to the local timezone." - (interactive (list t)) - (article-date-ut 'local highlight)) - -(defun article-date-original (&optional highlight) - "Convert the current article date to what it was originally. -This is only useful if you have used some other date conversion -function and want to see what the date was before converting." - (interactive (list t)) - (article-date-ut 'original highlight)) - -(defun article-date-lapsed (&optional highlight) - "Convert the current article date to time lapsed since it was sent." - (interactive (list t)) - (article-date-ut 'lapsed highlight)) - -(defun article-show-all () - "Show all hidden text in the article buffer." - (interactive) - (save-excursion - (let ((buffer-read-only nil)) - (article-unhide-text (point-min) (point-max))))) - -(defun article-emphasize (&optional arg) - "Emphasize text according to `gnus-emphasis-alist'." - (interactive (article-hidden-arg)) - (unless (article-check-hidden-text 'emphasis arg) - (save-excursion - (let ((alist gnus-emphasis-alist) - (buffer-read-only nil) - (props (append '(article-type emphasis) - gnus-hidden-properties)) - regexp elem beg invisible visible face) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (setq beg (point)) - (while (setq elem (pop alist)) - (goto-char beg) - (setq regexp (car elem) - invisible (nth 1 elem) - visible (nth 2 elem) - face (nth 3 elem)) - (while (re-search-forward regexp nil t) - (when (and (match-beginning visible) (match-beginning invisible)) - (article-hide-text - (match-beginning invisible) (match-end invisible) props) - (article-unhide-text-type - (match-beginning visible) (match-end visible) 'emphasis) - (gnus-put-text-property-excluding-newlines - (match-beginning visible) (match-end visible) 'face face) - (goto-char (match-end invisible))))))))) - -(provide 'article) - -;;; article.el ends here diff --git a/lisp/custom-edit.el b/lisp/custom-edit.el index 31752e8ed..45ed5091e 100644 --- a/lisp/custom-edit.el +++ b/lisp/custom-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.12 +;; Version: 1.15 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -17,9 +17,9 @@ (require 'widget-edit) (require 'easymenu) -(define-widget-keywords :custom-menu :custom-show :custom-magic - :custom-state :custom-level :custom-form - :custom-apply :custom-set-default :custom-reset) +(define-widget-keywords :custom-prefixes :custom-menu :custom-show + :custom-magic :custom-state :custom-level :custom-form + :custom-set :custom-save :custom-reset) ;;; Utilities. @@ -88,6 +88,22 @@ IF REGEXP is not a string, return it unchanged." (insert "...")) (buffer-string))))) +(defcustom custom-unlispify-tag-names t + "Display tag names as words instead of symbols if non nil." + :group 'customize + :type 'boolean) + +(defun custom-unlispify-tag-name (symbol) + "Convert symbol into a menu entry." + (let ((custom-unlispify-menu-entries custom-unlispify-tag-names)) + (custom-unlispify-menu-entry symbol t))) + +(defun custom-prefix-add (symbol prefixes) + ;; Addd SYMBOL to list of ignored PREFIXES. + (cons (or (get symbol 'custom-prefix) + (concat (symbol-name symbol) "-")) + prefixes)) + ;;; The Custom Mode. (defvar custom-options nil @@ -104,10 +120,10 @@ IF REGEXP is not a string, return it unchanged." custom-mode-map "Menu used in customization buffers." '("Custom" - ["Apply" custom-apply t] - ["Set Default" custom-set-default t] + ["Set" custom-set t] + ["Save" custom-save t] ["Reset" custom-reset t] - ["Save" custom-save t])) + ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) (defcustom custom-mode-hook nil "Hook called when entering custom-mode." @@ -123,10 +139,9 @@ The following commands are available: \\[widget-backward] Move to previous button or editable field. \\[widget-button-click] Activate button under the mouse pointer. \\[widget-button-press] Activate button under point. -\\[custom-apply] Apply all modifications. -\\[custom-set-default] Make all modifications default. +\\[custom-set] Set all modifications. +\\[custom-save] Make all modifications default. \\[custom-reset] Undo all modifications. -\\[custom-save] Save defaults for future emacs sessions. Entry to this mode calls the value of `custom-mode-hook' if that value is non-nil." @@ -139,23 +154,24 @@ if that value is non-nil." ;;; Custom Mode Commands. -(defun custom-apply () - "Apply changes in all modified options." +(defun custom-set () + "Set changes in all modified options." (interactive) (let ((children custom-options)) (mapcar (lambda (child) (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-apply))) + (widget-apply child :custom-set))) children))) -(defun custom-set-default () - "Set default in all modified group members." +(defun custom-save () + "Set all modified group members and save them." (interactive) (let ((children custom-options)) (mapcar (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-set-default))) - children))) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children)) + (custom-save-all)) (defun custom-reset () "Reset all modified group members." @@ -274,10 +290,14 @@ Push RET or click mouse-2 on the word ") (prog1 (if (> (length options) 1) (widget-create (nth 1 entry) + :tag (custom-unlispify-tag-name + (nth 0 entry)) :value (nth 0 entry)) ;; If there is only one entry, don't hide it! (widget-create (nth 1 entry) :custom-state 'unknown + :tag (custom-unlispify-tag-name + (nth 0 entry)) :value (nth 0 entry))) (unless (eq (preceding-char) ?\n) (widget-insert "\n")) @@ -285,28 +305,22 @@ Push RET or click mouse-2 on the word ") options)) (mapcar 'custom-magic-reset custom-options) (widget-create 'push-button - :tag "Apply" - :help-echo "Push me to apply all modifications." + :tag "Set" + :help-echo "Push me to set all modifications." :action (lambda (widget &optional event) - (custom-apply))) + (custom-set))) (widget-insert " ") (widget-create 'push-button - :tag "Set Default" + :tag "Save" :help-echo "Push me to make the modifications default." :action (lambda (widget &optional event) - (custom-set-default))) + (custom-save))) (widget-insert " ") (widget-create 'push-button :tag "Reset" :help-echo "Push me to undo all modifications.." :action (lambda (widget &optional event) (custom-reset))) - (widget-insert " ") - (widget-create 'push-button - :tag "Save" - :help-echo "Push me to store the new defaults permanently." - :action (lambda (widget &optional event) - (custom-save))) (widget-insert "\n") (widget-setup)) @@ -337,12 +351,6 @@ Push RET or click mouse-2 on the word ") ;;; The `custom-magic' Widget. -(define-widget 'custom-magic 'item - "Status feedback for customization option." - :format "%[%v%]" - :action 'widget-choice-item-action - :value-create 'custom-magic-value-create) - (defface custom-invalid-face '((((class color)) (:foreground "yellow" :background "red")) (t @@ -361,26 +369,43 @@ Push RET or click mouse-2 on the word ") (:italic t :bold))) "Face used when the customize item has been modified.") -(defface custom-applied-face '((((class color)) +(defface custom-set-face '((((class color)) (:foreground "blue" :background "white")) (t (:italic t))) - "Face used when the customize item has been applied.") + "Face used when the customize item has been set.") + +(defface custom-changed-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t))) + "Face used when the customize item has been changed.") (defface custom-saved-face '((t (:underline t))) "Face used when the customize item has been saved.") -(defcustom custom-magic-alist '((nil "#" underline) - (unknown "?" italic) - (hidden "-" default) - (invalid "x" custom-invalid-face) - (modified "*" custom-modified-face) - (applied "+" custom-applied-face) - (saved "!" custom-saved-face) - (rogue "@" custom-rogue-face) - (factory " " nil)) - "Alist of magic representing a customize items status. -Each entry is of the form (STATE MAGIC FACE), where +(defcustom custom-magic-alist '((nil "#" underline "\ +uninitialized, you should not see this.") + (unknown "?" italic "\ +unknown, you should not see this.") + (hidden "-" default "\ +hidden, press the stars `*' on the line above to show.") + (invalid "x" custom-invalid-face "\ +the value displayed for this item is invalid and cannot be set.") + (modified "*" custom-modified-face "\ +you have edited the item, and can now set it.") + (set "+" custom-set-face "\ +you have set this item, but not saved it.") + (changed ":" custom-changed-face "\ +this item has been changed outside customize.") + (saved "!" custom-saved-face "\ +this item has been saved.") + (rogue "@" custom-rogue-face "\ +this item is not prepared for customization.") + (factory " " nil "\ +this item is unchanged from its factory setting.")) + "Alist of customize option states. +Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where STATE is one of the following symbols: @@ -394,8 +419,10 @@ STATE is one of the following symbols: This item is modified, but has an invalid form. `modified' This item is modified, and has a valid form. -`applied' - This items current value has been changed temporarily. +`set' + This item has been set but not saved. +`changed' + The current value of this item has been changed temporarily. `saved' This item is marked for saving. `rogue' @@ -407,30 +434,113 @@ MAGIC is a string used to present that state. FACE is a face used to present the state. +DESCRIPTION is a string describing the state. + The list should be sorted most significant first." - :type '(repeat (list (choice (const nil) - (const unknown) - (const hidden) - (const invalid) - (const modified) - (const applied) - (const saved) - (const rogue) - (const factory)) - string face)) + :type '(list (checklist :inline t + (group (const nil) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const unknown) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const hidden) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const invalid) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const modified) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const set) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const changed) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const saved) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const rogue) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const factory) + (string :tag "Magic") + face + (string :tag "Description"))) + (editable-list :inline t + (group symbol + (string :tag "Magic") + face + (string :tag "Description")))) + :group 'customize) + +(defcustom custom-magic-show 'long + "Show long description of the state of each customization option." + :type '(choice (const :tag "no" nil) + (const short) + (const long)) :group 'customize) +(defcustom custom-magic-show-button t + "Show a magic button indicating the state of each customization option." + :type 'boolean + :group 'customize) + +(define-widget 'custom-magic 'default + "Show and manipulate state for a customization option." + :format "%v" + :action 'widget-choice-item-action + :value-get 'ignore + :value-create 'custom-magic-value-create + :value-delete 'widget-children-value-delete) + (defun custom-magic-value-create (widget) ;; Create compact status report for WIDGET. (let* ((parent (widget-get widget :parent)) (state (widget-get parent :custom-state)) (entry (assq state custom-magic-alist)) (magic (nth 1 entry)) - (face (nth 2 entry))) - (if (eq (widget-get parent :custom-form) 'lisp) - (widget-insert "(" magic ")") - (widget-insert "[" magic "]")) - (widget-put widget :button-face face))) + (face (nth 2 entry)) + (text (nth 3 entry)) + (lisp (eq (widget-get parent :custom-form) 'lisp)) + children) + (when custom-magic-show + (push (widget-create-child-and-convert widget 'choice-item + :format "%[%t%]" + :tag "State") + children) + (insert ": ") + (if (eq custom-magic-show 'long) + (insert text) + (insert (symbol-name state))) + (when lisp + (insert " (lisp)")) + (insert "\n")) + (when custom-magic-show-button + (when custom-magic-show + (let ((indent (widget-get parent :indent))) + (when indent + (insert-char ? indent)))) + (push (widget-create-child-and-convert widget 'choice-item + :button-face face + :format "%[%t%]" + :tag (if lisp + (concat "(" magic ")") + (concat "[" magic "]"))) + children) + (insert " ")) + (widget-put widget :children children))) (defun custom-magic-reset (widget) "Redraw the :custom-magic property of WIDGET." @@ -450,7 +560,7 @@ The list should be sorted most significant first." (let* ((parent (widget-get widget :parent)) (state (widget-get parent :custom-state))) (cond ((memq state '(invalid modified)) - (error "There are unapplied changes")) + (error "There are unset changes")) ((eq state 'hidden) (widget-put parent :custom-state 'unknown)) (t @@ -459,20 +569,10 @@ The list should be sorted most significant first." ;;; The `custom' Widget. -(defvar custom-save-needed-p nil - "Non-nil if any customizations need to be saved.") - -(add-hook 'kill-emacs-hook 'custom-save-maybe) - -(defun custom-save-maybe () - (and custom-save-needed-p - (y-or-n-p "You have unsaved customizations, save them now? ") - (custom-save))) - (define-widget 'custom 'default "Customize a user option." - :convert-widget 'widget-item-convert-widget - :format "%l%[%t%]: %v%m %h%a" + :convert-widget 'custom-convert-widget + :format "%l%[%t%]: %v%m%h%a" :format-handler 'custom-format-handler :notify 'custom-notify :custom-level 1 @@ -484,6 +584,16 @@ The list should be sorted most significant first." :validate 'widget-editable-list-validate :match (lambda (widget value) (symbolp value))) +(defun custom-convert-widget (widget) + ;; Initialize :value and :tag from :args in WIDGET. + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (widget-apply widget + :value-to-internal (car args))) + (widget-put widget :tag (custom-unlispify-tag-name (car args))) + (widget-put widget :args nil))) + widget) + (defun custom-format-handler (widget escape) ;; We recognize extra escape sequences. (let* ((buttons (widget-get widget :buttons)) @@ -497,13 +607,8 @@ The list should be sorted most significant first." (widget-insert " ") (widget-put widget :buttons buttons))) ((eq escape ?L) - (push (widget-create-child-and-convert - widget 'custom-level - :format "%[%t%]" - (if (eq state 'hidden) "show" "hide")) - buttons) - (widget-insert " ") - (widget-put widget :buttons buttons)) + (when (eq state 'hidden) + (widget-insert " ..."))) ((eq escape ?m) (and (eq (preceding-char) ?\n) (widget-get widget :indent) @@ -592,7 +697,7 @@ The list should be sorted most significant first." (define-widget 'custom-variable 'custom "Customize variable." - :format "%l%v%m %h%a" + :format "%l%v%m%h%a" :help-echo "Push me to set or reset this variable." :documentation-property 'variable-documentation :custom-state nil @@ -600,8 +705,8 @@ The list should be sorted most significant first." :custom-form 'edit :value-create 'custom-variable-value-create :action 'custom-variable-action - :custom-apply 'custom-variable-apply - :custom-set-default 'custom-variable-set-default + :custom-set 'custom-variable-set + :custom-save 'custom-variable-save :custom-reset 'custom-redraw) (defun custom-variable-value-create (widget) @@ -614,6 +719,7 @@ The list should be sorted most significant first." (symbol (widget-get widget :value)) (options (get symbol 'custom-options)) (child-type (or (get symbol 'custom-type) 'sexp)) + (tag (widget-get widget :tag)) (type (let ((tmp (if (listp child-type) (copy-list child-type) (list child-type)))) @@ -638,11 +744,7 @@ The list should be sorted most significant first." ;; Now we can create the child widget. (cond ((eq state 'hidden) ;; Make hidden value easy to show. - (push (widget-create-child-and-convert - widget 'custom-level - :tag (symbol-name symbol) - :format "%t: %[show%]") - buttons)) + (insert tag ": ...")) ((eq form 'lisp) ;; In lisp mode edit the saved value when possible. (let* ((value (cond ((get symbol 'saved-value) @@ -660,10 +762,10 @@ The list should be sorted most significant first." children))) (t ;; Edit mode. - - (push (widget-create-child-and-convert widget type - :tag (symbol-name symbol) - :value value) + (push (widget-create-child-and-convert + widget type + :tag tag + :value value) children))) ;; Now update the state. (unless (eq (preceding-char) ?\n) @@ -681,28 +783,33 @@ The list should be sorted most significant first." (value (if (default-boundp symbol) (default-value symbol) (widget-get widget :value))) - (state (if (get symbol 'saved-value) - (if (condition-case nil - (equal value - (eval (car (get symbol 'saved-value)))) - (error nil)) - 'saved - 'applied) - (if (get symbol 'factory-value) - (if (condition-case nil - (equal value - (eval (car (get symbol 'factory-value)))) - (error nil)) - 'factory - 'applied) - 'rogue)))) + tmp + (state (cond ((setq tmp (get symbol 'customized-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'set)) + ((setq tmp (get symbol 'saved-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'set)) + ((setq tmp (get symbol 'factory-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'factory + 'set)) + (t 'rogue)))) (widget-put widget :custom-state state))) (defvar custom-variable-menu '(("Edit" . custom-variable-edit) - ("Edit Default" . custom-variable-edit-lisp) - ("Apply" . custom-variable-apply) - ("Set Default" . custom-variable-set-default) + ("Edit Lisp" . custom-variable-edit-lisp) + ("Set" . custom-variable-set) + ("Save" . custom-variable-save) ("Reset" . custom-redraw) ("Reset to Default" . custom-variable-default) ("Reset to Factory Settings" . custom-variable-factory)) @@ -733,7 +840,7 @@ Optional EVENT is the location for the menu." (widget-put widget :custom-form 'lisp) (custom-redraw widget)) -(defun custom-variable-apply (widget) +(defun custom-variable-set (widget) "Set the current value for the variable being edited by WIDGET." (let ((form (widget-get widget :custom-form)) (state (widget-get widget :custom-state)) @@ -741,17 +848,19 @@ Optional EVENT is the location for the menu." (symbol (widget-value widget)) val) (cond ((eq state 'hidden) - (error "Cannot apply hidden variable.")) + (error "Cannot set hidden variable.")) ((setq val (widget-apply child :validate)) (error "Invalid %S" val)) ((eq form 'lisp) - (set symbol (eval (widget-value child)))) + (set symbol (eval (setq val (widget-value child)))) + (put symbol 'customized-value (list val))) (t - (set symbol (widget-value child)))) + (set symbol (widget-value child)) + (put symbol 'customized-value (list (custom-quote val))))) (custom-variable-state-set widget) (custom-redraw-magic widget))) -(defun custom-variable-set-default (widget) +(defun custom-variable-save (widget) "Set the default value for the variable being edited by WIDGET." (let ((form (widget-get widget :custom-form)) (state (widget-get widget :custom-state)) @@ -759,19 +868,19 @@ Optional EVENT is the location for the menu." (symbol (widget-value widget)) val) (cond ((eq state 'hidden) - (error "Cannot apply hidden variable.")) + (error "Cannot set hidden variable.")) ((setq val (widget-apply child :validate)) (error "Invalid %S" val)) ((eq form 'lisp) - (setq custom-save-needed-p (cons symbol custom-save-needed-p)) (put symbol 'saved-value (list (widget-value child))) (set symbol (eval (widget-value child)))) (t - (setq custom-save-needed-p (cons symbol custom-save-needed-p)) (put symbol 'saved-value (list (custom-quote (widget-value child)))) (set symbol (widget-value child)))) + (put symbol 'customized-value nil) + (custom-save-all) (custom-variable-state-set widget) (custom-redraw-magic widget))) @@ -783,6 +892,7 @@ Optional EVENT is the location for the menu." (set symbol (eval (car (get symbol 'saved-value)))) (error nil)) (error "No default value for %s" symbol)) + (put symbol 'customized-value nil) (widget-put widget :custom-state 'unknown) (custom-redraw widget))) @@ -792,9 +902,10 @@ Optional EVENT is the location for the menu." (if (get symbol 'factory-value) (set symbol (eval (car (get symbol 'factory-value)))) (error "No factory default for %S" symbol)) + (put symbol 'customized-value nil) (when (get symbol 'saved-value) - (setq custom-save-needed-p (cons symbol custom-save-needed-p)) - (put symbol 'saved-value nil)) + (put symbol 'saved-value nil) + (custom-save-all)) (widget-put widget :custom-state 'unknown) (custom-redraw widget))) @@ -834,6 +945,12 @@ Optional EVENT is the location for the menu." :offset 0 (const :format "X " x) + (const :format "PM " + pm) + (const :format "Win32 " + win32) + (const :format "DOS " + pc) (const :format "TTY%n" tty))) (group (const :format "Class: " class) @@ -858,14 +975,14 @@ Optional EVENT is the location for the menu." (define-widget 'custom-face 'custom "Customize face." - :format "%l%[%t%]: %s%m %h%a%v" + :format "%l%[%t%]: %s%m%h%a%v" :format-handler 'custom-face-format-handler :help-echo "Push me to set or reset this face." :documentation-property 'face-documentation :value-create 'custom-face-value-create :action 'custom-face-action - :custom-apply 'custom-face-apply - :custom-set-default 'custom-face-set-default + :custom-set 'custom-face-set + :custom-save 'custom-face-save :custom-reset 'custom-redraw :custom-menu 'custom-face-menu-create) @@ -883,7 +1000,7 @@ Optional EVENT is the location for the menu." widget 'custom-level :format "(%[%t%])\n" :button-face symbol - (if (eq state 'hidden) "show" "hide")))) + (if (eq state 'hidden) "*** show ***" "hide")))) (t (custom-format-handler widget escape))) (when child @@ -908,8 +1025,8 @@ Optional EVENT is the location for the menu." (widget-put widget :children (list edit))))) (defvar custom-face-menu - '(("Apply" . custom-face-apply) - ("Set Default" . custom-face-set-default) + '(("Set" . custom-face-set) + ("Save" . custom-face-save) ("Reset to Default" . custom-face-default) ("Reset to Factory Setting" . custom-face-factory)) "Alist of actions for the `custom-face' widget. @@ -920,7 +1037,9 @@ when the action is chosen.") (defun custom-face-state-set (widget) "Set the state of WIDGET." (let ((symbol (widget-value widget))) - (widget-put widget :custom-state (cond ((get symbol 'saved-face) + (widget-put widget :custom-state (cond ((get symbol 'customized-face) + 'set) + ((get symbol 'saved-face) 'saved) ((get symbol 'factory-face) 'factory) @@ -938,22 +1057,24 @@ Optional EVENT is the location for the menu." (if answer (funcall answer widget)))) -(defun custom-face-apply (widget) +(defun custom-face-set (widget) "Make the face attributes in WIDGET take effect." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) (value (widget-value child))) + (put symbol 'customized-face value) (custom-face-display-set symbol value) (custom-face-state-set widget) (custom-redraw-magic widget))) -(defun custom-face-set-default (widget) +(defun custom-face-save (widget) "Make the face attributes in WIDGET default." (let* ((symbol (widget-value widget)) (child (car (widget-get widget :children))) (value (widget-value child))) (custom-face-display-set symbol value) (put symbol 'saved-face value) + (put symbol 'customized-face nil) (custom-face-state-set widget) (custom-redraw-magic widget))) @@ -963,11 +1084,12 @@ Optional EVENT is the location for the menu." (child (car (widget-get widget :children))) (value (get symbol 'saved-face))) (unless value - (error "No saved value for this face") - (custom-face-display-set symbol value) + (error "No saved value for this face")) + (put symbol 'customized-face nil) + (custom-face-display-set symbol value) (widget-value-set child value) (custom-face-state-set widget) - (custom-redraw-magic widget)))) + (custom-redraw-magic widget))) (defun custom-face-factory (widget) "Restore WIDGET to the face's factory settings." @@ -976,8 +1098,10 @@ Optional EVENT is the location for the menu." (value (get symbol 'factory-face))) (unless value (error "No factory default for this face")) + (put symbol 'customized-face nil) (when (get symbol 'saved-face) - (put symbol 'saved-face nil)) + (put symbol 'saved-face nil) + (custom-save-all)) (custom-face-display-set symbol value) (widget-value-set child value) (custom-face-state-set widget) @@ -1003,7 +1127,7 @@ Optional EVENT is the location for the menu." (let* ((symbol (widget-value widget)) (child (widget-create-child-and-convert widget 'custom-face - :format "%t %s%m %h%v" + :format "%t %s%m%h%v" :custom-level nil :value symbol))) (custom-magic-reset child) @@ -1059,13 +1183,13 @@ Optional EVENT is the location for the menu." (define-widget 'custom-group 'custom "Customize group." - :format "%l%[%t%]: %L\n%m %h%a%v" + :format "%l%[%t%]:%L\n%m%h%a%v" :documentation-property 'group-documentation :help-echo "Push me to set or reset all members of this group." :value-create 'custom-group-value-create :action 'custom-group-action - :custom-apply 'custom-group-apply - :custom-set-default 'custom-group-set-default + :custom-set 'custom-group-set + :custom-save 'custom-group-save :custom-reset 'custom-group-reset :custom-menu 'custom-group-menu-create) @@ -1076,12 +1200,17 @@ Optional EVENT is the location for the menu." (let* ((level (widget-get widget :custom-level)) (symbol (widget-value widget)) (members (get symbol 'custom-group)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) (children (mapcar (lambda (entry) (widget-insert "\n") (prog1 (widget-create-child-and-convert widget (nth 1 entry) :group widget + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :custom-prefixes custom-prefix-list :custom-level (1+ level) :value (nth 0 entry)) (unless (eq (preceding-char) ?\n) @@ -1092,8 +1221,8 @@ Optional EVENT is the location for the menu." (custom-group-state-update widget))))) (defvar custom-group-menu - '(("Apply" . custom-group-apply) - ("Set Default" . custom-group-set-default) + '(("Set" . custom-group-set) + ("Save" . custom-group-save) ("Reset" . custom-group-reset)) "Alist of actions for the `custom-group' widget. The key is a string containing the name of the action, the value is a @@ -1110,20 +1239,20 @@ Optional EVENT is the location for the menu." (if answer (funcall answer widget)))) -(defun custom-group-apply (widget) - "Apply changes in all modified group members." +(defun custom-group-set (widget) + "Set changes in all modified group members." (let ((children (widget-get widget :children))) (mapcar (lambda (child) (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-apply))) + (widget-apply child :custom-set))) children ))) -(defun custom-group-set-default (widget) - "Set default in all modified group members." +(defun custom-group-save (widget) + "Save all modified group members." (let ((children (widget-get widget :children))) (mapcar (lambda (child) - (when (eq (widget-get child :custom-state) 'modified) - (widget-apply child :custom-set-default))) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) children ))) (defun custom-group-reset (widget) @@ -1153,7 +1282,7 @@ Optional EVENT is the location for the menu." (widget-put widget :custom-state found))) (custom-magic-reset widget)) -;;; The `custom-save' Command. +;;; The `custom-save-all' Function. (defcustom custom-file "~/.emacs" "File used for storing customization information. @@ -1228,12 +1357,10 @@ Leave point at the location of the call, or after the last expression." (unless (eolp) (princ "\n"))))) -(defun custom-save () +(defun custom-save-all () "Save all customizations in `custom-file'." - (interactive) (custom-save-variables) (custom-save-faces) - (setq custom-save-needed-p nil) (save-excursion (set-buffer (find-file-noselect custom-file)) (save-buffer))) @@ -1284,11 +1411,11 @@ The menu is in a format applicable to `easy-menu-define'." (let ((item (vector name `(custom-buffer-create '((,symbol custom-group))) t))) - (if (> custom-menu-nesting 0) + (if (and (> custom-menu-nesting 0) + (< (length (get symbol 'custom-group)) widget-menu-max-size)) (let ((custom-menu-nesting (1- custom-menu-nesting)) - (custom-prefix-list (cons (or (get symbol 'custom-prefix) - (concat (symbol-name symbol) "-")) - custom-prefix-list))) + (custom-prefix-list (custom-prefix-add symbol + custom-prefix-list))) (custom-load-symbol symbol) `(,(custom-unlispify-menu-entry symbol t) ,item diff --git a/lisp/custom-opt.el b/lisp/custom-opt.el index c39a55ca2..063f8f83e 100644 --- a/lisp/custom-opt.el +++ b/lisp/custom-opt.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.12 +;; Version: 1.15 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Code: diff --git a/lisp/custom.el b/lisp/custom.el index 7e0c299c8..63fa47b49 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.12 +;; Version: 1.15 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 22102bf82..1cc845ff6 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -25,13 +25,171 @@ ;;; Code: +(require 'custom) (require 'gnus) (require 'gnus-sum) -(require 'article) (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) +(defgroup article nil + "Article display." + :group 'gnus) + +(defcustom gnus-ignored-headers + '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" + "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" + "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" + "^Approved:" "^Sender:" "^Received:" "^Mail-from:") + "All headers that match this regexp will be hidden. +This variable can also be a list of regexps of headers to be ignored. +If `gnus-visible-headers' is non-nil, this variable will be ignored." + :type '(choice :custom-show nil + regexp + (repeat regexp)) + :group 'article) + +(defcustom gnus-visible-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-" + "All headers that do not match this regexp will be hidden. +This variable can also be a list of regexp of headers to remain visible. +If this variable is non-nil, `gnus-ignored-headers' will be ignored." + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp) + :group 'article) + +(defcustom gnus-sorted-header-list + '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:" + "^Cc:" "^Date:" "^Organization:") + "This variable is a list of regular expressions. +If it is non-nil, headers that match the regular expressions will +be placed first in the article buffer in the sequence specified by +this list." + :type '(repeat regexp) + :group 'article) + +(defcustom gnus-boring-article-headers '(empty followup-to reply-to) + "Headers that are only to be displayed if they have interesting data. +Possible values in this list are `empty', `newsgroups', `followup-to', +`reply-to', and `date'." + :type '(set (const :tag "Headers with no content." empty) + (const :tag "Newsgroups with only one group." newsgroups) + (const :tag "Followup-to identical to newsgroups." followup-to) + (const :tag "Reply-to identical to from." reply-to) + (const :tag "Date less than four days old." date)) + :group 'article) + +(defcustom gnus-signature-separator '("^-- $" "^-- *$") + "Regexp matching signature separator. +This can also be a list of regexps. In that case, it will be checked +from head to tail looking for a separator. Searches will be done from +the end of the buffer." + :type '(repeat string) + :group 'article) + +(defcustom gnus-signature-limit nil + "Provide a limit to what is considered a signature. +If it is a number, no signature may not be longer (in characters) than +that number. If it is a floating point number, no signature may be +longer (in lines) than that number. If it is a function, the function +will be called without any parameters, and if it returns nil, there is +no signature in the buffer. If it is a string, it will be used as a +regexp. If it matches, the text in question is not a signature." + :type '(choice integer number function regexp) + :group 'article) + +(defcustom gnus-hidden-properties '(invisible t intangible t) + "Property list to use for hiding text." + :type 'sexp + :group 'article) + +(defcustom 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." + :type 'string ;Leave function case to Lisp. + :group 'article) + +(defcustom gnus-article-x-face-too-ugly nil + "Regexp matching posters whose face shouldn't be shown automatically." + :type 'regexp + :group 'article) + +(defcustom gnus-emphasis-alist + (let ((format + "\\(\\s-\\|^\\|[-\"\(]\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*\\)%s\\)\\(\\s-\\|[-?!.,;:\"\)]\\)") + (types + '(("_" "_" underline) + ("/" "/" italic) + ("\\*" "\\*" bold) + ("_/" "/_" underline-italic) + ("_\\*" "\\*_" underline-bold) + ("\\*/" "/\\*" bold-italic) + ("_\\*/" "/\\*_" underline-bold-italic)))) + `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-underline) + ,@(mapcar + (lambda (spec) + (list + (format format (car spec) (cadr spec)) + 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) + types))) + "Alist that says how to fontify certain phrases. +Each item looks like this: + + (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) + +The first element is a regular expression to be matched. The second +is a number that says what regular expression grouping used to find +the entire emphasized word. The third is a number that says what +regexp grouping should be displayed and highlighted. The fourth +is the face used for highlighting." + :type '(repeat (list :value ("" 0 0 default) + regexp + (integer :tag "Match group") + (integer :tag "Emphasize group") + face)) + :group 'article) + +(defface gnus-emphasis-bold '((t (:bold t))) + "Face used for displaying strong emphasized text (*word*)." + :group 'article) + +(defface gnus-emphasis-italic '((t (:italic t))) + "Face used for displaying italic emphasized text (/word/)." + :group 'article) + +(defface gnus-emphasis-underline '((t (:underline t))) + "Face used for displaying underlined emphasized text (_word_)." + :group 'article) + +(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) + "Face used for displaying underlined bold emphasized text (_*word*_)." + :group 'article) + +(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) + "Face used for displaying underlined italic emphasized text (_*word*_)." + :group 'article) + +(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) + "Face used for displaying bold italic emphasized text (/*word*/)." + :group 'article) + +(defface gnus-emphasis-underline-bold-italic + '((t (:bold t :italic t :underline t))) + "Face used for displaying underlined bold italic emphasized text (_/*word*/_)." + :group 'article) + +(eval-and-compile + (autoload 'hexl-hex-string-to-integer "hexl") + (autoload 'timezone-make-date-arpa-standard "timezone") + (autoload 'mail-extract-address-components "mail-extr")) + (defcustom gnus-article-save-directory gnus-directory "*Name of the directory articles will be saved in (default \"~/News\")." :group 'article @@ -303,48 +461,775 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-number-of-articles-to-be-saved nil) -;;; Provide a mapping from `gnus-*' commands to Article commands. +(defvar gnus-inhibit-hiding nil) +(defvar gnus-newsgroup-name) + +(defsubst gnus-article-hide-text (b e props) + "Set text PROPS on the B to E region, extending `intangible' 1 past B." + (add-text-properties b e props) + (when (memq 'intangible props) + (put-text-property + (max (1- b) (point-min)) + b 'intangible (cddr (memq 'intangible props))))) + +(defsubst gnus-article-unhide-text (b e) + "Remove hidden text properties from region between B and E." + (remove-text-properties b e gnus-hidden-properties) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-type (b e type) + "Hide text of TYPE between B and E." + (gnus-article-hide-text + b e (cons 'article-type (cons type gnus-hidden-properties)))) + +(defun gnus-article-unhide-text-type (b e type) + "Hide text of TYPE between B and E." + (remove-text-properties + b e (cons 'article-type (cons type gnus-hidden-properties))) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-of-type (type) + "Hide text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min)) + (e (point-max))) + (while (setq b (text-property-any b e 'article-type type)) + (add-text-properties b (incf b) gnus-hidden-properties))))) -(eval-and-compile - (mapcar - (lambda (func) - (let (afunc gfunc) - (if (consp func) - (setq afunc (car func) - gfunc (cdr func)) - (setq afunc func - gfunc (intern (format "gnus-%s" func)))) - (fset gfunc - `(lambda (&optional interactive &rest args) - ,(documentation afunc t) - (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) - (if interactive - (call-interactively ',afunc) - (apply ',afunc args))))))) - '(article-hide-headers - article-hide-boring-headers - article-treat-overstrike - (article-fill . gnus-article-word-wrap) - article-remove-cr - article-display-x-face - article-de-quoted-unreadable - article-mime-decode-quoted-printable - article-hide-pgp - article-hide-pem - article-hide-signature - article-remove-trailing-blank-lines - article-strip-leading-blank-lines - article-strip-multiple-blank-lines - article-strip-blank-lines - article-date-local - article-date-original - article-date-lapsed - article-emphasize - (article-show-all . gnus-article-show-all-headers)))) - -(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) +(defun gnus-article-delete-text-of-type (type) + "Delete text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'article-type type)) + (delete-region b (incf b)))))) + +(defun gnus-article-delete-invisible-text () + "Delete all invisible text in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'invisible t)) + (delete-region b (incf b)))))) + +(defun gnus-article-text-type-exists-p (type) + "Say whether any text of type TYPE exists in the buffer." + (text-property-any (point-min) (point-max) 'article-type type)) + +(defsubst gnus-article-header-rank () + "Give the rank of the string HEADER as given by `article-sorted-header-list'." + (let ((list gnus-sorted-header-list) + (i 0)) + (while list + (when (looking-at (car list)) + (setq list nil)) + (setq list (cdr list)) + (incf i)) + i)) + +(defun gnus-article-hide-headers (&optional arg delete) + "Toggle whether to hide unwanted headers and possibly sort them as well. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (if (gnus-article-check-hidden-text 'headers arg) + ;; Show boring headers as well. + (gnus-article-show-hidden-text 'boring-headers) + ;; This function might be inhibited. + (unless gnus-inhibit-hiding + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (props (nconc (list 'article-type 'headers) + gnus-hidden-properties)) + (max (1+ (length gnus-sorted-header-list))) + (ignored (when (not gnus-visible-headers) + (cond ((stringp gnus-ignored-headers) + gnus-ignored-headers) + ((listp gnus-ignored-headers) + (mapconcat 'identity gnus-ignored-headers + "\\|"))))) + (visible + (cond ((stringp gnus-visible-headers) + gnus-visible-headers) + ((and gnus-visible-headers + (listp gnus-visible-headers)) + (mapconcat 'identity gnus-visible-headers "\\|")))) + (inhibit-point-motion-hooks t) + want-list beg) + ;; First we narrow to just the headers. + (widen) + (goto-char (point-min)) + ;; Hide any "From " lines at the beginning of (mail) articles. + (while (looking-at "From ") + (forward-line 1)) + (unless (bobp) + (if delete + (delete-region (point-min) (point)) + (gnus-article-hide-text (point-min) (point) props))) + ;; Then treat the rest of the header lines. + (narrow-to-region + (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 + ;; article buffer. + (goto-char (point-min)) + (while (re-search-forward "^[^ \t]*:" nil t) + (beginning-of-line) + ;; Mark the rank of the header. + (put-text-property + (point) (1+ (point)) 'message-rank + (if (or (and visible (looking-at visible)) + (and ignored + (not (looking-at ignored)))) + (gnus-article-header-rank) + (+ 2 max))) + (forward-line 1)) + (message-sort-headers-1) + (when (setq beg (text-property-any + (point-min) (point-max) 'message-rank (+ 2 max))) + ;; We make the unwanted headers invisible. + (if delete + (delete-region beg (point-max)) + ;; Suggested by Sudish Joseph . + (gnus-article-hide-text-type beg (point-max) 'headers)) + ;; Work around XEmacs lossage. + (put-text-property (point-min) beg 'invisible nil)))))))) + +(defun gnus-article-hide-boring-headers (&optional arg) + "Toggle hiding of headers that aren't very interesting. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) + (not gnus-show-all-headers)) + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (list gnus-boring-article-headers) + (inhibit-point-motion-hooks t) + elem) + (nnheader-narrow-to-headers) + (while list + (setq elem (pop list)) + (goto-char (point-min)) + (cond + ;; Hide empty headers. + ((eq elem 'empty) + (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) + (forward-line -1) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers))) + ;; Hide boring Newsgroups header. + ((eq elem 'newsgroups) + (when (equal (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) + (gnus-article-hide-header "newsgroups"))) + ((eq elem 'followup-to) + (when (equal (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) + (gnus-article-hide-header "followup-to"))) + ((eq elem 'reply-to) + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when (and + from reply-to + (equal + (nth 1 (mail-extract-address-components from)) + (nth 1 (mail-extract-address-components reply-to)))) + (gnus-article-hide-header "reply-to")))) + ((eq elem 'date) + (let ((date (message-fetch-field "date"))) + (when (and date + (< (gnus-days-between (current-time-string) date) + 4)) + (gnus-article-hide-header "date"))))))))))) + +(defun gnus-article-hide-header (header) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^" header ":") nil t) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers)))) + +;; Written by Per Abrahamsen . +(defun gnus-article-treat-overstrike () + "Translate overstrikes into bold text." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (while (search-forward "\b" nil t) + (let ((next (following-char)) + (previous (char-after (- (point) 2)))) + ;; We do the boldification/underlining by hiding the + ;; overstrikes and putting the proper text property + ;; on the letters. + (cond + ((eq next previous) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property (point) (1+ (point)) 'face 'bold)) + ((eq next ?_) + (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike) + (put-text-property + (- (point) 2) (1- (point)) 'face 'underline)) + ((eq previous ?_) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property + (point) (1+ (point)) 'face 'underline)))))))) + +(defun gnus-article-fill () + "Format too long lines." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (end-of-line 1) + (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") + (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") + (adaptive-fill-mode t)) + (while (not (eobp)) + (and (>= (current-column) (min fill-column (window-width))) + (/= (preceding-char) ?:) + (fill-paragraph nil)) + (end-of-line 2)))))) + +(defun gnus-article-remove-cr () + "Remove carriage returns from an article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (replace-match "" t t))))) + +(defun gnus-article-remove-trailing-blank-lines () + "Remove all trailing blank lines from the article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (delete-region + (point) + (progn + (while (and (not (bobp)) + (looking-at "^[ \t]*$")) + (forward-line -1)) + (forward-line 1) + (point)))))) + +(defun gnus-article-display-x-face (&optional force) + "Look for an X-Face header and display it if present." + (interactive (list 'force)) + (save-excursion + ;; Delete the old process, if any. + (when (process-status "article-x-face") + (delete-process "article-x-face")) + (let ((inhibit-point-motion-hooks t) + (case-fold-search nil) + from) + (save-restriction + (nnheader-narrow-to-headers) + (setq from (message-fetch-field "from")) + (goto-char (point-min)) + (when (and gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and gnus-article-x-face-too-ugly from + (not (string-match gnus-article-x-face-too-ugly + from)))) + ;; Has to be present. + (re-search-forward "^X-Face: " nil t)) + ;; We now have the area of the buffer where the X-Face is stored. + (let ((beg (point)) + (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) + ;; We display the face. + (if (symbolp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (if (gnus-functionp gnus-article-x-face-command) + (funcall gnus-article-x-face-command beg end) + (error "%s is not a function" gnus-article-x-face-command)) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name shell-command-switch + gnus-article-x-face-command)) + (process-send-region "article-x-face" beg end) + (process-send-eof "article-x-face"))))))))) + +(defalias 'gnus-decode-rfc1522 'gnus-article-decode-rfc1522) +(defun gnus-article-decode-rfc1522 () + "Hack to remove QP encoding from headers." + (let ((case-fold-search t) + (inhibit-point-motion-hooks t) + (buffer-read-only nil) + string) + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point-max))) + (goto-char (point-min)) + (while (re-search-forward + "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) + (setq string (match-string 1)) + (save-restriction + (narrow-to-region (match-beginning 0) (match-end 0)) + (delete-region (point-min) (point-max)) + (insert string) + (gnus-article-mime-decode-quoted-printable + (goto-char (point-min)) (point-max)) + (subst-char-in-region (point-min) (point-max) ?_ ? ) + (goto-char (point-max))) + (goto-char (point-min)))))) + +(defun gnus-article-de-quoted-unreadable (&optional force) + "Do a naive translation of a quoted-printable-encoded article. +This is in no way, shape or form meant as a replacement for real MIME +processing, but is simply a stop-gap measure until MIME support is +written. +If FORCE, decode the article whether it is marked as quoted-printable +or not." + (interactive (list 'force)) + (save-excursion + (let ((case-fold-search t) + (buffer-read-only nil) + (type (gnus-fetch-field "content-transfer-encoding"))) + (gnus-article-decode-rfc1522) + (when (or force + (and type (string-match "quoted-printable" (downcase type)))) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (gnus-article-mime-decode-quoted-printable (point) (point-max)))))) + +(defun gnus-article-mime-decode-quoted-printable-buffer () + "Decode Quoted-Printable in the current buffer." + (gnus-article-mime-decode-quoted-printable (point-min) (point-max))) + +(defun gnus-article-mime-decode-quoted-printable (from to) + "Decode Quoted-Printable in the region between FROM and TO." + (interactive "r") + (goto-char from) + (while (search-forward "=" to t) + (cond ((eq (following-char) ?\n) + (delete-char -1) + (delete-char 1)) + ((looking-at "[0-9A-F][0-9A-F]") + (subst-char-in-region + (1- (point)) (point) ?= + (hexl-hex-string-to-integer + (buffer-substring (point) (+ 2 (point))))) + (delete-char 2)) + ((looking-at "=") + (delete-char 1)) + ((gnus-message 3 "Malformed MIME quoted-printable message"))))) + +(defun gnus-article-hide-pgp (&optional arg) + "Toggle hiding of any PGP headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'pgp arg) + (save-excursion + (let (buffer-read-only beg end) + (widen) + (goto-char (point-min)) + ;; Hide the "header". + (and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) + (gnus-article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) + (setq beg (point)) + ;; Hide the actual signature. + (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) + (match-end 0) + ;; Perhaps we shouldn't hide to the end of the buffer + ;; if there is no end to the signature? + (point-max)) + 'pgp)) + ;; Hide "- " PGP quotation markers. + (when (and beg end) + (narrow-to-region beg end) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (gnus-article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) + (widen)))))) + +(defun gnus-article-hide-pem (&optional arg) + "Toggle hiding of any PEM headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'pem arg) + (save-excursion + (let (buffer-read-only end) + (widen) + (goto-char (point-min)) + ;; hide the horrendously ugly "header". + (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" + nil + t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-max)) + 'pem)) + ;; hide the trailer as well + (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" + nil + t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pem)))))) + +(defun gnus-article-hide-signature (&optional arg) + "Hide the signature in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'signature arg) + (save-excursion + (save-restriction + (let ((buffer-read-only nil)) + (when (gnus-article-narrow-to-signature) + (gnus-article-hide-text-type (point-min) (point-max) 'signature))))))) + +(defun gnus-article-strip-leading-blank-lines () + "Remove all blank lines from the beginning of the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (while (and (not (eobp)) + (looking-at "[ \t]*$")) + (gnus-delete-line)))))) + +(defun gnus-article-strip-multiple-blank-lines () + "Replace consecutive blank lines with one empty line." + (interactive) + (save-excursion + (let (buffer-read-only) + ;; First make all blank lines empty. + (goto-char (point-min)) + (while (re-search-forward "^[ \t]+$" nil t) + (replace-match "" nil t)) + ;; Then replace multiple empty lines with a single empty line. + (goto-char (point-min)) + (while (re-search-forward "\n\n\n+" nil t) + (replace-match "\n\n" t t))))) + +(defun gnus-article-strip-blank-lines () + "Strip leading, trailing and multiple blank lines." + (interactive) + (gnus-article-strip-leading-blank-lines) + (gnus-article-remove-trailing-blank-lines) + (gnus-article-strip-multiple-blank-lines)) + +(defvar mime::preview/content-list) +(defvar mime::preview-content-info/point-min) +(defun gnus-article-narrow-to-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) + ;; We have a MIMEish article, so we use the MIME data to narrow. + (let ((pcinfo (car (last mime::preview/content-list)))) + (ignore-errors + (narrow-to-region + (funcall (intern "mime::preview-content-info/point-min") pcinfo) + (point-max))))) + + (when (gnus-article-search-signature) + (forward-line 1) + ;; Check whether we have some limits to what we consider + ;; to be a signature. + (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit + (list gnus-signature-limit))) + limit limited) + (while (setq limit (pop limits)) + (if (or (and (integerp limit) + (< (- (point-max) (point)) limit)) + (and (floatp limit) + (< (count-lines (point) (point-max)) limit)) + (and (gnus-functionp limit) + (funcall limit)) + (and (stringp limit) + (not (re-search-forward limit nil t)))) + () ; This limit did not succeed. + (setq limited t + limits nil))) + (unless limited + (narrow-to-region (point) (point-max)) + t)))) + +(defun gnus-article-search-signature () + "Search the current buffer for the signature separator. +Put point at the beginning of the signature separator." + (let ((cur (point))) + (goto-char (point-max)) + (if (if (stringp gnus-signature-separator) + (re-search-backward gnus-signature-separator nil t) + (let ((seps gnus-signature-separator)) + (while (and seps + (not (re-search-backward (car seps) nil t))) + (pop seps)) + seps)) + t + (goto-char cur) + nil))) + +(defun gnus-article-hidden-arg () + "Return the current prefix arg as a number, or 0 if no prefix." + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 0))) + +(defun gnus-article-check-hidden-text (type arg) + "Return nil if hiding is necessary. +Arg can be nil or a number. Nil and positive means hide, negative +means show, 0 means toggle." + (save-excursion + (let ((hide (gnus-article-hidden-text-p type))) + (cond + ((or (null arg) + (> arg 0)) + nil) + ((< arg 0) + (gnus-article-show-hidden-text type)) + (t + (if (eq hide 'hidden) + (gnus-article-show-hidden-text type) + nil)))))) + +(defun gnus-article-hidden-text-p (type) + "Say whether the current buffer contains hidden text of type TYPE." + (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) + (when pos + (if (get-text-property pos 'invisible) + 'hidden + 'shown)))) + +(defun gnus-article-show-hidden-text (type &optional hide) + "Show all hidden text of type TYPE. +If HIDE, hide the text instead." + (save-excursion + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (beg (point-min))) + (while (gnus-goto-char (text-property-any + beg (point-max) 'article-type type)) + (setq beg (point)) + (forward-char) + (if hide + (gnus-article-hide-text beg (point) gnus-hidden-properties) + (gnus-article-unhide-text beg (point))) + (setq beg (point))) + t))) + +(defconst article-time-units + `((year . ,(* 365.25 24 60 60)) + (week . ,(* 7 24 60 60)) + (day . ,(* 24 60 60)) + (hour . ,(* 60 60)) + (minute . 60) + (second . 1)) + "Mapping from time units to seconds.") + +(defun gnus-article-date-ut (&optional type highlight header) + "Convert DATE date to universal time in the current article. +If TYPE is `local', convert to local time; if it is `lapsed', output +how much time has lapsed since DATE." + (interactive (list 'ut t)) + (let* ((header (or header + (mail-header-date gnus-current-headers) + (message-fetch-field "date") + "")) + (date (if (vectorp header) (mail-header-date header) + header)) + (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") + (inhibit-point-motion-hooks t) + bface eface) + (when (and date (not (string= date ""))) + (save-excursion + (save-restriction + (nnheader-narrow-to-headers) + (let ((buffer-read-only nil)) + ;; Delete any old Date headers. + (if (re-search-forward date-regexp nil t) + (progn + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) + 'face)) + (message-remove-header date-regexp t) + (beginning-of-line)) + (goto-char (point-max))) + (insert (gnus-article-make-date-line date type)) + ;; Do highlighting. + (forward-line -1) + (when (looking-at "\\([^:]+\\): *\\(.*\\)$") + (put-text-property (match-beginning 1) (match-end 1) + 'face bface) + (put-text-property (match-beginning 2) (match-end 2) + 'face eface)))))))) + +(defun gnus-article-make-date-line (date type) + "Return a DATE line of TYPE." + (cond + ;; Convert to the local timezone. We have to slap a + ;; `condition-case' round the calls to the timezone + ;; functions since they aren't particularly resistant to + ;; buggy dates. + ((eq type 'local) + (concat "Date: " (condition-case () + (timezone-make-date-arpa-standard date) + (error date)) + "\n")) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (condition-case () + (timezone-make-date-arpa-standard date nil "UT") + (error date)) + "\n")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " date "\n")) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time + (ignore-errors + (gnus-time-minus + (gnus-encode-date + (timezone-make-date-arpa-standard + (current-time-string now) + (current-time-zone now) "UT")) + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown\n") + ((zerop sec) + "X-Sent: Now\n") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago\n" + " in the future\n")))))) + (t + (error "Unknown conversion type: %s" type)))) + +(defun gnus-article-date-local (&optional highlight) + "Convert the current article date to the local timezone." + (interactive (list t)) + (gnus-article-date-ut 'local highlight)) + +(defun gnus-article-date-original (&optional highlight) + "Convert the current article date to what it was originally. +This is only useful if you have used some other date conversion +function and want to see what the date was before converting." + (interactive (list t)) + (gnus-article-date-ut 'original highlight)) + +(defun gnus-article-date-lapsed (&optional highlight) + "Convert the current article date to time lapsed since it was sent." + (interactive (list t)) + (gnus-article-date-ut 'lapsed highlight)) + +(defun gnus-article-show-all () + "Show all hidden text in the article buffer." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (gnus-article-unhide-text (point-min) (point-max))))) + +(defun gnus-article-emphasize (&optional arg) + "Emphasize text according to `gnus-emphasis-alist'." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'emphasis arg) + (save-excursion + (let ((alist gnus-emphasis-alist) + (buffer-read-only nil) + (props (append '(gnus-article-type emphasis) + gnus-hidden-properties)) + regexp elem beg invisible visible face) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq beg (point)) + (while (setq elem (pop alist)) + (goto-char beg) + (setq regexp (car elem) + invisible (nth 1 elem) + visible (nth 2 elem) + face (nth 3 elem)) + (while (re-search-forward regexp nil t) + (when (and (match-beginning visible) (match-beginning invisible)) + (gnus-article-hide-text + (match-beginning invisible) (match-end invisible) props) + (gnus-article-unhide-text-type + (match-beginning visible) (match-end visible) 'emphasis) + (gnus-put-text-property-excluding-newlines + (match-beginning visible) (match-end visible) 'face face) + (goto-char (match-end invisible))))))))) (defvar gnus-summary-article-menu) (defvar gnus-summary-post-menu) @@ -417,10 +1302,12 @@ Initialized from `text-mode-syntax-table.") (let (result) (let ((file-name-history (nconc split-name file-name-history))) (setq result - (read-file-name - (concat prompt " (`M-p' for defaults) ") - gnus-article-save-directory - (car split-name)))) + (expand-file-name + (read-file-name + (concat prompt " (`M-p' for defaults) ") + gnus-article-save-directory + (car split-name)) + gnus-article-save-directory))) (car (push result file-name-history))))))) ;; Create the directory. (gnus-make-directory (file-name-directory file)) @@ -799,7 +1686,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-find-method-for-group gnus-newsgroup-name)) (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) (gnus-request-group gnus-newsgroup-name t)) - (let* ((article (if header (mail-header-number header) article)) + (let* ((gnus-article (if header (mail-header-number header) article)) (summary-buffer (current-buffer)) (internal-hook gnus-article-internal-prepare-hook) (group gnus-newsgroup-name) @@ -907,14 +1794,14 @@ If ALL-HEADERS is non-nil, no headers are hidden." "Return a string which display status of article washing." (save-excursion (set-buffer gnus-article-buffer) - (let ((cite (article-hidden-text-p 'cite)) - (headers (article-hidden-text-p 'headers)) - (boring (article-hidden-text-p 'boring-headers)) - (pgp (article-hidden-text-p 'pgp)) - (pem (article-hidden-text-p 'pem)) - (signature (article-hidden-text-p 'signature)) - (overstrike (article-hidden-text-p 'overstrike)) - (emphasis (article-hidden-text-p 'emphasis)) + (let ((cite (gnus-article-hidden-text-p 'cite)) + (headers (gnus-article-hidden-text-p 'headers)) + (boring (gnus-article-hidden-text-p 'boring-headers)) + (pgp (gnus-article-hidden-text-p 'pgp)) + (pem (gnus-article-hidden-text-p 'pem)) + (signature (gnus-article-hidden-text-p 'signature)) + (overstrike (gnus-article-hidden-text-p 'overstrike)) + (emphasis (gnus-article-hidden-text-p 'emphasis)) (mime gnus-show-mime)) (format "%c%c%c%c%c%c%c" (if cite ?c ? ) @@ -1356,16 +2243,6 @@ If given a prefix, show the hidden text instead." (point)) (set-buffer buf)))))) -(defun gnus-article-date-ut (&optional type highlight) - "Convert DATE date to universal time in the current article. -If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE." - (interactive (list 'ut t)) - (let ((headers (or gnus-current-headers (gnus-summary-article-header)))) - (save-excursion - (set-buffer gnus-article-buffer) - (article-date-ut type highlight headers)))) - ;;; ;;; Article editing ;;; @@ -1704,11 +2581,11 @@ It does this by highlighting everything after (inhibit-point-motion-hooks t)) (save-restriction (when (and gnus-signature-face - (article-narrow-to-signature)) + (gnus-article-narrow-to-signature)) (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) 'face gnus-signature-face) (widen) - (article-search-signature) + (gnus-article-search-signature) (let ((start (match-beginning 0)) (end (set-marker (make-marker) (1+ (match-end 0))))) (gnus-article-add-button start (1- end) 'gnus-signature-toggle @@ -1812,8 +2689,8 @@ specified by `gnus-button-alist'." (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) (if (get-text-property end 'invisible) - (article-unhide-text end (point-max)) - (article-hide-text end (point-max) gnus-hidden-properties))))) + (gnus-article-unhide-text end (point-max)) + (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) (defun gnus-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. diff --git a/lisp/gnus-async.el b/lisp/gnus-async.el index 27f657c81..c0a7b6ab9 100644 --- a/lisp/gnus-async.el +++ b/lisp/gnus-async.el @@ -257,8 +257,15 @@ It should return non-nil if the article is to be prefetched." (defun gnus-async-prefetched-article-entry (group article) "Return the entry for ARTICLE in GROUP iff it has been prefetched." - (assq (intern (format "%s-%d" group article)) - gnus-async-article-alist)) + (let ((entry (assq (intern (format "%s-%d" group article)) + gnus-async-article-alist))) + ;; Perhaps something has emptied the buffer? + (if (and entry + (= (cadr entry) (caddr entry))) + (progn + (gnus-async-delete-prefected-entry entry) + nil) + entry))) ;;; ;;; Header prefetch diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el index 00136f10a..f126d4845 100644 --- a/lisp/gnus-cache.el +++ b/lisp/gnus-cache.el @@ -28,8 +28,9 @@ (require 'gnus) (require 'gnus-int) (require 'gnus-range) -(require 'gnus-sum) (require 'gnus-start) +(eval-when-compile + (require 'gnus-sum)) (defgroup gnus-cache nil "Cache interface." diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el index 1da62e926..53b6e9a93 100644 --- a/lisp/gnus-cite.el +++ b/lisp/gnus-cite.el @@ -361,7 +361,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (search-forward "\n\n" nil t) (push (cons (point-marker) "") marks) (goto-char (point-max)) - (article-search-signature) + (gnus-article-search-signature) (push (cons (point-marker) "") marks) (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) (let* ((omarks marks)) @@ -421,18 +421,18 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps See the documentation for `gnus-article-highlight-citation'. If given a negative prefix, always show; if given a positive prefix, always hide." - (interactive (append (article-hidden-arg) (list 'force))) + (interactive (append (gnus-article-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)) (save-excursion (set-buffer gnus-article-buffer) (cond - ((article-check-hidden-text 'cite arg) + ((gnus-article-check-hidden-text 'cite arg) t) - ((article-text-type-exists-p 'cite) + ((gnus-article-text-type-exists-p 'cite) (let ((buffer-read-only nil)) - (article-hide-text-of-type 'cite))) + (gnus-article-hide-text-of-type 'cite))) (t (let ((buffer-read-only nil) (marks (gnus-dissect-cited-text)) @@ -493,8 +493,8 @@ 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 (append (article-hidden-arg) (list 'force))) - (unless (article-check-hidden-text 'cite arg) + (interactive (append (gnus-article-hidden-arg) (list 'force))) + (unless (gnus-article-check-hidden-text 'cite arg) (save-excursion (set-buffer gnus-article-buffer) (gnus-cite-parse-maybe force) @@ -507,7 +507,7 @@ See also the documentation for `gnus-article-highlight-citation'." (hiden 0) total) (goto-char (point-max)) - (article-search-signature) + (gnus-article-search-signature) (setq total (count-lines start (point))) (while atts (setq hiden (+ hiden (length (cdr (assoc (cdar atts) @@ -572,7 +572,7 @@ See also the documentation for `gnus-article-highlight-citation'." (case-fold-search t) (max (save-excursion (goto-char (point-max)) - (article-search-signature) + (gnus-article-search-signature) (point))) alist entry start begin end numbers prefix) ;; Get all potential prefixes in `alist'. diff --git a/lisp/gnus-demon.el b/lisp/gnus-demon.el index 4ef6db935..d5e0c11e8 100644 --- a/lisp/gnus-demon.el +++ b/lisp/gnus-demon.el @@ -73,7 +73,6 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (defvar gnus-demon-idle-has-been-called nil) (defvar gnus-demon-idle-time 0) (defvar gnus-demon-handler-state nil) -(defvar gnus-demon-is-idle nil) (defvar gnus-demon-last-keys nil) (eval-and-compile @@ -188,7 +187,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (or (not (setq idle (nth 2 handler))) ; Don't care about idle. (and (numberp idle) ; Numerical idle... (< idle gnus-demon-idle-time)) ; Idle timed out. - gnus-demon-is-idle) ; Or just need to be idle. + gnus-demon-idle-time) ; Or just need to be idle. ;; So we call the handler. (progn (funcall (car handler)) diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 1a7188265..9f9372803 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -277,182 +277,6 @@ variable." (string :tag "Name") (sexp :tag "Method")))) -(defface gnus-group-news-1-face - '((((class color) - (background dark)) - (:foreground "PaleTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "ForestGreen" :bold t)) - (t - ())) - "Level 1 newsgroup face.") - -(defface gnus-group-news-1-empty-face - '((((class color) - (background dark)) - (:foreground "PaleTurquoise")) - (((class color) - (background light)) - (:foreground "ForestGreen")) - (t - ())) - "Level 1 empty newsgroup face.") - -(defface gnus-group-news-2-face - '((((class color) - (background dark)) - (:foreground "turquoise" :bold t)) - (((class color) - (background light)) - (:foreground "CadetBlue4" :bold t)) - (t - ())) - "Level 2 newsgroup face.") - -(defface gnus-group-news-2-empty-face - '((((class color) - (background dark)) - (:foreground "turquoise")) - (((class color) - (background light)) - (:foreground "CadetBlue4")) - (t - ())) - "Level 2 empty newsgroup face.") - -(defface gnus-group-news-3-face - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 3 newsgroup face.") - -(defface gnus-group-news-3-empty-face - '((((class color) - (background dark)) - ()) - (((class color) - (background light)) - ()) - (t - ())) - "Level 3 empty newsgroup face.") - -(defface gnus-group-news-low-face - '((((class color) - (background dark)) - (:foreground "DarkTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" :bold t)) - (t - ())) - "Low level newsgroup face.") - -(defface gnus-group-news-low-empty-face - '((((class color) - (background dark)) - (:foreground "DarkTurquoise")) - (((class color) - (background light)) - (:foreground "DarkGreen")) - (t - ())) - "Low level empty newsgroup face.") - -(defface gnus-group-mail-1-face - '((((class color) - (background dark)) - (:foreground "aquamarine1" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink3" :bold t)) - (t - (:bold t))) - "Level 1 mailgroup face.") - -(defface gnus-group-mail-1-empty-face - '((((class color) - (background dark)) - (:foreground "aquamarine1")) - (((class color) - (background light)) - (:foreground "DeepPink3")) - (t - (:italic t :bold t))) - "Level 1 empty mailgroup face.") - -(defface gnus-group-mail-2-face - '((((class color) - (background dark)) - (:foreground "aquamarine2" :bold t)) - (((class color) - (background light)) - (:foreground "HotPink3" :bold t)) - (t - (:bold t))) - "Level 2 mailgroup face.") - -(defface gnus-group-mail-2-empty-face - '((((class color) - (background dark)) - (:foreground "aquamarine2")) - (((class color) - (background light)) - (:foreground "HotPink3")) - (t - (:bold t))) - "Level 2 empty mailgroup face.") - -(defface gnus-group-mail-3-face - '((((class color) - (background dark)) - (:foreground "aquamarine3" :bold t)) - (((class color) - (background light)) - (:foreground "magenta4" :bold t)) - (t - (:bold t))) - "Level 3 mailgroup face.") - -(defface gnus-group-mail-3-empty-face - '((((class color) - (background dark)) - (:foreground "aquamarine3")) - (((class color) - (background light)) - (:foreground "magenta4")) - (t - ())) - "Level 3 empty mailgroup face.") - -(defface gnus-group-mail-low-face - '((((class color) - (background dark)) - (:foreground "aquamarine4" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink4" :bold t)) - (t - (:bold t))) - "Low level mailgroup face.") - -(defface gnus-group-mail-low-empty-face - '((((class color) - (background dark)) - (:foreground "aquamarine4")) - (((class color) - (background light)) - (:foreground "DeepPink4")) - (t - (:bold t))) - "Low level empty mailgroup face.") - (defcustom gnus-group-highlight '(;; News. ((and (= unread 0) (not mailp) (eq level 1)) . @@ -2535,15 +2359,20 @@ caught up is returned." (interactive "P") (unless (gnus-group-group-name) (error "No group on the current line")) - (if (not (or (not gnus-interactive-catchup) ;Without confirmation? - gnus-expert-user - (gnus-y-or-n-p - (if all - "Do you really want to mark all articles as read? " - "Mark all unread articles as read? ")))) - n - (let ((groups (gnus-group-process-prefix n)) - (ret 0)) + (let ((groups (gnus-group-process-prefix n)) + (ret 0)) + (if (not + (or (not gnus-interactive-catchup) ;Without confirmation? + gnus-expert-user + (gnus-y-or-n-p + (format + (if all + "Do you really want to mark all articles in %s as read? " + "Mark all unread articles in %s as read? ") + (if (= (length groups) 1) + (car groups) + (format "these %d groups" (length groups))))))) + n (while groups ;; Virtual groups have to be given special treatment. (let ((method (gnus-find-method-for-group (car groups)))) @@ -3007,7 +2836,7 @@ re-scanning. If ARG is non-nil and not a number, this will force (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) (gnus-get-unread-articles arg))) (run-hooks 'gnus-after-getting-new-news-hook) - (gnus-group-list-groups)) + (gnus-group-list-groups arg)) (defun gnus-group-get-new-news-this-group (&optional n) "Check for newly arrived news in the current group (and the N-1 next groups). diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 04fd0585b..e940dd095 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -317,8 +317,9 @@ header line with the old Message-ID." (push gnus-article-copy gnus-buffer-list)) (let ((article-buffer (or article-buffer gnus-article-buffer)) end beg contents) - (when (and (get-buffer article-buffer) - (buffer-name (get-buffer article-buffer))) + (if (not (and (get-buffer article-buffer) + (buffer-name (get-buffer article-buffer)))) + (error "Can't find any article buffer") (save-excursion (set-buffer article-buffer) (save-restriction @@ -327,7 +328,7 @@ header line with the old Message-ID." (widen) (copy-to-buffer gnus-article-copy (point-min) (point-max)) (set-buffer gnus-article-copy) - (article-delete-text-of-type 'annotation) + (gnus-article-delete-text-of-type 'annotation) (gnus-remove-text-with-property 'gnus-prev) (gnus-remove-text-with-property 'gnus-next) (insert @@ -347,7 +348,7 @@ header line with the old Message-ID." (or (search-forward "\n\n" nil t) (point))) ;; Insert the original article headers. (insert-buffer-substring gnus-original-article-buffer beg end) - (article-decode-rfc1522))) + (gnus-article-decode-rfc1522))) gnus-article-copy))) (defun gnus-post-news (post &optional group header article-buffer yank subject diff --git a/lisp/gnus-nocem.el b/lisp/gnus-nocem.el index 4e80e2f43..15044a837 100644 --- a/lisp/gnus-nocem.el +++ b/lisp/gnus-nocem.el @@ -188,7 +188,6 @@ matches an previously scanned and verified nocem message." (push (mail-header-message-id header) ; But don't come back for gnus-nocem-seen-message-ids)))))) ; second helpings. - (defun gnus-nocem-verify-issuer (person) "Verify using PGP that the canceler is who she says she is." (if (fboundp gnus-nocem-verifyer) diff --git a/lisp/gnus-salt.el b/lisp/gnus-salt.el index 89a867044..3108a758a 100644 --- a/lisp/gnus-salt.el +++ b/lisp/gnus-salt.el @@ -75,6 +75,7 @@ It accepts the same format specs that `gnus-summary-line-format' does.") "." gnus-pick-article gnus-down-mouse-2 gnus-pick-mouse-pick-region ;;gnus-mouse-2 gnus-pick-mouse-pick + "X" gnus-pick-start-reading "\r" gnus-pick-start-reading)) (defun gnus-pick-make-menu-bar () @@ -144,9 +145,12 @@ If given a prefix, mark all unpicked articles as read." (gnus-configure-windows (if gnus-pick-display-summary 'article 'pick) t)) (if gnus-pick-elegant-flow - (if (gnus-group-quit-config gnus-newsgroup-name) - (gnus-summary-exit) - (gnus-summary-next-group)) + (progn + (when (or catch-up gnus-mark-unpicked-articles-as-read) + (gnus-summary-limit-mark-excluded-as-read)) + (if (gnus-group-quit-config gnus-newsgroup-name) + (gnus-summary-exit) + (gnus-summary-next-group))) (error "No articles have been picked")))) (defun gnus-pick-article (&optional arg) @@ -705,7 +709,8 @@ Two predefined functions are available: (setq beg (point)) ;; Draw "-" lines leftwards. (while (progn - (forward-char -2) + (unless (bolp) + (forward-char -2)) (= (following-char) ? )) (delete-char 1) (insert (car gnus-tree-parent-child-edges))) diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index 0f45e5099..3819eaf91 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -715,6 +715,7 @@ prompt the user for the name of an NNTP server to use." (buffer-name gnus-dribble-buffer)) (let ((obuf (current-buffer))) (set-buffer gnus-dribble-buffer) + (goto-char (point-max)) (insert string "\n") (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 9f21ed5da..8778d5d94 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -736,138 +736,11 @@ automatically when it is selected." :group 'gnus-group-select :type 'hook) -(defface gnus-summary-selected-face '((t - (:underline t))) - "Face used for selected articles.") - (defcustom gnus-summary-selected-face 'gnus-summary-selected-face "Face used for highlighting the current article in the summary buffer." :group 'gnus-summary-visual :type 'face) -(defface gnus-summary-cancelled-face - '((((class color)) - (:foreground "yellow" :background "black"))) - "Face used for cancelled articles.") - -(defface gnus-summary-high-ticked-face - '((((class color) - (background dark)) - (:foreground "pink" :bold t)) - (((class color) - (background light)) - (:foreground "firebrick" :bold t)) - (t - (:bold t))) - "Face used for high interest ticked articles.") - -(defface gnus-summary-low-ticked-face - '((((class color) - (background dark)) - (:foreground "pink" :italic t)) - (((class color) - (background light)) - (:foreground "firebrick" :italic t)) - (t - (:italic t))) - "Face used for low interest ticked articles.") - -(defface gnus-summary-normal-ticked-face - '((((class color) - (background dark)) - (:foreground "pink")) - (((class color) - (background light)) - (:foreground "firebrick")) - (t - ())) - "Face used for normal interest ticked articles.") - -(defface gnus-summary-high-ancient-face - '((((class color) - (background dark)) - (:foreground "SkyBlue" :bold t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :bold t)) - (t - (:bold t))) - "Face used for high interest ancient articles.") - -(defface gnus-summary-low-ancient-face - '((((class color) - (background dark)) - (:foreground "SkyBlue" :italic t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :italic t)) - (t - (:italic t))) - "Face used for low interest ancient articles.") - -(defface gnus-summary-normal-ancient-face - '((((class color) - (background dark)) - (:foreground "SkyBlue")) - (((class color) - (background light)) - (:foreground "RoyalBlue")) - (t - ())) - "Face used for normal interest ancient articles.") - -(defface gnus-summary-high-unread-face - '((t - (:bold t))) - "Face used for high interest unread articles.") - -(defface gnus-summary-low-unread-face - '((t - (:italic t))) - "Face used for low interest unread articles.") - -(defface gnus-summary-normal-unread-face - '((t - ())) - "Face used for normal interest unread articles.") - -(defface gnus-summary-high-read-face - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :bold t)) - (t - (:bold t))) - "Face used for high interest read articles.") - -(defface gnus-summary-low-read-face - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :italic t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :italic t)) - (t - (:italic t))) - "Face used for low interest read articles.") - -(defface gnus-summary-normal-read-face - '((((class color) - (background dark)) - (:foreground "PaleGreen")) - (((class color) - (background light)) - (:foreground "DarkGreen")) - (t - ())) - "Face used for normal interest read articles.") - (defcustom gnus-summary-highlight '(((= mark gnus-canceled-mark) . gnus-summary-cancelled-face) @@ -4514,7 +4387,20 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')." (gnus-error 4 "Strange nov line (%d)" (count-lines (point-min) (point))))) (forward-line 1)) - (nreverse headers)))) + ;; A common bug in inn is that if you have posted an article and + ;; then retrieves the active file, it will answer correctly -- + ;; the new article is included. However, a NOV entry for the + ;; article may not have been generated yet, so this may fail. + ;; We work around this problem by retrieving the last few + ;; headers using HEAD. + (if (not sequence) + (nreverse headers) + (let ((gnus-nov-is-evil t) + (nntp-nov-is-evil t)) + (nconc + (nreverse headers) + (when (gnus-retrieve-headers sequence gnus-newsgroup-name) + (gnus-get-newsgroup-headers)))))))) (defun gnus-article-get-xrefs () "Fill in the Xref value in `gnus-current-headers', if necessary. @@ -4957,7 +4843,7 @@ The prefix argument ALL means to select all articles." (defun gnus-summary-save-newsrc (&optional force) "Save the current number of read/marked articles in the dribble buffer. If FORCE (the prefix), also save the .newsrc file(s)." - (interactive) + (interactive "P") (gnus-summary-update-info) (when force (gnus-save-newsrc-file))) @@ -6138,9 +6024,13 @@ fetch-old-headers verbiage, and so on." gnus-newsgroup-reads))) t) ;; Check NoCeM things. - (and gnus-use-nocem - (gnus-nocem-unwanted-article-p - (mail-header-id (car thread)))))) + (if (and gnus-use-nocem + (gnus-nocem-unwanted-article-p + (mail-header-id (car thread)))) + (progn + (setq gnus-newsgroup-reads + (delq number gnus-newsgroup-unreads)) + t)))) ;; Nope, invisible article. 0 ;; Ok, this article is to be visible, so we add it to the limit @@ -6556,7 +6446,7 @@ to save in." (progn (copy-to-buffer buffer (point-min) (point-max)) (set-buffer buffer) - (article-delete-invisible-text) + (gnus-article-delete-invisible-text) (ps-print-buffer-with-faces filename)) (kill-buffer buffer))))) @@ -7021,7 +6911,7 @@ deleted forever, right now." (interactive) (gnus-set-global-variables) (or gnus-expert-user - (gnus-y-or-n-p + (gnus-yes-or-no-p "Are you really, really, really sure you want to delete all these messages? ") (error "Phew!")) (gnus-summary-expire-articles t)) @@ -7044,7 +6934,7 @@ delete these instead." (let ((articles (gnus-summary-work-articles n)) not-deleted) (if (and gnus-novice-user - (not (gnus-y-or-n-p + (not (gnus-yes-or-no-p (format "Do you really want to delete %s forever? " (if (> (length articles) 1) (format "these %s articles" (length articles)) @@ -7452,7 +7342,7 @@ marked." (and (not no-expire) gnus-newsgroup-auto-expire (or (not mark) - (and (numberp mark) + (and (gnus-characterp mark) (or (= mark gnus-killed-mark) (= mark gnus-del-mark) (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) (= mark gnus-read-mark) (= mark gnus-souped-mark) @@ -8220,6 +8110,7 @@ The variable `gnus-default-article-saver' specifies the saver function." (gnus-summary-set-saved-mark article)))) (gnus-kill-buffer save-buffer) (gnus-summary-position-point) + (gnus-set-mode-line 'summary) n)) (defun gnus-summary-pipe-output (&optional arg) diff --git a/lisp/gnus-undo.el b/lisp/gnus-undo.el index 6a188257b..91f6ff9ed 100644 --- a/lisp/gnus-undo.el +++ b/lisp/gnus-undo.el @@ -71,12 +71,10 @@ "\M-\C-_" gnus-undo)) (defun gnus-undo-make-menu-bar () - (unless (boundp 'gnus-undo-menu) - (easy-menu-define - gnus-undo-menu gnus-undo-mode-map "" - '("Undo" - ("Undo" - ["Undo" gnus-undo gnus-undo-actions]))))) + (when nil + (define-key-after (current-local-map) [menu-bar file gnus-undo] + (cons "Undo" 'gnus-undo-actions) + [menu-bar file whatever]))) (defun gnus-undo-mode (&optional arg) "Minor mode for providing `undo' in Gnus buffers. diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index caf08dc3c..d0d1a5c2f 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -482,6 +482,7 @@ If N, return the Nth ancestor instead." (defun gnus-read-event-char () "Get the next event." (let ((event (read-event))) + ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) (defun gnus-sortable-date (date) diff --git a/lisp/gnus-win.el b/lisp/gnus-win.el index a0ceabbe9..e481006d4 100644 --- a/lisp/gnus-win.el +++ b/lisp/gnus-win.el @@ -65,7 +65,8 @@ (if gnus-carpal '(summary-carpal 4)))) (article (cond - ((and gnus-use-picons (not (eq gnus-picons-display-where 'article))) + ((and gnus-use-picons + (eq gnus-picons-display-where 'picons)) '(frame 1.0 (vertical 1.0 (summary 0.25 point) diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index f1f047500..4bd9a59f4 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -381,6 +381,7 @@ call it with the value of the `gnus-data' text property." (unless (face-differs-from-default-p 'underline) (funcall (intern "set-face-underline-p") 'underline t)) + (fset 'gnus-characterp 'characterp) (fset 'gnus-make-overlay 'make-extent) (fset 'gnus-overlay-put 'set-extent-property) (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) @@ -720,8 +721,8 @@ If HIDE, hide the text instead." (setq beg (point)) (forward-char) (if hide - (article-hide-text beg (point) gnus-hidden-properties) - (article-unhide-text beg (point))) + (gnus-article-hide-text beg (point) gnus-hidden-properties) + (gnus-article-unhide-text beg (point))) (setq beg (point))) (save-window-excursion (select-window (get-buffer-window (current-buffer))) diff --git a/lisp/gnus.el b/lisp/gnus.el index 33cc8a61b..1fab55a9f 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -42,7 +42,7 @@ "Score and kill file handling." :group 'gnus ) -(defconst gnus-version-number "0.76" +(defconst gnus-version-number "0.77" "Version number for this version of Gnus.") (defconst gnus-version (format "Red Gnus v%s" gnus-version-number) @@ -80,6 +80,7 @@ be set in `.emacs' instead." (defalias 'gnus-add-text-properties 'add-text-properties) (defalias 'gnus-put-text-property 'put-text-property) (defalias 'gnus-mode-line-buffer-identification 'identity) + (defalias 'gnus-characterp 'numberp) (defalias 'gnus-key-press-event-p 'numberp)) ;; The XEmacs people think this is evil, so it must go. @@ -123,13 +124,322 @@ be set in `.emacs' instead." ;;; Internal variables +;; We define these group faces here to avoid the display +;; update forced when creating new faces. + +(defface gnus-group-news-1-face + '((((class color) + (background dark)) + (:foreground "PaleTurquoise" :bold t)) + (((class color) + (background light)) + (:foreground "ForestGreen" :bold t)) + (t + ())) + "Level 1 newsgroup face.") + +(defface gnus-group-news-1-empty-face + '((((class color) + (background dark)) + (:foreground "PaleTurquoise")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + ())) + "Level 1 empty newsgroup face.") + +(defface gnus-group-news-2-face + '((((class color) + (background dark)) + (:foreground "turquoise" :bold t)) + (((class color) + (background light)) + (:foreground "CadetBlue4" :bold t)) + (t + ())) + "Level 2 newsgroup face.") + +(defface gnus-group-news-2-empty-face + '((((class color) + (background dark)) + (:foreground "turquoise")) + (((class color) + (background light)) + (:foreground "CadetBlue4")) + (t + ())) + "Level 2 empty newsgroup face.") + +(defface gnus-group-news-3-face + '((((class color) + (background dark)) + (:bold t)) + (((class color) + (background light)) + (:bold t)) + (t + ())) + "Level 3 newsgroup face.") + +(defface gnus-group-news-3-empty-face + '((((class color) + (background dark)) + ()) + (((class color) + (background light)) + ()) + (t + ())) + "Level 3 empty newsgroup face.") + +(defface gnus-group-news-low-face + '((((class color) + (background dark)) + (:foreground "DarkTurquoise" :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" :bold t)) + (t + ())) + "Low level newsgroup face.") + +(defface gnus-group-news-low-empty-face + '((((class color) + (background dark)) + (:foreground "DarkTurquoise")) + (((class color) + (background light)) + (:foreground "DarkGreen")) + (t + ())) + "Low level empty newsgroup face.") + +(defface gnus-group-mail-1-face + '((((class color) + (background dark)) + (:foreground "aquamarine1" :bold t)) + (((class color) + (background light)) + (:foreground "DeepPink3" :bold t)) + (t + (:bold t))) + "Level 1 mailgroup face.") + +(defface gnus-group-mail-1-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine1")) + (((class color) + (background light)) + (:foreground "DeepPink3")) + (t + (:italic t :bold t))) + "Level 1 empty mailgroup face.") + +(defface gnus-group-mail-2-face + '((((class color) + (background dark)) + (:foreground "aquamarine2" :bold t)) + (((class color) + (background light)) + (:foreground "HotPink3" :bold t)) + (t + (:bold t))) + "Level 2 mailgroup face.") + +(defface gnus-group-mail-2-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine2")) + (((class color) + (background light)) + (:foreground "HotPink3")) + (t + (:bold t))) + "Level 2 empty mailgroup face.") + +(defface gnus-group-mail-3-face + '((((class color) + (background dark)) + (:foreground "aquamarine3" :bold t)) + (((class color) + (background light)) + (:foreground "magenta4" :bold t)) + (t + (:bold t))) + "Level 3 mailgroup face.") + +(defface gnus-group-mail-3-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine3")) + (((class color) + (background light)) + (:foreground "magenta4")) + (t + ())) + "Level 3 empty mailgroup face.") + +(defface gnus-group-mail-low-face + '((((class color) + (background dark)) + (:foreground "aquamarine4" :bold t)) + (((class color) + (background light)) + (:foreground "DeepPink4" :bold t)) + (t + (:bold t))) + "Low level mailgroup face.") + +(defface gnus-group-mail-low-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine4")) + (((class color) + (background light)) + (:foreground "DeepPink4")) + (t + (:bold t))) + "Low level empty mailgroup face.") + +;; Summary mode faces. + +(defface gnus-summary-selected-face '((t + (:underline t))) + "Face used for selected articles.") + +(defface gnus-summary-cancelled-face + '((((class color)) + (:foreground "yellow" :background "black"))) + "Face used for cancelled articles.") + +(defface gnus-summary-high-ticked-face + '((((class color) + (background dark)) + (:foreground "pink" :bold t)) + (((class color) + (background light)) + (:foreground "firebrick" :bold t)) + (t + (:bold t))) + "Face used for high interest ticked articles.") + +(defface gnus-summary-low-ticked-face + '((((class color) + (background dark)) + (:foreground "pink" :italic t)) + (((class color) + (background light)) + (:foreground "firebrick" :italic t)) + (t + (:italic t))) + "Face used for low interest ticked articles.") + +(defface gnus-summary-normal-ticked-face + '((((class color) + (background dark)) + (:foreground "pink")) + (((class color) + (background light)) + (:foreground "firebrick")) + (t + ())) + "Face used for normal interest ticked articles.") + +(defface gnus-summary-high-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue" :bold t)) + (((class color) + (background light)) + (:foreground "RoyalBlue" :bold t)) + (t + (:bold t))) + "Face used for high interest ancient articles.") + +(defface gnus-summary-low-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue" :italic t)) + (((class color) + (background light)) + (:foreground "RoyalBlue" :italic t)) + (t + (:italic t))) + "Face used for low interest ancient articles.") + +(defface gnus-summary-normal-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue")) + (((class color) + (background light)) + (:foreground "RoyalBlue")) + (t + ())) + "Face used for normal interest ancient articles.") + +(defface gnus-summary-high-unread-face + '((t + (:bold t))) + "Face used for high interest unread articles.") + +(defface gnus-summary-low-unread-face + '((t + (:italic t))) + "Face used for low interest unread articles.") + +(defface gnus-summary-normal-unread-face + '((t + ())) + "Face used for normal interest unread articles.") + +(defface gnus-summary-high-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen" + :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" + :bold t)) + (t + (:bold t))) + "Face used for high interest read articles.") + +(defface gnus-summary-low-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen" + :italic t)) + (((class color) + (background light)) + (:foreground "DarkGreen" + :italic t)) + (t + (:italic t))) + "Face used for low interest read articles.") + +(defface gnus-summary-normal-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen")) + (((class color) + (background light)) + (:foreground "DarkGreen")) + (t + ())) + "Face used for normal interest read articles.") + + +;;; Splash screen. + (defvar gnus-group-buffer "*Group*") (eval-and-compile (autoload 'gnus-play-jingle "gnus-audio")) -;;; Splash screen. - (defface gnus-splash-face '((((class color) (background dark)) @@ -1154,9 +1464,9 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.") gnus-article-hide-pem gnus-article-hide-signature gnus-article-strip-leading-blank-lines gnus-article-date-local gnus-article-date-original gnus-article-date-lapsed - gnus-decode-rfc1522 gnus-article-show-all-headers + gnus-article-show-all-headers gnus-article-edit-mode gnus-article-edit-article - gnus-article-edit-done) + gnus-article-edit-done gnus-decode-rfc1522) ("gnus-int" gnus-request-type) ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 gnus-dribble-enter) @@ -1171,7 +1481,6 @@ gnus-newsrc-hashtb should be kept so that both hold the same information.") ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next gnus-async-prefetch-article gnus-async-prefetch-remove-group gnus-async-halt-prefetch) - ("article" article-decode-rfc1522) ("gnus-vm" :interactive t gnus-summary-save-in-vm gnus-summary-save-article-vm)))) diff --git a/lisp/message.el b/lisp/message.el index b91b1c070..c31fd4def 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -970,6 +970,8 @@ Return the number of headers removed." (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) (define-key message-mode-map "\C-c\C-d" 'message-dont-send) + (define-key message-mode-map "\C-c\C-e" 'message-elide-region) + (define-key message-mode-map "\t" 'message-tab)) (easy-menu-define @@ -980,7 +982,8 @@ Return the number of headers removed." ["Fill Yanked Message" message-fill-yanked-message t] ["Insert Signature" message-insert-signature t] ["Caesar (rot13) Message" message-caesar-buffer-body t] - ["Caesar (rot13) Region" message-caesar-region t] + ["Caesar (rot13) Region" message-caesar-region mark-active] + ["Elide Region" message-elide-region mark-active] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message t] "----" @@ -1027,6 +1030,7 @@ C-c C-i message-goto-signature (move to the beginning of the signature). C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). +C-c C-e message-elide-region (elide the text between point and mark). C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) @@ -1229,6 +1233,16 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (goto-char (point-max)) (or (bolp) (insert "\n"))))) +(defun message-elide-region (b e) + "Elide the text between point and mark. +An ellipsis (\"[...]\") will be inserted where the text was +killed." + (interactive "r") + (kill-region b e) + (unless (bolp) + (insert "\n")) + (insert "\n[...]\n\n")) + (defvar message-caesar-translation-table nil) (defun message-caesar-region (b e &optional n) diff --git a/lisp/nnmail.el b/lisp/nnmail.el index d1b0a180c..f80e3426f 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -1047,7 +1047,7 @@ Return the number of characters in the body." "Remove excessive whitespace from all headers." (goto-char (point-min)) (while (re-search-forward "^\\([^ :]+: \\) +" nil t) - (replace-match "\\1" t t))) + (replace-match "\\1" t))) (defun nnmail-remove-list-identifiers () "Remove list identifiers from Subject headers." diff --git a/lisp/nnml.el b/lisp/nnml.el index 52b5520ea..630777758 100644 --- a/lisp/nnml.el +++ b/lisp/nnml.el @@ -250,7 +250,8 @@ all. This may very well take some time.") (save-excursion (nnmail-find-file nnml-newsgroups-file))) -(deffoo nnml-request-expire-articles (articles newsgroup &optional server force) +(deffoo nnml-request-expire-articles (articles newsgroup + &optional server force) (nnml-possibly-change-directory newsgroup server) (let* ((active-articles (nnheader-directory-articles nnml-current-directory)) diff --git a/lisp/pop3.el b/lisp/pop3.el index 387013917..0d26cb045 100644 --- a/lisp/pop3.el +++ b/lisp/pop3.el @@ -4,7 +4,7 @@ ;; Author: Richard L. Pieri ;; Keywords: mail, pop3 -;; Version: 1.2 +;; Version: 1.3 ;; This file is part of GNU Emacs. @@ -79,7 +79,6 @@ Used for APOP authentication.") (while (<= n message-count) (message (format "Retrieving message %d of %d from %s..." n message-count pop3-mailhost)) - (sit-for 0) (pop3-retr process n crashbuf) (save-excursion (set-buffer crashbuf) @@ -89,7 +88,6 @@ Used for APOP authentication.") (pop3-quit process) (kill-buffer crashbuf) ) - (sit-for 0) ) (defun pop3-open-server (mailhost port) @@ -120,16 +118,16 @@ Returns the process associated with the connection." (insert output))) (defun pop3-send-command (process command) - (set-buffer (process-buffer process)) - (goto-char (point-max)) - ;; (if (= (aref command 0) ?P) - ;; (insert "PASS \r\n") - ;; (insert command "\r\n")) - (setq pop3-read-point (point)) - (goto-char (point-max)) - (process-send-string process command) - (process-send-string process "\r\n") - ) + (set-buffer (process-buffer process)) + (goto-char (point-max)) +;; (if (= (aref command 0) ?P) +;; (insert "PASS \r\n") +;; (insert command "\r\n")) + (setq pop3-read-point (point)) + (goto-char (point-max)) + (process-send-string process command) + (process-send-string process "\r\n") + ) (defun pop3-read-response (process &optional return) "Read the response from the server. @@ -253,9 +251,6 @@ Return the response string if optional second argument is non-nil." (pop3-quit process))))) )) -(eval-and-compile - (if (not (fboundp 'md5)) (autoload 'md5 "md5"))) - (defun pop3-apop (process user) "Send alternate authentication information to the server." (if (not (fboundp 'md5)) (autoload 'md5 "md5")) @@ -296,6 +291,13 @@ buffer CRASHBUF." (set-buffer (process-buffer process)) (while (not (re-search-forward "^\\.\r\n" nil t)) (accept-process-output process) + ;; bill@att.com ... to save wear and tear on the heap + (if (> (buffer-size) 20000) (sleep-for 1)) + (if (> (buffer-size) 50000) (sleep-for 1)) + (if (> (buffer-size) 100000) (sleep-for 1)) + (if (> (buffer-size) 200000) (sleep-for 1)) + (if (> (buffer-size) 500000) (sleep-for 1)) + ;; bill@att.com (goto-char start)) (setq pop3-read-point (point-marker)) (goto-char (match-beginning 0)) diff --git a/lisp/widget-edit.el b/lisp/widget-edit.el index c125bd2b1..9c4106afb 100644 --- a/lisp/widget-edit.el +++ b/lisp/widget-edit.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.12 +;; Version: 1.15 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -77,7 +77,13 @@ into the buffer visible in the event's window." :prefix "widget-" :group 'emacs) -(defface widget-documentation-face '((t ())) +(defface widget-documentation-face '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) "Face used for documentation text." :group 'widgets) @@ -90,12 +96,10 @@ into the buffer visible in the event's window." :type 'face :group 'widgets) -(defface widget-field-face '((((type x) - (class grayscale color) +(defface widget-field-face '((((class grayscale color) (background light)) (:background "light gray")) - (((type x) - (class grayscale color) + (((class grayscale color) (background dark)) (:background "dark gray")) (t @@ -106,6 +110,7 @@ into the buffer visible in the event's window." (defcustom widget-menu-max-size 40 "Largest number of items allowed in a popup-menu. Larger menus are read through the minibuffer." + :group 'widgets :type 'integer) ;;; Utility functions. @@ -468,10 +473,9 @@ Recommended as a parent keymap for modes using widgets.") (call-interactively (lookup-key widget-global-map (this-command-keys)))))) -(defun widget-forward (arg) - "Move point to the next field or button. -With optional ARG, move across that many fields." - (interactive "p") +(defun widget-move (arg) + "Move point to the ARG next field or button. +ARG may be negative to move backward." (while (> arg 0) (setq arg (1- arg)) (let ((next (cond ((get-text-property (point) 'button) @@ -533,13 +537,22 @@ With optional ARG, move across that many fields." (goto-char (max button field))) (button (goto-char button)) (field (goto-char field))))) - (widget-echo-help (point))) + (widget-echo-help (point)) + (run-hooks 'widget-move-hook)) + +(defun widget-forward (arg) + "Move point to the next field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-forward-hook) + (widget-move arg)) (defun widget-backward (arg) "Move point to the previous field or button. With optional ARG, move across that many fields." (interactive "p") - (widget-forward (- arg))) + (run-hooks 'widget-backward-hook) + (widget-move (- arg))) ;;; Setting up the buffer. @@ -833,7 +846,7 @@ With optional ARG, move across that many fields." :format "%t\n") (defun widget-item-convert-widget (widget) - ;; Initialize :value and :tag from :args in WIDGET. + ;; Initialize :value from :args in WIDGET. (let ((args (widget-get widget :args))) (when args (widget-put widget :value (widget-apply widget diff --git a/lisp/widget.el b/lisp/widget.el index 0677474ce..0d1ffa0c3 100644 --- a/lisp/widget.el +++ b/lisp/widget.el @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.12 +;; Version: 1.15 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: diff --git a/texi/ChangeLog b/texi/ChangeLog index deed89cbd..f46fcc438 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -1,3 +1,11 @@ +Fri Jan 3 18:13:02 1997 Lars Magne Ingebrigtsen + + * message.texi (Various Commands): Addition. + +Thu Jan 2 16:12:27 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Optional Backend Functions): Fix. + Mon Dec 16 13:53:28 1996 Lars Magne Ingebrigtsen * gnus.texi (Exiting the Summary Buffer): Update. diff --git a/texi/custom.texi b/texi/custom.texi index 1ed37bb09..58862b125 100644 --- a/texi/custom.texi +++ b/texi/custom.texi @@ -13,16 +13,14 @@ @comment node-name, next, previous, up @top The Customization Library -Version: 1.12 +Version: 1.15 @menu * Introduction:: * User Commands:: * The Customization Buffer:: -* Declaring Groups:: -* Declaring Variables:: -* Declaring Faces:: -* Utilities:: +* Declarations:: +* Utilities:: * The Init File:: * Wishlist:: @end menu @@ -38,8 +36,8 @@ simultaneously: @table @dfn @item factory setting The value specified by the programmer. -@item default value -The value specified by the user as the default for this variable. This +@item saved value +The value saved by the user as the default for this variable. This overwrites the factory setting when starting a new emacs. @item current value The value used by Emacs. This will not be remembered next time you @@ -80,7 +78,7 @@ Create a customization buffer containing all variables, faces, and groups that match a user specified regular expression. @end table -@node The Customization Buffer, Declaring Groups, User Commands, Top +@node The Customization Buffer, Declarations, User Commands, Top @comment node-name, next, previous, up @section The Customization Buffer. @@ -184,7 +182,7 @@ using the standard emacs editing commands. The state button. This look of this button will indicate the state of the option, e.g. whether it is currently hidden, or whether it has been modified or not. Activating the button will allow you to change the -state, e.g. apply or reset the changes you have made. This is explained +state, e.g. set or reset the changes you have made. This is explained in detail in the following sections. @item [?] @@ -213,29 +211,29 @@ the list, or delete existing items from the list. You may want to see @ref{User Interface,,, widget, The Widget Library}, where some examples of editing are discussed. -You can either choose to edit the value directly, or edit the default -value for that variable. The default value is a lisp expression that +You can either choose to edit the value directly, or edit the lisp +value for that variable. The lisp value is a lisp expression that will be evaluated when you start emacs. The result of the evaluation will be used as the initial value for that variable. Editing the -default value is for experts only, but if the current value of the +lisp value is for experts only, but if the current value of the variable is of a wrong type (i.e. a symbol where a string is expected), -the `edit default' mode will always be selected. +the `edit lisp' mode will always be selected. You can see what mode is currently selected by looking at the state -button. If it uses parenthesises (like @samp{( )}) it is in `Edit -default' mode, with square brackets (like @samp{[ ]}) it is normal edit -mode. You can switch mode by activating the state button, and select -either @samp{Edit} or @samp{Edit default} from the menu. +button. If it uses parenthesises (like @samp{( )}) it is in edit lisp +mode, with square brackets (like @samp{[ ]}) it is normal edit mode. +You can switch mode by activating the state button, and select either +@samp{Edit} or @samp{Edit lisp} from the menu. You can change the state of the variable with the other menu items: @table @samp -@item Apply +@item Set When you have made your modifications in the buffer, you need to activate this item to make the modifications take effect. The modifications will be forgotten next time you run emacs. -@item Set Default +@item Save Unless you activate this item instead! This will mark the modification as permanent, i.e. the changes will be remembered in the next emacs session. @@ -244,9 +242,9 @@ session. If you have made some modifications and not yet applied them, you can undo the modification by activating this item. -@item Reset to Default +@item Reset to Saved Activating this item will reset the value of the variable to the last -value you marked as permanent with `Set Default'. +value you marked as permanent with `Save'. @item Reset to Factory Settings Activating this item will undo all modifications you have made, and @@ -335,10 +333,10 @@ stars in the level button. Since there is really no customization needed for the group itself, the menu items in the groups state button will affect all modified group -members recursively. Thus, if you activate the @samp{Apply} menu item, +members recursively. Thus, if you activate the @samp{Set} menu item, all variables and faces that have been modified and belong to that group will be applied. For those members that themselves are groups, it will -work as if you had activated the @samp{Apply} menu item on them as well. +work as if you had activated the @samp{Set} menu item on them as well. @node The State Button, The Customization Buttons, The Group Options, The Customization Buffer @comment node-name, next, previous, up @@ -362,10 +360,13 @@ The value if this option has been modified in the buffer, but not yet applied. @item + -The current value of this option is different from the default value. +The item has has been set by the user. + +@item : +The current value of this option is different from the saved value. @item ! -The default value of this option is different from the factory setting. +The saved value of this option is different from the factory setting. @item @@ The factory setting of this option is not known. This occurs when you @@ -388,37 +389,25 @@ list above (except hidden members, which are ignored). The last part of the customization buffer looks like this: @example -[Apply] [Set Default] [Reset] [Save] +[Set] [Save] [Reset] @end example -Activating the @samp{[Apply]}, @samp{[Set Default]}, or @samp{[Reset]} +Activating the @samp{[Set]}, @samp{[Save]}, or @samp{[Reset]} button will affect all modified customization items that are visible in the buffer. -Activating the @samp{[Save]} button will ensure that all customization -options who are marked as persistent with @samp{Set default} (either -with the button at the end of the buffer, or with any of the state -button menus), will actually be saved in your initialization file. - -@node Declaring Groups, Declaring Variables, The Customization Buffer, Top +@node Declarations, Utilities, The Customization Buffer, Top @comment node-name, next, previous, up -@section Declaring Groups - -Use @code{defgroup} to declare new customization groups. - -@defun defgroup symbol members doc [keyword value]... -Declare @var{symbol} as a customization group containing @var{members}. -@var{symbol} does not need to be quoted. - -@var{doc} is the group documentation. +@section Declarations -@var{members} should be an alist of the form ((@var{name} -@var{widget})...) where @var{name} is a symbol and @var{widget} is a -widget for editing that symbol. Useful widgets are -@code{custom-variable} for editing variables, @code{custom-face} for -editing faces, and @code{custom-group} for editing groups.@refill +@menu +* Declaring Groups:: +* Declaring Variables:: +* Declaring Faces:: +@end menu -The following @var{keyword}'s are defined: +All the customization declarations can be changes by keyword arguments. +Groups, variables, and faces all share these common keywords: @table @code @item :group @@ -435,16 +424,46 @@ this customization option. The value should be iether a string, which should be a string which will be loaded with @code{load-library} unless present in @code{load-history}, or a symbol which will be loaded with @code{require}. +@item :tag +@var{Value} should be a short string used for identifying the option in +customization menus and buffers. By default the tag will be +automatically created from the options name. @end table -@end defun + +@node Declaring Groups, Declaring Variables, Declarations, Declarations +@comment node-name, next, previous, up +@subsection Declaring Groups + +Use @code{defgroup} to declare new customization groups. + +@defun defgroup symbol members doc [keyword value]... +Declare @var{symbol} as a customization group containing @var{members}. +@var{symbol} does not need to be quoted. + +@var{doc} is the group documentation. + +@var{members} should be an alist of the form ((@var{name} +@var{widget})...) where @var{name} is a symbol and @var{widget} is a +widget for editing that symbol. Useful widgets are +@code{custom-variable} for editing variables, @code{custom-face} for +editing faces, and @code{custom-group} for editing groups.@refill Internally, custom uses the symbol property @code{custom-group} to keep track of the group members, and @code{group-documentation} for the documentation string. -@node Declaring Variables, Declaring Faces, Declaring Groups, Top +The following additional @var{keyword}'s are defined: + +@table @code +@item :prefix +@var{value} should be a string. If the string is a prefix for the name +of a member of the group, that prefix will be ignored when creating a +tag for that member. +@end table + +@node Declaring Variables, Declaring Faces, Declaring Groups, Declarations @comment node-name, next, previous, up -@section Declaring Variables +@subsection Declaring Variables Use @code{defcustom} to declare user editable variables. @@ -455,7 +474,7 @@ If @var{symbol} is not already bound, initialize it to @var{value}. @var{doc} is the variable documentation. -The following @var{keyword}'s are defined: +The following additional @var{keyword}'s are defined: @table @code @item :type @@ -463,20 +482,6 @@ The following @var{keyword}'s are defined: @item :options @var{value} should be a list of possible members of the specified type. For hooks, this is a list of function names. -@item :group -@var{value} should be a customization group. -Add @var{symbol} to that group. -@item :link -@var{value} should be a widget type. -Add @var{value} to the extrenal links for this customization option. -Useful widget types include @code{custom-manual}, @code{info-link}, and -@code{url-link}. -@item :load -Add @var{value} to the files that should be loaded nefore displaying -this customization option. The value should be iether a string, which -should be a string which will be loaded with @code{load-library} unless -present in @code{load-history}, or a symbol which will be loaded with -@code{require}. @end table @xref{Sexp Types,,,widget,The Widget Library}, for information about @@ -485,9 +490,8 @@ widgets to use together with the @code{:type} keyword. Internally, custom uses the symbol property @code{custom-type} to keep track of the variables type, @code{factory-value} for the program -specified default value, @code{default-value} for a user specified -default value, and @code{variable-documentation} for the documentation -string. +specified default value, @code{saved-value} for a value saved by the +user, and @code{variable-documentation} for the documentation string. Use @code{custom-add-option} to specify that a specific function is useful as an meber of a hook. @@ -499,9 +503,9 @@ If @var{symbol} is a hook variable, @var{option} should be a hook member. For other types variables, the effect is undefined." @end defun -@node Declaring Faces, Utilities, Declaring Variables, Top +@node Declaring Faces, , Declaring Variables, Declarations @comment node-name, next, previous, up -@section Declaring Faces +@subsection Declaring Faces Faces are declared with @code{defface}. @@ -516,25 +520,6 @@ according to @var{spec}. @var{doc} is the face documentation. -The following @var{keyword}'s are defined: - -@table @code -@item :group -@var{value} should be a customization group. -Add @var{symbol} to that group. -@item :link -@var{value} should be a widget type. -Add @var{value} to the extrenal links for this customization option. -Useful widget types include @code{custom-manual}, @code{info-link}, and -@code{url-link}. -@item :load -Add @var{value} to the files that should be loaded nefore displaying -this customization option. The value should be iether a string, which -should be a string which will be loaded with @code{load-library} unless -present in @code{load-history}, or a symbol which will be loaded with -@code{require}. -@end table - @var{spec} should be an alist of the form @samp{((@var{display} @var{atts})...)}. @var{atts} is a list of face attributes and their values. The possible @@ -566,13 +551,13 @@ Should be one of @code{light} or @code{dark}. @end table Internally, custom uses the symbol property @code{factory-face} for the -program specified default face properties, @code{default-face} for a -user specified default properties, and @code{face-documentation} for the +program specified default face properties, @code{saved-face} for +properties saved by the user, and @code{face-documentation} for the documentation string.@refill @end defun -@node Utilities, The Init File, Declaring Faces, Top +@node Utilities, The Init File, Declarations, Top @comment node-name, next, previous, up @section Utilities @@ -597,6 +582,13 @@ To the custom option @var{symbol} add the dependency @var{load}. @var{load} should be either a library file name, or a feature name. @end defun +@defun custom-menu-create symbol &optional name +Create menu for customization group @var{symbol}. +If optional @var{name} is given, use that as the name of the menu. +Otherwise make up a name from @var{symbol}. +The menu is in a format applicable to @code{easy-menu-define}. +@end defun + @node The Init File, Wishlist, Utilities, Top @comment node-name, next, previous, up @section The Init File diff --git a/texi/gnus.texi b/texi/gnus.texi index 6f78b1d95..1f5c38912 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @setfilename gnus -@settitle Red Gnus 0.76 Manual +@settitle Red Gnus 0.77 Manual @synindex fn cp @synindex vr cp @synindex pg cp @@ -287,7 +287,7 @@ into another language, under the above conditions for modified versions. @tex @titlepage -@title Red Gnus 0.76 Manual +@title Red Gnus 0.77 Manual @author by Lars Magne Ingebrigtsen @page @@ -323,7 +323,7 @@ can be gotten by any nefarious means you can think of---@sc{nntp}, local spool or your mbox file. All at the same time, if you want to push your luck. -This manual corresponds to Red Gnus 0.76 +This manual corresponds to Red Gnus 0.77 @end ifinfo @@ -8691,7 +8691,7 @@ Hook run in the buffer where the mail headers of each message is kept just before the splitting based on these headers is done. The hook is free to modify the buffer contents in any way it sees fit---the buffer is discarded after the splitting has been done, and no changes performed -in the buffer will show up in any files. @code{article-decode-rfc1522} +in the buffer will show up in any files. @code{gnus-article-decode-rfc1522} is one likely function to add to this hook. @vindex nnmail-pre-get-new-mail-hook @@ -13764,8 +13764,10 @@ Marc Horowitz, Ishikawa Ichiro, @c Ishikawa Francois Felix Ingrand, Lee Iverson, +Rajappa Iyer, Randell Jesup, Fred Johansen, +Peter Skov Knudsen, Shuhei Kobayashi, @c Kobayashi Thor Kristoffersen, Jens Lautenbacher, @@ -13780,6 +13782,7 @@ Timo Metzemakers, Richard Mlynarik, Lantz Moore, Morioka Tomohiko, @c Morioka +Erik Toubro Nielsen, Hrvoje Niksic, Andy Norman, C. R. Oldham, @@ -13801,6 +13804,7 @@ Jeff Sparkes, Michael Sperber, Richard Stallman, Greg Stark, +Paul Stodghill, Kurt Swanson, Samuel Tardieu, Teddy, @@ -15129,9 +15133,8 @@ group-buffer = *active-line / *group-status A Gnus group info (@pxref{Group Info}) is handed to the backend for alterations. This comes in handy if the backend really carries all the information (as is the case with virtual an imap groups). This function -may alter the info in any manner it sees fit, and should return the -(altered) group info. This function may alter the group info -destructively, so no copying is needed before boogeying. +should destructively alter the info to suit its needs, and should return +the (altered) group info. There should be no result data from this function. diff --git a/texi/message.texi b/texi/message.texi index 1f2e8a2b7..eb5203f24 100644 --- a/texi/message.texi +++ b/texi/message.texi @@ -497,6 +497,13 @@ Caesar rotate (aka. rot13) the current message rotate the visible portion of the buffer. A numerical prefix says how many places to rotate the text. The default is 13. +@item C-c C-e +@kindex C-c C-e +@findex message-elide-region +Elide the text between point and mark (@code{message-elide-region}). +The text is killed and an ellipsis (@samp{[...]}) will be inserted in +its place. + @item C-c C-t @kindex C-c C-t @findex message-insert-to diff --git a/texi/widget.texi b/texi/widget.texi index 52a6d5579..50e3c3a89 100644 --- a/texi/widget.texi +++ b/texi/widget.texi @@ -1,6 +1,6 @@ \input texinfo.tex -@c $Id: widget.texi,v 1.3 1996/12/14 09:53:45 steve Exp $ +@c $Id: widget.texi,v 1.4 1997/01/05 10:05:31 steve Exp $ @c %**start of header @setfilename widget @@ -15,7 +15,7 @@ @comment node-name, next, previous, up @top The Emacs Widget Library -Version: 1.12 +Version: 1.15 @menu * Introduction:: -- 2.25.1