diff options
author | Miles Bader <miles@gnu.org> | 2007-11-11 00:56:44 +0000 |
---|---|---|
committer | Miles Bader <miles@gnu.org> | 2007-11-11 00:56:44 +0000 |
commit | f23d76bdefbd4c06e14d69e99e50d35ce91c8226 (patch) | |
tree | ded28d1da6df2d0135514bac83074f4ca1c9099a /lisp | |
parent | e2d092da5980a7d05a5428074f8eb4925fa801e8 (diff) | |
parent | a457417ee5ba797ab1c91d35ee957bb7a7f8d4b6 (diff) | |
download | emacs-f23d76bdefbd4c06e14d69e99e50d35ce91c8226.tar.gz |
Merge from emacs--devo--0
Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-283
Diffstat (limited to 'lisp')
274 files changed, 31058 insertions, 13381 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fef3bfe5b7c..e77106f06da 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,20 +1,1201 @@ +2007-11-10 Jason Rumney <jasonr@gnu.org> + + * w32-fns.el: Sync charset names with setup-default-fontset. + Append "-1" where second part missing. + +2007-11-11 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp> + + * faces.el (face-normalize-spec): Remove function. + (frame-set-background-mode): Undo last change. + +2007-11-10 Juri Linkov <juri@jurta.org> + + * isearch.el (isearch-mode-end-hook, isearch-mode-end-hook-quit): + Fix docstring. Reported by Leo <sdl.web@gmail.com>. + + * custom.el (custom-note-var-changed): Remove the `interactive' + spec from this new non-interactive function. + +2007-11-10 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el (doc-view-mode-map, doc-view-menu) + (doc-view-pdf->txt-sentinel): Adapt to new search UI. + (doc-view-search-backward): New function. + (doc-view-search): Query new regexp if prefix arg is given, else + jump to next/previous match. + (doc-view-mode): Handle compressed files. + (jka-compr): Required for compressed files. + +2007-11-10 Paul Pogonyshev <pogonyshev@gmx.net> + + * replace.el (query-replace-show-replacement): New defcustom. + (perform-replace): Use `match-substitute-replacement' if + `query-replace-show-replacement' is non-nil. + +2007-11-10 David Kastrup <dak@gnu.org> + + * subr.el (match-substitute-replacement): New function. + +2007-11-10 Carsten Dominik <dominik@science.uva.nl> + + * files.el (auto-mode-alist): Select org-mode for files with the + extension ".org". + +2007-11-10 Martin Rudalics <rudalics@gmx.at> + + * help.el (help-window, help-window-point-marker): New variables. + (help-window-select): New option. + (with-help-window): New macro for displaying help windows. + (help-window-display-message, help-window-setup-finish) + (help-window-setup): New functions used for setting up help windows. + (print-help-return-message): Reset help-window to nil. + (view-lossage): Use with-help-window instead of + with-output-to-temp-buffer and move help-window-point-marker after + inserted text. + (describe-bindings, describe-key, describe-mode): Use + with-help-window instead of with-output-to-temp-buffer. + + * help-mode.el (help-mode): Set view-exit-action to bury the + buffer instead of fiddling with windows. Simplify code. + (help-mode-finish): When help-window eqs t set it to the selected + window and have with-help-window set up view-return-to-alist. + (help-buffer): Add autoload cookie. + + * view.el (view-remove-frame-by-deleting): Change default value to t. + Add autoload cookie. + (view-exit-action, view-file, view-file-other-window) + (view-file-other-frame, view-buffer, view-buffer-other-window) + (view-buffer-other-frame): Rewrite doc strings. + (view-return-to-alist-update): New function to remove stale entries + from view-return-to-alist. + (view-mode-enter): Rewrite doc string and simplify code. + (view-mode-exit): Handle new case 'keep-frame. Don't reset + view-exit-action to nil. Simplify code and rewrite doc string. + + * apropos.el (apropos-describe-plist): + * descr-text.el (describe-char): + * disp-table.el (describe-display-table): + * faces.el (list-faces-display, describe-face): + * facemenu.el (list-colors-display): + * help-fns.el (describe-function, describe-variable) + (describe-syntax, describe-categories): + Use with-help-window instead of with-output-to-temp-buffer. + +2007-11-10 Dan Nicolaescu <dann@ics.uci.edu> + + * emacs-lisp/byte-opt.el (byte-optimize-featurep): Optimize + (featurep 'emacs) to t. + + * emacs-lisp/bytecomp.el (byte-compile-find-bound-condition): New + function. + (byte-compile-maybe-guarded): Use it to also look for bound + symbols inside `and' forms. Comment out non-working code that was + trying to avoid warnings for XEmacs code. + + * vc.el (vc-diff-internal): Make the *vc-diff* buffer read only. + + * vc-svn.el (vc-svn-print-log, vc-svn-diff): + * vc-mcvs.el (vc-mcvs-print-log, vc-mcvs-annotate-command): + * vc-cvs.el (vc-cvs-print-log, vc-cvs-diff) + (vc-cvs-annotate-command): + * vc-arch.el (vc-arch-diff): Remove test to check if start-process + is bound, it always is. + +2007-11-10 Jason Rumney <jasonr@gnu.org> + + * term/w32-win.el (w32-initialize-window-system): Move SJIS font + setup here from global scope. + +2007-11-10 Juanma Barranquero <lekktu@gmail.com> + + * ido.el (ido-save-history): Save the history file in UTF-8, not + the current filename coding system. + +2007-11-09 Stefan Monnier <monnier@iro.umontreal.ca> + + * simple.el (interprogram-cut-function, interprogram-paste-function): + Don't make them frame-local any more. + + * faces.el (x-create-frame-with-faces, tty-create-frame-with-faces): + Don't set interprogram-(cut|paste)-function on each frame. + + * term/x-win.el (x-select-text, x-cut-buffer-or-selection-value): + Make them work in tty frames. + (interprogram-cut-function, interprogram-paste-function): + Set them globally. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * international/iso-cvt.el (iso-spanish, iso-german, iso-iso2tex) + (iso-tex2iso, iso-gtex2iso, iso-iso2gtex, iso-iso2duden): Doc fixes. + (iso-iso2duden-trans-tab): Add docstring. + +2007-11-09 Stefan Monnier <monnier@iro.umontreal.ca> + + * abbrev.el (define-abbrev-table): Record the variable definition. + + * emacs-lisp/bytecomp.el (byte-compile-file-form-define-abbrev-table): + New function. + +2007-11-09 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * ps-print.el: Clean the code for checking suitable Emacs version. + (ps-do-despool): If ps-lpr-switches is not a list, force it to be one. + (ps-print-version): New version 6.8.1. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * files.el (enable-local-variables): Doc fix. + +2007-11-09 Nick Roberts <nickrob@snap.net.nz> + + * progmodes/gud.el (gud-gdb): Remove vestigial gdba doc and code. + +2007-11-09 Sven Joachim <svenjoac@gmx.de> + + * dired-aux.el (dired-copy-file-recursive): + Preserve directory permissions. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * whitespace.el (whitespace-write-file-hook): Remove interactive spec. + (whitespace-unload-function): New-style unload function. When run, + unintern `whitespace-unload-hook' and call `unload-feature' recursively + to stop the old hook from messing with the unloading. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * emacs-lisp/elp.el (elp-report-limit, elp-restore-all) + (elp-unset-master, elp-results): Fix typos. + (elp-sort-by-function, elp-use-standard-output, elp-recycle-buffers-p): + Doc fixes. + + * msb.el (msb--many-menus): Remove variable. + (msb-max-menu-items, msb--add-to-menu): Doc fixes. + (msb-menu-cond, msb-item-handling-function, msb--create-function-info) + (msb--toggle-menu-type): Fix typos in docstrings. + + * shadowfile.el (shadow-inhibit-overload, shadow-remove-from-todo) + (shadow-insert-var): Doc fixes. + (shadow-file-match, shadow-define-cluster, shadow-define-regexp-group): + Reflow docstrings. + (shadow-parse-fullname, shadow-read-files): Fix typos in docstrings. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * ediff-hook.el (ediff, ediff-files, ediff-buffers, ebuffers, ediff3) + (ediff-files3, ediff-buffers3, ebuffers3, erevision, ediff-revision): + Fix typos in autoload docstrings. + +2007-11-09 Richard Stallman <rms@gnu.org> + + * savehist.el (savehist-save): Obey savehist-ignored-variables. + +2007-11-09 Nick Roberts <nickrob@snap.net.nz> + + * progmodes/gdb-ui.el (gdb-delete-out-of-scope): New option. + (gdb-var-update-handler-1): Use it. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * loadhist.el (unload-feature): Remove erroneous check for the + FEATURE-unload-function variable; check the existence of the + function (that's what the docstring says, and it makes more sense). + + * follow.el (follow-unload-function): Add docstring. + (follow-unload-function): Remove variable. + + * server.el (server-unload-function): Remove variable. + (server-unload-function): Unbind `server-edit' from `C-x #'. + + * ses.el (ses-unload-function): New function. + +2007-11-09 Juanma Barranquero <lekktu@gmail.com> + + * emacs-lisp/unsafep.el (unsafep, unsafep-function) + (unsafep-progn, unsafep-let): Fix typos in docstrings. + + * uniquify.el (uniquify-maybe-rerationalize-w/o-cb): Define it + before use to avoid a warning in packages that require uniquify. + (uniquify-unload-function): New function and var. + +2007-11-09 Dan Nicolaescu <dann@ics.uci.edu> + + * ediff-init.el (ediff-xemacs-p, ediff-emacs-p): Remove. + (ediff-has-face-support-p, ediff-BAD-INFO, ediff-check-version) + (ediff-current-diff-A, ediff-current-diff-B) + (ediff-current-diff-C, ediff-fine-diff-C, ediff-fine-diff-A) + (ediff-fine-diff-B, ediff-fine-diff-Ancestor, ediff-even-diff-A) + (ediff-even-diff-B, ediff-even-diff-C, ediff-even-diff-Ancestor) + (ediff-odd-diff-A, ediff-odd-diff-B, ediff-odd-diff-C) + (ediff-odd-diff-Ancestor, ediff-reset-mouse): + * ediff-wind.el (ediff-narrow-control-frame-leftward-shift) + (ediff-setup-windows-plain-merge) + (ediff-setup-windows-plain-compare, ediff-setup-control-frame) + (ediff-refresh-control-frame, ediff-get-visible-buffer-window): + * ediff-util.el (ediff-setup-keymap, ) + (ediff-toggle-wide-display, ediff-toggle-multiframe) + (ediff-toggle-use-toolbar, ediff-really-quit) + (ediff-good-frame-under-mouse) + (ediff-highlight-diff-in-one-buffer) + (ediff-remove-flags-from-buffer, ediff-place-flags-in-buffer1) + (ediff-make-bullet-proof-overlay): + * ediff-mult.el (ediff-setup-meta-map, ediff-emacs-p) + (ediff-set-meta-overlay): + * ediff-help.el (ediff-help-region-map, ediff-set-help-overlays): + * ediff.el (ediff-documentation): Replace ediff-xemacs-p and + ediff-emacs-p with their former definitions. + + * emulation/viper-init.el (viper-xemacs-p, viper-emacs-p): Remove. + (viper-has-face-support-p, viper-inactivate-input-method) + (viper-activate-input-method) + (viper-use-replace-region-delimiters, viper-restore-cursor-type): + * emulation/viper-mous.el (viper-multiclick-timeout) + (viper-surrounding-word, viper-mouse-click-insert-word) + (viper-mouse-click-search-word, viper-parse-mouse-key): + * emulation/viper-macs.el (viper-char-array-to-macro): + * emulation/viper.el (viper-go-away, viper-set-hooks) + (viper-non-hook-settings): + * emulation/viper-util.el (viper-get-saved-cursor-color-in-replace-mode) + (viper-get-saved-cursor-color-in-insert-mode) + (viper-get-saved-cursor-color-in-emacs-mode) + (viper-check-version, viper-get-visible-buffer-window) + (viper-file-checked-in-p, viper-set-replace-overlay) + (viper-set-replace-overlay-glyphs, viper-set-minibuffer-overlay) + (viper-check-minibuffer-overlay, viper-read-key-sequence) + (viper-key-to-emacs-key): Replace viper-xemacs-p and viper-emacs-p + with their former definitions. + (viper-eventify-list-xemacs): Only do work for XEmacs. + (viper-set-unread-command-events): Only do work for Emacs. + (viper-overlay-p, viper-make-overlay, viper-overlay-live-p) + (viper-move-overlay, viper-overlay-start, viper-overlay-end) + (viper-overlay-get, viper-overlay-put, viper-read-event) + (viper-characterp, viper-int-to-char, viper-get-face) + (viper-color-defined-p, viper-iconify): New defaliases replacing + the old fsets. + + * progmodes/fortran.el (comment-region-function) + (uncomment-region-function): Pacify byte compiler. + + * vc.el (vc-diff-internal): Remove code for an old version of gnus. + +2007-11-08 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-maybe-open-connection): Use a local copy of + `process-environment'. + +2007-11-08 David Hansen <david.hansen@gmx.net> (tiny change) + + * eshell/em-dirs.el (eshell-expand-multiple-dots): Change regexp to + match dir like "a...b". + +2007-11-08 Stefan Monnier <monnier@iro.umontreal.ca> + + * smerge-mode.el (smerge-refine-subst): Pass "-d" to diff. + +2007-11-07 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-handle-substitute-in-file-name): + Don't expand the remote connection identification. + (tramp-find-shell, tramp-open-connection-setup-interactive-shell): + Set also $PS2 and $PS3 when setting $PS1. Check for shell echoing + before calling stty. + + * net/tramp-cache.el (tramp-cache-print) + (tramp-dump-connection-properties): Fix docstring. + (tramp-list-connections): Rename from + `tramp-cache-list-connections'. + + * net/tramp-cmds.el (tramp-cleanup-connection): Apply it. + + * net/tramp-ftp.el (tramp-ftp-file-name-handler): Don't expand the + remote connection identification when setting connection property. + + * net/tramp-smb.el (tramp-smb-handle-substitute-in-file-name): + "//" substitutes only in the local filename part. + +2007-11-07 David Hansen <david.hansen@gmx.net> + + * eshell/em-glob.el (eshell-extended-glob): Sort matches. + +2007-11-07 Glenn Morris <rgm@gnu.org> + + * emulation/tpu-mapper.el (tpu-map-key): Use unless rather than cond. + Remove superfluous concats. Move final set-buffer to + non-emacs-specific code. + +2007-11-07 Rob Riepel <riepel@networking.stanford.edu> + + * emulation/tpu-mapper.el (tpu-map-key): Remove un-needed cond branch. + +2007-11-07 Johan Bockg,Ae(Brd <bojohan@gnu.org> + + * eshell/esh-mode.el (eshell-output-filter): + * eshell/esh-proc.el (eshell-insertion-filter, eshell-sentinel): + Use `with-current-buffer'. + +2007-11-07 Andreas Schwab <schwab@suse.de> + + * server.el (server-start): Only register cleanup after server was + started. + +2007-11-06 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (top): Don't autoload `tramp-cache-print'. + + * net/tramp-cache (tramp-cache-print): Move down. + (tramp-cache-list-connections): New defun. + + * net/tramp-cmds.el (tramp-cleanup-connection): Use it. + +2007-11-06 Juanma Barranquero <lekktu@gmail.com> + + * ido.el (ido-save-history): Write the history file in the current + filename coding system, and add `coding' file-local variable. + +2007-11-06 Carsten Dominik <dominik@science.uva.nl> + + * textmodes/org.el (org-table-formula-substitute-names): + Remove forgotten temporary debugging code. + +2007-11-05 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-wait-for-output): Ignore escape sequences in + the prompt. + +2007-10-05 Chris Moore <christopher.ian.moore@gmail.com> + + * wdired.el (wdired-use-dired-vertical-movement): Doc fix. + +2007-11-05 Simon Josefsson <simon@josefsson.org> + + * net/tls.el (tls-end-of-info): Doc fix. + +2007-11-05 Kenichi Handa <handa@ni.aist.go.jp> + + * international/utf-7.el (utf-7-imap): New coding system. + (utf-7-imap-post-read-conversion): New function. + (utf-7-imap-pre-write-conversion): New function. + +2007-11-05 Stefan Monnier <monnier@iro.umontreal.ca> + + * abbrev.el (abbrev--write): Fix up typo. + +2007-11-04 Juanma Barranquero <lekktu@gmail.com> + + * abbrev.el (define-abbrev-table): Doc fix. + +2007-11-04 Thien-Thi Nguyen <ttn@gnuvola.org> + + * info.el (Info-revert-buffer-function): New func. + (Info-mode): Arrange to use it for reverting. + (Info-copy-current-node-name): Add space between filename and nodename. + +2007-11-04 Stefan Monnier <monnier@iro.umontreal.ca> + + * abbrev.el (expand-abbrev): Move point back to expansion's end. + +2007-11-04 Glenn Morris <rgm@gnu.org> + + * net/tls.el: Don't require rx when compiling. + (tls-end-of-info): Rewrite without using rx. + (open-tls-stream): Use with-current-buffer. + +2007-11-04 Riccardo Murri <riccardo.murri@gmail.com> + + * net/tls.el: Require rx when compiling. + (tls-end-of-info): New variable. + (open-tls-stream): Keep reading input until `tls-end-of-info' is + matched. + +2007-11-03 Sean O'Rourke <seano@cs.ucla.edu> + + * register.el (append-to-register, prepend-to-register): + Don't signal error on empty register; use the text, instead. + +2007-11-03 Michael Olson <mwolson@gnu.org> + + * textmodes/remember.el (remember-buffer): + Use define-obsolete-function-alias rather than defalias. + +2007-11-03 Ulrich Mueller <ulm@gentoo.org> (tiny change) + + * simple.el (bad-packages-alist): Anchor semantic regexp. + +2007-11-03 Glenn Morris <rgm@gnu.org> + + * newcomment.el (comment-dwim): Call comment-insert-comment-function, + if defined, for blank lines. Doc fix. + + * progmodes/fortran.el (fortran-mode-map): Don't bind M-;. + (fortran-mode): Set values for comment-region-function, + uncomment-region-function and comment-insert-comment-function. + (fortran-uncomment-region): New function. + + * textmodes/nroff-mode.el (nroff-mode): + Set comment-insert-comment-function rather than indent-line-function. + (nroff-indent-line-function): Remove. + (nroff-insert-comment-function): New function. + +2007-11-02 Michael Kifer <kifer@cs.stonybrook.edu> + + * ediff-vers.el (ediff-vc-working-revision): Add a quote. + +2007-11-02 Michael Kifer <kifer@cs.stonybrook.edu> + + * emulation/viper-ex.el (viper-ex): Do not ignore the region. + + * emulation/viper-cmd.el (viper-prev-destructive-command) + (viper-insert-prev-from-insertion-ring): Use ring-copy instead of + copy-sequence. + + * ediff-util.el (ediff-make-current-diff-overlay): Do not use face-name. + Got rid of ediff-copy-list. + + * ediff-diff.el (ediff-set-fine-diff-properties-in-one-buffer): Do not + use face-name. + (ediff-test-utility,ediff-diff-mandatory-option) + (ediff-reset-diff-options): Remove to simplify the mandatory option + handling on Windows. + (ediff-set-diff-options): Add. + (ediff-diff-options): Set "--binary" option as default in some cases. + + * ediff-vers.el (ediff-vc-internal): Use ediff-vc-revision-other-window. + (ediff-vc-merge-internal): Use ediff-vc-revision-other-window and + ediff-vc-working-revision. Require vc-hooks. + +2007-11-02 Drake Wilson <drake@begriffli.ch> (tiny change) + + * files.el (hack-local-variables): Fix membership tests to avoid + treating all variables as safe if `enable-local-variables' is + set to :safe (CVE-2007-5795). + +2007-11-02 Glenn Morris <rgm@gnu.org> + + * newcomment.el (comment-indent): Let comment-insert-comment-function, + if defined, do all the work of inserting a new comment. + + * progmodes/etags.el (tags-table-mode): Disable undo. + + * simple.el (bad-packages-alist): Revert previous change. + +2007-11-02 Dan Nicolaescu <dann@ics.uci.edu> + + * emacs-lisp/lselect.el: Move to obsolete/lselect.el. + + * obsolete/lselect.el: Do not warn about unknown functions. + +2007-11-02 Michael Olson <mwolson@gnu.org> + + * textmodes/remember.el (remember-buffer): Make this an alias of + remember-finalize, because Org uses it. + +2007-11-01 Michael Olson <mwolson@gnu.org> + + * textmodes/remember.el: Improve documentation in heading. + (remember-before-remember-hook): Turn into a customizable option. + (remember): Document INITIAL argument. + (remember-region): Remove autoload cookie. Improve docstring to + mention that it is called from the *Remember* buffer, and does not + have any functional overlap with the `remember' function. + (remember-finalize): Remove autoload cookie. Rename from + remember-buffer to emphasize that this does not have any + functional overlap with the `remember' function. + (remember-destroy): Remove autoload cookie. + (remember-mode-map): Define and initialize in one step. + (remember-mode): Improve docstring. + (remember-annotation-functions): Default to just '(buffer-file-name), + and don't try to take the default value from Planner. + +2007-11-01 Glenn Morris <rgm@gnu.org> + + * doc-view.el (doc-view-cache-directory): Remove superfluous concat. + + * simple.el (bad-packages-alist): Add an entry for standalone vc-svn. + + * emacs-lisp/authors.el (authors-scan-change-log) + (authors-scan-el): Don't enable local eval; enable only safe local + variables, without querying. + + * mail/footnote.el (footnote-numeric-regexp) + (footnote-english-upper-regexp, footnote-english-lower-regexp) + (footnote-roman-lower-regexp, footnote-roman-upper-regexp): + Match multi-character footnotes. + + * textmodes/nroff-mode.el (nroff-mode): Set indent-line-function. + (nroff-indent-line-function): New function. + (nroff-count-text-lines): Use nroff-forward-text-line rather than + obsolete alias. + +2007-11-01 Ryan Yeske <rcyeske@gmail.com> + + * net/rcirc.el (rcirc-last-quit-line, rcirc-last-line) + (rcirc-elapsed-lines): New argument PROCESS. Update callers. + (rcirc-print): Only update the line count when not marking the + line as omittable. + (rcirc-log-write): Specify coding system when writing logfile. + (rcirc-markup-fill): Make sure ellipsis does not cause line to wrap. + +2007-11-01 Dan Nicolaescu <dann@ics.uci.edu> + + * printing.el (printing): Fix :version, printing.el was included + for in emacs-22.1. + (pr-path-style, pr-path-alist, pr-txt-name) + (pr-txt-printer-alist, pr-ps-name, pr-ps-printer-alist) + (pr-temp-dir, pr-ps-temp-file, pr-file-modes, pr-gv-command) + (pr-gs-command, pr-gs-switches, pr-gs-device, pr-gs-resolution) + (pr-print-using-ghostscript, pr-file-tumble, pr-auto-region) + (pr-auto-mode, pr-mode-alist, pr-ps-utility) + (pr-ps-utility-alist, pr-menu-char-height, pr-menu-char-width) + (pr-setting-database, pr-visible-entry-list) + (pr-delete-temp-file, pr-list-directory, pr-buffer-name) + (pr-buffer-name-ignore, pr-buffer-verbose): Remove incorrect :version. + + * ediff-util.el (ediff-nuke-selective-display): Move definition to + top level, make it dependent on the emacs flavor. + + * play/gamegrid.el (gamegrid-kill-timer, gamegrid-start-timer): + Test for XEmacs not for itimer. + + * term/sun-mouse.el: + * obsolete/sun-fns.el: + * obsolete/sun-curs.el: Remove files. + + * term/sun.el (select-previous-complex-command): Remove obsolete code. + +2007-10-31 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el (doc-view-cache-directory): Fix bug where an integer + was given to concat. + +2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * doc-view.el (doc-view-mode-map): Bind doc-view-goto-page to the keys + used normally for goto-line. Change `g' to revert the buffer. + Add redundant `r' binding for buffer-revert. + + * mail/mailabbrev.el (mail-abbrevs-mode): Use define-minor-mode. + (mail-abbrevs-setup): Use abbrev-expand-functions. + (build-mail-abbrevs): Use with-temp-buffer. + (define-mail-abbrev): Simplify. + (mail-abbrev-expand-wrapper): Rename sendmail-pre-abbrev-expand-hook. + Change it for use on abbrev-expand-functions. + (mail-abbrev-complete-alias): Use with-syntax-table. + +2007-10-31 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-handle-shell-command): Call `start-file-process' + directly. Fix bug in deleting temp file. + +2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/python.el (python-mode-abbrev-table): Use :regexp. + Merge defvar and define-abbrev-table. + (def-python-skeleton): Use :case-fixed and :enable-function. + (python-abbrev-pc-hook, python-abbrev-syntax-table, python-pea-hook): + Remove. + (python-mode): Don't modify pre-abbrev-expand-hook. + +2007-10-31 Dan Nicolaescu <dann@ics.uci.edu> + + * ediff-util.el (ediff-file-checked-out-p) + (ediff-file-checked-in-p): Only call vc-locking-user for XEmacs. + +2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * abbrev.el (abbrev-symbol): Correct let->let*. + (abbrev--before-point): Only use abbrev-start-location if before point. + +2007-10-31 Juanma Barranquero <lekktu@gmail.com> + + * strokes.el (strokes-alphabetic-lessp): Simplify. Doc fix. + (strokes-unload-hook): Remove function and variable. + (strokes-unload-function): New-style unload function, adapted + from `strokes-unload-hook'. + + * emacs-lisp/cl.el (cl-cannot-unload): Remove function. + (cl-unload-hook): Remove variable. + (cl-unload-function): New-style unload function, adapted + from `cl-cannot-unload'. + + * emacs-lisp/elp.el (elp-unload-hook): Remove function and variable. + (elp-unload-function): New-style unload function, adapted + from `elp-unload-hook'. + +2007-10-31 Sean O'Rourke <sorourke@cs.ucsd.edu> + + * emacs-lisp/find-func.el (find-library): Use library at + point as default interactive argument. + +2007-10-31 Juanma Barranquero <lekktu@gmail.com> + + * shadowfile.el (shadow-join): Remove. + (shadow-shadows): Use `mapconcat' instead of `shadow-join'. + (shadow-initialize): Use `write-file-functions', not `write-file-hooks'. + (shadowfile-unload-hook): Remove function and variable. + (shadowfile-unload-function): New-style unload function, adapted + from `shadowfile-unload-hook'. + +2007-10-31 Dan Nicolaescu <dann@ics.uci.edu> + + * progmodes/mixal-mode.el (mixal-run, mixal-debug): Call mixvm + only if it is bound. + + * textmodes/reftex.el: Move autoloads for before all uses. + (reftex-make-overlay, reftex-overlay-put, reftex-move-overlay) + (reftex-delete-overlay): Move to the top level with the condition + in the body. + + * progmodes/simula.el: Use when instead of if. + + * iimage.el (iimage-locate-file): Define unconditionally. + + * mail/mailabbrev.el (mail-abbrev-next-line): + * emulation/vip.el (vip-enlarge-region, vip-line) + (vip-next-line-at-bol, vip-previous-line) + (vip-previous-line-at-bol, vip-find-char, vip-put-back, ex-read): + Wrap with-no-warnings around uses of next-line and previous-line. + + * ediff.el (run-ediff-from-cvs-buffer): + * ediff-vers.el (cvs-run-ediff-on-file-descriptor): + Remove function not used by pcl-cvs anymore. + (noninteractive, generic-sc-get-latest-rev) + (ediff-generic-sc-internal, ediff-generic-sc-merge-internal): + Delete support for long obsolete generic-sc.el. + +2007-10-31 Glenn Morris <rgm@gnu.org> + + * cvs-status.el: No longer require pcvs when compiling. + + * doc-view.el (doc-view-conversion-refresh-interval) + (doc-view-dvi->pdf, doc-view-pdf/ps->png, doc-view-pdf->txt) + (doc-view-reset-slice): Doc fixes. + (doc-view-menu): Remove deleted function doc-view-edit-doc. + +2007-10-31 Juanma Barranquero <lekktu@gmail.com> + + * help-at-pt.el (help-at-pt-unload-hook): Remove. + Timers are automatically canceled by `unload-feature'. + + * delsel.el (delsel-unload-hook): Remove function and variable. + (delsel-unload-function): New-style unload function, adapted + from `delsel-unload-hook'. + + * msb.el (msb-unload-hook): Remove function and variable. + (msb-unload-function): New-style unload function, adapted from + `msb-unload-hook'. + +2007-10-30 Juanma Barranquero <lekktu@gmail.com> + + * desktop.el (uniquify-managed): Pacify byte compiler. + (desktop-buffer-info): If the buffer name is managed by uniquify, + save the base name, not the uniquified one. + (desktop-create-buffer): Allow `rename-buffer' to generate a new + name in case of conflict. + +2007-10-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * doc-view.el: Use expand-file-name rather than concat. + (doc-view-cache-directory): Add the UID so multiple users won't clash. + (doc-view-current-overlay, doc-view-pending-cache-flush): New vars. + (doc-view-goto-page, doc-view-insert-image, doc-view-buffer-message) + (doc-view-toggle-display): Use an overlay over the whole buffer so as + not to have to touch the buffer's content. + (doc-view-initiate-display): New function, extracted from doc-view-mode. + (doc-view-mode): Use it. Don't mark as a special mode. + Put the page numbers in the modeline. + Set up the overlay. Hide the cursor. Run the mode hook. + Use after-revert-hook rather than revert-buffer-function. + (doc-view-search-internal): Fix typo. + (doc-view-convert-current-doc, doc-view-insert-image): Delay the + image-cache flush. + (doc-view-reconvert-doc): Don't reset the whole mode. + (doc-view-make-safe-dir): New function. + (doc-view-current-cache-dir): Use it. + +2007-10-30 Jason Rumney <jasonr@gnu.org> + + * time.el (display-time-world-list): Test for zoneinfo support. + +2007-10-30 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-maybe-open-connection): Set $LC_ALL to "C". + + * net/tramp-cache.el (tramp-flush-file-function): Check also + `default-directory' if `buffer-file-name' does not return a + string. Added to `eshell-pre-command-hook'. + +2007-10-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * doc-view.el (doc-view-current-doc): Remove. + Replace all uses by buffer-file-name. + (doc-view-menu): New menu. + (doc-view-reconvert-doc): Don't bind inhibit-read-only and remove + unused var `doc'. + (doc-view-sort): Simplify. + (doc-view-buffer-message): Don't change buffer-modified-p. + (doc-view-mode): Change it here instead. + Tighten scoping of prev-major-mode. Don't re-insert the file's content. + Don't modify the global value of revert-buffer-function. + + * image-mode.el (image-forward-hscroll, image-next-line, image-eol) + (image-eob, image-mode, image-minor-mode, image-toggle-display-text) + (image-toggle-display): Take overlays into account and don't assume + point-min==1. + +2007-10-30 Thien-Thi Nguyen <ttn@gnuvola.org> + + * vc.el (vc-annotate): Fix omission bug: + Specify value for vc-sentinel-movepoint. + +2007-10-30 Michael Olson <mwolson@gnu.org> + + * textmodes/remember.el (remember-mode-hook) + (remember-handler-functions, remember-annotation-functions): + Add additional items as options, including some Org functions. + +2007-10-30 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el: Remove cl-dependency. + (doc-view-buffer-message): Mention new binding K. + (doc-view-convert-current-doc): Use function d-v-current-cache-dir + instead of variable. + (doc-view-current-cache-dir): Better cache dir naming. + (doc-view-current-display): Remove variable. + (doc-view-edit-doc, doc-view-display-maybe): Remove functions. + (doc-view-kill-proc): Set converter process to nil. + (doc-view-minor-mode): New minor mode. + (doc-view-minor-mode-map): New keymap. + (doc-view-mode): Remove text/image switching code. Use plain defun. + (doc-view-mode-map): New binding K kills converter process. + Remove C-c C-e binding. + (doc-view-mode-text-map): Remove keymap. + (doc-view-pdf/ps->png): Timer calls d-v-display instead of + d-v-display-maybe. + (doc-view-previous-major-mode): New variable. + (doc-view-ps->pdf): Resort args to make ps2pdf happy. + (doc-view-remove-if): New function. + (doc-view-search-next-match, doc-view-search-previous-match): Use it. + (doc-view-toggle-display): Toggle modes instead of display styles. + (doc-view-reconvert-doc): Adapt to new way of doing things. + + * progmodes/ps-mode.el (ps-mode-map): Enable doc-view-minor-mode. + +2007-10-30 Glenn Morris <rgm@gnu.org> + + * dirtrack.el (dirtrack-mode): Doc fix. + + * shell.el (shell-dirtrack-verbose, shell-mode) + (shell-directory-tracker, shell-dirtrack-mode): Doc fix. + + * emacs-lisp/bytecomp.el (byte-compile-disable-warning) + (byte-compile-enable-warning): Doc fix. + + * emulation/tpu-mapper.el (tpu-map-key): Use with-no-warnings to + suppress byte-opt warning. + +2007-10-30 Dan Nicolaescu <dann@ics.uci.edu> + + * emulation/edt.el (edt-emacs19-p, edt-x-emacs19-p) + (edt-gnu-emacs19-p): Remove. + (edt-emacs-variant, edt-window-system): Use feature 'emacs. + (edt-xserver, edt-page-backward, edt-beginning-of-line) + (edt-end-of-line-forward, edt-end-of-line-backward) + (edt-one-word-forward, edt-one-word-backward, edt-character) + (edt-line-forward, edt-next-line, edt-previous-line, edt-top) + (edt-find-forward, edt-find-backward, edt-find-next-forward) + (edt-find-next-backward, edt-reset, edt-advance, edt-backup) + (edt-define-key, edt-bottom-check, edt-sentence-forward) + (edt-sentence-backward, edt-paragraph-forward) + (edt-paragraph-backward, edt-restore-key, edt-window-top) + (edt-window-bottom, edt-scroll-window-forward-line) + (edt-scroll-window-backward-line, edt-line-to-bottom-of-window) + (edt-line-to-top-of-window, edt-paragraph-backward) + (edt-restore-key, edt-window-top, edt-window-bottom) + (edt-scroll-window-forward-line) + (edt-scroll-window-backward-line, edt-line-to-bottom-of-window) + (edt-line-to-middle-of-window, edt-goto-percentage) + (edt-display-the-time, edt-remember, edt-split-window) + (edt-emulation-on, edt-emulation-off) + (edt-default-emulation-setup, edt-user-emulation-setup) + (edt-select-default-global-map, edt-select-user-global-map): + Replace uses of edt-x-emacs19-p and edt-gnu-emacs19-p with feature + tests. + + * textmodes/reftex-index.el (reftex-index-selection-or-word): + Use feature test instead of boundp test so it can be resolved at + compile time. + + * net/newsticker.el (replace-regexp-in-string): Only define for + XEmacs. + +2007-10-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * abbrev.el: Rename `count' and `system-flag' to :count and :system. + Update all users. + (abbrev-get, abbrev-put): Simplify. + (define-abbrev): Don't store the `force' value in the :system property. + (abbrev--before-point): Obey the :enable-function of the abbrev as well. + +2007-10-30 Michael Olson <mwolson@gnu.org> + + * desktop.el (desktop-minor-mode-table): Add line for ERC. + + * textmodes/remember.el: New file that implements a mode for + quickly jotting down things to remember. + + * textmodes/remember-diary.el: A backend for remember.el that + implements saving notes to a Diary file. + +2007-10-29 Ken Manheimer <ken.manheimer@gmail.com> + + * allout.el (allout-command-prefix, allout-inhibit-auto-fill): + Relocate in file. + (allout-doublecheck-at-and-shallower): Increase to include + slightly greater depths, since yank interaction is now ok. + Also, elaborate the docstring to explain the situation. + (produce-allout-mode-map, allout-hotspot-key-handler): Use vconcat + instead of concat, so we accommodate key sequences expressed as + vectors as well as strings and lists. + (allout-flag-region, allout-hide-by-annotation): Make the + hidden-text overlays 'front-advance. + (allout-overlay-insert-in-front-handler): Correct docstring's grammar. + (allout-aberrant-container-p, allout-on-current-heading-p) + (allout-e-o-prefix-p, allout-next-heading) + (allout-previous-heading, allout-goto-prefix) + (allout-end-of-prefix, allout-next-sibling-leap) + (allout-next-visible-heading, allout-auto-fill) + (allout-rebullet-heading, allout-kill-line, allout-kill-topic) + (allout-yank-processing, allout-resolve-xref) + (allout-current-topic-collapsed-p, allout-hide-region-body) + (allout-latex-verbatim-quote-curr-line, allout-encrypt-string) + (allout-encrypted-topic-p, allout-next-topic-pending-encryption) + (count-trailing-whitespace-region): Preserve match data, so allout + outline navigation doesn't disrupt other Emacs operations. + (allout-beginning-of-line): Retreat to the beginning of the hidden + text, so fields are respected (for submodes that care). + (allout-end-of-line): Preserve mark activation status when jumping. + (allout-open-topic): Account for opening after a child that + contains a hidden trailing newline. Preserve match data. + Run allout-structure-added-hook + (allout-encrypt-decrypted): Preserve match data. + (allout-toggle-current-subtree-exposure): Add new interactive + function for toggle subtree exposure - suggested by tassilo. + (move-beginning-of-line, move-end-of-line): Don't use + line-move-invisible-p, it's obsolete - substitute the code, + instead. + +2007-10-29 Dan Nicolaescu <dann@ics.uci.edu> + + * textmodes/flyspell.el (message-signature-separator): + * longlines.el (message-indent-citation-function): Pacify byte + compiler. + + * emacs-lisp/cl-loaddefs.el: + * ldefs-boot.el: Regenerate. + + * Makefile.in (BYTE_COMPILE_EXTRA_FLAGS): New variable. + (.el.elc, compile, compile-always, compile-calc) + ($(lisp)/progmodes/cc-mode.elc): Use it. + + * ps-print.el (ps-xemacs-color-name, ps-xemacs-face-kind-p): + Only do work for XEmacs. + (ps-xemacs-mapper): Rename from ps-mapper, only work on XEmacs. + (ps-xemacs-extent-sorter): Rename from ps-extent-sorter, only work + on XEmacs. + (ps-x-color-instance-p, ps-x-color-instance-rgb-components) + (ps-x-color-name, ps-x-color-specifier-p) + (ps-x-copy-coding-system, ps-x-device-class) + (ps-x-extent-end-position, ps-x-extent-face) + (ps-x-extent-priority, ps-x-extent-start-position) + (ps-x-face-font-instance, ps-x-find-coding-system) + (ps-x-font-instance-properties, ps-x-make-color-instance) + (ps-x-map-extents, ps-e-face-bold-p, ps-e-face-italic-p) + (ps-e-next-overlay-change, ps-e-overlays-at, ps-e-overlay-get) + (ps-e-overlay-end, ps-e-x-color-values, ps-e-color-values): + (ps-generate-postscript-with-faces): Delete defaliases. + (ps-face-foreground-name, ps-face-background-name) + (ps-color-values, ps-face-bold-p, ps-face-italic-p): + Move definitions to top level, make the body conditional on the Emacs + flavor. Replace uses of deleted aliases and renamed functions. + (ps-generate-postscript-with-faces, ps-color-device): Replace uses + of deleted aliases and renamed functions. + + * calc/calc.el (calc-emacs-type-lucid): Remove. + (calc-digit-map, calcDigit-start, calc-read-key) + (calc-clear-unread-commands): + * calc/calc-ext.el (calc-user-key-map): Replace uses of + calc-emacs-type-lucid with (featurep 'xemacs) + + * emulation/tpu-mapper.el: Replace tpu-lucid-emacs19-p with + (featurep 'xemacs). + (tpu-lucid-emacs19-p): Remove. + (tpu-map-key): Make it a function instead of using fset. Inline + tpu-emacs-map-key and tpu-lucid-map-key. Use featurep 'xemacs. + (tpu-emacs-map-key, tpu-lucid-map-key): Remove. + + * ielm.el: Use featurep 'xemacs. + + * progmodes/cperl-mode.el (cperl-xemacs-p): Remove. + (condition-case, cperl-can-font-lock, cperl-singly-quote-face) + (cperl-define-key, cperl-mode-map, cperl-mode, cperl-init-faces) + (cperl-write-tags, cperl-tags-hier-init, cperl-perldoc): Replace + cperl-xemacs-p with (featurep 'xemacs). + (font-lock-cache-position): Pacify byte compiler. + +2007-10-29 Drew Adams <drew.adams@oracle.com> + + * faces.el (read-color): New function. + (face-at-point, foreground-color-at-point) + (background-color-at-point): New functions. + +2007-10-28 Richard Stallman <rms@gnu.org> + + * net/browse-url.el (browse-url-text-xterm): Rename from + browse-url-lynx-xterm and made generic. + (browse-url-text-emacs): Likewise. + (browse-url-text-browser): New variable. + (browse-url-text-emacs-args): Rename from browse-url-lynx-emacs-args. + (browse-url-text-input-field, browse-url-text-input-attempts) + (browse-url-kde-program): Likewise. + +2007-10-29 Glenn Morris <rgm@gnu.org> + + * textmodes/org-publish.el (org-publish-get-plist-from-filename): + Use mapc rather than mapcar (reinstall change deleted without log + entry 2007-10-22). + +2007-10-29 Martin Rudalics <rudalics@gmx.at> + + * wdired.el (wdired-next-line, wdired-previous-line): + Use next-line and previous-line wrapped in with-no-warnings. + +2007-10-29 Ryan Yeske <rcyeske@gmail.com> + + * net/rcirc.el (rcirc-server-alist): Use keywords for parameter names. + (rcirc-recent-quit-alist): New function. + (rcirc): Print a better message when there is only one connected server. + (rcirc-complete-nick): Do not update the nick table here. + (rcirc-mode-map): Add M-o. + (rcirc-current-line): Add variable. + (rcirc-mode): Setup variables for line based omit. + (rcirc-edit-multiline): Strip text properties. + (rcirc-omit-responses): Add NICK. + (rcirc-omit-threshold): Add variable. + (rcirc-last-quit-line, rcirc-last-line, rcirc-elapsed-lines): + Add functions. + (rcirc-print): Keep track of current line. Do not fill text if + `rcirc-fill-flag' is null. Only omit text if the last activity + from the sender is more than `rcirc-omit-threshold' lines ago. + (rcirc-put-nick-channel, rcirc-handler-PRIVMSG): Track line + numbers instead of time. + (rcirc-channel-nicks): Sort by line numbers instead of time. + (rcirc-omit-mode): Add `...' when omitting text and recenter. + (rcirc-handler-JOIN): Restore the joiners linestamp. + (rcirc-maybe-remember-nick-quit): Add function. + (rcirc-handler-QUIT): Record sender in table of recently quit nicks. + +2007-10-29 Juanma Barranquero <lekktu@gmail.com> + + * loadhist.el (unload-feature-special-hooks): + Add `delete-frame-functions' and `suspend-tty-functions'. + + * server.el (server-unload-function): Rename from `server-unload-hook' + and adapt to new `unload-feature' functionality. Remove hook from + `kill-buffer-hook' buffer-locally. + (server-unload-hook): Remove. + (server-unload-function): New var; replaces `server-unload-hook'. + +2007-10-29 Glenn Morris <rgm@gnu.org> + + * dirtrack.el (dirtrack-debug): Doc fix. + (dirtrack-mode, dirtrack-debug-mode): New names for + dirtrack-toggle and dirtrack-debug-toggle. Use define-minor-mode. + (dirtrack-toggle, dirtrack-debug-toggle, dirtrackp, dirtrack-debug): + Make obsolete. + (dirtrack-debug-message): Only print message if + dirtrack-debug-mode is non-nil. Use with-current-buffer. + (dirtrack): Doc fix. Use dirtrack-mode rather than dirtrackp. + Remove dirtrack-debug checks now that dirtrack-debug-message does this. + +2007-10-28 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/bytecomp.el (byte-compile-warnings): Document `not'. + (byte-compile-warnings-safe-p): Handle `not'. + (byte-compile-warning-enabled-p, byte-compile-disable-warning) + (byte-compile-enable-warning): New functions. + (byte-compile-eval-before-compile) + (byte-compile-file-form-require): Use byte-compile-disable-warning. + (byte-compile-close-variables): Locally bind byte-compile-warnings, + but do not modify it. + (byte-compile-eval, byte-compile-obsolete) + (byte-compile-warn-about-unresolved-functions) + (byte-compile-file-form-defvar) + (byte-compile-file-form-custom-declare-variable) + (byte-compile-file-form-require) + (byte-compile-file-form-defmumble, byte-compile-lambda) + (byte-compile-form, byte-compile-normal-call) + (byte-compile-variable-ref, byte-compile-defvar) + (byte-compile-make-variable-buffer-local): + Use byte-compile-warning-enabled-p. + * emacs-lisp/advice.el (ad-compile-function): + Use byte-compile-disable-warning. + * emacs-lisp/cl.el: Move local variables to end of file, and set + byte-compile-warnings to `(not cl-functions)'. + * emacs-lisp/cl-compat.el: Add a local variables section, and set + byte-compile-warnings to `(not cl-functions)'. + * emacs-lisp/cl-macs.el: Unify local variable section, and set + byte-compile-warnings to `(not cl-functions)'. + (cl-do-proclaim): Use byte-compile-disable-warning and + byte-compile-enable-warning. + * emacs-lisp/cl-seq.el: Unify local variable section, and set + byte-compile-warnings to `(not cl-functions)'. + * progmodes/cc-bytecomp.el (cc-bytecomp-ignore-obsolete): + Use byte-compile-disable-warning. + +2007-10-28 Dan Nicolaescu <dann@ics.uci.edu> + + * cus-edit.el (custom-browse-insert-prefix): + * emulation/edt.el (edt-x-emacs19-p): Use featurep 'xemacs. + +2007-10-28 Juanma Barranquero <lekktu@gmail.com> + + * server.el (server-process-filter): Fix typo in docstring. + (server-log): Reflow docstrings. + (server-delete-client, server-kill-emacs-query-function): Doc fixes. + (server-goto-line-column): Use `when'. + +2007-10-28 Juri Linkov <juri@jurta.org> + + * isearch.el (isearch-other-meta-char): Call `isearch-edit-string' + when mouse is clicked on the isearch message. + (isearch-resume): Call `isearch-update' at the end. + Rename argument `search' to `string' to conform to the + isearch terminology. + +2007-10-28 Stefan Monnier <monnier@iro.umontreal.ca> + + Rewrite abbrev.c in Elisp. + * abbrev.el (abbrev-mode): Move custom group from cus-edit.el. + (abbrev-table-get, abbrev-table-put, abbrev-get) + (abbrev-put, make-abbrev-table, abbrev-table-p, clear-abbrev-table) + (define-abbrev, abbrev--check-chars, define-global-abbrev) + (define-mode-abbrev, abbrev--active-tables, abbrev-symbol) + (abbrev-expansion, abbrev--before-point, expand-abbrev) + (unexpand-abbrev, abbrev--write, abbrev--describe) + (insert-abbrev-table-description, define-abbrev-table): + New funs, largely transcribed from abbrev.c. + (abbrev-with-wrapper-hook): New macro. + (abbrev-table-name-list, global-abbrev-table) + (abbrev-minor-mode-table-alist, fundamental-mode-abbrev-table) + (abbrevs-changed, abbrev-all-caps, abbrev-start-location) + (abbrev-start-location-buffer, last-abbrev, last-abbrev-text) + (last-abbrev-location, pre-abbrev-expand-hook, abbrev-expand-function): + New vars, largely transcribed from abbrev.c. + * cus-edit.el (abbrev-mode): Remove. Move to abbrev.el. + * cus-start.el: Remove abbrev-all-caps and pre-abbrev-expand-hook. + * loadup.el: Load "abbrev.el" before "lisp-mode.el". + +2007-10-27 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * ps-print.el: Now detect if text foreground and background colors are + equal and replace the foreground color by another color, so the text + becomes visible. Doc fix. + (ps-print-version): New version 6.8. + (ps-default-fg, ps-default-bg): Docstring fix. + (ps-postscript-code-directory): Fix default value code. + (ps-fg-list, ps-fg-validate-p): New options. + (ps-foreground-list): New var. + (ps-setup, ps-begin-job, ps-plot-region): Fix code. + +2007-10-27 Glenn Morris <rgm@gnu.org> + + * shell.el (shell-dirtrack-verbose, shell-directory-tracker): Doc fix. + (shell-dirtrack-toggle): Mark as obsolete. + (dirtrack-toggle, dirtrack-mode): No longer alias to + shell-dirtrack-mode. + +2007-10-27 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc.el (math-standard-opers): Lower the precedence + of negation. + * calc/calc-lang.el (math-oper-table): Lower precedence of + negation for C, TeX, and eqn. + +2007-10-27 Dan Nicolaescu <dann@ics.uci.edu> + + * progmodes/cc-defs.el: Reorder conditions to avoid warnings. + +2007-10-27 Juanma Barranquero <lekktu@gmail.com> + + * desktop.el (desktop-load-locked-desktop, desktop-base-lock-name) + (desktop-not-loaded-hook): Fix :version tags. + +2007-10-27 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-wrong-passwd-regexp): Tune regexp. + (tramp-get-remote-tmpdir): New defun. + (tramp-make-tramp-temp-file): Use it. + (tramp-local-call-process): New defun. Replace all calls of + `call-process' by this when appropriate. + (tramp-handle-write-region): Replace calls of `file-attributes' by + `tramp-compat-file-attributes'. + (tramp-find-shell, tramp-open-connection-setup-interactive-shell): + Make the first command a `tramp-send-command' call, with let-bind + of `tramp-end-of-output'. + (tramp-version, tramp-bug, tramp-reporter-dump-variable) + (tramp-load-report-modules, tramp-append-tramp-buffers): + Move to tramp-cmds.el. + + * net/tramp-fish.el (tramp-fish-handle-copy-file) + (tramp-fish-do-copy-or-rename-file) + (tramp-fish-do-copy-or-rename-file-directly): + * net/tramp-smb.el (tramp-smb-handle-copy-file): + Add parameter PRESERVE-UID-GID. + +2007-10-27 Eli Zaretskii <eliz@gnu.org> + + * time.el (zoneinfo-style-world-list, legacy-style-world-list): + New defcustoms. + (display-time-world-list): Use them as appropriate for the current + value of `system-type'. + +2007-10-26 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * printing.el: Pacify byte compiler, that is, no compiler warnings. + Move (again) some variable definitions before use, define some fun + aliases, no code change. + (pr-version): New version 6.9.2. + (pr-path-style, pr-auto-region, pr-menu-char-height) + (pr-menu-char-width, pr-menu-lock, pr-ps-printer-alist) + (pr-txt-printer-alist, pr-ps-utility-alist): Options declaration + via (defvar VAR). + (pr-menu-lookup, pr-menu-lock, pr-menu-alist, pr-even-or-odd-pages) + (pr-menu-get-item, pr-menu-set-item-name, pr-menu-set-utility-title) + (pr-menu-set-ps-title, pr-menu-set-txt-title, pr-region-active-p) + (pr-do-update-menus, pr-update-mode-line, pr-f-read-string) + (pr-f-set-keymap-parents, pr-keep-region-active): Fun aliases. + (pr-menu-print-item, pr-ps-printer-menu-modified) + (pr-txt-printer-menu-modified, pr-ps-utility-menu-modified) + (pr-even-or-odd-alist): Vars definition moved. + 2007-10-26 Dan Nicolaescu <dann@ics.uci.edu> * emulation/pc-select.el (next-line-mark, next-line-nomark) (previous-line-mark, previous-line-nomark): Wrap with-no-warnings around uses of previous-line and next-line. - * diff.el (diff-old-file, diff-new-file, diff-extra-args): New - defvars. + * diff.el (diff-old-file, diff-new-file, diff-extra-args): + New defvars. * textmodes/css-mode.el (comment-continue): * net/browse-url.el (url-handler-regexp): - * progmodes/idlw-help.el (idlwave-system-routines): Pacify - byte-compiler. + * progmodes/idlw-help.el (idlwave-system-routines): + Pacify byte-compiler. * textmodes/fill.el (fill-nobreak-p): Replace obsolete alias - line-move-invisible-p it's former definition: - invisible-p. line-move-invisible-p was removed on 2007-08-29. + line-move-invisible-p with its former definition: invisible-p. + line-move-invisible-p was removed on 2007-08-29. 2007-10-26 Juanma Barranquero <lekktu@gmail.com> @@ -145,7 +1326,7 @@ * savehist.el (savehist-save): Omit unreadable elements. - * loadhist.el (unload-function-defs-list): Renamed from + * loadhist.el (unload-function-defs-list): Rename from unload-function-features-list. (unload-feature-special-hooks, unload-feature): Doc fixes. @@ -309,6 +1490,17 @@ Call isearch-buffers-minor-mode. (change-log-next-buffer): New function. +2007-10-22 Bastien Guerry <Bastien.Guerry@ens.fr> + + * org-export-latex.el (org-export-latex-protect-string): + Renaming of `org-latex-protect'. + (org-export-latex-emphasis-alist): By default, don't protect + any emphasis formatter from further conversion. + (org-export-latex-tables): Honor column grouping for tables. + (org-export-latex-title-command): New option. + (org-export-latex-treat-backslash-char): Use \textbackslash{} to + export backslash character. + 2007-10-22 Carsten Dominik <dominik@science.uva.nl> * textmodes/org.el (org-read-date-get-relative): New function. @@ -1335,7 +2527,6 @@ * follow.el (follow-stop-intercept-process-output): Use `follow-call-process-filter' rather than `process-filter'. Simplify. - * vc.el (vc0iff): Prevent errors in an edge case. 2007-10-11 Eric S. Raymond <esr@snark.thyrsus.com> @@ -3029,11 +4220,11 @@ * textmodes/org.el (org-re): Also replace the :alpha: class. (org-todo-tag-alist): Variable removed. - (org-todo-key-alist, org-todo-key-trigger) New variables. + (org-todo-key-alist, org-todo-key-trigger): New variables. (org-use-fast-todo-selection): New option. (org-log-done): Docstring fixed. (org-deadline-warning-days): New default value 14. - (org-edit-timestamp-down-means-later) New option. + (org-edit-timestamp-down-means-later): New option. (org-tag-alist): Docstring fixed. (org-fast-tag-selection-include-todo): New option. (org-export-language-setup): New languages added. diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 39d74ce003e..06457607c5a 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -35,6 +35,12 @@ EMACS = ../src/emacs EMACSOPT = -batch --no-site-file --multibyte +# Extra flags to pass to the byte compiler +BYTE_COMPILE_EXTRA_FLAGS = +# For example to not display the undefined function warnings you can use this: +# BYTE_COMPILE_EXTRA_FLAGS = --eval '(setq byte-compile-warnings (quote (not unresolved)))' +# The example above is just for developers, it should not be used by default. + SOURCES = *.el COPYING Makefile lisptagsfiles1 = $(lisp)/[a-zA-Z]*.el lisptagsfiles2 = $(lisp)/[a-zA-Z]*/[a-zA-Z]*.el @@ -143,7 +149,7 @@ TAGS-LISP: $(lisptagsfiles1) $(lisptagsfiles2) .SUFFIXES: .elc .el .el.elc: $(lisp)/subdirs.el - -$(emacs) -f batch-byte-compile $< + -$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $< # Compile all Lisp files, but don't recompile those that are up to # date. Some files don't actually get compiled because they set the @@ -168,7 +174,7 @@ compile: $(lisp)/subdirs.el mh-autoloads doit if test -f $$el; \ then \ echo Compiling $$el; \ - $(emacs) -f batch-byte-compile-if-not-done $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile-if-not-done $$el || exit 1; \ fi \ done @@ -187,14 +193,14 @@ compile-always: $(lisp)/subdirs.el mh-autoloads doit if test -f $$el; \ then \ echo Compiling $$el; \ - $(emacs) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ fi \ done compile-calc: for el in `find $(lisp)/calc -name '*.el'`; do \ echo Compiling $$el; \ - $(emacs) -f batch-byte-compile $$el || exit 1; \ + $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \ done # Backup compiled Lisp files in elc.tar.gz. If that file already @@ -221,7 +227,7 @@ $(lisp)/progmodes/cc-mode.elc: \ $(lisp)/progmodes/cc-mode.el \ $(lisp)/progmodes/cc-langs.el \ $(lisp)/progmodes/cc-defs.el - $(emacs) -f batch-byte-compile $(lisp)/progmodes/cc-mode.el + $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $(lisp)/progmodes/cc-mode.el # Update MH-E internal autoloads. These are not to be confused with # the autoloads for the MH-E entry points, which are already in diff --git a/lisp/abbrev.el b/lisp/abbrev.el index b2b03fe63bb..0c140a84159 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -27,8 +27,20 @@ ;; This facility is documented in the Emacs Manual. +;; Todo: + +;; - Make abbrev-file-name obey user-emacs-directory. +;; - Cleanup name space. + ;;; Code: +(eval-when-compile (require 'cl)) + +(defgroup abbrev-mode nil + "Word abbreviations mode." + :link '(custom-manual "(emacs)Abbrevs") + :group 'abbrev) + (defcustom only-global-abbrevs nil "Non-nil means user plans to use global abbrevs only. This makes the commands that normally define mode-specific abbrevs @@ -363,6 +375,538 @@ A prefix argument means don't query; expand all abbrevs." (if (or noquery (y-or-n-p (format "Expand `%s'? " string))) (expand-abbrev))))))) +;;; Abbrev properties. + +(defun abbrev-table-get (table prop) + "Get the PROP property of abbrev table TABLE." + (let ((sym (intern-soft "" table))) + (if sym (get sym prop)))) + +(defun abbrev-table-put (table prop val) + "Set the PROP property of abbrev table TABLE to VAL." + (let ((sym (intern "" table))) + (set sym nil) ; Make sure it won't be confused for an abbrev. + (put sym prop val))) + +(defalias 'abbrev-get 'get + "Get the property PROP of abbrev ABBREV + +\(fn ABBREV PROP)") + +(defalias 'abbrev-put 'put + "Set the property PROP of abbrev ABREV to value VAL. +See `define-abbrev' for the effect of some special properties. + +\(fn ABBREV PROP VAL)") + +(defmacro abbrev-with-wrapper-hook (var &rest body) + "Run BODY wrapped with the VAR hook. +VAR is a special hook: its functions are called with one argument which +is the \"original\" code (the BODY), so the hook function can wrap the +original function, can call it several times, or even not call it at all. +VAR is normally a symbol (a variable) in which case it is treated like a hook, +with a buffer-local and a global part. But it can also be an arbitrary expression. +This is similar to an `around' advice." + (declare (indent 1) (debug t)) + ;; We need those two gensyms because CL's lexical scoping is not available + ;; for function arguments :-( + (let ((funs (make-symbol "funs")) + (global (make-symbol "global"))) + ;; Since the hook is a wrapper, the loop has to be done via + ;; recursion: a given hook function will call its parameter in order to + ;; continue looping. + `(labels ((runrestofhook (,funs ,global) + ;; `funs' holds the functions left on the hook and `global' + ;; holds the functions left on the global part of the hook + ;; (in case the hook is local). + (lexical-let ((funs ,funs) + (global ,global)) + (if (consp funs) + (if (eq t (car funs)) + (runrestofhook (append global (cdr funs)) nil) + (funcall (car funs) + (lambda () (runrestofhook (cdr funs) global)))) + ;; Once there are no more functions on the hook, run + ;; the original body. + ,@body)))) + (runrestofhook ,var + ;; The global part of the hook, if any. + ,(if (symbolp var) + `(if (local-variable-p ',var) + (default-value ',var))))))) + + +;;; Code that used to be implemented in src/abbrev.c + +(defvar abbrev-table-name-list '(fundamental-mode-abbrev-table + global-abbrev-table) + "List of symbols whose values are abbrev tables.") + +(defun make-abbrev-table (&optional props) + "Create a new, empty abbrev table object. +PROPS is a " + ;; The value 59 is an arbitrary prime number. + (let ((table (make-vector 59 0))) + ;; Each abbrev-table has a `modiff' counter which can be used to detect + ;; when an abbreviation was added. An example of use would be to + ;; construct :regexp dynamically as the union of all abbrev names, so + ;; `modiff' can let us detect that an abbrev was added and hence :regexp + ;; needs to be refreshed. + ;; The presence of `modiff' entry is also used as a tag indicating this + ;; vector is really an abbrev-table. + (abbrev-table-put table :abbrev-table-modiff 0) + (while (consp props) + (abbrev-table-put table (pop props) (pop props))) + table)) + +(defun abbrev-table-p (object) + (and (vectorp object) + (numberp (abbrev-table-get object :abbrev-table-modiff)))) + +(defvar global-abbrev-table (make-abbrev-table) + "The abbrev table whose abbrevs affect all buffers. +Each buffer may also have a local abbrev table. +If it does, the local table overrides the global one +for any particular abbrev defined in both.") + +(defvar abbrev-minor-mode-table-alist nil + "Alist of abbrev tables to use for minor modes. +Each element looks like (VARIABLE . ABBREV-TABLE); +ABBREV-TABLE is active whenever VARIABLE's value is non-nil.") + +(defvar fundamental-mode-abbrev-table + (let ((table (make-abbrev-table))) + ;; Set local-abbrev-table's default to be fundamental-mode-abbrev-table. + (setq-default local-abbrev-table table) + table) + "The abbrev table of mode-specific abbrevs for Fundamental Mode.") + +(defvar abbrevs-changed nil + "Set non-nil by defining or altering any word abbrevs. +This causes `save-some-buffers' to offer to save the abbrevs.") + +(defcustom abbrev-all-caps nil + "Non-nil means expand multi-word abbrevs all caps if abbrev was so." + :type 'boolean + :group 'abbrev-mode) + +(defvar abbrev-start-location nil + "Buffer position for `expand-abbrev' to use as the start of the abbrev. +When nil, use the word before point as the abbrev. +Calling `expand-abbrev' sets this to nil.") + +(defvar abbrev-start-location-buffer nil + "Buffer that `abbrev-start-location' has been set for. +Trying to expand an abbrev in any other buffer clears `abbrev-start-location'.") + +(defvar last-abbrev nil + "The abbrev-symbol of the last abbrev expanded. See `abbrev-symbol'.") + +(defvar last-abbrev-text nil + "The exact text of the last abbrev expanded. +nil if the abbrev has already been unexpanded.") + +(defvar last-abbrev-location 0 + "The location of the start of the last abbrev expanded.") + +;; (defvar local-abbrev-table fundamental-mode-abbrev-table +;; "Local (mode-specific) abbrev table of current buffer.") +;; (make-variable-buffer-local 'local-abbrev-table) + +(defcustom pre-abbrev-expand-hook nil + "Function or functions to be called before abbrev expansion is done. +This is the first thing that `expand-abbrev' does, and so this may change +the current abbrev table before abbrev lookup happens." + :type 'hook + :group 'abbrev-mode) +(make-obsolete-variable 'pre-abbrev-expand-hook 'abbrev-expand-functions "23.1") + +(defun clear-abbrev-table (table) + "Undefine all abbrevs in abbrev table TABLE, leaving it empty." + (setq abbrevs-changed t) + (dotimes (i (length table)) + (aset table i 0))) + +(defun define-abbrev (table name expansion &optional hook &rest props) + "Define an abbrev in TABLE named NAME, to expand to EXPANSION and call HOOK. +NAME must be a string, and should be lower-case. +EXPANSION should usually be a string. +To undefine an abbrev, define it with EXPANSION = nil. +If HOOK is non-nil, it should be a function of no arguments; +it is called after EXPANSION is inserted. +If EXPANSION is not a string, the abbrev is a special one, + which does not expand in the usual way but only runs HOOK. + +PROPS is a property list. The following properties are special: +- `:count': the value for the abbrev's usage-count, which is incremented each time + the abbrev is used (the default is zero). +- `:system': if non-nil, says that this is a \"system\" abbreviation + which should not be saved in the user's abbreviation file. + Unless `:system' is `force', a system abbreviation will not + overwrite a non-system abbreviation of the same name. +- `:case-fixed': non-nil means that abbreviations are looked up without + case-folding, and the expansion is not capitalized/upcased. +- `:enable-function': a function of no argument which returns non-nil iff the + abbrev should be used for a particular call of `expand-abbrev'. + +An obsolete but still supported calling form is: + +\(define-abbrev TABLE NAME EXPANSION &optional HOOK COUNT SYSTEM)." + (when (and (consp props) (or (null (car props)) (numberp (car props)))) + ;; Old-style calling convention. + (setq props (list* :count (car props) + (if (cadr props) (list :system (cadr props)))))) + (unless (plist-get props :count) + (setq props (plist-put props :count 0))) + (let ((system-flag (plist-get props :system)) + (sym (intern name table))) + ;; Don't override a prior user-defined abbrev with a system abbrev, + ;; unless system-flag is `force'. + (unless (and (not (memq system-flag '(nil force))) + (boundp sym) (symbol-value sym) + (not (abbrev-get sym :system))) + (unless (or system-flag + (and (boundp sym) (fboundp sym) + ;; load-file-name + (equal (symbol-value sym) expansion) + (equal (symbol-function sym) hook))) + (setq abbrevs-changed t)) + (set sym expansion) + (fset sym hook) + (setplist sym + ;; Don't store the `force' value of `system-flag' into + ;; the :system property. + (if (eq 'force system-flag) (plist-put props :system t) props)) + (abbrev-table-put table :abbrev-table-modiff + (1+ (abbrev-table-get table :abbrev-table-modiff)))) + name)) + +(defun abbrev--check-chars (abbrev global) + "Check if the characters in ABBREV have word syntax in either the +current (if global is nil) or standard syntax table." + (with-syntax-table + (cond ((null global) (standard-syntax-table)) + ;; ((syntax-table-p global) global) + (t (syntax-table))) + (when (string-match "\\W" abbrev) + (let ((badchars ()) + (pos 0)) + (while (string-match "\\W" abbrev pos) + (pushnew (aref abbrev (match-beginning 0)) badchars) + (setq pos (1+ pos))) + (error "Some abbrev characters (%s) are not word constituents %s" + (apply 'string (nreverse badchars)) + (if global "in the standard syntax" "in this mode")))))) + +(defun define-global-abbrev (abbrev expansion) + "Define ABBREV as a global abbreviation for EXPANSION. +The characters in ABBREV must all be word constituents in the standard +syntax table." + (interactive "sDefine global abbrev: \nsExpansion for %s: ") + (abbrev--check-chars abbrev 'global) + (define-abbrev global-abbrev-table (downcase abbrev) expansion)) + +(defun define-mode-abbrev (abbrev expansion) + "Define ABBREV as a mode-specific abbreviation for EXPANSION. +The characters in ABBREV must all be word-constituents in the current mode." + (interactive "sDefine mode abbrev: \nsExpansion for %s: ") + (unless local-abbrev-table + (error "Major mode has no abbrev table")) + (abbrev--check-chars abbrev nil) + (define-abbrev local-abbrev-table (downcase abbrev) expansion)) + +(defun abbrev--active-tables (&optional tables) + "Return the list of abbrev tables currently active. +TABLES if non-nil overrides the usual rules. It can hold +either a single abbrev table or a list of abbrev tables." + ;; We could just remove the `tables' arg and let callers use + ;; (or table (abbrev--active-tables)) but then they'd have to be careful + ;; to treat the distinction between a single table and a list of tables. + (cond + ((consp tables) tables) + ((vectorp tables) (list tables)) + (t + (let ((tables (if (listp local-abbrev-table) + (append local-abbrev-table + (list global-abbrev-table)) + (list local-abbrev-table global-abbrev-table)))) + ;; Add the minor-mode abbrev tables. + (dolist (x abbrev-minor-mode-table-alist) + (when (and (symbolp (car x)) (boundp (car x)) (symbol-value (car x))) + (setq tables + (if (listp (cdr x)) + (append (cdr x) tables) (cons (cdr x) tables))))) + tables)))) + + +(defun abbrev-symbol (abbrev &optional table) + "Return the symbol representing abbrev named ABBREV. +This symbol's name is ABBREV, but it is not the canonical symbol of that name; +it is interned in an abbrev-table rather than the normal obarray. +The value is nil if that abbrev is not defined. +Optional second arg TABLE is abbrev table to look it up in. +The default is to try buffer's mode-specific abbrev table, then global table." + (let ((tables (abbrev--active-tables table)) + sym) + (while (and tables (not (symbol-value sym))) + (let* ((table (pop tables)) + (case-fold (not (abbrev-table-get table :case-fixed)))) + (setq tables (append (abbrev-table-get table :parents) tables)) + ;; In case the table doesn't set :case-fixed but some of the + ;; abbrevs do, we have to be careful. + (setq sym + ;; First try without case-folding. + (or (intern-soft abbrev table) + (when case-fold + ;; We didn't find any abbrev, try case-folding. + (let ((sym (intern-soft (downcase abbrev) table))) + ;; Only use it if it doesn't require :case-fixed. + (and sym (not (abbrev-get sym :case-fixed)) + sym))))))) + (if (symbol-value sym) + sym))) + + +(defun abbrev-expansion (abbrev &optional table) + "Return the string that ABBREV expands into in the current buffer. +Optionally specify an abbrev table as second arg; +then ABBREV is looked up in that table only." + (symbol-value (abbrev-symbol abbrev table))) + + +(defun abbrev--before-point () + "Try and find an abbrev before point. Return it if found, nil otherwise." + (unless (eq abbrev-start-location-buffer (current-buffer)) + (setq abbrev-start-location nil)) + + (let ((tables (abbrev--active-tables)) + (pos (point)) + start end name res) + + (if abbrev-start-location + (progn + (setq start abbrev-start-location) + (setq abbrev-start-location nil) + ;; Remove the hyphen inserted by `abbrev-prefix-mark'. + (if (and (< start (point-max)) + (eq (char-after start) ?-)) + (delete-region start (1+ start))) + (skip-syntax-backward " ") + (setq end (point)) + (when (> end start) + (setq name (buffer-substring start end)) + (goto-char pos) ; Restore point. + (list (abbrev-symbol name tables) name start end))) + + (while (and tables (not (car res))) + (let* ((table (pop tables)) + (enable-fun (abbrev-table-get table :enable-function))) + (setq tables (append (abbrev-table-get table :parents) tables)) + (setq res + (and (or (not enable-fun) (funcall enable-fun)) + (looking-back (or (abbrev-table-get table :regexp) + "\\<\\(\\w+\\)\\W*") + (line-beginning-position)) + (setq start (match-beginning 1)) + (setq end (match-end 1)) + (setq name (buffer-substring start end)) + (let ((abbrev (abbrev-symbol name table))) + (when abbrev + (setq enable-fun (abbrev-get abbrev :enable-function)) + (and (or (not enable-fun) (funcall enable-fun)) + ;; This will also look it up in parent tables. + ;; This is not on purpose, but it seems harmless. + (list abbrev name start end)))))) + ;; Restore point. + (goto-char pos))) + res))) + +(defvar abbrev-expand-functions nil + "Wrapper hook around `expand-abbrev'. +The functions on this special hook are called with one argument: +a function that performs the abbrev expansion. It should return +the abbrev symbol if expansion took place.") + +(defun expand-abbrev () + "Expand the abbrev before point, if there is an abbrev there. +Effective when explicitly called even when `abbrev-mode' is nil. +Returns the abbrev symbol, if expansion took place." + (interactive) + (run-hooks 'pre-abbrev-expand-hook) + (abbrev-with-wrapper-hook abbrev-expand-functions + (destructuring-bind (&optional sym name wordstart wordend) + (abbrev--before-point) + (when sym + (let ((value sym)) + (unless (or ;; executing-kbd-macro + noninteractive + (window-minibuffer-p (selected-window))) + ;; Add an undo boundary, in case we are doing this for + ;; a self-inserting command which has avoided making one so far. + (undo-boundary)) + ;; Now sym is the abbrev symbol. + (setq last-abbrev-text name) + (setq last-abbrev sym) + (setq last-abbrev-location wordstart) + ;; Increment use count. + (abbrev-put sym :count (1+ (abbrev-get sym :count))) + ;; If this abbrev has an expansion, delete the abbrev + ;; and insert the expansion. + (when (stringp (symbol-value sym)) + (goto-char wordstart) + ;; Insert at beginning so that markers at the end (e.g. point) + ;; are preserved. + (insert (symbol-value sym)) + (delete-char (- wordend wordstart)) + (let ((case-fold-search nil)) + ;; If the abbrev's name is different from the buffer text (the + ;; only difference should be capitalization), then we may want + ;; to adjust the capitalization of the expansion. + (when (and (not (equal name (symbol-name sym))) + (string-match "[[:upper:]]" name)) + (if (not (string-match "[[:lower:]]" name)) + ;; Abbrev was all caps. If expansion is multiple words, + ;; normally capitalize each word. + (if (and (not abbrev-all-caps) + (save-excursion + (> (progn (backward-word 1) (point)) + (progn (goto-char wordstart) + (forward-word 1) (point))))) + (upcase-initials-region wordstart (point)) + (upcase-region wordstart (point))) + ;; Abbrev included some caps. Cap first initial of expansion. + (let ((end (point))) + ;; Find the initial. + (goto-char wordstart) + (skip-syntax-forward "^w" (1- end)) + ;; Change just that. + (upcase-initials-region (point) (1+ (point))) + (goto-char end)))))) + ;; Now point is at the end of the expansion and the beginning is + ;; in last-abbrev-location. + (when (symbol-function sym) + (let* ((hook (symbol-function sym)) + (expanded + ;; If the abbrev has a hook function, run it. + (funcall hook))) + ;; In addition, if the hook function is a symbol with + ;; a non-nil `no-self-insert' property, let the value it + ;; returned specify whether we consider that an expansion took + ;; place. If it returns nil, no expansion has been done. + (if (and (symbolp hook) + (null expanded) + (get hook 'no-self-insert)) + (setq value nil)))) + value))))) + +(defun unexpand-abbrev () + "Undo the expansion of the last abbrev that expanded. +This differs from ordinary undo in that other editing done since then +is not undone." + (interactive) + (save-excursion + (unless (or (< last-abbrev-location (point-min)) + (> last-abbrev-location (point-max))) + (goto-char last-abbrev-location) + (when (stringp last-abbrev-text) + ;; This isn't correct if last-abbrev's hook was used + ;; to do the expansion. + (let ((val (symbol-value last-abbrev))) + (unless (stringp val) + (error "value of abbrev-symbol must be a string")) + (delete-region (point) (+ (point) (length val))) + ;; Don't inherit properties here; just copy from old contents. + (insert last-abbrev-text) + (setq last-abbrev-text nil)))))) + +(defun abbrev--write (sym) + "Write the abbrev in a `read'able form. +Only writes the non-system abbrevs. +Presumes that `standard-output' points to `current-buffer'." + (unless (or (null (symbol-value sym)) (abbrev-get sym :system)) + (insert " (") + (prin1 sym) + (insert " ") + (prin1 (symbol-value sym)) + (insert " ") + (prin1 (symbol-function sym)) + (insert " ") + (prin1 (abbrev-get sym :count)) + (insert ")\n"))) + +(defun abbrev--describe (sym) + (when (symbol-value sym) + (prin1 (symbol-name sym)) + (if (null (abbrev-get sym :system)) + (indent-to 15 1) + (insert " (sys)") + (indent-to 20 1)) + (prin1 (abbrev-get sym :count)) + (indent-to 20 1) + (prin1 (symbol-value sym)) + (when (symbol-function sym) + (indent-to 45 1) + (prin1 (symbol-function sym))) + (terpri))) + +(defun insert-abbrev-table-description (name &optional readable) + "Insert before point a full description of abbrev table named NAME. +NAME is a symbol whose value is an abbrev table. +If optional 2nd arg READABLE is non-nil, a human-readable description +is inserted. Otherwise the description is an expression, +a call to `define-abbrev-table', which would +define the abbrev table NAME exactly as it is currently defined. + +Abbrevs marked as \"system abbrevs\" are omitted." + (let ((table (symbol-value name)) + (symbols ())) + (mapatoms (lambda (sym) (if (symbol-value sym) (push sym symbols))) table) + (setq symbols (sort symbols 'string-lessp)) + (let ((standard-output (current-buffer))) + (if readable + (progn + (insert "(") + (prin1 name) + (insert ")\n\n") + (mapc 'abbrev--describe symbols) + (insert "\n\n")) + (insert "(define-abbrev-table '") + (prin1 name) + (insert " '(") + (mapc 'abbrev--write symbols) + (insert " ))\n\n")) + nil))) + +(defun define-abbrev-table (tablename definitions + &optional docstring &rest props) + "Define TABLENAME (a symbol) as an abbrev table name. +Define abbrevs in it according to DEFINITIONS, which is a list of elements +of the form (ABBREVNAME EXPANSION HOOK USECOUNT SYSTEMFLAG). +\(If the list is shorter than that, omitted elements default to nil). +PROPS is a property list to apply to the table. +Properties with special meaning: +- `:parents' contains a list of abbrev tables from which this table inherits + abbreviations. +- `:case-fixed' non-nil means that abbreviations are looked up without + case-folding, and the expansion is not capitalized/upcased. +- `:regexp' describes the form of abbrevs. It defaults to \\=\\<\\(\\w+\\)\\W* which + means that an abbrev can only be a single word. The submatch 1 is treated + as the potential name of an abbrev. +- `:enable-function' can be set to a function of no argument which returns + non-nil iff the abbrevs in this table should be used for this instance + of `expand-abbrev'." + ;; We used to manually add the docstring, but we also want to record this + ;; location as the definition of the variable (in load-history), so we may + ;; as well just use `defvar'. + (eval `(defvar ,tablename nil ,@(if (stringp docstring) (list docstring)))) + (let ((table (if (boundp tablename) (symbol-value tablename)))) + (unless table + (setq table (make-abbrev-table props)) + (set tablename table) + (push tablename abbrev-table-name-list)) + (dolist (elt definitions) + (apply 'define-abbrev table elt)))) + (provide 'abbrev) ;; arch-tag: dbd6f3ae-dfe3-40ba-b00f-f9e3ff960df5 diff --git a/lisp/allout.el b/lisp/allout.el index 49dfef21547..8878c56735f 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -109,6 +109,65 @@ ;;;_ + Layout, Mode, and Topic Header Configuration +;;;_ = allout-command-prefix +(defcustom allout-command-prefix "\C-c " + "*Key sequence to be used as prefix for outline mode command key bindings. + +Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're +willing to let allout use a bunch of \C-c keybindings." + :type 'string + :group 'allout) +;;;_ = allout-keybindings-list +;;; You have to reactivate allout-mode - `(allout-mode t)' - to +;;; institute changes to this var. +(defvar allout-keybindings-list () + "*List of `allout-mode' key / function bindings, for `allout-mode-map'. + +String or vector key will be prefaced with `allout-command-prefix', +unless optional third, non-nil element is present.") +(setq allout-keybindings-list + '( + ; Motion commands: + ("\C-n" allout-next-visible-heading) + ("\C-p" allout-previous-visible-heading) + ("\C-u" allout-up-current-level) + ("\C-f" allout-forward-current-level) + ("\C-b" allout-backward-current-level) + ("\C-a" allout-beginning-of-current-entry) + ("\C-e" allout-end-of-entry) + ; Exposure commands: + ("\C-i" allout-show-children) + ("\C-s" allout-show-current-subtree) + ("\C-h" allout-hide-current-subtree) + ("\C-t" allout-toggle-current-subtree-exposure) + ("h" allout-hide-current-subtree) + ("\C-o" allout-show-current-entry) + ("!" allout-show-all) + ("x" allout-toggle-current-subtree-encryption) + ; Alteration commands: + (" " allout-open-sibtopic) + ("." allout-open-subtopic) + ("," allout-open-supertopic) + ("'" allout-shift-in) + (">" allout-shift-in) + ("<" allout-shift-out) + ("\C-m" allout-rebullet-topic) + ("*" allout-rebullet-current-heading) + ("#" allout-number-siblings) + ("\C-k" allout-kill-line t) + ("\M-k" allout-copy-line-as-kill t) + ("\C-y" allout-yank t) + ("\M-y" allout-yank-pop t) + ("\C-k" allout-kill-topic) + ("\M-k" allout-copy-topic-as-kill) + ; Miscellaneous commands: + ;([?\C-\ ] allout-mark-topic) + ("@" allout-resolve-xref) + ("=c" allout-copy-exposed-to-buffer) + ("=i" allout-indented-exposed-to-buffer) + ("=t" allout-latexify-exposed) + ("=p" allout-flatten-exposed-to-buffer))) + ;;;_ = allout-auto-activation (defcustom allout-auto-activation nil "*Regulates auto-activation modality of allout outlines - see `allout-init'. @@ -204,6 +263,54 @@ is modulo the setting of `allout-use-mode-specific-leader', which see." (const :tag "- (expose topic body but not offspring)" -) (allout-layout-type :tag "<Nested layout>")))) +;;;_ = allout-inhibit-auto-fill +(defcustom allout-inhibit-auto-fill nil + "*If non-nil, auto-fill will be inhibited in the allout buffers. + +You can customize this setting to set it for all allout buffers, or set it +in individual buffers if you want to inhibit auto-fill only in particular +buffers. (You could use a function on `allout-mode-hook' to inhibit +auto-fill according, eg, to the major mode.) + +If you don't set this and auto-fill-mode is enabled, allout will use the +value that `normal-auto-fill-function', if any, when allout mode starts, or +else allout's special hanging-indent maintaining auto-fill function, +`allout-auto-fill'." + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-inhibit-auto-fill) +;;;_ = allout-use-hanging-indents +(defcustom allout-use-hanging-indents t + "*If non-nil, topic body text auto-indent defaults to indent of the header. +Ie, it is indented to be just past the header prefix. This is +relevant mostly for use with indented-text-mode, or other situations +where auto-fill occurs." + :type 'boolean + :group 'allout) +(make-variable-buffer-local 'allout-use-hanging-indents) +;;;###autoload +(put 'allout-use-hanging-indents 'safe-local-variable + (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) +;;;_ = allout-reindent-bodies +(defcustom allout-reindent-bodies (if allout-use-hanging-indents + 'text) + "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts. + +When active, topic body lines that are indented even with or beyond +their topic header are reindented to correspond with depth shifts of +the header. + +A value of t enables reindent in non-programming-code buffers, ie +those that do not have the variable `comment-start' set. A value of +`force' enables reindent whether or not `comment-start' is set." + :type '(choice (const nil) (const t) (const text) (const force)) + :group 'allout) + +(make-variable-buffer-local 'allout-reindent-bodies) +;;;###autoload +(put 'allout-reindent-bodies 'safe-local-variable + '(lambda (x) (memq x '(nil t text force)))) + ;;;_ = allout-show-bodies (defcustom allout-show-bodies nil "*If non-nil, show entire body when exposing a topic, rather than @@ -667,115 +774,6 @@ See `allout-run-unit-tests' to see what's run." ;;;_ + Miscellaneous customization -;;;_ = allout-command-prefix -(defcustom allout-command-prefix "\C-c " - "*Key sequence to be used as prefix for outline mode command key bindings. - -Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're -willing to let allout use a bunch of \C-c keybindings." - :type 'string - :group 'allout) - -;;;_ = allout-keybindings-list -;;; You have to reactivate allout-mode - `(allout-mode t)' - to -;;; institute changes to this var. -(defvar allout-keybindings-list () - "*List of `allout-mode' key / function bindings, for `allout-mode-map'. - -String or vector key will be prefaced with `allout-command-prefix', -unless optional third, non-nil element is present.") -(setq allout-keybindings-list - '( - ; Motion commands: - ("\C-n" allout-next-visible-heading) - ("\C-p" allout-previous-visible-heading) - ("\C-u" allout-up-current-level) - ("\C-f" allout-forward-current-level) - ("\C-b" allout-backward-current-level) - ("\C-a" allout-beginning-of-current-entry) - ("\C-e" allout-end-of-entry) - ; Exposure commands: - ("\C-i" allout-show-children) - ("\C-s" allout-show-current-subtree) - ("\C-h" allout-hide-current-subtree) - ("h" allout-hide-current-subtree) - ("\C-o" allout-show-current-entry) - ("!" allout-show-all) - ("x" allout-toggle-current-subtree-encryption) - ; Alteration commands: - (" " allout-open-sibtopic) - ("." allout-open-subtopic) - ("," allout-open-supertopic) - ("'" allout-shift-in) - (">" allout-shift-in) - ("<" allout-shift-out) - ("\C-m" allout-rebullet-topic) - ("*" allout-rebullet-current-heading) - ("#" allout-number-siblings) - ("\C-k" allout-kill-line t) - ("\M-k" allout-copy-line-as-kill t) - ("\C-y" allout-yank t) - ("\M-y" allout-yank-pop t) - ("\C-k" allout-kill-topic) - ("\M-k" allout-copy-topic-as-kill) - ; Miscellaneous commands: - ;([?\C-\ ] allout-mark-topic) - ("@" allout-resolve-xref) - ("=c" allout-copy-exposed-to-buffer) - ("=i" allout-indented-exposed-to-buffer) - ("=t" allout-latexify-exposed) - ("=p" allout-flatten-exposed-to-buffer))) - -;;;_ = allout-inhibit-auto-fill -(defcustom allout-inhibit-auto-fill nil - "*If non-nil, auto-fill will be inhibited in the allout buffers. - -You can customize this setting to set it for all allout buffers, or set it -in individual buffers if you want to inhibit auto-fill only in particular -buffers. (You could use a function on `allout-mode-hook' to inhibit -auto-fill according, eg, to the major mode.) - -If you don't set this and auto-fill-mode is enabled, allout will use the -value that `normal-auto-fill-function', if any, when allout mode starts, or -else allout's special hanging-indent maintaining auto-fill function, -`allout-auto-fill'." - :type 'boolean - :group 'allout) -(make-variable-buffer-local 'allout-inhibit-auto-fill) - -;;;_ = allout-use-hanging-indents -(defcustom allout-use-hanging-indents t - "*If non-nil, topic body text auto-indent defaults to indent of the header. -Ie, it is indented to be just past the header prefix. This is -relevant mostly for use with indented-text-mode, or other situations -where auto-fill occurs." - :type 'boolean - :group 'allout) -(make-variable-buffer-local 'allout-use-hanging-indents) -;;;###autoload -(put 'allout-use-hanging-indents 'safe-local-variable - (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) - -;;;_ = allout-reindent-bodies -(defcustom allout-reindent-bodies (if allout-use-hanging-indents - 'text) - "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts. - -When active, topic body lines that are indented even with or beyond -their topic header are reindented to correspond with depth shifts of -the header. - -A value of t enables reindent in non-programming-code buffers, ie -those that do not have the variable `comment-start' set. A value of -`force' enables reindent whether or not `comment-start' is set." - :type '(choice (const nil) (const t) (const text) (const force)) - :group 'allout) - -(make-variable-buffer-local 'allout-reindent-bodies) -;;;###autoload -(put 'allout-reindent-bodies 'safe-local-variable - '(lambda (x) (memq x '(nil t text force)))) - ;;;_ = allout-enable-file-variable-adjustment (defcustom allout-enable-file-variable-adjustment t "*If non-nil, some allout outline actions edit Emacs local file var text. @@ -906,13 +904,31 @@ This is properly set by `set-allout-regexp'.") (make-variable-buffer-local 'allout-plain-bullets-string-len) ;;;_ = allout-doublecheck-at-and-shallower -(defconst allout-doublecheck-at-and-shallower 2 +(defconst allout-doublecheck-at-and-shallower 3 "Validate apparent topics of this depth and shallower as being non-aberrant. -Verified with `allout-aberrant-container-p'. This check's usefulness is -limited to shallow depths, because the determination of aberrance -is according to the mistaken item being followed by a legitimate item of -excessively greater depth.") +Verified with `allout-aberrant-container-p'. The usefulness of +this check is limited to shallow depths, because the +determination of aberrance is according to the mistaken item +being followed by a legitimate item of excessively greater depth. + +The classic example of a mistaken item, for a standard allout +outline configuration, is a body line that begins with an '...' +ellipsis. This happens to contain a legitimate depth-2 header +prefix, constituted by two '..' dots at the beginning of the +line. The only thing that can distinguish it *in principle* from +a legitimate one is if the following real header is at a depth +that is discontinuous from the depth of 2 implied by the +ellipsis, ie depth 4 or more. As the depth being tested gets +greater, the likelihood of this kind of disqualification is +lower, and the usefulness of this test is lower. + +Extending the depth of the doublecheck increases the amount it is +applied, increasing the cost of the test - on casual estimation, +for outlines with many deep topics, geometrically (O(n)?). +Taken together with decreasing likelihood that the test will be +useful at greater depths, more modest doublecheck limits are more +suitably economical.") ;;;_ X allout-reset-header-lead (header-lead) (defun allout-reset-header-lead (header-lead) "*Reset the leading string used to identify topic headers." @@ -1131,16 +1147,16 @@ See doc string for allout-keybindings-list for format of binding list." (let ((map (or base-map (make-sparse-keymap))) (pref (list allout-command-prefix))) (mapc (function - (lambda (cell) - (let ((add-pref (null (cdr (cdr cell)))) - (key-suff (list (car cell)))) - (apply 'define-key - (list map - (apply 'concat (if add-pref - (append pref key-suff) - key-suff)) - (car (cdr cell))))))) - keymap-list) + (lambda (cell) + (let ((add-pref (null (cdr (cdr cell)))) + (key-suff (list (car cell)))) + (apply 'define-key + (list map + (apply 'vconcat (if add-pref + (append pref key-suff) + key-suff)) + (car (cdr cell))))))) + keymap-list) map)) ;;;_ : Menu bar (defvar allout-mode-exposure-menu) @@ -2130,8 +2146,10 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be." ;;; &optional prelen) (defun allout-overlay-insert-in-front-handler (ol after beg end &optional prelen) - "Shift the overlay so stuff inserted in front of it are excluded." + "Shift the overlay so stuff inserted in front of it is excluded." (if after + ;; XXX Shouldn't moving the overlay should be unnecessary, if overlay + ;; front-advance on the overlay worked as it should? (move-overlay ol (1+ beg) (overlay-end ol)))) ;;;_ > allout-overlay-interior-modification-handler (ol after beg end ;;; &optional prelen) @@ -2319,19 +2337,20 @@ exceeds the topic by more than one." (let ((depth (allout-depth)) (start-point (point)) done aberrant) - (save-excursion - (while (and (not done) - (re-search-forward allout-line-boundary-regexp nil 0)) - (allout-prefix-data) - (goto-char allout-recent-prefix-beginning) - (cond - ;; sibling - continue: - ((eq allout-recent-depth depth)) - ;; first offspring is excessive - aberrant: - ((> allout-recent-depth (1+ depth)) - (setq done t aberrant t)) - ;; next non-sibling is lower-depth - not aberrant: - (t (setq done t))))) + (save-match-data + (save-excursion + (while (and (not done) + (re-search-forward allout-line-boundary-regexp nil 0)) + (allout-prefix-data) + (goto-char allout-recent-prefix-beginning) + (cond + ;; sibling - continue: + ((eq allout-recent-depth depth)) + ;; first offspring is excessive - aberrant: + ((> allout-recent-depth (1+ depth)) + (setq done t aberrant t)) + ;; next non-sibling is lower-depth - not aberrant: + (t (setq done t)))))) (if aberrant aberrant (goto-char start-point) @@ -2345,19 +2364,21 @@ exceeds the topic by more than one." Actually, returns prefix beginning point." (save-excursion (allout-beginning-of-current-line) - (and (looking-at allout-regexp) - (allout-prefix-data) - (or (not (allout-do-doublecheck)) - (not (allout-aberrant-container-p)))))) + (save-match-data + (and (looking-at allout-regexp) + (allout-prefix-data) + (or (not (allout-do-doublecheck)) + (not (allout-aberrant-container-p))))))) ;;;_ > allout-on-heading-p () (defalias 'allout-on-heading-p 'allout-on-current-heading-p) ;;;_ > allout-e-o-prefix-p () (defun allout-e-o-prefix-p () "True if point is located where current topic prefix ends, heading begins." - (and (save-excursion (let ((inhibit-field-text-motion t)) - (beginning-of-line)) - (looking-at allout-regexp)) - (= (point)(save-excursion (allout-end-of-prefix)(point))))) + (and (save-match-data + (save-excursion (let ((inhibit-field-text-motion t)) + (beginning-of-line)) + (looking-at allout-regexp)) + (= (point) (save-excursion (allout-end-of-prefix)(point)))))) ;;;_ : Location attributes ;;;_ > allout-depth () (defun allout-depth () @@ -2485,7 +2506,12 @@ Outermost is first." (if (or (not allout-beginning-of-line-cycles) (not (equal last-command this-command))) - (move-beginning-of-line 1) + (progn + (if (and (not (bolp)) + (allout-hidden-p (1- (point)))) + (goto-char (previous-single-char-property-change + (1- (point)) 'invisible))) + (move-beginning-of-line 1)) (allout-depth) (let ((beginning-of-body (save-excursion @@ -2528,7 +2554,10 @@ Outermost is first." ((>= (point) end-of-entry) (allout-back-to-current-heading) (allout-end-of-current-line)) - (t (allout-end-of-entry)))))) + (t + (if (not (and transient-mark-mode mark-active)) + (push-mark)) + (allout-end-of-entry)))))) ;;;_ > allout-next-heading () (defsubst allout-next-heading () "Move to the heading for the topic (possibly invisible) after this one. @@ -2536,16 +2565,18 @@ Outermost is first." Returns the location of the heading, or nil if none found. We skip anomolous low-level topics, a la `allout-aberrant-container-p'." - (if (looking-at allout-regexp) - (forward-char 1)) - - (when (re-search-forward allout-line-boundary-regexp nil 0) - (allout-prefix-data) - (and (allout-do-doublecheck) - ;; this will set allout-recent-* on the first non-aberrant topic, - ;; whether it's the current one or one that disqualifies it: - (allout-aberrant-container-p)) - (goto-char allout-recent-prefix-beginning))) + (save-match-data + + (if (looking-at allout-regexp) + (forward-char 1)) + + (when (re-search-forward allout-line-boundary-regexp nil 0) + (allout-prefix-data) + (and (allout-do-doublecheck) + ;; this will set allout-recent-* on the first non-aberrant topic, + ;; whether it's the current one or one that disqualifies it: + (allout-aberrant-container-p)) + (goto-char allout-recent-prefix-beginning)))) ;;;_ > allout-this-or-next-heading (defun allout-this-or-next-heading () "Position cursor on current or next heading." @@ -2565,17 +2596,18 @@ We skip anomolous low-level topics, a la `allout-aberrant-container-p'." (let ((start-point (point))) ;; allout-goto-prefix-doublechecked calls us, so we can't use it here. (allout-goto-prefix) - (when (or (re-search-backward allout-line-boundary-regexp nil 0) - (looking-at allout-bob-regexp)) - (goto-char (allout-prefix-data)) - (if (and (allout-do-doublecheck) - (allout-aberrant-container-p)) - (or (allout-previous-heading) - (and (goto-char start-point) - ;; recalibrate allout-recent-*: - (allout-depth) - nil)) - (point)))))) + (save-match-data + (when (or (re-search-backward allout-line-boundary-regexp nil 0) + (looking-at allout-bob-regexp)) + (goto-char (allout-prefix-data)) + (if (and (allout-do-doublecheck) + (allout-aberrant-container-p)) + (or (allout-previous-heading) + (and (goto-char start-point) + ;; recalibrate allout-recent-*: + (allout-depth) + nil)) + (point))))))) ;;;_ > allout-get-invisibility-overlay () (defun allout-get-invisibility-overlay () "Return the overlay at point that dictates allout invisibility." @@ -2782,19 +2814,20 @@ Not sensitive to topic visibility. Returns the point at the beginning of the prefix, or nil if none." - (let (done) - (while (and (not done) - (search-backward "\n" nil 1)) - (forward-char 1) - (if (looking-at allout-regexp) - (setq done (allout-prefix-data)) - (forward-char -1))) - (if (bobp) - (cond ((looking-at allout-regexp) - (allout-prefix-data)) - ((allout-next-heading)) - (done)) - done))) + (save-match-data + (let (done) + (while (and (not done) + (search-backward "\n" nil 1)) + (forward-char 1) + (if (looking-at allout-regexp) + (setq done (allout-prefix-data)) + (forward-char -1))) + (if (bobp) + (cond ((looking-at allout-regexp) + (allout-prefix-data)) + ((allout-next-heading)) + (done)) + done)))) ;;;_ > allout-goto-prefix-doublechecked () (defun allout-goto-prefix-doublechecked () "Put point at beginning of immediately containing outline topic. @@ -2819,10 +2852,11 @@ otherwise skip white space between bullet and ensuing text." (if (not (allout-goto-prefix-doublechecked)) nil (goto-char allout-recent-prefix-end) - (if ignore-decorations - t - (while (looking-at "[0-9]") (forward-char 1)) - (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1))) + (save-match-data + (if ignore-decorations + t + (while (looking-at "[0-9]") (forward-char 1)) + (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))) ;; Reestablish where we are: (allout-current-depth))) ;;;_ > allout-current-bullet-pos () @@ -3104,10 +3138,11 @@ situation." found done) (while (not done) - (setq found (if backward - (re-search-backward expression nil 'to-limit) - (forward-char 1) - (re-search-forward expression nil 'to-limit))) + (setq found (save-match-data + (if backward + (re-search-backward expression nil 'to-limit) + (forward-char 1) + (re-search-forward expression nil 'to-limit)))) (if (and found (allout-aberrant-container-p)) (setq found nil)) (setq done (or found (if backward (bobp) (eobp))))) @@ -3184,18 +3219,19 @@ Move to buffer limit in indicated direction if headings are exhausted." (error nil)) (allout-beginning-of-current-line)) ;; Deal with apparent header line: - (if (not (looking-at allout-regexp)) - ;; not a header line, keep looking: - t - (allout-prefix-data) - (if (and (allout-do-doublecheck) - (allout-aberrant-container-p)) - ;; skip this aberrant prospective header line: + (save-match-data + (if (not (looking-at allout-regexp)) + ;; not a header line, keep looking: t - ;; this prospective headerline qualifies - register: - (setq got allout-recent-prefix-beginning) - ;; and break the loop: - nil)))) + (allout-prefix-data) + (if (and (allout-do-doublecheck) + (allout-aberrant-container-p)) + ;; skip this aberrant prospective header line: + t + ;; this prospective headerline qualifies - register: + (setq got allout-recent-prefix-beginning) + ;; and break the loop: + nil))))) ;; Register this got, it may be the last: (if got (setq prev got)) (setq arg (1- arg))) @@ -3354,7 +3390,7 @@ Returns the qualifying command, if any, else nil." ;; translate literal membership on list: (cadr (assoc key-string allout-keybindings-list))) ;; translate as a keybinding: - (key-binding (concat allout-command-prefix + (key-binding (vconcat allout-command-prefix (char-to-string (if (and (<= 97 key-num) ; "a" (>= 122 key-num)) ; "z" @@ -3623,154 +3659,156 @@ Nuances: from there." (allout-beginning-of-current-line) - (let* ((inhibit-field-text-motion t) - (depth (+ (allout-current-depth) relative-depth)) - (opening-on-blank (if (looking-at "^\$") - (not (setq before nil)))) - ;; bunch o vars set while computing ref-topic - opening-numbered - ref-depth - ref-bullet - (ref-topic (save-excursion - (cond ((< relative-depth 0) - (allout-ascend-to-depth depth)) - ((>= relative-depth 1) nil) - (t (allout-back-to-current-heading))) - (setq ref-depth allout-recent-depth) - (setq ref-bullet - (if (> allout-recent-prefix-end 1) - (allout-recent-bullet) - "")) - (setq opening-numbered - (save-excursion - (and allout-numbered-bullet - (or (<= relative-depth 0) - (allout-descend-to-depth depth)) - (if (allout-numbered-type-prefix) - allout-numbered-bullet)))) - (point))) - dbl-space - doing-beginning - start end) - - (if (not opening-on-blank) + (save-match-data + (let* ((inhibit-field-text-motion t) + (depth (+ (allout-current-depth) relative-depth)) + (opening-on-blank (if (looking-at "^\$") + (not (setq before nil)))) + ;; bunch o vars set while computing ref-topic + opening-numbered + ref-depth + ref-bullet + (ref-topic (save-excursion + (cond ((< relative-depth 0) + (allout-ascend-to-depth depth)) + ((>= relative-depth 1) nil) + (t (allout-back-to-current-heading))) + (setq ref-depth allout-recent-depth) + (setq ref-bullet + (if (> allout-recent-prefix-end 1) + (allout-recent-bullet) + "")) + (setq opening-numbered + (save-excursion + (and allout-numbered-bullet + (or (<= relative-depth 0) + (allout-descend-to-depth depth)) + (if (allout-numbered-type-prefix) + allout-numbered-bullet)))) + (point))) + dbl-space + doing-beginning + start end) + + (if (not opening-on-blank) ; Positioning and vertical ; padding - only if not ; opening-on-blank: - (progn - (goto-char ref-topic) - (setq dbl-space ; Determine double space action: - (or (and (<= relative-depth 0) ; not descending; - (save-excursion - ;; at b-o-b or preceded by a blank line? - (or (> 0 (forward-line -1)) - (looking-at "^\\s-*$") - (bobp))) - (save-excursion - ;; succeeded by a blank line? - (allout-end-of-current-subtree) - (looking-at "\n\n"))) - (and (= ref-depth 1) - (or before - (= depth 1) - (save-excursion - ;; Don't already have following - ;; vertical padding: - (not (allout-pre-next-prefix))))))) - - ;; Position to prior heading, if inserting backwards, and not - ;; going outwards: - (if (and before (>= relative-depth 0)) - (progn (allout-back-to-current-heading) - (setq doing-beginning (bobp)) - (if (not (bobp)) - (allout-previous-heading))) - (if (and before (bobp)) - (open-line 1))) - - (if (<= relative-depth 0) - ;; Not going inwards, don't snug up: - (if doing-beginning - (if (not dbl-space) - (open-line 1) - (open-line 2)) - (if before - (progn (end-of-line) - (allout-pre-next-prefix) - (while (and (= ?\n (following-char)) - (save-excursion - (forward-char 1) - (allout-hidden-p))) - (forward-char 1)) - (if (not (looking-at "^$")) - (open-line 1))) - (allout-end-of-current-subtree) - (if (looking-at "\n\n") (forward-char 1)))) - ;; Going inwards - double-space if first offspring is - ;; double-spaced, otherwise snug up. - (allout-end-of-entry) - (if (eobp) - (newline 1) - (line-move 1)) - (allout-beginning-of-current-line) - (backward-char 1) - (if (bolp) - ;; Blank lines between current header body and next - ;; header - get to last substantive (non-white-space) - ;; line in body: - (progn (setq dbl-space t) - (re-search-backward "[^ \t\n]" nil t))) - (if (looking-at "\n\n") - (setq dbl-space t)) - (if (save-excursion - (allout-next-heading) - (when (> allout-recent-depth ref-depth) - ;; This is an offspring. - (forward-line -1) - (looking-at "^\\s-*$"))) - (progn (forward-line 1) - (open-line 1) - (forward-line 1))) - (allout-end-of-current-line)) - - ;;(if doing-beginning (goto-char doing-beginning)) - (if (not (bobp)) - ;; We insert a newline char rather than using open-line to - ;; avoid rear-stickiness inheritence of read-only property. - (progn (if (and (not (> depth ref-depth)) - (not before)) + (progn + (goto-char ref-topic) + (setq dbl-space ; Determine double space action: + (or (and (<= relative-depth 0) ; not descending; + (save-excursion + ;; at b-o-b or preceded by a blank line? + (or (> 0 (forward-line -1)) + (looking-at "^\\s-*$") + (bobp))) + (save-excursion + ;; succeeded by a blank line? + (allout-end-of-current-subtree) + (looking-at "\n\n"))) + (and (= ref-depth 1) + (or before + (= depth 1) + (save-excursion + ;; Don't already have following + ;; vertical padding: + (not (allout-pre-next-prefix))))))) + + ;; Position to prior heading, if inserting backwards, and not + ;; going outwards: + (if (and before (>= relative-depth 0)) + (progn (allout-back-to-current-heading) + (setq doing-beginning (bobp)) + (if (not (bobp)) + (allout-previous-heading))) + (if (and before (bobp)) + (open-line 1))) + + (if (<= relative-depth 0) + ;; Not going inwards, don't snug up: + (if doing-beginning + (if (not dbl-space) + (open-line 1) + (open-line 2)) + (if before + (progn (end-of-line) + (allout-pre-next-prefix) + (while (and (= ?\n (following-char)) + (save-excursion + (forward-char 1) + (allout-hidden-p))) + (forward-char 1)) + (if (not (looking-at "^$")) + (open-line 1))) + (allout-end-of-current-subtree) + (if (looking-at "\n\n") (forward-char 1)))) + ;; Going inwards - double-space if first offspring is + ;; double-spaced, otherwise snug up. + (allout-end-of-entry) + (if (eobp) + (newline 1) + (line-move 1)) + (allout-beginning-of-current-line) + (backward-char 1) + (if (bolp) + ;; Blank lines between current header body and next + ;; header - get to last substantive (non-white-space) + ;; line in body: + (progn (setq dbl-space t) + (re-search-backward "[^ \t\n]" nil t))) + (if (looking-at "\n\n") + (setq dbl-space t)) + (if (save-excursion + (allout-next-heading) + (when (> allout-recent-depth ref-depth) + ;; This is an offspring. + (forward-line -1) + (looking-at "^\\s-*$"))) + (progn (forward-line 1) (open-line 1) - (if (and (not dbl-space) (> depth ref-depth)) - (newline 1) - (if dbl-space - (open-line 1) - (if (not before) - (newline 1))))) - (if (and dbl-space (not (> relative-depth 0))) - (newline 1)) - (if (and (not (eobp)) - (or (not (bolp)) - (and (not (bobp)) - ;; bolp doesnt detect concealed - ;; trailing newlines, compensate: - (save-excursion - (forward-char -1) - (allout-hidden-p))))) - (forward-char 1)))) - )) - (setq start (point)) - (insert (concat (allout-make-topic-prefix opening-numbered t depth) - " ")) - (setq end (1+ (point))) - - (allout-rebullet-heading (and offer-recent-bullet ref-bullet) - depth nil nil t) - (if (> relative-depth 0) - (save-excursion (goto-char ref-topic) - (allout-show-children))) - (end-of-line) + (forward-line 1))) + (allout-end-of-current-line)) + + ;;(if doing-beginning (goto-char doing-beginning)) + (if (not (bobp)) + ;; We insert a newline char rather than using open-line to + ;; avoid rear-stickiness inheritence of read-only property. + (progn (if (and (not (> depth ref-depth)) + (not before)) + (open-line 1) + (if (and (not dbl-space) (> depth ref-depth)) + (newline 1) + (if dbl-space + (open-line 1) + (if (not before) + (newline 1))))) + (if (and dbl-space (not (> relative-depth 0))) + (newline 1)) + (if (and (not (eobp)) + (or (not (bolp)) + (and (not (bobp)) + ;; bolp doesnt detect concealed + ;; trailing newlines, compensate: + (save-excursion + (forward-char -1) + (allout-hidden-p))))) + (forward-char 1)))) + )) + (setq start (point)) + (insert (concat (allout-make-topic-prefix opening-numbered t depth) + " ")) + (setq end (1+ (point))) + + (allout-rebullet-heading (and offer-recent-bullet ref-bullet) + depth nil nil t) + (if (> relative-depth 0) + (save-excursion (goto-char ref-topic) + (allout-show-children))) + (end-of-line) - (run-hook-with-args 'allout-structure-added-hook start end) + (run-hook-with-args 'allout-structure-added-hook start end) + ) ) ) ;;;_ > allout-open-subtopic (arg) @@ -3816,14 +3854,15 @@ Maintains outline hanging topic indentation if (when (not allout-inhibit-auto-fill) (let ((fill-prefix (if allout-use-hanging-indents ;; Check for topic header indentation: - (save-excursion - (beginning-of-line) - (if (looking-at allout-regexp) - ;; ... construct indentation to account for - ;; length of topic prefix: - (make-string (progn (allout-end-of-prefix) - (current-column)) - ?\ ))))) + (save-match-data + (save-excursion + (beginning-of-line) + (if (looking-at allout-regexp) + ;; ... construct indentation to account for + ;; length of topic prefix: + (make-string (progn (allout-end-of-prefix) + (current-column)) + ?\ )))))) (use-auto-fill-function (or allout-outside-normal-auto-fill-function auto-fill-function 'do-auto-fill))) @@ -3967,11 +4006,12 @@ this function." (goto-char mb) ; Dispense with number if ; numbered-bullet prefix: - (if (and allout-numbered-bullet - (string= allout-numbered-bullet current-bullet) - (looking-at "[0-9]+")) - (allout-unprotected - (delete-region (match-beginning 0)(match-end 0)))) + (save-match-data + (if (and allout-numbered-bullet + (string= allout-numbered-bullet current-bullet) + (looking-at "[0-9]+")) + (allout-unprotected + (delete-region (match-beginning 0)(match-end 0))))) ;; convey 'allout-was-hidden annotation, if original had it: (if has-annotation @@ -4297,7 +4337,7 @@ subtopics into siblings of the item." (if (or (not (allout-mode-p)) (not (bolp)) - (not (looking-at allout-regexp))) + (not (save-match-data (looking-at allout-regexp)))) ;; Just do a regular kill: (kill-line arg) ;; Ah, have to watch out for adjustments: @@ -4317,7 +4357,7 @@ subtopics into siblings of the item." (if allout-numbered-bullet (save-excursion ; Renumber subsequent topics if needed: - (if (not (looking-at allout-regexp)) + (if (not (save-match-data (looking-at allout-regexp))) (allout-next-heading)) (allout-renumber-to-depth depth))) (run-hook-with-args 'allout-structure-deleted-hook depth (point))))) @@ -4352,7 +4392,7 @@ allout-yank-processing for exposure recovery." (if (and (/= (current-column) 0) (not (eobp))) (forward-char 1)) (if (not (eobp)) - (if (and (looking-at "\n") + (if (and (save-match-data (looking-at "\n")) (or (save-excursion (or (not (allout-next-heading)) (= depth allout-recent-depth))) @@ -4449,7 +4489,7 @@ allout-yank-processing for exposure recovery." (setq next (next-single-char-property-change (point) 'allout-was-hidden nil end)) - (overlay-put (make-overlay prev next) + (overlay-put (make-overlay prev next nil 'front-advance) 'category 'allout-exposure-category) (allout-deannotate-hidden prev next) (setq prev next) @@ -4481,117 +4521,120 @@ however, are left exactly like normal, non-allout-specific yanks." ; region around subject: (if (< (allout-mark-marker t) (point)) (exchange-point-and-mark)) - (let* ((subj-beg (point)) - (into-bol (bolp)) - (subj-end (allout-mark-marker t)) - ;; 'resituate' if yanking an entire topic into topic header: - (resituate (and (let ((allout-inhibit-aberrance-doublecheck t)) - (allout-e-o-prefix-p)) - (looking-at allout-regexp) - (allout-prefix-data))) - ;; `rectify-numbering' if resituating (where several topics may - ;; be resituating) or yanking a topic into a topic slot (bol): - (rectify-numbering (or resituate - (and into-bol (looking-at allout-regexp))))) - (if resituate - ;; Yanking a topic into the start of a topic - reconcile to fit: - (let* ((inhibit-field-text-motion t) - (prefix-len (if (not (match-end 1)) - 1 - (- (match-end 1) subj-beg))) - (subj-depth allout-recent-depth) - (prefix-bullet (allout-recent-bullet)) - (adjust-to-depth - ;; Nil if adjustment unnecessary, otherwise depth to which - ;; adjustment should be made: - (save-excursion - (and (goto-char subj-end) - (eolp) - (goto-char subj-beg) - (and (looking-at allout-regexp) - (progn - (beginning-of-line) - (not (= (point) subj-beg))) - (looking-at allout-regexp) - (allout-prefix-data)) - allout-recent-depth))) - (more t)) - (setq rectify-numbering allout-numbered-bullet) - (if adjust-to-depth + (save-match-data + (let* ((subj-beg (point)) + (into-bol (bolp)) + (subj-end (allout-mark-marker t)) + ;; 'resituate' if yanking an entire topic into topic header: + (resituate (and (let ((allout-inhibit-aberrance-doublecheck t)) + (allout-e-o-prefix-p)) + (looking-at allout-regexp) + (allout-prefix-data))) + ;; `rectify-numbering' if resituating (where several topics may + ;; be resituating) or yanking a topic into a topic slot (bol): + (rectify-numbering (or resituate + (and into-bol + (looking-at allout-regexp))))) + (if resituate + ;; Yanking a topic into the start of a topic - reconcile to fit: + (let* ((inhibit-field-text-motion t) + (prefix-len (if (not (match-end 1)) + 1 + (- (match-end 1) subj-beg))) + (subj-depth allout-recent-depth) + (prefix-bullet (allout-recent-bullet)) + (adjust-to-depth + ;; Nil if adjustment unnecessary, otherwise depth to which + ;; adjustment should be made: + (save-excursion + (and (goto-char subj-end) + (eolp) + (goto-char subj-beg) + (and (looking-at allout-regexp) + (progn + (beginning-of-line) + (not (= (point) subj-beg))) + (looking-at allout-regexp) + (allout-prefix-data)) + allout-recent-depth))) + (more t)) + (setq rectify-numbering allout-numbered-bullet) + (if adjust-to-depth ; Do the adjustment: - (progn - (save-restriction - (narrow-to-region subj-beg subj-end) + (progn + (save-restriction + (narrow-to-region subj-beg subj-end) ; Trim off excessive blank ; line at end, if any: - (goto-char (point-max)) - (if (looking-at "^$") - (allout-unprotected (delete-char -1))) + (goto-char (point-max)) + (if (looking-at "^$") + (allout-unprotected (delete-char -1))) ; Work backwards, with each ; shallowest level, ; successively excluding the ; last processed topic from ; the narrow region: - (while more - (allout-back-to-current-heading) + (while more + (allout-back-to-current-heading) ; go as high as we can in each bunch: - (while (allout-ascend t)) - (save-excursion - (allout-unprotected - (allout-rebullet-topic-grunt (- adjust-to-depth - subj-depth))) - (allout-depth)) - (if (setq more (not (bobp))) - (progn (widen) - (forward-char -1) - (narrow-to-region subj-beg (point)))))) - ;; Preserve new bullet if it's a distinctive one, otherwise - ;; use old one: - (if (string-match (regexp-quote prefix-bullet) - allout-distinctive-bullets-string) + (while (allout-ascend t)) + (save-excursion + (allout-unprotected + (allout-rebullet-topic-grunt (- adjust-to-depth + subj-depth))) + (allout-depth)) + (if (setq more (not (bobp))) + (progn (widen) + (forward-char -1) + (narrow-to-region subj-beg (point)))))) + ;; Preserve new bullet if it's a distinctive one, otherwise + ;; use old one: + (if (string-match (regexp-quote prefix-bullet) + allout-distinctive-bullets-string) ; Delete from bullet of old to ; before bullet of new: - (progn - (beginning-of-line) - (allout-unprotected - (delete-region (point) subj-beg)) - (set-marker (allout-mark-marker t) subj-end) - (goto-char subj-beg) - (allout-end-of-prefix)) + (progn + (beginning-of-line) + (allout-unprotected + (delete-region (point) subj-beg)) + (set-marker (allout-mark-marker t) subj-end) + (goto-char subj-beg) + (allout-end-of-prefix)) ; Delete base subj prefix, ; leaving old one: - (allout-unprotected - (progn - (delete-region (point) (+ (point) - prefix-len - (- adjust-to-depth - subj-depth))) + (allout-unprotected + (progn + (delete-region (point) (+ (point) + prefix-len + (- adjust-to-depth + subj-depth))) ; and delete residual subj ; prefix digits and space: - (while (looking-at "[0-9]") (delete-char 1)) - (if (looking-at " ") (delete-char 1)))))) - (exchange-point-and-mark)))) - (if rectify-numbering - (progn - (save-excursion + (while (looking-at "[0-9]") (delete-char 1)) + (if (looking-at " ") + (delete-char 1)))))) + (exchange-point-and-mark)))) + (if rectify-numbering + (progn + (save-excursion ; Give some preliminary feedback: - (message "... reconciling numbers") + (message "... reconciling numbers") ; ... and renumber, in case necessary: - (goto-char subj-beg) - (if (allout-goto-prefix-doublechecked) - (allout-unprotected - (allout-rebullet-heading nil ;;; solicit - (allout-depth) ;;; depth - nil ;;; number-control - nil ;;; index - t))) - (message "")))) - (if (or into-bol resituate) - (allout-hide-by-annotation (point) (allout-mark-marker t)) - (allout-deannotate-hidden (allout-mark-marker t) (point))) - (if (not resituate) - (exchange-point-and-mark)) - (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end))) + (goto-char subj-beg) + (if (allout-goto-prefix-doublechecked) + (allout-unprotected + (allout-rebullet-heading nil ;;; solicit + (allout-depth) ;;; depth + nil ;;; number-control + nil ;;; index + t))) + (message "")))) + (if (or into-bol resituate) + (allout-hide-by-annotation (point) (allout-mark-marker t)) + (allout-deannotate-hidden (allout-mark-marker t) (point))) + (if (not resituate) + (exchange-point-and-mark)) + (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end)))) ;;;_ > allout-yank (&optional arg) (defun allout-yank (&optional arg) "`allout-mode' yank, with depth and numbering adjustment of yanked topics. @@ -4658,13 +4701,15 @@ by pops to non-distinctive yanks. Bug..." allout-file-xref-bullet) (let ((inhibit-field-text-motion t) file-name) - (save-excursion - (let* ((text-start allout-recent-prefix-end) - (heading-end (progn (end-of-line) (point)))) - (goto-char text-start) - (setq file-name - (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t) - (buffer-substring (match-beginning 1) (match-end 1)))))) + (save-match-data + (save-excursion + (let* ((text-start allout-recent-prefix-end) + (heading-end (progn (end-of-line) (point)))) + (goto-char text-start) + (setq file-name + (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t) + (buffer-substring (match-beginning 1) + (match-end 1))))))) (setq file-name (expand-file-name file-name)) (if (or (file-exists-p file-name) (if (file-writable-p file-name) @@ -4695,7 +4740,7 @@ invoked.)" ;; We use outline invisibility spec. (remove-overlays from to 'category 'allout-exposure-category) (when flag - (let ((o (make-overlay from to))) + (let ((o (make-overlay from to nil 'front-advance))) (overlay-put o 'category 'allout-exposure-category) (when (featurep 'xemacs) (let ((props (symbol-plist 'allout-exposure-category))) @@ -4898,16 +4943,17 @@ Single line topics intrinsically can be considered as being both collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is true, then single-line topics are considered to be collapsed. By default, they are treated as being uncollapsed." - (save-excursion - (and - ;; Is the topic all on one line (allowing for trailing blank line)? - (>= (progn (allout-back-to-current-heading) - (move-end-of-line 1) - (point)) - (allout-end-of-current-subtree (not (looking-at "\n\n")))) - - (or include-single-liners - (progn (backward-char 1) (allout-hidden-p)))))) + (save-match-data + (save-excursion + (and + ;; Is the topic all on one line (allowing for trailing blank line)? + (>= (progn (allout-back-to-current-heading) + (move-end-of-line 1) + (point)) + (allout-end-of-current-subtree (not (looking-at "\n\n")))) + + (or include-single-liners + (progn (backward-char 1) (allout-hidden-p))))))) ;;;_ > allout-hide-current-subtree (&optional just-close) (defun allout-hide-current-subtree (&optional just-close) "Close the current topic, or containing topic if this one is already closed. @@ -4931,6 +4977,16 @@ siblings, even if the target topic is already closed." (allout-expose-topic '(0 :)) (message (concat sibs-msg " Done.")))) (goto-char from))) +;;;_ > allout-toggle-current-subtree-exposure +(defun allout-toggle-current-subtree-exposure () + "Show or hide the current subtree depending on its current state." + ;; thanks to tassilo for suggesting this. + (interactive) + (save-excursion + (allout-back-to-heading) + (if (allout-hidden-p (point-at-eol)) + (allout-show-current-subtree) + (allout-hide-current-subtree)))) ;;;_ > allout-show-current-branches () (defun allout-show-current-branches () "Show all subheadings of this heading, but not their bodies." @@ -4962,18 +5018,19 @@ siblings, even if the target topic is already closed." ;;;_ > allout-hide-region-body (start end) (defun allout-hide-region-body (start end) "Hide all body lines in the region, but not headings." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (let ((inhibit-field-text-motion t)) - (while (not (eobp)) - (end-of-line) - (allout-flag-region (point) (allout-end-of-entry) t) - (if (not (eobp)) - (forward-char - (if (looking-at "\n\n") - 2 1)))))))) + (save-match-data + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (let ((inhibit-field-text-motion t)) + (while (not (eobp)) + (end-of-line) + (allout-flag-region (point) (allout-end-of-entry) t) + (if (not (eobp)) + (forward-char + (if (looking-at "\n\n") + 2 1))))))))) ;;;_ > allout-expose-topic (spec) (defun allout-expose-topic (spec) @@ -5596,14 +5653,15 @@ environment. Leaves point at the end of the line." (let ((beg (point)) (end (progn (end-of-line)(point)))) (goto-char beg) - (while (re-search-forward "\\\\" - ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#" - end ; bounded by end-of-line - 1) ; no matches, move to end & return nil - (goto-char (match-beginning 2)) - (insert "\\") - (setq end (1+ end)) - (goto-char (1+ (match-end 2))))))) + (save-match-data + (while (re-search-forward "\\\\" + ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#" + end ; bounded by end-of-line + 1) ; no matches, move to end & return nil + (goto-char (match-beginning 2)) + (insert "\\") + (setq end (1+ end)) + (goto-char (1+ (match-end 2)))))))) ;;;_ > allout-insert-latex-header (buffer) (defun allout-insert-latex-header (buffer) "Insert initial LaTeX commands at point in BUFFER." @@ -6050,8 +6108,9 @@ Returns the resulting string, or nil if the transformation fails." (let ((re (if (listp re) (car re) re)) (replacement (if (listp re) (cadr re) ""))) (goto-char (point-min)) - (while (re-search-forward re nil t) - (replace-match replacement nil nil))))) + (save-match-data + (while (re-search-forward re nil t) + (replace-match replacement nil nil)))))) (cond @@ -6282,7 +6341,7 @@ of the availability of a cached copy." (allout-end-of-prefix t) (and (string= (buffer-substring-no-properties (1- (point)) (point)) allout-topic-encryption-bullet) - (looking-at "\\*")) + (save-match-data (looking-at "\\*"))) ) ) ;;;_ > allout-encrypted-key-info (text) @@ -6420,47 +6479,49 @@ Such a topic has the allout-topic-encryption-bullet without an immediately following '*' that would mark the topic as being encrypted. It must also have content." (let (done got content-beg) - (while (not done) - - (if (not (re-search-forward - (format "\\(\\`\\|\n\\)%s *%s[^*]" - (regexp-quote allout-header-prefix) - (regexp-quote allout-topic-encryption-bullet)) - nil t)) - (setq got nil - done t) - (goto-char (setq got (match-beginning 0))) - (if (looking-at "\n") - (forward-char 1)) - (setq got (point))) - - (cond ((not got) - (setq done t)) - - ((not (search-forward "\n")) - (setq got nil - done t)) - - ((eobp) - (setq got nil - done t)) + (save-match-data + (while (not done) - (t - (setq content-beg (point)) - (backward-char 1) - (allout-end-of-subtree) - (if (or (<= (point) content-beg) - (and except-mark - (<= content-beg except-mark) - (>= (point) except-mark))) - ;; Continue looking - (setq got nil) - ;; Got it! - (setq done t))) - ) + (if (not (re-search-forward + (format "\\(\\`\\|\n\\)%s *%s[^*]" + (regexp-quote allout-header-prefix) + (regexp-quote allout-topic-encryption-bullet)) + nil t)) + (setq got nil + done t) + (goto-char (setq got (match-beginning 0))) + (if (save-match-data (looking-at "\n")) + (forward-char 1)) + (setq got (point))) + + (cond ((not got) + (setq done t)) + + ((not (search-forward "\n")) + (setq got nil + done t)) + + ((eobp) + (setq got nil + done t)) + + (t + (setq content-beg (point)) + (backward-char 1) + (allout-end-of-subtree) + (if (or (<= (point) content-beg) + (and except-mark + (<= content-beg except-mark) + (>= (point) except-mark))) + ;; Continue looking + (setq got nil) + ;; Got it! + (setq done t))) + ) + ) + (if got + (goto-char got)) ) - (if got - (goto-char got)) ) ) ;;;_ > allout-encrypt-decrypted (&optional except-mark) @@ -6478,36 +6539,38 @@ and exactly resituate the cursor if this is being done as part of a file save. See `allout-encrypt-unencrypted-on-saves' for more info." (interactive "p") - (save-excursion - (let* ((current-mark (point-marker)) - (current-mark-position (marker-position current-mark)) - was-modified - bo-subtree - editing-topic editing-point) - (goto-char (point-min)) - (while (allout-next-topic-pending-encryption except-mark) - (setq was-modified (buffer-modified-p)) - (when (save-excursion - (and (boundp 'allout-encrypt-unencrypted-on-saves) - allout-encrypt-unencrypted-on-saves - (setq bo-subtree (re-search-forward "$")) - (not (allout-hidden-p)) - (>= current-mark (point)) - (allout-end-of-current-subtree) - (<= current-mark (point)))) + (save-match-data + (save-excursion + (let* ((current-mark (point-marker)) + (current-mark-position (marker-position current-mark)) + was-modified + bo-subtree + editing-topic editing-point) + (goto-char (point-min)) + (while (allout-next-topic-pending-encryption except-mark) + (setq was-modified (buffer-modified-p)) + (when (save-excursion + (and (boundp 'allout-encrypt-unencrypted-on-saves) + allout-encrypt-unencrypted-on-saves + (setq bo-subtree (re-search-forward "$")) + (not (allout-hidden-p)) + (>= current-mark (point)) + (allout-end-of-current-subtree) + (<= current-mark (point)))) (setq editing-topic (point) ;; we had to wait for this 'til now so prior topics are ;; encrypted, any relevant text shifts are in place: editing-point (- current-mark-position (count-trailing-whitespace-region bo-subtree current-mark-position)))) - (allout-toggle-subtree-encryption) + (allout-toggle-subtree-encryption) + (if (not was-modified) + (set-buffer-modified-p nil)) + ) (if (not was-modified) (set-buffer-modified-p nil)) + (if editing-topic (list editing-topic editing-point)) ) - (if (not was-modified) - (set-buffer-modified-p nil)) - (if editing-topic (list editing-topic editing-point)) ) ) ) @@ -6725,13 +6788,14 @@ Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion." If BEG is bigger than END we return 0." (if (> beg end) 0 - (save-excursion - (goto-char beg) - (let ((count 0)) - (while (re-search-forward "[ ][ ]*$" end t) - (goto-char (1+ (match-beginning 2))) - (setq count (1+ count))) - count)))) + (save-match-data + (save-excursion + (goto-char beg) + (let ((count 0)) + (while (re-search-forward "[ ][ ]*$" end t) + (goto-char (1+ (match-beginning 2))) + (setq count (1+ count))) + count))))) ;;;_ > allout-format-quote (string) (defun allout-format-quote (string) "Return a copy of string with all \"%\" characters doubled." @@ -6844,7 +6908,13 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." ;; Move to beginning-of-line, ignoring fields and invisibles. (skip-chars-backward "^\n") - (while (and (not (bobp)) (line-move-invisible-p (1- (point)))) + (while (and (not (bobp)) + (let ((prop + (get-char-property (1- (point)) 'invisible))) + (if (eq buffer-invisibility-spec t) + prop + (or (memq prop buffer-invisibility-spec) + (assq prop buffer-invisibility-spec))))) (goto-char (if (featurep 'xemacs) (previous-property-change (point)) (previous-char-property-change (point)))) @@ -6873,8 +6943,18 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." (error nil)) (not (bobp)) (progn - (while (and (not (bobp)) - (line-move-invisible-p (1- (point)))) + (while + (and + (not (bobp)) + (let ((prop + (get-char-property (1- (point)) + 'invisible))) + (if (eq buffer-invisibility-spec t) + prop + (or (memq prop + buffer-invisibility-spec) + (assq prop + buffer-invisibility-spec))))) (goto-char (previous-char-property-change (point)))) (backward-char 1))) @@ -6891,16 +6971,6 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." (setq arg 1) (setq done t))))))) ) -;;;_ > line-move-invisible-p if necessary -(if (not (fboundp 'line-move-invisible-p)) - (defun line-move-invisible-p (pos) - "Return non-nil if the character after POS is currently invisible." - (let ((prop - (get-char-property pos 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec)))))) ;;;_ #10 Unfinished ;;;_ > allout-bullet-isearch (&optional bullet) diff --git a/lisp/apropos.el b/lisp/apropos.el index 9e784e087e6..9fddf0103fb 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1005,7 +1005,7 @@ If non-nil TEXT is a string that will be printed as a heading." (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." (help-setup-xref (list 'apropos-describe-plist symbol) (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (set-buffer standard-output) (princ "Symbol ") (prin1 symbol) @@ -1014,8 +1014,7 @@ If non-nil TEXT is a string that will be printed as a heading." (put-text-property (+ (point-min) 7) (- (point) 14) 'face apropos-symbol-face)) (insert (apropos-format-plist symbol "\n ")) - (princ ")") - (print-help-return-message))) + (princ ")"))) (provide 'apropos) diff --git a/lisp/calc/README b/lisp/calc/README index 55fa216497b..dc474c43813 100644 --- a/lisp/calc/README +++ b/lisp/calc/README @@ -78,6 +78,8 @@ Summary of changes to "Calc" * Made unit conversions exact when possible. +* Lower the precedence of negation. + Version 2.1: * New matrix mode for square matrices. Improved handling of diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 0aa053702b8..bb054de4951 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1782,8 +1782,8 @@ calc-kill calc-kill-region calc-yank)))) ;;; User menu. (defun calc-user-key-map () - (if calc-emacs-type-lucid - (error "User-defined keys are not supported in Lucid Emacs")) + (if (featurep 'xemacs) + (error "User-defined keys are not supported in XEmacs")) (let ((res (cdr (lookup-key calc-mode-map "z")))) (if (eq (car (car res)) 27) (cdr res) diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index efaf17ecae8..3871a1b0f09 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -84,10 +84,10 @@ (message "`C' language mode"))) (put 'c 'math-oper-table - '( ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 ) - ( "u!" calcFunc-lnot -1 1000 ) + '( ( "u!" calcFunc-lnot -1 1000 ) ( "~" calcFunc-not -1 1000 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "*" * 190 191 ) ( "/" / 190 191 ) ( "%" % 190 191 ) @@ -328,9 +328,7 @@ "LaTeX language mode with \\func(\\text{var}) and multiline matrices"))))) (put 'tex 'math-oper-table - '( ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 ) - ( "\\hat" calcFunc-hat -1 950 ) + '( ( "\\hat" calcFunc-hat -1 950 ) ( "\\check" calcFunc-check -1 950 ) ( "\\tilde" calcFunc-tilde -1 950 ) ( "\\acute" calcFunc-acute -1 950 ) @@ -351,6 +349,8 @@ ( "!" calcFunc-fact 210 -1 ) ( "^" ^ 201 200 ) ( "_" calcFunc-subscr 201 200 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "\\times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) @@ -575,9 +575,7 @@ (message "Eqn language mode"))) (put 'eqn 'math-oper-table - '( ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 ) - ( "prime" (math-parse-eqn-prime) 950 -1 ) + '( ( "prime" (math-parse-eqn-prime) 950 -1 ) ( "prime" calcFunc-Prime 950 -1 ) ( "dot" calcFunc-dot 950 -1 ) ( "dotdot" calcFunc-dotdot 950 -1 ) @@ -599,6 +597,8 @@ ( "right ceil" closing 0 -1 ) ( "+-" sdev 300 300 ) ( "!" calcFunc-fact 210 -1 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 913b02e003f..5cfccb4f8db 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -821,9 +821,6 @@ If nil, selections displayed but ignored.") (defvar calc-embedded-mode-hook nil "Hook run when starting embedded mode.") -;; Verify that Calc is running on the right kind of system. -(defvar calc-emacs-type-lucid (not (not (string-match "Lucid" emacs-version)))) - ;; Set up the autoloading linkage. (let ((name (and (fboundp 'calc-dispatch) (eq (car-safe (symbol-function 'calc-dispatch)) 'autoload) @@ -968,7 +965,7 @@ If nil, selections displayed but ignored.") (defvar calc-digit-map (let ((map (make-keymap))) - (if calc-emacs-type-lucid + (if (featurep 'xemacs) (map-keymap (function (lambda (keys bind) (define-key map keys @@ -999,7 +996,7 @@ If nil, selections displayed but ignored.") (define-key calc-mode-map x 'calc-pop) (define-key calc-mode-map (if (vectorp x) - (if calc-emacs-type-lucid + (if (featurep 'xemacs) (if (= (length x) 1) (vector (if (consp (aref x 0)) (cons 'meta (aref x 0)) @@ -2109,13 +2106,13 @@ See calc-keypad for details." (calc-prev-char nil) (calc-prev-prev-char nil) (calc-buffer (current-buffer)) - (buf (if calc-emacs-type-lucid + (buf (if (featurep 'xemacs) (catch 'calc-foo (catch 'execute-kbd-macro (throw 'calc-foo (read-from-minibuffer "Calc: " "" calc-digit-map))) - (error "Lucid Emacs requires RET after %s" + (error "XEmacs requires RET after %s" "digit entry in kbd macro")) (let ((old-esc (lookup-key global-map "\e"))) (unwind-protect @@ -3531,8 +3528,6 @@ and all digits are kept, regardless of Calc's current precision." (defconst math-standard-opers '( ( "_" calcFunc-subscr 1200 1201 ) ( "%" calcFunc-percent 1100 -1 ) - ( "u+" ident -1 1000 ) - ( "u-" neg -1 1000 197 ) ( "u!" calcFunc-lnot -1 1000 ) ( "mod" mod 400 400 185 ) ( "+/-" sdev 300 300 185 ) @@ -3540,6 +3535,8 @@ and all digits are kept, regardless of Calc's current precision." ( "!" calcFunc-fact 210 -1 ) ( "^" ^ 201 200 ) ( "**" ^ 201 200 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) ( "/" / 190 191 ) ( "%" % 190 191 ) ( "\\" calcFunc-idiv 190 191 ) @@ -3646,7 +3643,7 @@ Also looks for the equivalent TeX words, \\gets and \\evalto." ;;; Functions needed for Lucid Emacs support. (defun calc-read-key (&optional optkey) - (cond (calc-emacs-type-lucid + (cond ((featurep 'xemacs) (let ((event (next-command-event))) (let ((key (event-to-character event t t))) (or key optkey (error "Expected a plain keystroke")) @@ -3664,7 +3661,7 @@ Also looks for the equivalent TeX words, \\gets and \\evalto." (defun calc-clear-unread-commands () (if (featurep 'xemacs) - (calc-emacs-type-lucid (setq unread-command-event nil)) + (setq unread-command-event nil) (setq unread-command-events nil))) (when calc-always-load-extensions diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 63753af76df..5e398d46ccf 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -374,11 +374,6 @@ :prefix "custom-" :group 'customize) -(defgroup abbrev-mode nil - "Word abbreviations mode." - :link '(custom-manual "(emacs)Abbrevs") - :group 'abbrev) - (defgroup alloc nil "Storage allocation and gc for GNU Emacs Lisp interpreter." :tag "Storage Allocation" @@ -1718,7 +1713,7 @@ item in another window.\n\n")) (defun custom-browse-insert-prefix (prefix) "Insert PREFIX. On XEmacs convert it to line graphics." ;; Fixme: do graphics. - (if nil ; (string-match "XEmacs" emacs-version) + (if nil ; (featurep 'xemacs) (progn (insert "*") (while (not (string-equal prefix "")) diff --git a/lisp/cus-start.el b/lisp/cus-start.el index c6b0f269d1b..9647134ca74 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -35,10 +35,7 @@ ;;; Code: -(let ((all '(;; abbrev.c - (abbrev-all-caps abbrev-mode boolean) - (pre-abbrev-expand-hook abbrev-mode hook) - ;; alloc.c +(let ((all '(;; alloc.c (gc-cons-threshold alloc integer) (garbage-collection-messages alloc boolean) ;; buffer.c diff --git a/lisp/custom.el b/lisp/custom.el index e75cdc32459..bbee71ecf1f 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -583,10 +583,10 @@ This recursively follows aliases." "Inform Custom that VARIABLE has been set (changed). VARIABLE is a symbol that names a user option. The result is that the change is treated as having been made through Custom." - (interactive "vVariable: ") (put variable 'customized-value (list (custom-quote (eval variable))))) - - ;;; Custom Themes + + +;;; Custom Themes ;;; Loading files needed to customize a symbol. ;;; This is in custom.el because menu-bar.el needs it for toggle cmds. diff --git a/lisp/cvs-status.el b/lisp/cvs-status.el index 55fc52544b1..82ac90453c8 100644 --- a/lisp/cvs-status.el +++ b/lisp/cvs-status.el @@ -33,7 +33,6 @@ (eval-when-compile (require 'cl)) (require 'pcvs-util) -(eval-when-compile (require 'pcvs)) ;;; diff --git a/lisp/delsel.el b/lisp/delsel.el index 82593985650..eb14bc5ac8e 100644 --- a/lisp/delsel.el +++ b/lisp/delsel.el @@ -35,7 +35,7 @@ ;; Commands which will delete the selection need a 'delete-selection ;; property on their symbols; commands which insert text but don't -;; have this property won't delete the selction. It can be one of +;; have this property won't delete the selection. It can be one of ;; the values: ;; 'yank ;; For commands which do a yank; ensures the region about to be @@ -147,14 +147,19 @@ then it takes a second \\[keyboard-quit] to abort the minibuffer." (define-key minibuffer-local-must-match-map "\C-g" 'minibuffer-keyboard-quit) (define-key minibuffer-local-isearch-map "\C-g" 'minibuffer-keyboard-quit) -(defun delsel-unload-hook () +(defun delsel-unload-function () + "Unload the Delete Selection library." (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit) (define-key minibuffer-local-ns-map "\C-g" 'abort-recursive-edit) (define-key minibuffer-local-completion-map "\C-g" 'abort-recursive-edit) (define-key minibuffer-local-must-match-map "\C-g" 'abort-recursive-edit) - (define-key minibuffer-local-isearch-map "\C-g" 'abort-recursive-edit)) - -(add-hook 'delsel-unload-hook 'delsel-unload-hook) + (define-key minibuffer-local-isearch-map "\C-g" 'abort-recursive-edit) + (dolist (sym '(self-insert-command self-insert-iso yank clipboard-yank + insert-register delete-backward-char backward-delete-char-untabify + delete-char newline-and-indent newline open-line)) + (remprop sym 'delete-selection)) + ;; continue standard unloading + nil) (provide 'delsel) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index c1bdfeb55a8..18c4144c5f4 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -512,7 +512,7 @@ as well as widgets, buttons, overlays, and text properties." (if (cadr x) (length (car x)) 0)) item-list))) (help-setup-xref nil (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (with-current-buffer standard-output (set-buffer-multibyte multibyte-p) (let ((formatter (format "%%%ds:" max-width))) @@ -631,8 +631,7 @@ as well as widgets, buttons, overlays, and text properties." (if text-props-desc (insert text-props-desc)) (setq help-xref-stack-item (list 'help-insert-string (buffer-string))) - (toggle-read-only 1) - (print-help-return-message))))) + (toggle-read-only 1))))) (defalias 'describe-char-after 'describe-char) (make-obsolete 'describe-char-after 'describe-char "22.1") diff --git a/lisp/desktop.el b/lisp/desktop.el index dd0e6adac3f..6054099bb4d 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -135,6 +135,8 @@ ;;; Code: +(defvar uniquify-managed) + (defvar desktop-file-version "206" "Version number of desktop file format. Written into the desktop file and used at desktop read to provide @@ -204,7 +206,7 @@ the normal hook `desktop-not-loaded-hook' is run." (const :tag "Don't load" nil) (const :tag "Ask the user" ask)) :group 'desktop - :version "23.1") + :version "22.2") (defcustom desktop-base-file-name (convert-standard-filename ".emacs.desktop") @@ -219,7 +221,7 @@ the normal hook `desktop-not-loaded-hook' is run." "Name of lock file for Emacs desktop, excluding the directory part." :type 'file :group 'desktop - :version "23.1") + :version "22.2") (defcustom desktop-path '("." "~") "List of directories to search for the desktop file. @@ -253,7 +255,7 @@ May be used to deal with accidental multiple Emacs jobs." :type 'hook :group 'desktop :options '(desktop-save-mode-off save-buffers-kill-emacs) - :version "23.1") + :version "22.2") (defcustom desktop-after-read-hook nil "Normal hook run after a successful `desktop-read'. @@ -454,7 +456,8 @@ Furthermore the major mode function must be autoloaded.") (defcustom desktop-minor-mode-table '((auto-fill-function auto-fill-mode) (vc-mode nil) - (vc-dired-mode nil)) + (vc-dired-mode nil) + (erc-track-minor-mode nil)) "Table mapping minor mode variables to minor mode functions. Each entry has the form (NAME RESTORE-FUNCTION). NAME is the name of the buffer-local variable indicating that the minor @@ -653,7 +656,9 @@ is nil, ask the user where to save the desktop." (list ;; basic information (desktop-file-name (buffer-file-name) desktop-dirname) - (buffer-name) + (if (bound-and-true-p uniquify-managed) + (uniquify-item-base (car uniquify-managed)) + (buffer-name)) major-mode ;; minor modes (let (ret) @@ -1150,7 +1155,7 @@ directory DIRNAME." (setq desktop-first-buffer result)) (set-buffer result) (unless (equal (buffer-name) desktop-buffer-name) - (rename-buffer desktop-buffer-name)) + (rename-buffer desktop-buffer-name t)) ;; minor modes (cond ((equal '(t) desktop-buffer-minor-modes) ; backwards compatible (auto-fill-mode 1)) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index e0749f375ae..b9ceb728dbc 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1160,7 +1160,8 @@ Special value `always' suppresses confirmation." (or (eq recursive 'always) (yes-or-no-p (format "Recursive copies of %s? " from)))) ;; This is a directory. - (let ((files + (let ((mode (file-modes from)) + (files (condition-case err (directory-files from nil dired-re-no-dot) (file-error @@ -1174,7 +1175,9 @@ Special value `always' suppresses confirmation." (if (file-exists-p to) (or top (dired-handle-overwrite to)) (condition-case err - (make-directory to) + (progn + (make-directory to) + (set-file-modes to #o700)) (file-error (push (dired-make-relative from) dired-create-files-failures) @@ -1193,7 +1196,9 @@ Special value `always' suppresses confirmation." (file-error (push (dired-make-relative thisfrom) dired-create-files-failures) - (dired-log "Copying error for %s:\n%s\n" thisfrom err)))))) + (dired-log "Copying error for %s:\n%s\n" thisfrom err))))) + (when (file-directory-p to) + (set-file-modes to mode))) ;; Not a directory. (or top (dired-handle-overwrite to)) (condition-case err diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 245e41ba3a7..0be3aa393e1 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -939,7 +939,7 @@ dired." ;;; string. COMMAND may be a list of commands. ;;; ;;; * Return this command to `dired-guess-shell-command' which prompts user -;;; with it. The list of commands is temporarily put into the history list. +;;; with it. The list of commands is put into the list of default values. ;;; If a command is used successfully then it is stored permanently in ;;; `dired-shell-command-history'. diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el index 11442d8f6f5..86e64eeb453 100644 --- a/lisp/dirtrack.el +++ b/lisp/dirtrack.el @@ -57,18 +57,12 @@ ;; add 't' as a third element. Note that some of the functions in ;; 'comint.el' assume a single-line prompt (eg, comint-bol). ;; -;; Determining this information may take some experimentation. Setting -;; the variable `dirtrack-debug' may help; it causes the directory-tracking -;; filter to log messages to the buffer `dirtrack-debug-buffer'. You can easily -;; toggle this setting with the `dirtrack-debug-toggle' function. +;; Determining this information may take some experimentation. Using +;; `dirtrack-debug-mode' may help; it causes the directory-tracking +;; filter to log messages to the buffer `dirtrack-debug-buffer'. ;; -;; 3) Add a hook to shell-mode to enable the directory tracking: -;; -;; (add-hook 'shell-mode-hook -;; (lambda () (add-hook 'comint-preoutput-filter-functions 'dirtrack nil t))) -;; -;; You may wish to turn ordinary shell tracking off by calling -;; `shell-dirtrack-toggle' or setting `shell-dirtrackp'. +;; 3) Activate `dirtrack-mode'. You may wish to turn ordinary shell +;; tracking off by calling `shell-dirtrack-mode'. ;; ;; Examples: ;; @@ -147,7 +141,7 @@ be on a single line." :type 'boolean) (defcustom dirtrack-debug-buffer "*Directory Tracking Log*" - "Buffer to write directory tracking debug information." + "Buffer in which to write directory tracking debug information." :group 'dirtrack :type 'string) @@ -196,49 +190,53 @@ and ends with a forward slash." (concat (match-string 1 dir) ":" (match-string 2 dir)) dir)) -;; Copied from shell.el -(defun dirtrack-toggle () - "Enable or disable Dirtrack directory tracking in a shell buffer." - (interactive) - (if (setq dirtrackp (not dirtrackp)) + +;;;###autoload +(define-minor-mode dirtrack-mode + "Enable or disable Dirtrack directory tracking in a shell buffer. +This method requires that your shell prompt contain the full +current working directory at all times, and that `dirtrack-list' +is set to match the prompt. This is an alternative to +`shell-dirtrack-mode', which works differently, by tracking `cd' +and similar commands which change the shell working directory." + nil nil nil + (if dirtrack-mode (add-hook 'comint-preoutput-filter-functions 'dirtrack nil t) - (remove-hook 'comint-preoutput-filter-functions 'dirtrack t)) - (message "Directory tracking %s" (if dirtrackp "ON" "OFF"))) + (remove-hook 'comint-preoutput-filter-functions 'dirtrack t))) -(defun dirtrack-debug-toggle () +(define-obsolete-function-alias 'dirtrack-toggle 'dirtrack-mode "23.1") +(define-obsolete-variable-alias 'dirtrackp 'dirtrack-mode "23.1") + + +(define-minor-mode dirtrack-debug-mode "Enable or disable Dirtrack debugging." - (interactive) - (setq dirtrack-debug (not dirtrack-debug)) - (message "Directory debugging %s" (if dirtrack-debug "ON" "OFF")) - (and dirtrack-debug - (display-buffer (get-buffer-create dirtrack-debug-buffer)))) + nil nil nil + (if dirtrack-debug-mode + (display-buffer (get-buffer-create dirtrack-debug-buffer)))) + +(define-obsolete-function-alias 'dirtrack-debug-toggle 'dirtrack-debug-mode + "23.1") +(define-obsolete-variable-alias 'dirtrack-debug 'dirtrack-debug-mode "23.1") + (defun dirtrack-debug-message (string) - (let ((buf (current-buffer)) - (debug-buf (get-buffer-create dirtrack-debug-buffer)) - ) - (set-buffer debug-buf) - (goto-char (point-max)) - (insert (concat string "\n")) - (set-buffer buf) - )) + "Insert string at the end of `dirtrack-debug-buffer'." + (when dirtrack-debug-mode + (with-current-buffer (get-buffer-create dirtrack-debug-buffer) + (goto-char (point-max)) + (insert (concat string "\n"))))) ;;;###autoload (defun dirtrack (input) "Determine the current directory by scanning the process output for a prompt. The prompt to look for is the first item in `dirtrack-list'. -You can toggle directory tracking by using the function `dirtrack-toggle'. +You can toggle directory tracking by using the function `dirtrack-mode'. If directory tracking does not seem to be working, you can use the -function `dirtrack-debug-toggle' to turn on debugging output. - -You can enable directory tracking by adding this function to -`comint-output-filter-functions'." - (if (or (null dirtrackp) - ;; No output? - (eq (point) (point-min))) - nil +function `dirtrack-debug-mode' to turn on debugging output." + (unless (or (null dirtrack-mode) + (eq (point) (point-min))) ; no output? (let (prompt-path (current-dir default-directory) (dirtrack-regexp (nth 0 dirtrack-list)) @@ -247,40 +245,31 @@ You can enable directory tracking by adding this function to (multi-line (nth 2 dirtrack-list))) (save-excursion ;; No match - (if (null (string-match dirtrack-regexp input)) - (and dirtrack-debug - (dirtrack-debug-message - (format - "Input `%s' failed to match `dirtrack-regexp'" input))) + (if (not (string-match dirtrack-regexp input)) + (dirtrack-debug-message + (format "Input `%s' failed to match `dirtrack-regexp'" input)) (setq prompt-path (match-string match-num input)) ;; Empty string (if (not (> (length prompt-path) 0)) - (and dirtrack-debug - (dirtrack-debug-message "Match is empty string")) + (dirtrack-debug-message "Match is empty string") ;; Transform prompts into canonical forms (setq prompt-path (funcall dirtrack-directory-function - prompt-path)) - (setq current-dir (funcall dirtrack-canonicalize-function + prompt-path) + current-dir (funcall dirtrack-canonicalize-function current-dir)) - (and dirtrack-debug - (dirtrack-debug-message - (format - "Prompt is %s\nCurrent directory is %s" - prompt-path current-dir))) + (dirtrack-debug-message + (format "Prompt is %s\nCurrent directory is %s" + prompt-path current-dir)) ;; Compare them (if (or (string= current-dir prompt-path) - (string= current-dir - (abbreviate-file-name prompt-path))) - (and dirtrack-debug - (dirtrack-debug-message - (format "Not changing directory"))) + (string= current-dir (abbreviate-file-name prompt-path))) + (dirtrack-debug-message (format "Not changing directory")) ;; It's possible that Emacs will think the directory ;; won't exist (eg, rlogin buffers) (if (file-accessible-directory-p prompt-path) ;; Change directory (and (shell-process-cd prompt-path) (run-hooks 'dirtrack-directory-change-hook) - dirtrack-debug (dirtrack-debug-message (format "Changing directory to %s" prompt-path))) (error "Directory %s does not exist" prompt-path))) diff --git a/lisp/disp-table.el b/lisp/disp-table.el index 543364867eb..201e4d6ce89 100644 --- a/lisp/disp-table.el +++ b/lisp/disp-table.el @@ -75,7 +75,7 @@ Valid symbols are `truncation', `wrap', `escape', `control', ;;;###autoload (defun describe-display-table (dt) "Describe the display table DT in a help buffer." - (with-output-to-temp-buffer "*Help*" + (with-help-window "*Help*" (princ "\nTruncation glyph: ") (prin1 (display-table-slot dt 'truncation)) (princ "\nWrap glyph: ") @@ -97,8 +97,7 @@ Valid symbols are `truncation', `wrap', `escape', `control', (aset vector i (aref dt i)) (setq i (1+ i))) (describe-vector vector)) - (help-mode)) - (print-help-return-message))) + (help-mode)))) ;;;###autoload (defun describe-current-display-table () diff --git a/lisp/doc-view.el b/lisp/doc-view.el index b6d8235a02b..89f1b009f7f 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -42,8 +42,7 @@ ;; ;; and the document will be converted and displayed, if your emacs supports png ;; images. With `C-c C-c' you can toggle between the rendered images -;; representation and the source text representation of the document. With -;; `C-c C-e' you can switch to an appropriate editing mode for the document. +;; representation and the source text representation of the document. ;; ;; Since conversion may take some time all the PNG images are cached in a ;; subdirectory of `doc-view-cache-directory' and reused when you want to view @@ -72,14 +71,14 @@ ;; You can also search within the document. The command `doc-view-search' ;; (bound to `C-s') queries for a search regexp and initializes a list of all ;; matching pages and messages how many match-pages were found. After that you -;; can jump to the next page containing a match with -;; `doc-view-search-next-match' (bound to `C-S-n') or to the previous matching -;; page with `doc-view-search-previous-match' (bound to `C-S-p'). This works -;; by searching a plain text representation of the document. If that doesn't -;; already exist the first invokation of `doc-view-search' starts the -;; conversion. When that finishes and you're still viewing the document -;; (i.e. you didn't switch to another buffer) you're queried for the regexp -;; then. +;; can jump to the next page containing a match with an additional `C-s'. With +;; `C-r' you can do the same, but backwards. To search for a new regexp give a +;; prefix arg to one of the search functions, e.g. by typing `C-u C-s'. The +;; searching works by using a plain text representation of the document. If +;; that doesn't already exist the first invokation of `doc-view-search' (or +;; `doc-view-search-backward') starts the conversion. When that finishes and +;; you're still viewing the document (i.e. you didn't switch to another buffer) +;; you're queried for the regexp then. ;; ;; Dired users can simply hit `v' on a document file. If it's a PS, PDF or DVI ;; it will be opened using `doc-view-mode'. @@ -100,9 +99,17 @@ ;;; Code: +;; Todo: +;; - better menu. +;; - don't use `find-file'. +;; - Bind slicing to a drag event. +;; - zoom (the whole document and/or just the region around the cursor). +;; - get rid of the silly arrow in the fringe. +;; - improve anti-aliasing (pdf-utils gets it better). + (require 'dired) (require 'image-mode) -(eval-when-compile (require 'cl)) +(require 'jka-compr) ;;;; Customization Options @@ -150,8 +157,9 @@ Needed for searching." :type 'file :group 'doc-view) -(defcustom doc-view-cache-directory (concat temporary-file-directory - "doc-view") +(defcustom doc-view-cache-directory + (expand-file-name (format "docview%d" (user-uid)) + temporary-file-directory) "The base directory, where the PNG images will be saved." :type 'directory :group 'doc-view) @@ -162,8 +170,8 @@ Needed for searching." :group 'doc-view) (defcustom doc-view-conversion-refresh-interval 3 - "Every how much seconds the DocView buffer gets refreshed while conversion. -After such an refresh newly converted pages will be available for + "Interval in seconds between refreshes of the DocView buffer while converting. +After such a refresh newly converted pages will be available for viewing. If set to nil there won't be any refreshes and the pages won't be displayed before conversion of the whole document has finished." @@ -178,9 +186,6 @@ has finished." (defvar doc-view-current-page nil "Only used internally.") -(defvar doc-view-current-doc nil - "Only used internally.") - (defvar doc-view-current-converter-process nil "Only used internally.") @@ -198,17 +203,20 @@ has finished." (defvar doc-view-current-image nil "Only used internally.") +(defvar doc-view-current-overlay) +(defvar doc-view-pending-cache-flush nil) (defvar doc-view-current-info nil "Only used internally.") -(defvar doc-view-current-display nil +(defvar doc-view-previous-major-mode nil "Only used internally.") ;;;; DocView Keymaps (defvar doc-view-mode-map (let ((map (make-sparse-keymap))) + (suppress-keymap map) ;; Navigation in the document (define-key map (kbd "n") 'doc-view-next-page) (define-key map (kbd "p") 'doc-view-previous-page) @@ -220,10 +228,11 @@ has finished." (define-key map (kbd "DEL") 'doc-view-scroll-down-or-previous-page) (define-key map (kbd "M-<") 'doc-view-first-page) (define-key map (kbd "M->") 'doc-view-last-page) - (define-key map (kbd "g") 'doc-view-goto-page) + (define-key map [remap goto-line] 'doc-view-goto-page) ;; Killing/burying the buffer (and the process) (define-key map (kbd "q") 'bury-buffer) (define-key map (kbd "k") 'doc-view-kill-proc-and-buffer) + (define-key map (kbd "K") 'doc-view-kill-proc) ;; Slicing the image (define-key map (kbd "s s") 'doc-view-set-slice) (define-key map (kbd "s m") 'doc-view-set-slice-using-mouse) @@ -231,8 +240,7 @@ has finished." ;; Searching (define-key map (kbd "C-s") 'doc-view-search) (define-key map (kbd "<find>") 'doc-view-search) - (define-key map (kbd "C-S-n") 'doc-view-search-next-match) - (define-key map (kbd "C-S-p") 'doc-view-search-previous-match) + (define-key map (kbd "C-r") 'doc-view-search-backward) ;; Scrolling (define-key map [remap forward-char] 'image-forward-hscroll) (define-key map [remap backward-char] 'image-backward-hscroll) @@ -242,24 +250,30 @@ has finished." (define-key map (kbd "C-t") 'doc-view-show-tooltip) ;; Toggle between text and image display or editing (define-key map (kbd "C-c C-c") 'doc-view-toggle-display) - (define-key map (kbd "C-c C-e") 'doc-view-edit-doc) ;; Reconvert the current document - (define-key map (kbd "g") 'doc-view-reconvert-doc) - (suppress-keymap map) + (define-key map (kbd "g") 'revert-buffer) + (define-key map (kbd "r") 'revert-buffer) map) "Keymap used by `doc-view-mode' when displaying a doc as a set of images.") -(defvar doc-view-mode-text-map +(easy-menu-define doc-view-menu doc-view-mode-map + "Menu for Doc View mode." + '("DocView" + ["Set Slice" doc-view-set-slice-using-mouse] + ["Set Slice (manual)" doc-view-set-slice] + ["Reset Slice" doc-view-reset-slice] + "---" + ["Search" doc-view-search] + ["Search Backwards" doc-view-search-backward] + ["Toggle display" doc-view-toggle-display] + )) + +(defvar doc-view-minor-mode-map (let ((map (make-sparse-keymap))) ;; Toggle between text and image display or editing (define-key map (kbd "C-c C-c") 'doc-view-toggle-display) - (define-key map (kbd "C-c C-e") 'doc-view-edit-doc) - ;; Killing/burying the buffer (and the process) - (define-key map (kbd "q") 'bury-buffer) - (define-key map (kbd "k") 'doc-view-kill-proc-and-buffer) - (define-key map (kbd "C-x k") 'doc-view-kill-proc-and-buffer) map) - "Keymap used by `doc-view-mode' when displaying a document as text.") + "Keymap used by `doc-minor-view-mode'.") ;;;; Navigation Commands @@ -293,16 +307,14 @@ has finished." (setq contexts (concat contexts " - \"" m "\"\n"))) contexts))))) ;; Update the buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (let ((beg (point))) - (doc-view-insert-image (nth (1- page) doc-view-current-files) - :pointer 'arrow) - (put-text-property beg (point) 'help-echo doc-view-current-info)) - (insert "\n" doc-view-current-info) - (goto-char (point-min)) - (forward-char)) - (set-buffer-modified-p nil))) + (doc-view-insert-image (nth (1- page) doc-view-current-files) + :pointer 'arrow) + (overlay-put doc-view-current-overlay 'help-echo doc-view-current-info) + (goto-char (point-min)) + ;; This seems to be needed for set-window-hscroll (in + ;; image-forward-hscroll) to do something useful, I don't have time to + ;; debug this now. :-( --Stef + (forward-char))) (defun doc-view-next-page (&optional arg) "Browse ARG pages forward." @@ -339,11 +351,14 @@ has finished." (error (doc-view-previous-page) (goto-char (point-max))))) +;;;; Utility Functions + (defun doc-view-kill-proc () "Kill the current converter process." (interactive) (when doc-view-current-converter-process - (kill-process doc-view-current-converter-process)) + (kill-process doc-view-current-converter-process) + (setq doc-view-current-converter-process nil)) (when doc-view-current-timer (cancel-timer doc-view-current-timer) (setq doc-view-current-timer nil)) @@ -356,33 +371,68 @@ has finished." (when (eq major-mode 'doc-view-mode) (kill-buffer (current-buffer)))) -;;;; Conversion Functions - -(defun doc-view-reconvert-doc (&rest args) - "Reconvert the current document. -Should be invoked when the cached images aren't up-to-date." - (interactive) - (let ((inhibit-read-only t) - (doc doc-view-current-doc)) - (doc-view-kill-proc) - ;; Clear the old cached files - (when (file-exists-p (doc-view-current-cache-dir)) - (dired-delete-file (doc-view-current-cache-dir) 'always)) - (doc-view-kill-proc-and-buffer) - (find-file doc))) +(defun doc-view-make-safe-dir (dir) + (condition-case nil + (let ((umask (default-file-modes))) + (unwind-protect + (progn + ;; Create temp files with strict access rights. It's easy to + ;; loosen them later, whereas it's impossible to close the + ;; time-window of loose permissions otherwise. + (set-default-file-modes #o0700) + (make-directory dir)) + ;; Reset the umask. + (set-default-file-modes umask))) + (file-already-exists + (if (file-symlink-p dir) + (error "Danger: %s points to a symbolic link" dir)) + ;; In case it was created earlier with looser rights. + ;; We could check the mode info returned by file-attributes, but it's + ;; a pain to parse and it may not tell you what we want under + ;; non-standard file-systems. So let's just say what we want and let + ;; the underlying C code and file-system figure it out. + ;; This also ends up checking a bunch of useful conditions: it makes + ;; sure we have write-access to the directory and that we own it, thus + ;; closing a bunch of security holes. + (set-file-modes dir #o0700)))) (defun doc-view-current-cache-dir () "Return the directory where the png files of the current doc should be saved. It's a subdirectory of `doc-view-cache-directory'." (if doc-view-current-cache-dir doc-view-current-cache-dir + ;; Try and make sure doc-view-cache-directory exists and is safe. + (doc-view-make-safe-dir doc-view-cache-directory) + ;; Now compute the subdirectory to use. (setq doc-view-current-cache-dir (file-name-as-directory - (concat (file-name-as-directory doc-view-cache-directory) - (let ((doc doc-view-current-doc)) - (with-temp-buffer - (insert-file-contents-literally doc) - (md5 (current-buffer))))))))) + (expand-file-name + (let ((doc buffer-file-name)) + (concat (file-name-nondirectory doc) + "-" + (with-temp-buffer + (insert-file-contents-literally doc) + (md5 (current-buffer))))) + doc-view-cache-directory))))) + +(defun doc-view-remove-if (predicate list) + "Return LIST with all items removed that satisfy PREDICATE." + (let (new-list) + (dolist (item list (nreverse new-list)) + (when (not (funcall predicate item)) + (setq new-list (cons item new-list)))))) + +;;;; Conversion Functions + +(defun doc-view-reconvert-doc () + "Reconvert the current document. +Should be invoked when the cached images aren't up-to-date." + (interactive) + (doc-view-kill-proc) + ;; Clear the old cached files + (when (file-exists-p (doc-view-current-cache-dir)) + (dired-delete-file (doc-view-current-cache-dir) 'always)) + (doc-view-initiate-display)) (defun doc-view-dvi->pdf-sentinel (proc event) "If DVI->PDF conversion was successful, convert the PDF to PNG now." @@ -393,12 +443,12 @@ It's a subdirectory of `doc-view-cache-directory'." mode-line-process nil) ;; Now go on converting this PDF to a set of PNG files. (let* ((pdf (process-get proc 'pdf-file)) - (png (concat (doc-view-current-cache-dir) - "page-%d.png"))) + (png (expand-file-name "page-%d.png" + (doc-view-current-cache-dir)))) (doc-view-pdf/ps->png pdf png)))) (defun doc-view-dvi->pdf (dvi pdf) - "Convert DVI to PDF asynchrounously." + "Convert DVI to PDF asynchronously." (setq doc-view-current-converter-process (start-process "dvi->pdf" doc-view-conversion-buffer doc-view-dvipdfm-program @@ -420,10 +470,10 @@ It's a subdirectory of `doc-view-cache-directory'." (cancel-timer doc-view-current-timer) (setq doc-view-current-timer nil)) ;; Yippie, finished. Update the display! - (doc-view-display doc-view-current-doc))) + (doc-view-display buffer-file-name))) (defun doc-view-pdf/ps->png (pdf-ps png) - "Convert PDF-PS to PNG asynchrounously." + "Convert PDF-PS to PNG asynchronously." (setq doc-view-current-converter-process (apply 'start-process (append (list "pdf/ps->png" doc-view-conversion-buffer @@ -439,8 +489,8 @@ It's a subdirectory of `doc-view-cache-directory'." (when doc-view-conversion-refresh-interval (setq doc-view-current-timer (run-at-time "1 secs" doc-view-conversion-refresh-interval - 'doc-view-display-maybe - doc-view-current-doc)))) + 'doc-view-display + buffer-file-name)))) (defun doc-view-pdf->txt-sentinel (proc event) (if (not (string-match "finished" event)) @@ -453,10 +503,10 @@ It's a subdirectory of `doc-view-cache-directory'." ;; If the user looks at the DocView buffer where the conversion was ;; performed, search anew. This time it will be queried for a regexp. (when (eq current-buffer proc-buffer) - (doc-view-search))))) + (doc-view-search nil))))) (defun doc-view-pdf->txt (pdf txt) - "Convert PDF to TXT asynchrounously." + "Convert PDF to TXT asynchronously." (setq doc-view-current-converter-process (start-process "pdf->txt" doc-view-conversion-buffer doc-view-pdftotext-program "-raw" @@ -474,18 +524,19 @@ It's a subdirectory of `doc-view-cache-directory'." mode-line-process nil) ;; Now we can transform to plain text. (doc-view-pdf->txt (process-get proc 'pdf-file) - (concat (doc-view-current-cache-dir) - "doc.txt")))) + (expand-file-name "doc.txt" + (doc-view-current-cache-dir))))) (defun doc-view-ps->pdf (ps pdf) "Convert PS to PDF asynchronously." (setq doc-view-current-converter-process (start-process "ps->pdf" doc-view-conversion-buffer doc-view-ps2pdf-program - ps pdf ;; Avoid security problems when rendering files from ;; untrusted sources. - "-dSAFER") + "-dSAFER" + ;; in-file and out-file + ps pdf) mode-line-process (list (format ":%s" doc-view-current-converter-process))) (set-process-sentinel doc-view-current-converter-process 'doc-view-ps->pdf-sentinel) @@ -493,21 +544,26 @@ It's a subdirectory of `doc-view-cache-directory'." (process-put doc-view-current-converter-process 'pdf-file pdf)) (defun doc-view-convert-current-doc () - "Convert `doc-view-current-doc' to a set of png files, one file per page. + "Convert `buffer-file-name' to a set of png files, one file per page. Those files are saved in the directory given by the function `doc-view-current-cache-dir'." - (clear-image-cache) - (let ((png-file (concat (doc-view-current-cache-dir) - "page-%d.png"))) - (make-directory doc-view-current-cache-dir t) - (if (not (string= (file-name-extension doc-view-current-doc) "dvi")) + ;; Let stale files still display while we recompute the new ones, so only + ;; flush the cache when the conversion is over. One of the reasons why it + ;; is important to keep displaying the stale page is so that revert-buffer + ;; preserves the horizontal/vertical scroll settings (which are otherwise + ;; resets during the redisplay). + (setq doc-view-pending-cache-flush t) + (let ((png-file (expand-file-name "page-%d.png" + (doc-view-current-cache-dir)))) + (make-directory (doc-view-current-cache-dir)) + (if (not (string= (file-name-extension buffer-file-name) "dvi")) ;; Convert to PNG images. - (doc-view-pdf/ps->png doc-view-current-doc png-file) + (doc-view-pdf/ps->png buffer-file-name png-file) ;; DVI files have to be converted to PDF before Ghostscript can process ;; it. - (doc-view-dvi->pdf doc-view-current-doc - (concat (file-name-as-directory doc-view-current-cache-dir) - "doc.pdf"))))) + (doc-view-dvi->pdf buffer-file-name + (expand-file-name "doc.pdf" + doc-view-current-cache-dir))))) ;;;; Slicing @@ -551,8 +607,7 @@ dragging it to its bottom-right corner. See also (defun doc-view-reset-slice () "Reset the current slice. -After calling this function the whole pages will be visible -again." +After calling this function whole pages will be visible again." (interactive) (setq doc-view-current-slice nil) ;; Redisplay @@ -563,23 +618,23 @@ again." (defun doc-view-insert-image (file &rest args) "Insert the given png FILE. ARGS is a list of image descriptors." + (when doc-view-pending-cache-flush + (clear-image-cache) + (setq doc-view-pending-cache-flush nil)) (let ((image (apply 'create-image file 'png nil args))) (setq doc-view-current-image image) - (insert-image image (concat "[" file "]") nil doc-view-current-slice))) + (move-overlay doc-view-current-overlay (point-min) (point-max)) + (overlay-put doc-view-current-overlay 'display + (if doc-view-current-slice + (list (cons 'slice doc-view-current-slice) image) + image)))) (defun doc-view-sort (a b) "Return non-nil if A should be sorted before B. Predicate for sorting `doc-view-current-files'." - (if (< (length a) (length b)) - t - (if (> (length a) (length b)) - nil - (string< a b)))) - -(defun doc-view-display-maybe (doc) - "Call `doc-view-display' iff we're in the image display." - (when (eq doc-view-current-display 'image) - (doc-view-display doc))) + (or (< (length a) (length b)) + (and (= (length a) (length b)) + (string< a b)))) (defun doc-view-display (doc) "Start viewing the document DOC." @@ -592,69 +647,50 @@ Predicate for sorting `doc-view-current-files'." (doc-view-goto-page doc-view-current-page))) (defun doc-view-buffer-message () - (insert (propertize "Welcome to DocView!" 'face 'bold) - "\n" - " -If you see this buffer it means that the document you want to -view gets converted to PNG now and the conversion of the first -page hasn't finished yet or + ;; Only show this message initially, not when refreshing the buffer (in which + ;; case it's better to keep displaying the "stale" page while computing + ;; the fresh new ones). + (unless (overlay-get doc-view-current-overlay 'display) + (overlay-put doc-view-current-overlay 'display + (concat (propertize "Welcome to DocView!" 'face 'bold) + "\n" + " +If you see this buffer it means that the document you want to view is being +converted to PNG and the conversion of the first page hasn't finished yet or `doc-view-conversion-refresh-interval' is set to nil. For now these keys are useful: `q' : Bury this buffer. Conversion will go on in background. -`k' : Kill the conversion process and this buffer.\n") - (set-buffer-modified-p nil)) +`k' : Kill the conversion process and this buffer. +`K' : Kill the conversion process.\n")))) (defun doc-view-show-tooltip () (interactive) (tooltip-show doc-view-current-info)) -;;;;; Toggle between text and image display +;;;;; Toggle between editing and viewing (defun doc-view-toggle-display () - "Start or stop displaying a document file as a set of images. -This command toggles between showing the text of the document -file and showing the document as a set of images." + "Toggle between editing a document as text or viewing it." (interactive) - (if (get-text-property (point-min) 'display) - ;; Switch to text display - (let ((inhibit-read-only t)) - (erase-buffer) - (insert-file-contents doc-view-current-doc) - (use-local-map doc-view-mode-text-map) - (setq mode-name "DocView[text]" - doc-view-current-display 'text) - (if (called-interactively-p) - (message "Repeat this command to go back to displaying the file as images"))) - ;; Switch to image display - (let ((inhibit-read-only t)) - (erase-buffer) - (doc-view-buffer-message) - (setq doc-view-current-page (or doc-view-current-page 1)) - (if (file-exists-p (doc-view-current-cache-dir)) - (progn - (message "DocView: using cached files!") - (doc-view-display doc-view-current-doc)) - (doc-view-convert-current-doc)) - (use-local-map doc-view-mode-map) - (setq mode-name (format "DocView") - doc-view-current-display 'image) - (if (called-interactively-p) - (message "Repeat this command to go back to displaying the file as text")))) - (set-buffer-modified-p nil)) - -;;;;; Leave doc-view-mode and open the file for edit - -(defun doc-view-edit-doc () - "Leave `doc-view-mode' and open the current doc with an appropriate editing mode." - (interactive) - (let ((filename doc-view-current-doc) - (auto-mode-alist (append '(("\\.[eE]?[pP][sS]\\'" . ps-mode) - ("\\.\\(pdf\\|PDF\\|dvi\\|DVI\\)$" . fundamental-mode)) - auto-mode-alist))) - (kill-buffer (current-buffer)) - (find-file filename))) + (if (eq major-mode 'doc-view-mode) + ;; Switch to editing mode + (progn + (doc-view-kill-proc) + (setq buffer-read-only nil) + (delete-overlay doc-view-current-overlay) + ;; Switch to the previously used major mode or fall back to fundamental + ;; mode. + (if doc-view-previous-major-mode + (funcall doc-view-previous-major-mode) + (fundamental-mode)) + (doc-view-minor-mode 1)) + ;; Switch to doc-view-mode + (when (and (buffer-modified-p) + (y-or-n-p "The buffer has been modified. Save the changes? ")) + (save-buffer)) + (doc-view-mode))) ;;;; Searching @@ -672,11 +708,11 @@ the pagenumber and CONTEXTS are all lines of text containing a match." (when (match-string 1) (incf page)) (when (match-string 2) (if (/= page lastpage) - (setq matches (push (cons page - (list (buffer-substring - (line-beginning-position) - (line-end-position)))) - matches)) + (push (cons page + (list (buffer-substring + (line-beginning-position) + (line-end-position)))) + matches) (setq matches (cons (append (or @@ -698,52 +734,64 @@ the pagenumber and CONTEXTS are all lines of text containing a match." (setq no (+ no (1- (length p))))) no)) -(defun doc-view-search () - "Query for a regexp and search the current document. +(defun doc-view-search-backward (new-query) + "Call `doc-view-search' for backward search. +If prefix NEW-QUERY is given, ask for a new regexp." + (interactive "P") + (doc-view-search arg t)) + +(defun doc-view-search (new-query &optional backward) + "Jump to the next match or initiate a new search if NEW-QUERY is given. If the current document hasn't been transformed to plain text -till now do that first. You should try searching anew when the -conversion finished." - (interactive) - ;; New search, so forget the old results. - (setq doc-view-current-search-matches nil) - (let ((txt (concat (doc-view-current-cache-dir) - "doc.txt"))) - (if (file-readable-p txt) - (progn - (setq doc-view-current-search-matches - (doc-view-search-internal - (read-from-minibuffer "Regexp: ") - txt)) - (message "DocView: search yielded %d matches." - (doc-view-search-no-of-matches - doc-view-current-search-matches))) - ;; We must convert to TXT first! - (if doc-view-current-converter-process - (message "DocView: please wait till conversion finished.") - (let ((ext (file-name-extension doc-view-current-doc))) - (cond - ((string= ext "pdf") - ;; Doc is a PDF, so convert it to TXT - (doc-view-pdf->txt doc-view-current-doc txt)) - ((string= ext "ps") - ;; Doc is a PS, so convert it to PDF (which will be converted to - ;; TXT thereafter). - (doc-view-ps->pdf doc-view-current-doc - (concat (doc-view-current-cache-dir) - "doc.pdf"))) - ((string= ext "dvi") - ;; Doc is a DVI. This means that a doc.pdf already exists in its - ;; cache subdirectory. - (doc-view-pdf->txt (concat (doc-view-current-cache-dir) - "doc.pdf") - txt)) - (t (error "DocView doesn't know what to do")))))))) +till now do that first. +If BACKWARD is non-nil, jump to the previous match." + (interactive "P") + (if (and (not arg) + doc-view-current-search-matches) + (if backward + (doc-view-search-previous-match 1) + (doc-view-search-next-match 1)) + ;; New search, so forget the old results. + (setq doc-view-current-search-matches nil) + (let ((txt (expand-file-name "doc.txt" + (doc-view-current-cache-dir)))) + (if (file-readable-p txt) + (progn + (setq doc-view-current-search-matches + (doc-view-search-internal + (read-from-minibuffer "Regexp: ") + txt)) + (message "DocView: search yielded %d matches." + (doc-view-search-no-of-matches + doc-view-current-search-matches))) + ;; We must convert to TXT first! + (if doc-view-current-converter-process + (message "DocView: please wait till conversion finished.") + (let ((ext (file-name-extension buffer-file-name))) + (cond + ((string= ext "pdf") + ;; Doc is a PDF, so convert it to TXT + (doc-view-pdf->txt buffer-file-name txt)) + ((string= ext "ps") + ;; Doc is a PS, so convert it to PDF (which will be converted to + ;; TXT thereafter). + (doc-view-ps->pdf buffer-file-name + (expand-file-name "doc.pdf" + (doc-view-current-cache-dir)))) + ((string= ext "dvi") + ;; Doc is a DVI. This means that a doc.pdf already exists in its + ;; cache subdirectory. + (doc-view-pdf->txt (expand-file-name "doc.pdf" + (doc-view-current-cache-dir)) + txt)) + (t (error "DocView doesn't know what to do"))))))))) (defun doc-view-search-next-match (arg) "Go to the ARGth next matching page." (interactive "p") - (let* ((next-pages (remove-if (lambda (i) (<= (car i) doc-view-current-page)) - doc-view-current-search-matches)) + (let* ((next-pages (doc-view-remove-if + (lambda (i) (<= (car i) doc-view-current-page)) + doc-view-current-search-matches)) (page (car (nth (1- arg) next-pages)))) (if page (doc-view-goto-page page) @@ -755,8 +803,9 @@ conversion finished." (defun doc-view-search-previous-match (arg) "Go to the ARGth previous matching page." (interactive "p") - (let* ((prev-pages (remove-if (lambda (i) (>= (car i) doc-view-current-page)) - doc-view-current-search-matches)) + (let* ((prev-pages (doc-view-remove-if + (lambda (i) (>= (car i) doc-view-current-page)) + doc-view-current-search-matches)) (page (car (nth (1- arg) (nreverse prev-pages))))) (if page (doc-view-goto-page page) @@ -767,40 +816,92 @@ conversion finished." ;;;; User interface commands and the mode -(put 'doc-view-mode 'mode-class 'special) +;; (put 'doc-view-mode 'mode-class 'special) + +(defun doc-view-initiate-display () + ;; Switch to image display if possible + (if (and (display-images-p) + (image-type-available-p 'png)) + (progn + (doc-view-buffer-message) + (setq doc-view-current-page (or doc-view-current-page 1)) + (if (file-exists-p (doc-view-current-cache-dir)) + (progn + (message "DocView: using cached files!") + (doc-view-display buffer-file-name)) + (doc-view-convert-current-doc)) + (message + "%s" + (substitute-command-keys + (concat "Type \\[doc-view-toggle-display] to toggle between " + "editing or viewing the document.")))) + (message + "%s" + (substitute-command-keys + (concat "No image (png) support available. Type \\[doc-view-toggle-display] " + "to switch to an editing mode."))))) ;;;###autoload -(define-derived-mode doc-view-mode nil "DocView" +(defun doc-view-mode () "Major mode in DocView buffers. You can use \\<doc-view-mode-map>\\[doc-view-toggle-display] to -toggle between display as a set of images and display as text." +toggle between displaying the document or editing it as text." + (interactive) + (if jka-compr-really-do-compress + ;; This is a compressed file uncompressed by auto-compression-mode. + (when (y-or-n-p (concat "DocView: Cannot convert compressed file. " + "Save it uncompressed first? ")) + (let ((file (read-file-name + "File: " + (file-name-directory buffer-file-name)))) + (write-region (point-min) (point-max) file) + (kill-buffer nil) + (find-file file) + (doc-view-mode))) + (let* ((prev-major-mode (if (eq major-mode 'doc-view-mode) + doc-view-previous-major-mode + major-mode))) + (kill-all-local-variables) + (set (make-local-variable 'doc-view-previous-major-mode) prev-major-mode)) + (make-local-variable 'doc-view-current-files) + (make-local-variable 'doc-view-current-image) + (make-local-variable 'doc-view-current-page) + (make-local-variable 'doc-view-current-converter-process) + (make-local-variable 'doc-view-current-timer) + (make-local-variable 'doc-view-current-slice) + (make-local-variable 'doc-view-current-cache-dir) + (make-local-variable 'doc-view-current-info) + (make-local-variable 'doc-view-current-search-matches) + (set (make-local-variable 'doc-view-current-overlay) + (make-overlay (point-min) (point-max) nil t)) + (add-hook 'change-major-mode-hook + (lambda () (delete-overlay doc-view-current-overlay)) + nil t) + (set (make-local-variable 'mode-line-position) + '(" P" (:eval (number-to-string doc-view-current-page)) + "/" (:eval (number-to-string (length doc-view-current-files))))) + (set (make-local-variable 'cursor-type) nil) + (use-local-map doc-view-mode-map) + (set (make-local-variable 'after-revert-hook) 'doc-view-reconvert-doc) + (setq mode-name "DocView" + buffer-read-only t + major-mode 'doc-view-mode) + (doc-view-initiate-display) + (run-mode-hooks 'doc-view-mode-hook))) + +;;;###autoload +(define-minor-mode doc-view-minor-mode + "Toggle Doc view minor mode. +With arg, turn Doc view minor mode on if arg is positive, off otherwise. +See the command `doc-view-mode' for more information on this mode." + nil " DocView" doc-view-minor-mode-map :group 'doc-view - (make-local-variable 'doc-view-current-files) - (make-local-variable 'doc-view-current-doc) - (make-local-variable 'doc-view-current-image) - (make-local-variable 'doc-view-current-page) - (make-local-variable 'doc-view-current-converter-process) - (make-local-variable 'doc-view-current-timer) - (make-local-variable 'doc-view-current-slice) - (make-local-variable 'doc-view-current-cache-dir) - (make-local-variable 'doc-view-current-info) - (make-local-variable 'doc-view-current-search-matches) - (setq doc-view-current-doc (buffer-file-name)) - (insert-file-contents doc-view-current-doc) - (use-local-map doc-view-mode-text-map) - (setq mode-name "DocView[text]" - doc-view-current-display 'text - buffer-read-only t - revert-buffer-function 'doc-view-reconvert-doc) - ;; Switch to image display if possible - (if (and (display-images-p) - (image-type-available-p 'png) - (not (get-text-property (point-min) 'display))) - (doc-view-toggle-display)) - (message - "%s" - (substitute-command-keys - "Type \\[doc-view-toggle-display] to toggle between image and text display."))) + (when doc-view-minor-mode + (add-hook 'change-major-mode-hook (lambda () (doc-view-minor-mode -1)) nil t) + (message + "%s" + (substitute-command-keys + "Type \\[doc-view-toggle-display] to toggle between editing or viewing the document.")))) (defun doc-view-clear-cache () "Delete the whole cache (`doc-view-cache-directory')." diff --git a/lisp/ediff-diff.el b/lisp/ediff-diff.el index 451f87e142d..06d7b603440 100644 --- a/lisp/ediff-diff.el +++ b/lisp/ediff-diff.el @@ -48,7 +48,6 @@ :prefix "ediff-" :group 'ediff) -;; these two must be here to prevent ediff-test-utility from barking (defcustom ediff-diff-program "diff" "*Program to use for generating the differential of the two files." :type 'string @@ -62,46 +61,8 @@ Must produce output compatible with Unix's diff3 program." ;; The following functions must precede all defcustom-defined variables. -;; The following functions needed for setting diff/diff3 options -;; test if diff supports the --binary option -(defsubst ediff-test-utility (diff-util option &optional files) - (condition-case nil - (eq 0 (apply 'call-process - (append (list diff-util nil nil nil option) files))) - (error (format "Cannot execute program %S." diff-util))) - ) - -(defun ediff-diff-mandatory-option (diff-util) - (let ((file (if (boundp 'null-device) null-device "/dev/null"))) - (cond ((not (memq system-type '(ms-dos windows-nt windows-95))) - "") - ((and (string= diff-util ediff-diff-program) - (ediff-test-utility - ediff-diff-program "--binary" (list file file))) - "--binary ") - ((and (string= diff-util ediff-diff3-program) - (ediff-test-utility - ediff-diff3-program "--binary" (list file file file))) - "--binary ") - (t "")))) - - -;; must be before ediff-reset-diff-options to avoid compiler errors (fset 'ediff-set-actual-diff-options '(lambda () nil)) -;; make sure that mandatory options are added even if the user changes -;; ediff-diff-options or ediff-diff3-options in the customization widget -(defun ediff-reset-diff-options (symb val) - (let* ((diff-program - (if (eq symb 'ediff-diff-options) - ediff-diff-program - ediff-diff3-program)) - (mandatory-option (ediff-diff-mandatory-option diff-program))) - (set symb (concat mandatory-option val)) - (ediff-set-actual-diff-options) - )) - - (defcustom ediff-shell (cond ((eq system-type 'emx) "cmd") ; OS/2 ((memq system-type '(ms-dos windows-nt windows-95)) @@ -130,17 +91,25 @@ are `-I REGEXP', to ignore changes whose lines match the REGEXP." :type '(repeat string) :group 'ediff-diff) -(defcustom ediff-diff-options "" +(defun ediff-set-diff-options (symbol value) + (set symbol value) + (ediff-set-actual-diff-options)) + +(defcustom ediff-diff-options + (if (memq system-type '(ms-dos windows-nt windows-95)) "--binary" "") "*Options to pass to `ediff-diff-program'. If Unix diff is used as `ediff-diff-program', then a useful option is `-w', to ignore space. Options `-c', `-u', and `-i' are not allowed. Case sensitivity can be toggled interactively using \\[ediff-toggle-ignore-case]. +Do not remove the default options. If you need to change this variable, add new +options after the default ones. + This variable is not for customizing the look of the differences produced by the command \\[ediff-show-diff-output]. Use the variable `ediff-custom-diff-options' for that." - :set 'ediff-reset-diff-options + :set 'ediff-set-diff-options :type 'string :group 'ediff-diff) @@ -179,7 +148,7 @@ This output is not used by Ediff internally." "Pattern to match lines produced by diff3 that describe differences.") (defcustom ediff-diff3-options "" "*Options to pass to `ediff-diff3-program'." - :set 'ediff-reset-diff-options + :set 'ediff-set-diff-options :type 'string :group 'ediff-diff) @@ -889,9 +858,9 @@ one optional arguments, diff-number to refine.") (let ((fine-diff-vector (ediff-get-fine-diff-vector n buf-type)) (face (if default 'default - (face-name - (ediff-get-symbol-from-alist - buf-type ediff-fine-diff-face-alist)))) + (ediff-get-symbol-from-alist + buf-type ediff-fine-diff-face-alist) + )) (priority (if default 0 (1+ (or (ediff-overlay-get diff --git a/lisp/ediff-help.el b/lisp/ediff-help.el index 1c7a72870fe..0c37be31372 100644 --- a/lisp/ediff-help.el +++ b/lisp/ediff-help.el @@ -165,7 +165,7 @@ the value of this variable and the variables `ediff-help-message-*' in (define-key ediff-help-region-map - (if ediff-emacs-p [mouse-2] [button2]) + (if (featurep 'emacs) [mouse-2] [button2]) 'ediff-help-for-quick-help) ;; runs in the control buffer @@ -177,7 +177,7 @@ the value of this variable and the variables `ediff-help-message-*' in end (match-end 0) cmd (buffer-substring (match-beginning 1) (match-end 1))) (setq overl (ediff-make-overlay beg end)) - (if ediff-emacs-p + (if (featurep 'emacs) (ediff-overlay-put overl 'mouse-face 'highlight) (ediff-overlay-put overl 'highlight t)) (ediff-overlay-put overl 'ediff-help-info cmd)))) diff --git a/lisp/ediff-hook.el b/lisp/ediff-hook.el index 00e6ba6bab2..306b2ed670c 100644 --- a/lisp/ediff-hook.el +++ b/lisp/ediff-hook.el @@ -261,17 +261,17 @@ () ; if dumping, autoloads are set up in loaddefs.el ;; if the user decides to load this file, set up autoloads ;; compare files and buffers - (autoload 'ediff "ediff" "Compare two files" t) - (autoload 'ediff-files "ediff" "Compare two files" t) - (autoload 'ediff-buffers "ediff" "Compare two bufers" t) - (autoload 'ebuffers "ediff" "Compare two bufers" t) - (autoload 'ediff3 "ediff" "Compare three files" t) - (autoload 'ediff-files3 "ediff" "Compare three files" t) - (autoload 'ediff-buffers3 "ediff" "Compare three bufers" t) - (autoload 'ebuffers3 "ediff" "Compare three bufers" t) - - (autoload 'erevision "ediff" "Compare versions of a file" t) - (autoload 'ediff-revision "ediff" "Compare versions of a file" t) + (autoload 'ediff "ediff" "Compare two files." t) + (autoload 'ediff-files "ediff" "Compare two files." t) + (autoload 'ediff-buffers "ediff" "Compare two buffers." t) + (autoload 'ebuffers "ediff" "Compare two buffers." t) + (autoload 'ediff3 "ediff" "Compare three files." t) + (autoload 'ediff-files3 "ediff" "Compare three files." t) + (autoload 'ediff-buffers3 "ediff" "Compare three buffers." t) + (autoload 'ebuffers3 "ediff" "Compare three buffers." t) + + (autoload 'erevision "ediff" "Compare versions of a file." t) + (autoload 'ediff-revision "ediff" "Compare versions of a file." t) ;; compare regions and windows (autoload 'ediff-windows-wordwise diff --git a/lisp/ediff-init.el b/lisp/ediff-init.el index 21e6bf660ee..dd69b52b022 100644 --- a/lisp/ediff-init.el +++ b/lisp/ediff-init.el @@ -43,11 +43,6 @@ (load "ange-ftp" 'noerror))) ;; end pacifier -;; Is it XEmacs? -(defconst ediff-xemacs-p (featurep 'xemacs)) -;; Is it Emacs? -(defconst ediff-emacs-p (not ediff-xemacs-p)) - ;; This is used to avoid compilation warnings. When emacs/xemacs forms can ;; generate compile time warnings, we use this macro. ;; In this case, the macro will expand into the form that is appropriate to the @@ -78,8 +73,8 @@ that Ediff doesn't know about.") (cond ((ediff-window-display-p)) (ediff-force-faces) ((ediff-color-display-p)) - (ediff-emacs-p (memq (ediff-device-type) '(pc))) - (ediff-xemacs-p (memq (ediff-device-type) '(tty pc))) + ((featurep 'emacs) (memq (ediff-device-type) '(pc))) + ((featurep 'xemacs) (memq (ediff-device-type) '(tty pc))) )) ;; toolbar support for emacs hasn't been implemented in ediff @@ -506,7 +501,7 @@ set local variables that determine how the display looks like." *** of %sEmacs, does not seem to be properly installed. *** *** Please contact your system administrator. " - (if ediff-xemacs-p "X" ""))) + (if (featurep 'xemacs) "X" ""))) ;; Selective browsing @@ -785,8 +780,8 @@ to temp files when Ediff needs to find fine differences." ;; testing for sufficiently high Emacs versions. (defun ediff-check-version (op major minor &optional type-of-emacs) (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) - (and (cond ((eq type-of-emacs 'xemacs) ediff-xemacs-p) - ((eq type-of-emacs 'emacs) ediff-emacs-p) + (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs)) + ((eq type-of-emacs 'emacs) (featurep 'emacs)) (t t)) (cond ((eq op '=) (and (= emacs-minor-version minor) (= emacs-major-version major))) @@ -908,7 +903,7 @@ to temp files when Ediff needs to find fine differences." (defface ediff-current-diff-A - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "firebrick" :background "pale green")) (((class color)) @@ -929,7 +924,7 @@ this variable represents.") (ediff-hide-face ediff-current-diff-face-A) ;; Until custom.el for XEmacs starts supporting :inverse-video we do this. ;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p +(if (and (featurep 'xemacs) (ediff-has-face-support-p) (not (ediff-color-display-p))) (copy-face 'modeline ediff-current-diff-face-A)) @@ -937,7 +932,7 @@ this variable represents.") (defface ediff-current-diff-B - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "DarkOrchid" :background "Yellow")) (((class color)) @@ -960,14 +955,14 @@ this variable represents.") (ediff-hide-face ediff-current-diff-face-B) ;; Until custom.el for XEmacs starts supporting :inverse-video we do this. ;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p +(if (and (featurep 'xemacs) (ediff-has-face-support-p) (not (ediff-color-display-p))) (copy-face 'modeline ediff-current-diff-face-B)) (defface ediff-current-diff-C - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "Navy" :background "Pink")) (((class color)) @@ -988,14 +983,14 @@ this variable represents.") (ediff-hide-face ediff-current-diff-face-C) ;; Until custom.el for XEmacs starts supporting :inverse-video we do this. ;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p +(if (and (featurep 'xemacs) (ediff-has-face-support-p) (not (ediff-color-display-p))) (copy-face 'modeline ediff-current-diff-face-C)) (defface ediff-current-diff-Ancestor - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "Black" :background "VioletRed")) (((class color)) @@ -1016,14 +1011,14 @@ this variable represents.") (ediff-hide-face ediff-current-diff-face-Ancestor) ;; Until custom.el for XEmacs starts supporting :inverse-video we do this. ;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p +(if (and (featurep 'xemacs) (ediff-has-face-support-p) (not (ediff-color-display-p))) (copy-face 'modeline ediff-current-diff-face-Ancestor)) (defface ediff-fine-diff-A - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "Navy" :background "sky blue")) (((class color)) @@ -1044,7 +1039,7 @@ this variable represents.") (ediff-hide-face ediff-fine-diff-face-A) (defface ediff-fine-diff-B - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "Black" :background "cyan")) (((class color)) @@ -1065,7 +1060,7 @@ this variable represents.") (ediff-hide-face ediff-fine-diff-face-B) (defface ediff-fine-diff-C - (if ediff-emacs-p + (if (featurep 'emacs) '((((type pc)) (:foreground "white" :background "Turquoise")) (((class color) (min-colors 16)) @@ -1091,7 +1086,7 @@ this variable represents.") (ediff-hide-face ediff-fine-diff-face-C) (defface ediff-fine-diff-Ancestor - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "Black" :background "Green")) (((class color)) @@ -1123,7 +1118,7 @@ this variable represents.") (t "Stipple"))) (defface ediff-even-diff-A - (if ediff-emacs-p + (if (featurep 'emacs) `((((type pc)) (:foreground "green3" :background "light grey")) (((class color) (min-colors 16)) @@ -1149,7 +1144,7 @@ this variable represents.") (ediff-hide-face ediff-even-diff-face-A) (defface ediff-even-diff-B - (if ediff-emacs-p + (if (featurep 'emacs) `((((class color) (min-colors 16)) (:foreground "White" :background "Grey")) (((class color)) @@ -1170,7 +1165,7 @@ this variable represents.") (ediff-hide-face ediff-even-diff-face-B) (defface ediff-even-diff-C - (if ediff-emacs-p + (if (featurep 'emacs) `((((type pc)) (:foreground "yellow3" :background "light grey")) (((class color) (min-colors 16)) @@ -1196,7 +1191,7 @@ this variable represents.") (ediff-hide-face ediff-even-diff-face-C) (defface ediff-even-diff-Ancestor - (if ediff-emacs-p + (if (featurep 'emacs) `((((type pc)) (:foreground "cyan3" :background "light grey")) (((class color) (min-colors 16)) @@ -1229,7 +1224,7 @@ this variable represents.") (Ancestor . ediff-even-diff-Ancestor))) (defface ediff-odd-diff-A - (if ediff-emacs-p + (if (featurep 'emacs) '((((type pc)) (:foreground "green3" :background "gray40")) (((class color) (min-colors 16)) @@ -1254,7 +1249,7 @@ this variable represents.") (defface ediff-odd-diff-B - (if ediff-emacs-p + (if (featurep 'emacs) '((((type pc)) (:foreground "White" :background "gray40")) (((class color) (min-colors 16)) @@ -1278,7 +1273,7 @@ this variable represents.") (ediff-hide-face ediff-odd-diff-face-B) (defface ediff-odd-diff-C - (if ediff-emacs-p + (if (featurep 'emacs) '((((type pc)) (:foreground "yellow3" :background "gray40")) (((class color) (min-colors 16)) @@ -1302,7 +1297,7 @@ this variable represents.") (ediff-hide-face ediff-odd-diff-face-C) (defface ediff-odd-diff-Ancestor - (if ediff-emacs-p + (if (featurep 'emacs) '((((class color) (min-colors 16)) (:foreground "cyan3" :background "gray40")) (((class color)) @@ -1630,7 +1625,7 @@ This default should work without changes." (or frame (setq frame (selected-frame))) (if (ediff-window-display-p) (let ((frame-or-wind frame)) - (if ediff-xemacs-p + (if (featurep 'xemacs) (setq frame-or-wind (frame-selected-window frame))) (or do-not-grab-mouse ;; don't set mouse if the user said to never do this diff --git a/lisp/ediff-mult.el b/lisp/ediff-mult.el index 3696d8ae776..51502615cf7 100644 --- a/lisp/ediff-mult.el +++ b/lisp/ediff-mult.el @@ -404,7 +404,7 @@ Toggled by ediff-toggle-verbose-help-meta-buffer" ) (define-key ediff-meta-buffer-map "=h" 'ediff-meta-mark-equal-files))) (if ediff-no-emacs-help-in-control-buffer (define-key ediff-meta-buffer-map "\C-h" 'ediff-previous-meta-item)) - (if ediff-emacs-p + (if (featurep 'emacs) (define-key ediff-meta-buffer-map [mouse-2] ediff-meta-action-function) (define-key ediff-meta-buffer-map [button2] ediff-meta-action-function)) @@ -448,7 +448,7 @@ Commands: (define-key ediff-dir-diffs-buffer-map "\C-?" 'previous-line) (define-key ediff-dir-diffs-buffer-map "p" 'previous-line) (define-key ediff-dir-diffs-buffer-map "C" 'ediff-dir-diff-copy-file) -(if ediff-emacs-p +(if (featurep 'emacs) (define-key ediff-dir-diffs-buffer-map [mouse-2] 'ediff-dir-diff-copy-file) (define-key ediff-dir-diffs-buffer-map [button2] 'ediff-dir-diff-copy-file)) (define-key ediff-dir-diffs-buffer-map [delete] 'previous-line) @@ -1493,7 +1493,7 @@ Useful commands: (defun ediff-set-meta-overlay (b e prop &optional session-number hidden) (let (overl) (setq overl (ediff-make-overlay b e)) - (if ediff-emacs-p + (if (featurep 'emacs) (ediff-overlay-put overl 'mouse-face 'highlight) (ediff-overlay-put overl 'highlight t)) (ediff-overlay-put overl 'ediff-meta-info prop) diff --git a/lisp/ediff-util.el b/lisp/ediff-util.el index 14b1be963d7..2ed8f73a282 100644 --- a/lisp/ediff-util.el +++ b/lisp/ediff-util.el @@ -38,7 +38,6 @@ (defvar bottom-toolbar-visible-p) (defvar bottom-toolbar-height) (defvar mark-active) -(defvar ediff-emacs-p) (defvar ediff-after-quit-hook-internal nil) @@ -64,7 +63,7 @@ (or (featurep 'ediff) (load "ediff.el" nil nil 'nosuffix)) (or (featurep 'ediff-tbar) - ediff-emacs-p + (featurep 'emacs) (load "ediff-tbar.el" 'noerror nil 'nosuffix)) )) ;; end pacifier @@ -77,7 +76,7 @@ (require 'ediff-diff) (require 'ediff-merg) -(if ediff-xemacs-p +(if (featurep 'xemacs) (require 'ediff-tbar)) @@ -154,7 +153,7 @@ to invocation.") (suppress-keymap ediff-mode-map) (define-key ediff-mode-map - (if ediff-emacs-p [mouse-2] [button2]) 'ediff-help-for-quick-help) + (if (featurep 'emacs) [mouse-2] [button2]) 'ediff-help-for-quick-help) (define-key ediff-mode-map "\C-m" 'ediff-help-for-quick-help) (define-key ediff-mode-map "p" 'ediff-previous-difference) @@ -1141,7 +1140,7 @@ of the current buffer." (or (memq (vc-state file) '(edited needs-merge)) (stringp (vc-state file))) ;; XEmacs has no vc-state - (vc-locking-user file)) + (when (featurep 'xemacs) (vc-locking-user file))) ))) (defun ediff-file-checked-in-p (file) @@ -1153,7 +1152,7 @@ of the current buffer." (not (memq (vc-state file) '(edited needs-merge))) (not (stringp (vc-state file)))) ;; XEmacs has no vc-state - (not (vc-locking-user file))) + (when (featurep 'xemacs) (not (vc-locking-user file)))) )) (defun ediff-file-compressed-p (file) @@ -1275,7 +1274,7 @@ This is especially useful when comparing buffers side-by-side." (ediff-barf-if-not-control-buffer) (or (ediff-window-display-p) (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) + (if (featurep 'emacs) "" "X"))) (ediff-recenter 'no-rehighlight) ; make sure buffs are displayed in windows (let ((ctl-buf ediff-control-buffer)) (setq ediff-wide-display-p (not ediff-wide-display-p)) @@ -1283,7 +1282,7 @@ This is especially useful when comparing buffers side-by-side." (ediff-with-current-buffer ctl-buf (modify-frame-parameters ediff-wide-display-frame ediff-wide-display-orig-parameters) - ;;(sit-for (if ediff-xemacs-p 0.4 0)) + ;;(sit-for (if (featurep 'xemacs) 0.4 0)) ;; restore control buf, since ctl window may have been deleted ;; during resizing (set-buffer ctl-buf) @@ -1291,7 +1290,7 @@ This is especially useful when comparing buffers side-by-side." ediff-window-B nil) ; force update of window config (ediff-recenter 'no-rehighlight)) (funcall ediff-make-wide-display-function) - ;;(sit-for (if ediff-xemacs-p 0.4 0)) + ;;(sit-for (if (featurep 'xemacs) 0.4 0)) (ediff-with-current-buffer ctl-buf (setq ediff-window-B nil) ; force update of window config (ediff-recenter 'no-rehighlight))))) @@ -1305,7 +1304,7 @@ which see." (let (window-setup-func) (or (ediff-window-display-p) (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) + (if (featurep 'emacs) "" "X"))) (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe) (setq window-setup-func 'ediff-setup-windows-plain)) @@ -1335,7 +1334,7 @@ To change the default, set the variable `ediff-use-toolbar-p', which see." (progn (or (ediff-window-display-p) (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) + (if (featurep 'emacs) "" "X"))) (if (ediff-use-toolbar-p) (ediff-kill-bottom-toolbar)) ;; do this only after killing the toolbar @@ -2529,7 +2528,7 @@ temporarily reverses the meaning of this variable." (cond ((ediff-good-frame-under-mouse)) (t warp-frame))) (if (and (ediff-window-display-p) (frame-live-p warp-frame) ediff-grab-mouse) - (set-mouse-position (if ediff-emacs-p + (set-mouse-position (if (featurep 'emacs) warp-frame (frame-selected-window warp-frame)) 2 1)) @@ -2544,11 +2543,11 @@ temporarily reverses the meaning of this variable." (buf-name "") frame obj-ok) (setq obj-ok - (if ediff-emacs-p + (if (featurep 'emacs) (frame-live-p frame-or-win) (window-live-p frame-or-win))) (if obj-ok - (setq frame (if ediff-emacs-p frame-or-win (window-frame frame-or-win)) + (setq frame (if (featurep 'emacs) frame-or-win (window-frame frame-or-win)) buf-name (buffer-name (window-buffer (frame-selected-window frame))))) (if (string-match "Minibuf" buf-name) @@ -3031,7 +3030,7 @@ Hit \\[ediff-recenter] to reset the windows afterward." (ediff-get-symbol-from-alist buf-type ediff-current-diff-overlay-alist)))) - (if ediff-xemacs-p + (if (featurep 'xemacs) (ediff-move-overlay current-diff-overlay begin end-hilit) (ediff-move-overlay current-diff-overlay begin end-hilit buff)) (ediff-overlay-put current-diff-overlay 'priority @@ -3611,11 +3610,11 @@ Ediff Control Panel to restore highlighting." (defun ediff-remove-flags-from-buffer (buffer overlay) (ediff-with-current-buffer buffer (let ((inhibit-read-only t)) - (if ediff-xemacs-p + (if (featurep 'xemacs) (ediff-overlay-put overlay 'begin-glyph nil) (ediff-overlay-put overlay 'before-string nil)) - (if ediff-xemacs-p + (if (featurep 'xemacs) (ediff-overlay-put overlay 'end-glyph nil) (ediff-overlay-put overlay 'after-string nil)) ))) @@ -3643,7 +3642,7 @@ Ediff Control Panel to restore highlighting." ediff-before-flag-bol ediff-before-flag-mol)))) ;; insert the flag itself - (if ediff-xemacs-p + (if (featurep 'xemacs) (ediff-overlay-put curr-overl 'begin-glyph flag) (ediff-overlay-put curr-overl 'before-string flag)) @@ -3659,7 +3658,7 @@ Ediff Control Panel to restore highlighting." ediff-after-flag-eol ediff-after-flag-mol)))) ;; insert the flag itself - (if ediff-xemacs-p + (if (featurep 'xemacs) (ediff-overlay-put curr-overl 'end-glyph flag) (ediff-overlay-put curr-overl 'after-string flag)) )) @@ -3786,10 +3785,10 @@ Ediff Control Panel to restore highlighting." ;; never detach (ediff-overlay-put - overl (if ediff-emacs-p 'evaporate 'detachable) nil) + overl (if (featurep 'emacs) 'evaporate 'detachable) nil) ;; make overlay open-ended ;; In emacs, it is made open ended at creation time - (if ediff-xemacs-p + (if (featurep 'xemacs) (progn (ediff-overlay-put overl 'start-open nil) (ediff-overlay-put overl 'end-open nil))) @@ -3802,9 +3801,8 @@ Ediff Control Panel to restore highlighting." (let ((overlay (ediff-get-symbol-from-alist type ediff-current-diff-overlay-alist)) (buffer (ediff-get-buffer type)) - (face (face-name - (ediff-get-symbol-from-alist - type ediff-current-diff-face-alist)))) + (face (ediff-get-symbol-from-alist + type ediff-current-diff-face-alist))) (set overlay (ediff-make-bullet-proof-overlay (point-max) (point-max) buffer)) (ediff-set-overlay-face (symbol-value overlay) face) @@ -4071,28 +4069,25 @@ Mail anyway? (y or n) ") ) )) -(cond ((fboundp 'nuke-selective-display) - ;; XEmacs has nuke-selective-display - (defalias 'ediff-nuke-selective-display 'nuke-selective-display)) - (t - (defun ediff-nuke-selective-display () - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((mod-p (buffer-modified-p)) - buffer-read-only end) - (and (eq t selective-display) - (while (search-forward "\^M" nil t) - (end-of-line) - (setq end (point)) - (beginning-of-line) - (while (search-forward "\^M" end t) - (delete-char -1) - (insert "\^J")))) - (set-buffer-modified-p mod-p) - (setq selective-display nil))))) - )) +(defun ediff-nuke-selective-display () + (if (featurep 'xemacs) + (nuke-selective-display) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let ((mod-p (buffer-modified-p)) + buffer-read-only end) + (and (eq t selective-display) + (while (search-forward "\^M" nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (while (search-forward "\^M" end t) + (delete-char -1) + (insert "\^J")))) + (set-buffer-modified-p mod-p) + (setq selective-display nil)))))) ;; The next two are modified versions from emerge.el. @@ -4295,20 +4290,7 @@ Mail anyway? (y or n) ") (add-to-history history-var newelt) (set history-var (cons newelt (symbol-value history-var))))) -(if (fboundp 'copy-sequence) - (defalias 'ediff-copy-list 'copy-sequence) - (defun ediff-copy-list (list) - (if (consp list) - ;;;(let ((res nil)) - ;;; (while (consp list) (push (pop list) res)) - ;;; (prog1 (nreverse res) (setcdr res list))) - (let (res elt) - (while (consp list) - (setq elt (car list) - res (cons elt res) - list (cdr list))) - (nreverse res)) - (car list)))) +(defalias 'ediff-copy-list 'copy-sequence) ;; don't report error if version control package wasn't found diff --git a/lisp/ediff-vers.el b/lisp/ediff-vers.el index 8480984b95c..293acc5a854 100644 --- a/lisp/ediff-vers.el +++ b/lisp/ediff-vers.el @@ -39,13 +39,6 @@ (let ((load-path (cons (expand-file-name ".") load-path))) (load "pcl-cvs" 'noerror) (load "rcs" 'noerror) - ;; On 8+3 MS-DOS filesystems, generic-x.el is loaded - ;; instead of (the missing) generic-sc.el. Since the - ;; version of Emacs which supports MS-DOS doesn't have - ;; generic-sc, we simply avoid loading it. - (or (and (fboundp 'msdos-long-file-names) - (not (msdos-long-file-names))) - (load "generic-sc" 'noerror)) ;; (load "vc" 'noerror) ; this sometimes causes compiler error (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) @@ -59,8 +52,22 @@ comparison or merge operations are being performed." :group 'ediff-vers ) +(defalias 'ediff-vc-revision-other-window + (if (fboundp 'vc-revision-other-window) + 'vc-revision-other-window + 'vc-version-other-window)) + +(defalias 'ediff-vc-working-revision + (if (fboundp 'vc-working-revision) + 'vc-working-revision + 'vc-workfile-version)) + ;; VC.el support +(eval-when-compile + (require 'vc-hooks)) ;; for vc-call macro + + (defun ediff-vc-latest-version (file) "Return the version level of the latest version of FILE in repository." (if (fboundp 'vc-latest-version) @@ -84,12 +91,12 @@ comparison or merge operations are being performed." (setq rev1 (ediff-vc-latest-version (buffer-file-name)))) (save-window-excursion (save-excursion - (vc-revision-other-window rev1) + (ediff-vc-revision-other-window rev1) (setq rev1buf (current-buffer) file1 (buffer-file-name))) (save-excursion (or (string= rev2 "") ; use current buffer - (vc-revision-other-window rev2)) + (ediff-vc-revision-other-window rev2)) (setq rev2buf (current-buffer) file2 (buffer-file-name))) (setq startup-hooks @@ -157,32 +164,6 @@ comparison or merge operations are being performed." (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision) )) - -;; GENERIC-SC.el support - -(defun generic-sc-get-latest-rev () - (cond ((eq sc-mode 'CCASE) - (eval "main/LATEST")) - (t (eval "")))) - -(defun ediff-generic-sc-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then compare current buffer with REV1. -;; If the current buffer is named `F', the version is named `F.~REV~'. -;; If `F.~REV~' already exists, it is used instead of being re-created. - (let (rev1buf rev2buf) - (save-excursion - (if (or (not rev1) (string= rev1 "")) - (setq rev1 (generic-sc-get-latest-rev))) - (sc-visit-previous-revision rev1) - (setq rev1buf (current-buffer))) - (save-excursion - (or (string= rev2 "") ; use current buffer - (sc-visit-previous-revision rev2)) - (setq rev2buf (current-buffer))) - (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision))) - - ;;; Merge with Version Control (defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev @@ -191,17 +172,17 @@ comparison or merge operations are being performed." (let (buf1 buf2 ancestor-buf) (save-window-excursion (save-excursion - (vc-revision-other-window rev1) + (ediff-vc-revision-other-window rev1) (setq buf1 (current-buffer))) (save-excursion (or (string= rev2 "") - (vc-revision-other-window rev2)) + (ediff-vc-revision-other-window rev2)) (setq buf2 (current-buffer))) (if ancestor-rev (save-excursion (if (string= ancestor-rev "") - (setq ancestor-rev (vc-working-revision buffer-file-name))) - (vc-revision-other-window ancestor-rev) + (setq ancestor-rev (ediff-vc-working-revision buffer-file-name))) + (ediff-vc-revision-other-window ancestor-rev) (setq ancestor-buf (current-buffer)))) (setq startup-hooks (cons @@ -245,76 +226,6 @@ comparison or merge operations are being performed." (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file)))) -(defun ediff-generic-sc-merge-internal (rev1 rev2 ancestor-rev - &optional - startup-hooks merge-buffer-file) - ;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (save-excursion - (if (string= rev1 "") - (setq rev1 (generic-sc-get-latest-rev))) - (sc-visit-previous-revision rev1) - (setq buf1 (current-buffer))) - (save-excursion - (or (string= rev2 "") - (sc-visit-previous-revision rev2)) - (setq buf2 (current-buffer))) - (if ancestor-rev - (save-excursion - (or (string= ancestor-rev "") - (sc-visit-previous-revision ancestor-rev)) - (setq ancestor-buf (current-buffer)))) - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file) - (ediff-merge-buffers - buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file)))) - - -;; PCL-CVS.el support - -;; MK: Check. This function doesn't seem to be used any more by pcvs or pcl-cvs -(defun cvs-run-ediff-on-file-descriptor (tin) -;; This is a replacement for cvs-emerge-mode -;; Runs after cvs-update. -;; Ediff-merge appropriate revisions of the selected file. - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo)) - (tmp-file - (cvs-retrieve-revision-to-tmpfile fileinfo)) - (default-directory - (file-name-as-directory (cvs-fileinfo->dir fileinfo))) - ancestor-file) - - (or (memq type '(MERGED CONFLICT MODIFIED)) - (error - "Can only merge `Modified', `Merged' or `Conflict' files")) - - (cond ((memq type '(MERGED CONFLICT)) - (setq ancestor-file - (cvs-retrieve-revision-to-tmpfile - fileinfo - ;; revision - (cvs-fileinfo->base-revision fileinfo))) - (ediff-merge-buffers-with-ancestor - (find-file-noselect tmp-file) - (find-file-noselect (cvs-fileinfo->backup-file fileinfo)) - (find-file-noselect ancestor-file) - nil ; startup-hooks - 'ediff-merge-revisions-with-ancestor)) - ((eq type 'MODIFIED) - (ediff-buffers - (find-file-noselect tmp-file) - (if (featurep 'xemacs) - ;; XEmacs doesn't seem to have cvs-fileinfo->full-name - (find-file-noselect (cvs-fileinfo->full-path fileinfo)) - (find-file-noselect (cvs-fileinfo->full-name fileinfo))) - nil ; startup-hooks - 'ediff-revisions))) - (if (stringp tmp-file) (ediff-delete-version-file tmp-file)) - (if (stringp ancestor-file) (ediff-delete-version-file ancestor-file)))) - ;; delete version file on exit unless ediff-keep-tmp-versions is true (defun ediff-delete-version-file (file) diff --git a/lisp/ediff-wind.el b/lisp/ediff-wind.el index c2c130ac6bb..8b72a673d17 100644 --- a/lisp/ediff-wind.el +++ b/lisp/ediff-wind.el @@ -39,7 +39,6 @@ (defvar top-gutter) (defvar frame-icon-title-format) (defvar ediff-diff-status) -(defvar ediff-emacs-p) (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) @@ -50,7 +49,7 @@ (or (featurep 'ediff-help) (load "ediff-help.el" nil nil 'nosuffix)) (or (featurep 'ediff-tbar) - ediff-emacs-p + (featurep 'emacs) (load "ediff-tbar.el" 'noerror nil 'nosuffix)) )) ;; end pacifier @@ -58,7 +57,7 @@ (require 'ediff-init) ;; be careful with ediff-tbar -(if ediff-xemacs-p +(if (featurep 'xemacs) (condition-case nil (require 'ediff-tbar) (error @@ -213,7 +212,7 @@ customization of the default control frame positioning." :type 'integer :group 'ediff-window) -(defcustom ediff-narrow-control-frame-leftward-shift (if ediff-xemacs-p 7 3) +(defcustom ediff-narrow-control-frame-leftward-shift (if (featurep 'xemacs) 7 3) "*The leftward shift of control frame from the right edge of buf A's frame. Measured in characters. This is used by the default control frame positioning function, @@ -380,7 +379,7 @@ into icons, regardless of the window manager." ;; XEmacs used to have a lot of trouble with display ;; It did't set things right unless we tell it to sit still ;; 19.12 seems ok. - ;;(if ediff-xemacs-p (sit-for 0)) + ;;(if (featurep 'xemacs) (sit-for 0)) (split-window-vertically (max 2 (- (window-height) merge-window-lines))) (if (eq (selected-window) wind-A) @@ -443,7 +442,7 @@ into icons, regardless of the window manager." ;; XEmacs used to have a lot of trouble with display ;; It did't set things right unless we told it to sit still ;; 19.12 seems ok. - ;;(if ediff-xemacs-p (sit-for 0)) + ;;(if (featurep 'xemacs) (sit-for 0)) (funcall split-window-function wind-width-or-height) @@ -1043,7 +1042,7 @@ into icons, regardless of the window manager." (or (eq this-command 'ediff-quit) (not (eq ediff-grab-mouse t))))) - (if ediff-xemacs-p + (if (featurep 'xemacs) (ediff-with-current-buffer ctl-buffer (ediff-cond-compile-for-xemacs-or-emacs (make-local-hook 'select-frame-hook) ; xemacs @@ -1238,7 +1237,7 @@ It assumes that it is called from within the control buffer." (defun ediff-refresh-control-frame () - (if ediff-emacs-p + (if (featurep 'emacs) ;; set frame/icon titles for Emacs (modify-frame-parameters ediff-control-frame @@ -1288,7 +1287,7 @@ It assumes that it is called from within the control buffer." ;; If buff is not live, return nil (defun ediff-get-visible-buffer-window (buff) (if (ediff-buffer-live-p buff) - (if ediff-xemacs-p + (if (featurep 'xemacs) (get-buffer-window buff t) (get-buffer-window buff 'visible)))) diff --git a/lisp/ediff.el b/lisp/ediff.el index 7475834fba6..a2aafc90292 100644 --- a/lisp/ediff.el +++ b/lisp/ediff.el @@ -1303,20 +1303,6 @@ buffer." (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) rev1 rev2 ancestor-rev startup-hooks merge-buffer-file))) -;; MK: Check. This function doesn't seem to be used any more by pcvs or pcl-cvs -;;;###autoload -(defun run-ediff-from-cvs-buffer (pos) - "Run Ediff-merge on appropriate revisions of the selected file. -First run after `M-x cvs-update'. Then place the cursor on a line describing a -file and then run `run-ediff-from-cvs-buffer'." - (interactive "d") - (ediff-load-version-control) - (let ((tin (tin-locate cvs-cookie-handle pos))) - (if tin - (cvs-run-ediff-on-file-descriptor tin) - (error "There is no file to merge")))) - - ;;; Apply patch ;;;###autoload @@ -1454,7 +1440,7 @@ With optional NODE, goes to that node." (condition-case nil (progn (pop-to-buffer (get-buffer-create "*info*")) - (info (if ediff-xemacs-p "ediff.info" "ediff")) + (info (if (featurep 'xemacs) "ediff.info" "ediff")) (if node (Info-goto-node node) (message "Type `i' to search for a specific topic")) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 21136721e60..f9c778443b4 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2675,12 +2675,9 @@ For that it has to be fbound with a non-autoload definition." (ad-with-auto-activation-disabled (require 'bytecomp) (let ((symbol (make-symbol "advice-compilation")) - (byte-compile-warnings - (if (listp byte-compile-warnings) byte-compile-warnings - byte-compile-warning-types))) + (byte-compile-warnings byte-compile-warnings)) (if (featurep 'cl) - (setq byte-compile-warnings - (remq 'cl-functions byte-compile-warnings))) + (byte-compile-disable-warning 'cl-functions)) (fset symbol (symbol-function function)) (byte-compile symbol) (fset function (symbol-function symbol)))))) diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 4b490621f51..50d2f41f7ae 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -475,8 +475,8 @@ with the file and the number of each action. :wrote means the author wrote the file :changed means he changed the file COUNT times." - (let* ((enable-local-variables t) - (enable-local-eval t) + (let* ((enable-local-variables :safe) + (enable-local-eval nil) (existing-buffer (get-file-buffer log-file)) (buffer (find-file-noselect log-file)) author file pos) @@ -521,8 +521,8 @@ with the file and the number of each action. "Scan Lisp file FILE for author information. TABLE is a hash table to add author information to." (let* ((existing-buffer (get-file-buffer file)) - (enable-local-variables t) - (enable-local-eval t) + (enable-local-variables :safe) + (enable-local-eval nil) (buffer (find-file-noselect file))) (save-excursion (set-buffer buffer) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 2ff453ac6e5..bc864aab490 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1150,7 +1150,9 @@ ;; can safely optimize away this test. (if (member (cdr-safe form) '(((quote xemacs)) ((quote sxemacs)))) nil - form)) + (if (member (cdr-safe form) '(((quote emacs)))) + t + form))) (put 'set 'byte-optimizer 'byte-optimize-set) (defun byte-optimize-set (form) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fbda38b79f0..27ee27eda92 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -362,7 +362,10 @@ Elements of the list may be: interactive-only commands that normally shouldn't be called from Lisp code. make-local calls to make-variable-buffer-local that may be incorrect. - mapcar mapcar called for effect." + mapcar mapcar called for effect. + +If the list begins with `not', then the remaining elements specify warnings to +suppress. For example, (not mapcar) will suppress warnings about mapcar." :group 'bytecomp :type `(choice (const :tag "All" t) (set :menu-tag "Some" @@ -377,6 +380,8 @@ Elements of the list may be: (defun byte-compile-warnings-safe-p (x) (or (booleanp x) (and (listp x) + (if (eq (car x) 'not) (setq x (cdr x)) + t) (equal (mapcar (lambda (e) (when (memq e '(free-vars unresolved @@ -388,6 +393,46 @@ Elements of the list may be: x) x)))) +(defun byte-compile-warning-enabled-p (warning) + "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'." + (or (eq byte-compile-warnings t) + (if (eq (car byte-compile-warnings) 'not) + (not (memq warning byte-compile-warnings)) + (memq warning byte-compile-warnings)))) + +;;;###autoload +(defun byte-compile-disable-warning (warning) + "Change `byte-compile-warnings' to disable WARNING. +If `byte-compile-warnings' is t, set it to `(not WARNING)'. +Otherwise, if the first element is `not', add WARNING, else remove it. +Normally you should let-bind `byte-compile-warnings' before calling this, +else the global value will be modified." + (setq byte-compile-warnings + (cond ((eq byte-compile-warnings t) + (list 'not warning)) + ((eq (car byte-compile-warnings) 'not) + (if (memq warning byte-compile-warnings) + byte-compile-warnings + (append byte-compile-warnings (list warning)))) + (t + (delq warning byte-compile-warnings))))) + +;;;###autoload +(defun byte-compile-enable-warning (warning) + "Change `byte-compile-warnings' to enable WARNING. +If `byte-compile-warnings' is `t', do nothing. Otherwise, if the +first element is `not', remove WARNING, else add it. +Normally you should let-bind `byte-compile-warnings' before calling this, +else the global value will be modified." + (or (eq byte-compile-warnings t) + (setq byte-compile-warnings + (cond ((eq (car byte-compile-warnings) 'not) + (delq warning byte-compile-warnings)) + ((memq warning byte-compile-warnings) + byte-compile-warnings) + (t + (append byte-compile-warnings (list warning))))))) + (defvar byte-compile-interactive-only-functions '(beginning-of-buffer end-of-buffer replace-string replace-regexp insert-file insert-buffer insert-file-literally previous-line next-line) @@ -830,7 +875,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((hist-orig load-history) (hist-nil-orig current-load-list)) (prog1 (eval form) - (when (memq 'noruntime byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'noruntime) (let ((hist-new load-history) (hist-nil-new current-load-list)) ;; Go through load-history, look for newly loaded files @@ -858,7 +903,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (push s byte-compile-noruntime-functions)) (when (and (consp s) (eq t (car s))) (push (cdr s) old-autoloads))))))) - (when (memq 'cl-functions byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'cl-functions) (let ((hist-new load-history)) ;; Go through load-history, look for newly loaded files ;; and mark all the functions defined therein. @@ -876,8 +921,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (let ((tem current-load-list)) (while (not (eq tem hist-nil-orig)) (when (equal (car tem) '(require . cl)) - (setq byte-compile-warnings - (remq 'cl-functions byte-compile-warnings))) + (byte-compile-disable-warning 'cl-functions)) (setq tem (cdr tem))))))) ;;; byte compiler messages @@ -1075,7 +1119,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (handler (nth 1 new)) (when (nth 2 new))) (byte-compile-set-symbol-position (car form)) - (if (memq 'obsolete byte-compile-warnings) + (if (byte-compile-warning-enabled-p 'obsolete) (byte-compile-warn "`%s' is an obsolete function%s; %s" (car form) (if when (concat " (as of Emacs " when ")") "") (if (stringp (car new)) @@ -1421,7 +1465,7 @@ extra args." ;; defined, issue a warning enumerating them. ;; `unresolved' in the list `byte-compile-warnings' disables this. (defun byte-compile-warn-about-unresolved-functions () - (when (memq 'unresolved byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'unresolved) (let ((byte-compile-current-form :end) (noruntime nil) (unresolved nil)) @@ -1484,9 +1528,7 @@ symbol itself." byte-compile-dynamic-docstrings) ;; (byte-compile-generate-emacs19-bytecodes ;; byte-compile-generate-emacs19-bytecodes) - (byte-compile-warnings (if (eq byte-compile-warnings t) - byte-compile-warning-types - byte-compile-warnings)) + (byte-compile-warnings byte-compile-warnings) ) body))) @@ -1829,9 +1871,7 @@ With argument, insert value in current buffer after the form." (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. - ;; (byte-compile-warnings (if (eq byte-compile-warnings t) - ;; byte-compile-warning-types - ;; byte-compile-warnings)) + ;; (byte-compile-warnings byte-compile-warnings) ) (byte-compile-close-variables (with-current-buffer @@ -2210,7 +2250,7 @@ list that represents a doc string reference. ;; Since there is no doc string, we can compile this as a normal form, ;; and not do a file-boundary. (byte-compile-keep-pending form) - (when (memq 'free-vars byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'free-vars) (push (nth 1 form) byte-compile-bound-variables) (if (eq (car form) 'defconst) (push (nth 1 form) byte-compile-const-variables))) @@ -2220,12 +2260,19 @@ list that represents a doc string reference. (byte-compile-top-level (nth 2 form) nil 'file)))) form)) +(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table) +(defun byte-compile-file-form-define-abbrev-table (form) + (when (and (byte-compile-warning-enabled-p 'free-vars) + (eq 'quote (car-safe (car-safe (cdr form))))) + (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) + (byte-compile-keep-pending form)) + (put 'custom-declare-variable 'byte-hunk-handler 'byte-compile-file-form-custom-declare-variable) (defun byte-compile-file-form-custom-declare-variable (form) - (when (memq 'callargs byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) - (when (memq 'free-vars byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'free-vars) (push (nth 1 (nth 1 form)) byte-compile-bound-variables)) (let ((tail (nthcdr 4 form))) (while tail @@ -2248,8 +2295,7 @@ list that represents a doc string reference. (apply 'require args) ;; Detect (require 'cl) in a way that works even if cl is already loaded. (if (member (car args) '("cl" cl)) - (setq byte-compile-warnings - (remq 'cl-functions byte-compile-warnings)))) + (byte-compile-disable-warning 'cl-functions))) (byte-compile-keep-pending form 'byte-compile-normal-call)) (put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) @@ -2295,12 +2341,12 @@ list that represents a doc string reference. (cons (list name nil nil) byte-compile-call-tree)))) (setq byte-compile-current-form name) ; for warnings - (if (memq 'redefine byte-compile-warnings) + (if (byte-compile-warning-enabled-p 'redefine) (byte-compile-arglist-warn form macrop)) (if byte-compile-verbose (message "Compiling %s... (%s)" (or filename "") (nth 1 form))) (cond (that-one - (if (and (memq 'redefine byte-compile-warnings) + (if (and (byte-compile-warning-enabled-p 'redefine) ;; don't warn when compiling the stubs in byte-run... (not (assq (nth 1 form) byte-compile-initial-macro-environment))) @@ -2309,7 +2355,7 @@ list that represents a doc string reference. (nth 1 form))) (setcdr that-one nil)) (this-one - (when (and (memq 'redefine byte-compile-warnings) + (when (and (byte-compile-warning-enabled-p 'redefine) ;; hack: don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... (not (assq (nth 1 form) @@ -2320,7 +2366,7 @@ list that represents a doc string reference. ((and (fboundp name) (eq (car-safe (symbol-function name)) (if macrop 'lambda 'macro))) - (when (memq 'redefine byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'redefine) (byte-compile-warn "%s `%s' being redefined as a %s" (if macrop "function" "macro") (nth 1 form) @@ -2560,7 +2606,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables - (nconc (and (memq 'free-vars byte-compile-warnings) + (nconc (and (byte-compile-warning-enabled-p 'free-vars) (delq '&rest (delq '&optional (copy-sequence arglist)))) byte-compile-bound-variables)) (body (cdr (cdr fun))) @@ -2800,7 +2846,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (handler (get fn 'byte-compile))) (when (byte-compile-const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) - (and (memq 'interactive-only byte-compile-warnings) + (and (byte-compile-warning-enabled-p 'interactive-only) (memq fn byte-compile-interactive-only-functions) (byte-compile-warn "`%s' used from Lisp code\n\ That command is designed for interactive use only" fn)) @@ -2815,12 +2861,12 @@ That command is designed for interactive use only" fn)) byte-compile-compatibility) (get (get fn 'byte-opcode) 'emacs19-opcode)))) (funcall handler form) - (when (memq 'callargs byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'callargs) (if (memq fn '(custom-declare-group custom-declare-variable custom-declare-face)) (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (byte-compile-normal-call form)) - (if (memq 'cl-functions byte-compile-warnings) + (if (byte-compile-warning-enabled-p 'cl-functions) (byte-compile-cl-warn form)))) ((and (or (byte-code-function-p (car form)) (eq (car-safe (car form)) 'lambda)) @@ -2837,7 +2883,7 @@ That command is designed for interactive use only" fn)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) (when (and for-effect (eq (car form) 'mapcar) - (memq 'mapcar byte-compile-warnings)) + (byte-compile-warning-enabled-p 'mapcar)) (byte-compile-set-symbol-position 'mapcar) (byte-compile-warn "`mapcar' called for effect; use `mapc' or `dolist' instead")) @@ -2857,7 +2903,7 @@ That command is designed for interactive use only" fn)) (if (symbolp var) "constant" "nonvariable") (prin1-to-string var)) (if (and (get var 'byte-obsolete-variable) - (memq 'obsolete byte-compile-warnings) + (byte-compile-warning-enabled-p 'obsolete) (not (eq var byte-compile-not-obsolete-var))) (let* ((ob (get var 'byte-obsolete-variable)) (when (cdr ob))) @@ -2866,7 +2912,7 @@ That command is designed for interactive use only" fn)) (if (stringp (car ob)) (car ob) (format "use `%s' instead." (car ob)))))) - (if (memq 'free-vars byte-compile-warnings) + (if (byte-compile-warning-enabled-p 'free-vars) (if (eq base-op 'byte-varbind) (push var byte-compile-bound-variables) (or (boundp var) @@ -3448,6 +3494,32 @@ That command is designed for interactive use only" fn)) (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) ,tag)) +;; Return the list of items in CONDITION-PARAM that match PRED-LIST. +;; Only return items that are not in ONLY-IF-NOT-PRESENT. +(defun byte-compile-find-bound-condition (condition-param + pred-list + &optional only-if-not-present) + (let ((result nil) + (nth-one nil) + (cond-list + (if (memq (car-safe condition-param) pred-list) + ;; The condition appears by itself. + (list condition-param) + ;; If the condition is an `and', look for matches among the + ;; `and' arguments. + (when (eq 'and (car-safe condition-param)) + (cdr condition-param))))) + + (dolist (crt cond-list) + (when (and (memq (car-safe crt) pred-list) + (eq 'quote (car-safe (setq nth-one (nth 1 crt)))) + ;; Ignore if the symbol is already on the unresolved + ;; list. + (not (assq (nth 1 nth-one) ; the relevant symbol + only-if-not-present))) + (push (nth 1 (nth 1 crt)) result))) + result)) + (defmacro byte-compile-maybe-guarded (condition &rest body) "Execute forms in BODY, potentially guarded by CONDITION. CONDITION is a variable whose value is a test in an `if' or `cond'. @@ -3459,35 +3531,34 @@ being undefined will be suppressed. If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) - `(let* ((fbound - (if (eq 'fboundp (car-safe ,condition)) - (and (eq 'quote (car-safe (nth 1 ,condition))) - ;; Ignore if the symbol is already on the - ;; unresolved list. - (not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol - byte-compile-unresolved-functions)) - (nth 1 (nth 1 ,condition))))) - (bound (if (or (eq 'boundp (car-safe ,condition)) - (eq 'default-boundp (car-safe ,condition))) - (and (eq 'quote (car-safe (nth 1 ,condition))) - (nth 1 (nth 1 ,condition))))) + `(let* ((fbound-list (byte-compile-find-bound-condition + ,condition (list 'fboundp) + byte-compile-unresolved-functions)) + (bound-list (byte-compile-find-bound-condition + ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound - (cons bound byte-compile-bound-variables) + (if bound-list + (append bound-list byte-compile-bound-variables) byte-compile-bound-variables)) ;; Suppress all warnings, for code not used in Emacs. - (byte-compile-warnings - (if (member ,condition '((featurep 'xemacs) - (not (featurep 'emacs)))) - nil byte-compile-warnings))) + ;; FIXME: by the time this is executed the `featurep' + ;; emacs/xemacs tests have been optimized away, so this is + ;; not doing anything useful here, is should probably be + ;; moved to a different place. + ;; (byte-compile-warnings + ;; (if (member ,condition '((featurep 'xemacs) + ;; (not (featurep 'emacs)))) + ;; nil byte-compile-warnings)) + ) (unwind-protect (progn ,@body) ;; Maybe remove the function symbol from the unresolved list. - (if fbound + (dolist (fbound fbound-list) + (when fbound (setq byte-compile-unresolved-functions (delq (assq fbound byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))))) + byte-compile-unresolved-functions))))))) (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) @@ -3809,7 +3880,7 @@ that suppresses all warnings during execution of BODY." (if (= 1 ncall) "" "s") (if (< ncall 2) "requires" "accepts only") "2-3"))) - (when (memq 'free-vars byte-compile-warnings) + (when (byte-compile-warning-enabled-p 'free-vars) (push var byte-compile-bound-variables) (if (eq fun 'defconst) (push var byte-compile-const-variables))) @@ -3901,7 +3972,7 @@ that suppresses all warnings during execution of BODY." (byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local) (defun byte-compile-make-variable-buffer-local (form) (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) - (memq 'make-local byte-compile-warnings)) + (byte-compile-warning-enabled-p 'make-local)) (byte-compile-warn "`make-variable-buffer-local' should be called at toplevel")) (byte-compile-normal-call form)) diff --git a/lisp/emacs-lisp/cl-compat.el b/lisp/emacs-lisp/cl-compat.el index ebfc43ebc80..1f476081f41 100644 --- a/lisp/emacs-lisp/cl-compat.el +++ b/lisp/emacs-lisp/cl-compat.el @@ -186,5 +186,9 @@ (provide 'cl-compat) +;; Local variables: +;; byte-compile-warnings: (not cl-functions) +;; End: + ;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163 ;;; cl-compat.el ends here diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 705f565e146..4cdf7036369 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -745,24 +745,24 @@ Not documented ;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not ;;;;;; substitute-if substitute delete-duplicates remove-duplicates ;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "c972a97c053d4e001ac1d1012c315b28") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "77bee7df392948b6ab0699e391e8abc1") ;;; Generated autoloads from cl-seq.el -(autoload (quote reduce) "cl-seq" "\ +(autoload 'reduce "cl-seq" "\ Reduce two-argument FUNCTION across SEQ. Keywords supported: :start :end :from-end :initial-value :key \(fn FUNCTION SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote fill) "cl-seq" "\ +(autoload 'fill "cl-seq" "\ Fill the elements of SEQ with ITEM. Keywords supported: :start :end \(fn SEQ ITEM [KEYWORD VALUE]...)" nil nil) -(autoload (quote replace) "cl-seq" "\ +(autoload 'replace "cl-seq" "\ Replace the elements of SEQ1 with the elements of SEQ2. SEQ1 is destructively modified, then returned. @@ -770,7 +770,7 @@ Keywords supported: :start1 :end1 :start2 :end2 \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove*) "cl-seq" "\ +(autoload 'remove* "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -779,7 +779,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove-if) "cl-seq" "\ +(autoload 'remove-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -788,7 +788,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove-if-not) "cl-seq" "\ +(autoload 'remove-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -797,7 +797,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete*) "cl-seq" "\ +(autoload 'delete* "cl-seq" "\ Remove all occurrences of ITEM in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -805,7 +805,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete-if) "cl-seq" "\ +(autoload 'delete-if "cl-seq" "\ Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -813,7 +813,7 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete-if-not) "cl-seq" "\ +(autoload 'delete-if-not "cl-seq" "\ Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -821,21 +821,21 @@ Keywords supported: :key :count :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote remove-duplicates) "cl-seq" "\ +(autoload 'remove-duplicates "cl-seq" "\ Return a copy of SEQ with all duplicate elements removed. Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote delete-duplicates) "cl-seq" "\ +(autoload 'delete-duplicates "cl-seq" "\ Remove all duplicate elements from SEQ (destructively). Keywords supported: :test :test-not :key :start :end :from-end \(fn SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote substitute) "cl-seq" "\ +(autoload 'substitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -844,7 +844,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote substitute-if) "cl-seq" "\ +(autoload 'substitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -853,7 +853,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote substitute-if-not) "cl-seq" "\ +(autoload 'substitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. @@ -862,7 +862,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubstitute) "cl-seq" "\ +(autoload 'nsubstitute "cl-seq" "\ Substitute NEW for OLD in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -870,7 +870,7 @@ Keywords supported: :test :test-not :key :count :start :end :from-end \(fn NEW OLD SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubstitute-if) "cl-seq" "\ +(autoload 'nsubstitute-if "cl-seq" "\ Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -878,7 +878,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubstitute-if-not) "cl-seq" "\ +(autoload 'nsubstitute-if-not "cl-seq" "\ Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. @@ -886,7 +886,7 @@ Keywords supported: :key :count :start :end :from-end \(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote find) "cl-seq" "\ +(autoload 'find "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the matching ITEM, or nil if not found. @@ -894,7 +894,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote find-if) "cl-seq" "\ +(autoload 'find-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -902,7 +902,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote find-if-not) "cl-seq" "\ +(autoload 'find-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the matching item, or nil if not found. @@ -910,7 +910,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote position) "cl-seq" "\ +(autoload 'position "cl-seq" "\ Find the first occurrence of ITEM in SEQ. Return the index of the matching item, or nil if not found. @@ -918,7 +918,7 @@ Keywords supported: :test :test-not :key :start :end :from-end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote position-if) "cl-seq" "\ +(autoload 'position-if "cl-seq" "\ Find the first item satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -926,7 +926,7 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote position-if-not) "cl-seq" "\ +(autoload 'position-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in SEQ. Return the index of the matching item, or nil if not found. @@ -934,28 +934,28 @@ Keywords supported: :key :start :end :from-end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote count) "cl-seq" "\ +(autoload 'count "cl-seq" "\ Count the number of occurrences of ITEM in SEQ. Keywords supported: :test :test-not :key :start :end \(fn ITEM SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote count-if) "cl-seq" "\ +(autoload 'count-if "cl-seq" "\ Count the number of items satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote count-if-not) "cl-seq" "\ +(autoload 'count-if-not "cl-seq" "\ Count the number of items not satisfying PREDICATE in SEQ. Keywords supported: :key :start :end \(fn PREDICATE SEQ [KEYWORD VALUE]...)" nil nil) -(autoload (quote mismatch) "cl-seq" "\ +(autoload 'mismatch "cl-seq" "\ Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the other, the return value indicates the end of the shorter sequence. @@ -964,7 +964,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote search) "cl-seq" "\ +(autoload 'search "cl-seq" "\ Search for SEQ1 as a subsequence of SEQ2. Return the index of the leftmost element of the first match found; return nil if there are no matches. @@ -973,7 +973,7 @@ Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end \(fn SEQ1 SEQ2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote sort*) "cl-seq" "\ +(autoload 'sort* "cl-seq" "\ Sort the argument SEQ according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -981,7 +981,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload (quote stable-sort) "cl-seq" "\ +(autoload 'stable-sort "cl-seq" "\ Sort the argument SEQ stably according to PREDICATE. This is a destructive function; it reuses the storage of SEQ if possible. @@ -989,7 +989,7 @@ Keywords supported: :key \(fn SEQ PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload (quote merge) "cl-seq" "\ +(autoload 'merge "cl-seq" "\ Destructively merge the two sequences to produce a new sequence. TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument sequences, and PREDICATE is a `less-than' predicate on the elements. @@ -998,7 +998,7 @@ Keywords supported: :key \(fn TYPE SEQ1 SEQ2 PREDICATE [KEYWORD VALUE]...)" nil nil) -(autoload (quote member*) "cl-seq" "\ +(autoload 'member* "cl-seq" "\ Find the first occurrence of ITEM in LIST. Return the sublist of LIST whose car is ITEM. @@ -1006,7 +1006,7 @@ Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote member-if) "cl-seq" "\ +(autoload 'member-if "cl-seq" "\ Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1014,7 +1014,7 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote member-if-not) "cl-seq" "\ +(autoload 'member-if-not "cl-seq" "\ Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. @@ -1022,54 +1022,54 @@ Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote cl-adjoin) "cl-seq" "\ +(autoload 'cl-adjoin "cl-seq" "\ Not documented \(fn CL-ITEM CL-LIST &rest CL-KEYS)" nil nil) -(autoload (quote assoc*) "cl-seq" "\ +(autoload 'assoc* "cl-seq" "\ Find the first item whose car matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote assoc-if) "cl-seq" "\ +(autoload 'assoc-if "cl-seq" "\ Find the first item whose car satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote assoc-if-not) "cl-seq" "\ +(autoload 'assoc-if-not "cl-seq" "\ Find the first item whose car does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote rassoc*) "cl-seq" "\ +(autoload 'rassoc* "cl-seq" "\ Find the first item whose cdr matches ITEM in LIST. Keywords supported: :test :test-not :key \(fn ITEM LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote rassoc-if) "cl-seq" "\ +(autoload 'rassoc-if "cl-seq" "\ Find the first item whose cdr satisfies PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote rassoc-if-not) "cl-seq" "\ +(autoload 'rassoc-if-not "cl-seq" "\ Find the first item whose cdr does not satisfy PREDICATE in LIST. Keywords supported: :key \(fn PREDICATE LIST [KEYWORD VALUE]...)" nil nil) -(autoload (quote union) "cl-seq" "\ +(autoload 'union "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The result list contains all items that appear in either LIST1 or LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1079,7 +1079,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nunion) "cl-seq" "\ +(autoload 'nunion "cl-seq" "\ Combine LIST1 and LIST2 using a set-union operation. The result list contains all items that appear in either LIST1 or LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1089,7 +1089,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote intersection) "cl-seq" "\ +(autoload 'intersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The result list contains all items that appear in both LIST1 and LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1099,7 +1099,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nintersection) "cl-seq" "\ +(autoload 'nintersection "cl-seq" "\ Combine LIST1 and LIST2 using a set-intersection operation. The result list contains all items that appear in both LIST1 and LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1109,7 +1109,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote set-difference) "cl-seq" "\ +(autoload 'set-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The result list contains all items that appear in LIST1 but not LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1119,7 +1119,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nset-difference) "cl-seq" "\ +(autoload 'nset-difference "cl-seq" "\ Combine LIST1 and LIST2 using a set-difference operation. The result list contains all items that appear in LIST1 but not LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1129,7 +1129,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote set-exclusive-or) "cl-seq" "\ +(autoload 'set-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The result list contains all items that appear in exactly one of LIST1, LIST2. This is a non-destructive function; it makes a copy of the data if necessary @@ -1139,7 +1139,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote nset-exclusive-or) "cl-seq" "\ +(autoload 'nset-exclusive-or "cl-seq" "\ Combine LIST1 and LIST2 using a set-exclusive-or operation. The result list contains all items that appear in exactly one of LIST1, LIST2. This is a destructive function; it reuses the storage of LIST1 and LIST2 @@ -1149,7 +1149,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote subsetp) "cl-seq" "\ +(autoload 'subsetp "cl-seq" "\ Return true if LIST1 is a subset of LIST2. I.e., if every element of LIST1 also appears in LIST2. @@ -1157,7 +1157,7 @@ Keywords supported: :test :test-not :key \(fn LIST1 LIST2 [KEYWORD VALUE]...)" nil nil) -(autoload (quote subst-if) "cl-seq" "\ +(autoload 'subst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. @@ -1165,7 +1165,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote subst-if-not) "cl-seq" "\ +(autoload 'subst-if-not "cl-seq" "\ Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. @@ -1173,7 +1173,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubst) "cl-seq" "\ +(autoload 'nsubst "cl-seq" "\ Substitute NEW for OLD everywhere in TREE (destructively). Any element of TREE which is `eql' to OLD is changed to NEW (via a call to `setcar'). @@ -1182,7 +1182,7 @@ Keywords supported: :test :test-not :key \(fn NEW OLD TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubst-if) "cl-seq" "\ +(autoload 'nsubst-if "cl-seq" "\ Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1190,7 +1190,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsubst-if-not) "cl-seq" "\ +(autoload 'nsubst-if-not "cl-seq" "\ Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). @@ -1198,7 +1198,7 @@ Keywords supported: :key \(fn NEW PREDICATE TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote sublis) "cl-seq" "\ +(autoload 'sublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (non-destructively). Return a copy of TREE with all matching elements replaced. @@ -1206,7 +1206,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote nsublis) "cl-seq" "\ +(autoload 'nsublis "cl-seq" "\ Perform substitutions indicated by ALIST in TREE (destructively). Any matching element of TREE is changed via a call to `setcar'. @@ -1214,7 +1214,7 @@ Keywords supported: :test :test-not :key \(fn ALIST TREE [KEYWORD VALUE]...)" nil nil) -(autoload (quote tree-equal) "cl-seq" "\ +(autoload 'tree-equal "cl-seq" "\ Return t if trees TREE1 and TREE2 have `eql' leaves. Atoms are compared by `eql'; cons cells are compared recursively. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8b55dd4a379..b99de0aac98 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,4 +1,4 @@ -;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*- +;;; cl-macs.el --- Common Lisp macros ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007 ;; Free Software Foundation, Inc. @@ -1554,15 +1554,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). byte-compile-delete-errors (nth 1 safety))))) ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) - (if (eq byte-compile-warnings t) - (setq byte-compile-warnings byte-compile-warning-types)) (while (setq spec (cdr spec)) (if (consp (car spec)) (if (eq (cadar spec) 0) - (setq byte-compile-warnings - (delq (caar spec) byte-compile-warnings)) - (setq byte-compile-warnings - (adjoin (caar spec) byte-compile-warnings))))))) + (byte-compile-disable-warning (caar spec)) + (byte-compile-enable-warning (caar spec))))))) nil) ;;; Process any proclamations made before cl-macs was loaded. @@ -2728,7 +2724,8 @@ surrounded by (block NAME ...). (run-hooks 'cl-macs-load-hook) ;; Local variables: -;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 8016b75aad9..4669d69c872 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1,4 +1,4 @@ -;;; cl-seq.el --- Common Lisp features, part 3 -*-byte-compile-dynamic: t;-*- +;;; cl-seq.el --- Common Lisp features, part 3 ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007 Free Software Foundation, Inc. @@ -1020,6 +1020,8 @@ Atoms are compared by `eql'; cons cells are compared recursively. (run-hooks 'cl-seq-load-hook) ;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 8d609509f10..c8a029a453a 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -1,4 +1,4 @@ -;;; cl.el --- Common Lisp extensions for Emacs -*-byte-compile-dynamic: t;-*- +;;; cl.el --- Common Lisp extensions for Emacs ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007 Free Software Foundation, Inc. @@ -109,9 +109,11 @@ printer proceeds to the next function on the list. This variable is not used at present, but it is defined in hopes that a future Emacs interpreter will be able to use it.") -(add-hook 'cl-unload-hook 'cl-cannot-unload) -(defun cl-cannot-unload () - (error "Cannot unload the feature `cl'")) +(defun cl-unload-function () + "Stop unloading of the Common Lisp extensions." + (message "Cannot unload the feature `cl'") + ;; stop standard unloading! + t) ;;; Generalized variables. ;; These macros are defined here so that they @@ -658,5 +660,10 @@ If ALIST is non-nil, the new pairs are prepended to it." (run-hooks 'cl-load-hook) +;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) +;; End: + ;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 ;;; cl.el ends here diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index ade2a23608d..c4ba3e4ca9c 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -147,16 +147,16 @@ Results are displayed with the `elp-results' command." :group 'elp) (defcustom elp-sort-by-function 'elp-sort-by-total-time - "*Non-nil specifies elp results sorting function. + "*Non-nil specifies ELP results sorting function. These functions are currently available: elp-sort-by-call-count -- sort by the highest call count elp-sort-by-total-time -- sort by the highest total time elp-sort-by-average-time -- sort by the highest average times -You can write you're own sort function. It should adhere to the -interface specified by the PRED argument for the `sort' defun. Each -\"element of LIST\" is really a 4 element vector where element 0 is +You can write your own sort function. It should adhere to the +interface specified by the PREDICATE argument for `sort'. +Each \"element of LIST\" is really a 4 element vector where element 0 is the call count, element 1 is the total time spent in the function, element 2 is the average time spent in the function, and element 3 is the symbol's name string." @@ -164,7 +164,7 @@ the symbol's name string." :group 'elp) (defcustom elp-report-limit 1 - "*Prevents some functions from being displayed in the results buffer. + "*Prevent some functions from being displayed in the results buffer. If a number, no function that has been called fewer than that number of times will be displayed in the output buffer. If nil, all functions will be displayed." @@ -173,12 +173,12 @@ functions will be displayed." :group 'elp) (defcustom elp-use-standard-output nil - "*Non-nil says to output to `standard-output' instead of a buffer." + "*If non-nil, output to `standard-output' instead of a buffer." :type 'boolean :group 'elp) (defcustom elp-recycle-buffers-p t - "*nil says to not recycle the `elp-results-buffer'. + "*If nil, don't recycle the `elp-results-buffer'. In other words, a new unique buffer is create every time you run \\[elp-results]." :type 'boolean @@ -372,7 +372,7 @@ Use optional LIST if provided instead." (mapcar 'elp-restore-function list))) (defun elp-restore-all () - "Restores the original definitions of all functions being profiled." + "Restore the original definitions of all functions being profiled." (interactive) (elp-restore-list elp-all-instrumented-list)) @@ -412,7 +412,7 @@ Use optional LIST if provided instead." (elp-instrument-function funsym))) (defun elp-unset-master () - "Unsets the master function." + "Unset the master function." (interactive) ;; when there's no master function, recording is turned on by default. (setq elp-master nil @@ -558,7 +558,7 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." (defun elp-results () "Display current profiling results. If `elp-reset-after-results' is non-nil, then current profiling -information for all instrumented functions are reset after results are +information for all instrumented functions is reset after results are displayed." (interactive) (let ((curbuf (current-buffer)) @@ -626,9 +626,11 @@ displayed." (and elp-reset-after-results (elp-reset-all)))) -(defun elp-unload-hook () - (elp-restore-all)) -(add-hook 'elp-unload-hook 'elp-unload-hook) +(defun elp-unload-function () + "Unload the Emacs Lisp Profiler." + (elp-restore-all) + ;; continue standard unloading + nil) (provide 'elp) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 20b91b10547..b3c7c339030 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -192,11 +192,21 @@ TYPE should be nil to find a function, or `defvar' to find a variable." (defun find-library (library) "Find the elisp source of LIBRARY." (interactive - (list - (completing-read "Library name: " - 'locate-file-completion - (cons (or find-function-source-path load-path) - (find-library-suffixes))))) + (let* ((path (cons (or find-function-source-path load-path) + (find-library-suffixes))) + (def (if (eq (function-called-at-point) 'require) + (save-excursion + (backward-up-list) + (forward-char) + (backward-sexp -2) + (thing-at-point 'symbol)) + (thing-at-point 'symbol)))) + (when def + (setq def (and (locate-file-completion def path 'test) def))) + (list + (completing-read (if def (format "Library name (default %s): " def) + "Library name: ") + 'locate-file-completion path nil nil nil def)))) (let ((buf (find-file-noselect (find-library-name library)))) (condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf))))) diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index d7dd1f19300..3bb93334c3c 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -116,9 +116,9 @@ in the parse.") ;;;###autoload (defun unsafep (form &optional unsafep-vars) - "Return nil if evaluating FORM couldn't possibly do any harm; -otherwise result is a reason why FORM is unsafe. UNSAFEP-VARS is a list -of symbols with local bindings." + "Return nil if evaluating FORM couldn't possibly do any harm. +Otherwise result is a reason why FORM is unsafe. +UNSAFEP-VARS is a list of symbols with local bindings." (catch 'unsafep (if (or (eq safe-functions t) ;User turned off safety-checking (atom form)) ;Atoms are never unsafe @@ -213,8 +213,8 @@ of symbols with local bindings." (defun unsafep-function (fun) "Return nil if FUN is a safe function. -\(either a safe lambda or a symbol that names a safe function). Otherwise -result is a reason code." +\(Either a safe lambda or a symbol that names a safe function). +Otherwise result is a reason code." (cond ((eq (car-safe fun) 'lambda) (unsafep fun unsafep-vars)) @@ -226,8 +226,8 @@ result is a reason code." `(function ,fun)))) (defun unsafep-progn (list) - "Return nil if all forms in LIST are safe, or the reason -for the first unsafe form." + "Return nil if all forms in LIST are safe. +Else, return the reason for the first unsafe form." (catch 'unsafep-progn (let (reason) (dolist (x list) @@ -236,8 +236,9 @@ for the first unsafe form." (defun unsafep-let (clause) "Check the safety of a let binding. -CLAUSE is a let-binding, either SYM or (SYM) or (SYM VAL). Checks VAL -and throws a reason to `unsafep' if unsafe. Returns SYM." +CLAUSE is a let-binding, either SYM or (SYM) or (SYM VAL). +Check VAL and throw a reason to `unsafep' if unsafe. +Return SYM." (let (reason sym) (if (atom clause) (setq sym clause) diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el index bff1a583586..4a68e258cb1 100644 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@ -321,24 +321,14 @@ This means that an edt-user.el file was found in the user's `load-path'.") ;;; ;;; o edt-emulation-on o edt-load-keys ;;; -(defconst edt-emacs19-p (not (string-lessp emacs-version "19")) - "Non-nil if we are running GNU Emacs or XEmacs version 19, or higher.") - -(defconst edt-x-emacs19-p - (and edt-emacs19-p (string-match "XEmacs" emacs-version)) - "Non-nil if we are running XEmacs version 19, or higher.") - -(defconst edt-gnu-emacs19-p (and edt-emacs19-p (not edt-x-emacs19-p)) - "Non-nil if we are running GNU Emacs version 19, or higher.") - -(defconst edt-emacs-variant (if edt-gnu-emacs19-p "gnu" "xemacs") +(defconst edt-emacs-variant (if (featurep 'emacs) "gnu" "xemacs") "Indicates Emacs variant: GNU Emacs or XEmacs \(aka Lucid Emacs\).") -(defconst edt-window-system (if edt-gnu-emacs19-p window-system (console-type)) +(defconst edt-window-system (if (featurep 'emacs) window-system (console-type)) "Indicates window system \(in GNU Emacs\) or console type \(in XEmacs\).") (defconst edt-xserver (if (eq edt-window-system 'x) - (if edt-x-emacs19-p + (if (featurep 'xemacs) ;; The Cygwin window manager has a `/' in its ;; name, which breaks the generated file name of ;; the custom key map file. Replace `/' with a @@ -409,7 +399,7 @@ Argument NUM is the number of page delimiters to move." (progn (backward-page num) (edt-line-to-top-of-window) - (if edt-x-emacs19-p (setq zmacs-region-stays t))))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))))) (defun edt-page (num) "Move in current direction to next page delimiter. @@ -470,7 +460,7 @@ Argument NUM is the number of BOL marks to move." (setq num (1- num)) (forward-line (* -1 num)))) (edt-top-check beg num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; @@ -486,7 +476,7 @@ Argument NUM is the number of EOL marks to move." (forward-char) (end-of-line num) (edt-bottom-check beg num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-end-of-line-backward (num) @@ -497,7 +487,7 @@ Argument NUM is the number of EOL marks to move." (let ((beg (edt-current-line))) (end-of-line (1- num)) (edt-top-check beg num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-end-of-line (num) @@ -542,7 +532,7 @@ Argument NUM is the number of EOL marks to move." (eq ?\ (char-syntax (following-char))) (not (memq (following-char) edt-word-entities))) (forward-char)))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-one-word-backward () "Move backward to first character of previous word." @@ -566,7 +556,7 @@ Argument NUM is the number of EOL marks to move." (not (eq ?\ (char-syntax (preceding-char)))) (not (memq (preceding-char) edt-word-entities))) (backward-char))))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-word-forward (num) "Move forward to first character of next word. @@ -606,7 +596,7 @@ Argument NUM is the number of characters to move." (if (equal edt-direction-string edt-forward-string) (forward-char num) (backward-char num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; LINE @@ -629,7 +619,7 @@ Argument NUM is the number of BOL marks to move." (let ((beg (edt-current-line))) (forward-line num) (edt-bottom-check beg num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-line (num) "Move in current direction to next beginning of line mark. @@ -651,7 +641,7 @@ Argument NUM is the number of lines to move." (let ((beg (edt-current-line))) (forward-line num) (edt-bottom-check beg num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-previous-line (num) "Move cursor up one line. @@ -661,7 +651,7 @@ Argument NUM is the number of lines to move." (let ((beg (edt-current-line))) (forward-line (- num)) (edt-top-check beg num)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; @@ -672,7 +662,7 @@ Argument NUM is the number of lines to move." "Move cursor to the beginning of buffer." (interactive) (goto-char (point-min)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; BOTTOM @@ -718,7 +708,7 @@ Optional argument FIND is t is this function is called from `edt-find'." (recenter (- left bottom-up-margin)))) (t (and (> (point) bottom) (recenter bottom-margin))))))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-find-backward (&optional find) "Find first occurrence of a string in the backward direction and save it. @@ -743,7 +733,7 @@ Optional argument FIND is t if this function is called from `edt-find'." (if (search-backward edt-find-last-text) (edt-set-match)) (and (< (point) top) (recenter (min beg top-margin)))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-find () "Find first occurrence of string in current direction and save it." @@ -789,7 +779,7 @@ Optional argument FIND is t if this function is called from `edt-find'." (progn (backward-char 1) (error "Search failed: \"%s\"" edt-find-last-text)))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-find-next-backward () "Find next occurrence of a string in backward direction." @@ -813,7 +803,7 @@ Optional argument FIND is t if this function is called from `edt-find'." (progn (edt-set-match) (and (< (point) top) (recenter (min beg top-margin)))))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-find-next () "Find next occurrence of a string in current direction." @@ -891,7 +881,7 @@ In select mode, selected text is highlighted." (defun edt-reset () "Cancel text selection." (interactive) - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (deactivate-mark) (zmacs-deactivate-region))) @@ -1108,7 +1098,7 @@ Also, execute command specified if in Minibuffer." (if (string-equal " *Minibuf" (substring (buffer-name) 0 (min (length (buffer-name)) 9))) (exit-minibuffer)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; @@ -1124,7 +1114,7 @@ Also, execute command specified if in Minibuffer." (if (string-equal " *Minibuf" (substring (buffer-name) 0 (min (length (buffer-name)) 9))) (exit-minibuffer)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; @@ -1174,12 +1164,12 @@ Argument NUM is the numbers of consecutive characters to change." The current key definition is saved in `edt-last-replaced-key-definition'. Use `edt-restore-key' to restore last replaced key definition." (interactive) - (if edt-x-emacs19-p (setq zmacs-region-stays t)) + (if (featurep 'xemacs) (setq zmacs-region-stays t)) (let (edt-function edt-key-definition) (setq edt-key-definition (read-key-sequence "Press the key to be defined: ")) - (if (if edt-gnu-emacs19-p + (if (if (featurep 'emacs) (string-equal "\C-m" edt-key-definition) (string-equal "\C-m" (events-to-keys edt-key-definition))) (message "Key not defined") @@ -1259,7 +1249,7 @@ Argument LINES is the number of lines the cursor moved toward the bottom." ;; subtract 1 from height because it includes mode line (difference (- height margin 1))) (cond ((> beg difference) (recenter beg)) - ((and edt-x-emacs19-p (> (+ beg lines 1) difference)) + ((and (featurep 'xemacs) (> (+ beg lines 1) difference)) (recenter (- margin))) ((> (+ beg lines) difference) (recenter (- margin)))))) @@ -1363,7 +1353,7 @@ Argument NUM is the positive number of sentences to move." (recenter (- left bottom-up-margin)))) (t (and (> (point) bottom) (recenter bottom-margin))))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-sentence-backward (num) "Move backward to next sentence beginning. @@ -1389,7 +1379,7 @@ Argument NUM is the positive number of sentences to move." (error "End of buffer")) (backward-sentence num)) (and (< (point) top) (recenter (min beg top-margin)))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-sentence (num) "Move in current direction to next sentence. @@ -1434,7 +1424,7 @@ Argument NUM is the positive number of paragraphs to move." (recenter (- left bottom-up-margin)))) (t (and (> (point) bottom) (recenter bottom-margin))))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-paragraph-backward (num) "Move backward to beginning of paragraph. @@ -1459,7 +1449,7 @@ Argument NUM is the positive number of paragraphs to move." (start-of-paragraph-text) (setq num (1- num))) (and (< (point) top) (recenter (min beg top-margin)))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-paragraph (num) "Move in current direction to next paragraph. @@ -1477,20 +1467,20 @@ Argument NUM is the positive number of paragraphs to move." "Restore last replaced key definition. Definition is stored in `edt-last-replaced-key-definition'." (interactive) - (if edt-x-emacs19-p (setq zmacs-region-stays t)) + (if (featurep 'xemacs) (setq zmacs-region-stays t)) (if edt-last-replaced-key-definition (progn (let (edt-key-definition) (set 'edt-key-definition (read-key-sequence "Press the key to be restored: ")) - (if (if edt-gnu-emacs19-p + (if (if (featurep 'emacs) (string-equal "\C-m" edt-key-definition) (string-equal "\C-m" (events-to-keys edt-key-definition))) (message "Key not restored") (progn (define-key (current-global-map) edt-key-definition edt-last-replaced-key-definition) - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (message "Key definition for %s has been restored." edt-key-definition) (message "Key definition for %s has been restored." @@ -1507,7 +1497,7 @@ Definition is stored in `edt-last-replaced-key-definition'." (let ((start-column (current-column))) (move-to-window-line 0) (move-to-column start-column)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; WINDOW BOTTOM @@ -1519,7 +1509,7 @@ Definition is stored in `edt-last-replaced-key-definition'." (let ((start-column (current-column))) (move-to-window-line (- (window-height) 2)) (move-to-column start-column)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; SCROLL WINDOW LINE @@ -1529,13 +1519,13 @@ Definition is stored in `edt-last-replaced-key-definition'." "Move window forward one line leaving cursor at position in window." (interactive) (scroll-up 1) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-scroll-window-backward-line () "Move window backward one line leaving cursor at position in window." (interactive) (scroll-down 1) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) (defun edt-scroll-line () "Move window one line in current direction." @@ -1582,7 +1572,7 @@ Argument NUM is the positive number of windows to move." "Move the current line to the bottom of the window." (interactive) (recenter -1) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; LINE TO TOP OF WINDOW @@ -1592,7 +1582,7 @@ Argument NUM is the positive number of windows to move." "Move the current line to the top of the window." (interactive) (recenter 0) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; LINE TO MIDDLE OF WINDOW @@ -1602,7 +1592,7 @@ Argument NUM is the positive number of windows to move." "Move window so line with cursor is in the middle of the window." (interactive) (recenter '(4)) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; GOTO PERCENTAGE @@ -1615,7 +1605,7 @@ Argument NUM is the percentage into the buffer to move." (if (or (> num 100) (< num 0)) (error "Percentage %d out of range 0 < percent < 100" num) (goto-char (/ (* (point-max) num) 100))) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; FILL REGION @@ -1785,7 +1775,7 @@ Argument NUM is the number of times to duplicate the line." (defun edt-display-the-time () "Display the current time." (interactive) - (if edt-x-emacs19-p (setq zmacs-region-stays t)) + (if (featurep 'xemacs) (setq zmacs-region-stays t)) (message "%s" (current-time-string))) ;;; @@ -1813,7 +1803,7 @@ Argument NUM is the number of times to duplicate the line." (let (edt-key-definition) (set 'edt-key-definition (read-key-sequence "Enter key for binding: ")) - (if (if edt-gnu-emacs19-p + (if (if (featurep 'emacs) (string-equal "\C-m" edt-key-definition) (string-equal "\C-m" (events-to-keys edt-key-definition))) (message "Key sequence not remembered") @@ -1866,7 +1856,7 @@ Warn user that modifications will be lost." (interactive) (split-window) (other-window 1) - (if edt-x-emacs19-p (setq zmacs-region-stays t))) + (if (featurep 'xemacs) (setq zmacs-region-stays t))) ;;; ;;; COPY RECTANGLE @@ -2152,7 +2142,7 @@ created." (setq edt-term term)))) (edt-load-keys nil)) ;; Make highlighting of selected text work properly for EDT commands. - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (progn (setq edt-orig-transient-mark-mode transient-mark-mode) (add-hook 'activate-mark-hook @@ -2188,7 +2178,7 @@ created." (setq edt-select-mode-current nil) (edt-reset) (force-mode-line-update t) - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (setq transient-mark-mode edt-orig-transient-mark-mode)) (message "Original key bindings restored; EDT Emulation disabled")) @@ -2203,7 +2193,7 @@ Optional argument USER-SETUP non-nil means called from function ;; disturbing the original bindings in global-map. (fset 'edt-default-ESC-prefix (copy-keymap 'ESC-prefix)) (setq edt-default-global-map (copy-keymap (current-global-map))) - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (define-key edt-default-global-map "\e" 'edt-default-ESC-prefix) (define-key edt-default-global-map [escape] 'edt-default-ESC-prefix)) (define-prefix-command 'edt-default-gold-map) @@ -2239,7 +2229,7 @@ Optional argument USER-SETUP non-nil means called from function ;; Setup user EDT global map by copying default EDT global map bindings. (fset 'edt-user-ESC-prefix (copy-keymap 'edt-default-ESC-prefix)) (setq edt-user-global-map (copy-keymap edt-default-global-map)) - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (define-key edt-user-global-map "\e" 'edt-user-ESC-prefix) (define-key edt-user-global-map [escape] 'edt-user-ESC-prefix)) ;; If terminal has additional function keys, the user's initialization @@ -2253,7 +2243,7 @@ Optional argument USER-SETUP non-nil means called from function (defun edt-select-default-global-map() "Select default EDT emulation key bindings." (interactive) - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (transient-mark-mode 1)) (use-global-map edt-default-global-map) (if (not edt-keep-current-page-delimiter) @@ -2271,7 +2261,7 @@ Optional argument USER-SETUP non-nil means called from function (interactive) (if edt-user-map-configured (progn - (if edt-gnu-emacs19-p + (if (featurep 'emacs) (transient-mark-mode 1)) (use-global-map edt-user-global-map) (if (not edt-keep-current-page-delimiter) diff --git a/lisp/emulation/tpu-mapper.el b/lisp/emulation/tpu-mapper.el index 3e5af7a38bd..b3ad67ec4df 100644 --- a/lisp/emulation/tpu-mapper.el +++ b/lisp/emulation/tpu-mapper.el @@ -78,13 +78,6 @@ ;;; -;;; Decide whether we're running Lucid Emacs or Emacs itself. -;;; -(defconst tpu-lucid-emacs19-p (string-match "Lucid" emacs-version) - "Non-nil if we are running Lucid Emacs version 19.") - - -;;; ;;; Key variables ;;; (defvar tpu-kp4 nil) @@ -100,7 +93,7 @@ ;;; ;;; Make sure the window is big enough to display the instructions ;;; -(if tpu-lucid-emacs19-p (set-screen-size (selected-screen) 80 36) +(if (featurep 'xemacs) (set-screen-size (selected-screen) 80 36) (set-frame-size (selected-frame) 80 36)) @@ -167,7 +160,7 @@ ;;; Save <CR> for future reference ;;; (cond - (tpu-lucid-emacs19-p + ((featurep 'xemacs) (setq tpu-return-seq (read-key-sequence "Hit carriage-return <CR> to continue ")) (setq tpu-return (concat "[" (format "%s" (event-key (aref tpu-return-seq 0))) "]"))) (t @@ -179,42 +172,29 @@ ;;; ;;; Key mapping functions ;;; -(defun tpu-lucid-map-key (ident descrip func gold-func) +(defun tpu-map-key (ident descrip func gold-func) (interactive) - (setq tpu-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) - (setq tpu-key (concat "[" (format "%s" (event-key (aref tpu-key-seq 0))) "]")) - (cond ((not (equal tpu-key tpu-return)) - (set-buffer "Keys") - (insert (format"(global-set-key %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key GOLD-map %s %s)\n" tpu-key gold-func)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits <CR>! - ;; check periodically to see if this is still needed... - (t - (format "%s" tpu-key))) + (if (featurep 'xemacs) + (progn + (setq tpu-key-seq (read-key-sequence + (format "Press %s%s: " ident descrip)) + tpu-key (format "[%s]" (event-key (aref tpu-key-seq 0)))) + (unless (equal tpu-key tpu-return) + (set-buffer "Keys") + (insert (format"(global-set-key %s %s)\n" tpu-key func)) + (set-buffer "Gold-Keys") + (insert (format "(define-key GOLD-map %s %s)\n" tpu-key gold-func)))) + (message "Press %s%s: " ident descrip) + (setq tpu-key-seq (read-event) + tpu-key (format "[%s]" tpu-key-seq)) + (unless (equal tpu-key tpu-return) + (set-buffer "Keys") + (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) + (set-buffer "Gold-Keys") + (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)))) + (set-buffer "Directions") tpu-key) -(defun tpu-emacs-map-key (ident descrip func gold-func) - (interactive) - (message "Press %s%s: " ident descrip) - (setq tpu-key-seq (read-event)) - (setq tpu-key (concat "[" (format "%s" tpu-key-seq) "]")) - (cond ((not (equal tpu-key tpu-return)) - (set-buffer "Keys") - (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits <CR>! - ;; check periodically to see if this is still needed... - (t - (format "%s" tpu-key))) - tpu-key) - -(fset 'tpu-map-key (if tpu-lucid-emacs19-p 'tpu-lucid-map-key 'tpu-emacs-map-key)) - - (set-buffer "Keys") (insert " ;; Arrows @@ -350,7 +330,7 @@ ;; ") -(cond (tpu-lucid-emacs19-p +(cond ((featurep 'xemacs) (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter-seq)) (insert (format "(setq tpu-help-return \"%s\")\n" tpu-return-seq)) (insert "(setq tpu-help-N \"[#<keypress-event N>]\")\n") @@ -368,7 +348,7 @@ ;;; (let ((file (convert-standard-filename - (if tpu-lucid-emacs19-p "~/.tpu-lucid-keys" "~/.tpu-keys")))) + (if (featurep 'xemacs) "~/.tpu-lucid-keys" "~/.tpu-keys")))) (set-visited-file-name (read-file-name (format "Save key mapping to file (default %s): " file) "" file))) (save-buffer) diff --git a/lisp/emulation/vip.el b/lisp/emulation/vip.el index c2d00a8ffba..e6fdd55f7c4 100644 --- a/lisp/emulation/vip.el +++ b/lisp/emulation/vip.el @@ -874,7 +874,7 @@ is the name of the register for COM." (set-mark beg)) (beginning-of-line) (exchange-point-and-mark) - (if (or (not (eobp)) (not (bolp))) (next-line 1)) + (if (or (not (eobp)) (not (bolp))) (with-no-warnings (next-line 1))) (beginning-of-line) (if (> beg end) (exchange-point-and-mark))) @@ -1050,7 +1050,7 @@ command was invoked with argument > 1." (defun vip-line (arg) (let ((val (car arg)) (com (cdr arg))) (move-marker vip-com-point (point)) - (next-line (1- val)) + (with-no-warnings (next-line (1- val))) (vip-execute-com 'vip-line val com))) (defun vip-yank-line (arg) @@ -1263,7 +1263,7 @@ beginning of buffer, stop and signal error." (interactive "P") (let ((val (vip-p-val arg)) (com (vip-getCom arg))) (if com (move-marker vip-com-point (point))) - (next-line val) + (with-no-warnings (next-line val)) (back-to-indentation) (if com (vip-execute-com 'vip-next-line-at-bol val com)))) @@ -1272,7 +1272,7 @@ beginning of buffer, stop and signal error." (interactive "P") (let ((val (vip-p-val arg)) (com (vip-getCom arg))) (if com (move-marker vip-com-point (point))) - (next-line (- val)) + (with-no-warnings (next-line (- val))) (setq this-command 'previous-line) (if com (vip-execute-com 'vip-previous-line val com)))) @@ -1281,7 +1281,7 @@ beginning of buffer, stop and signal error." (interactive "P") (let ((val (vip-p-val arg)) (com (vip-getCom arg))) (if com (move-marker vip-com-point (point))) - (next-line (- val)) + (with-no-warnings (next-line (- val))) (back-to-indentation) (if com (vip-execute-com 'vip-previous-line val com)))) @@ -1323,7 +1323,7 @@ after search." ;; forward search begins here (if (eolp) (error "") (point)) ;; forward search ends here - (progn (next-line 1) (beginning-of-line) (point))) + (progn (with-no-warnings (next-line 1)) (beginning-of-line) (point))) (narrow-to-region ;; backward search begins from here (if (bolp) (error "") (point)) @@ -1803,7 +1803,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (setq vip-use-register nil) (if (vip-end-with-a-newline-p text) (progn - (next-line 1) + (with-no-warnings (next-line 1)) (beginning-of-line)) (if (and (not (eolp)) (not (eobp))) (forward-char))) (setq vip-d-com (list 'vip-put-back val nil vip-use-register)) @@ -2883,7 +2883,7 @@ a token has type \(command, address, end-mark\) and value." (let ((point (if (null ex-addresses) (point) (car ex-addresses))) (variant nil) command file) (goto-char point) - (if (not (= point 0)) (next-line 1)) + (if (not (= point 0)) (with-no-warnings (next-line 1))) (beginning-of-line) (save-window-excursion (set-buffer " *ex-working-space*") diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 82dc312cf28..5e13edb9495 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -834,7 +834,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to viper-emacs-kbd-minor-mode ch) (cond ((and viper-special-input-method - viper-emacs-p + (featurep 'emacs) (fboundp 'quail-input-method)) ;; (let ...) is used to restore unread-command-events to the ;; original state. We don't want anything left in there after @@ -861,7 +861,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (1- (length quail-current-str))))) )) ((and viper-special-input-method - viper-xemacs-p + (featurep 'xemacs) (fboundp 'quail-start-translation)) ;; same as above but for XEmacs, which doesn't have ;; quail-input-method @@ -893,7 +893,7 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (t ;;(setq ch (read-char-exclusive)) (setq ch (aref (read-key-sequence nil) 0)) - (if viper-xemacs-p + (if (featurep 'xemacs) (setq ch (event-to-character ch))) ;; replace ^M with the newline (if (eq ch ?\C-m) (setq ch ?\n)) @@ -902,13 +902,13 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to (progn ;;(setq ch (read-char-exclusive)) (setq ch (aref (read-key-sequence nil) 0)) - (if viper-xemacs-p + (if (featurep 'xemacs) (setq ch (event-to-character ch)))) ) (insert ch)) ) (setq last-command-event - (viper-copy-event (if viper-xemacs-p + (viper-copy-event (if (featurep 'xemacs) (character-to-event ch) ch))) ) ; let (error nil) @@ -1080,10 +1080,10 @@ as a Meta key and any number of multiple escapes is allowed." ;; and return ESC as the key-sequence (viper-set-unread-command-events (viper-subseq keyseq 1)) (setq last-input-event event - keyseq (if viper-emacs-p + keyseq (if (featurep 'emacs) "\e" (vector (character-to-event ?\e))))) - ((and viper-xemacs-p + ((and (featurep 'xemacs) (key-press-event-p first-key) (equal '(meta) key-mod)) (viper-set-unread-command-events @@ -1320,7 +1320,7 @@ as a Meta key and any number of multiple escapes is allowed." (setq last-command-char char) (setq last-command-event (viper-copy-event - (if viper-xemacs-p (character-to-event char) char))) + (if (featurep 'xemacs) (character-to-event char) char))) (condition-case err (funcall cmd-to-exec-at-end cmd-info) (error @@ -1902,7 +1902,7 @@ With prefix argument, find next destructive command." (setq viper-intermediate-command 'repeating-display-destructive-command) ;; first search through command history--set temp ring - (setq viper-temp-command-ring (copy-sequence viper-command-ring))) + (setq viper-temp-command-ring (ring-copy viper-command-ring))) (setq cmd (if next (viper-special-ring-rotate1 viper-temp-command-ring 1) (viper-special-ring-rotate1 viper-temp-command-ring -1))) @@ -1936,7 +1936,7 @@ to in the global map, instead of cycling through the insertion ring." (length viper-last-inserted-string-from-insertion-ring)))) ) ;;first search through insertion history - (setq viper-temp-insertion-ring (copy-sequence viper-insertion-ring))) + (setq viper-temp-insertion-ring (ring-copy viper-insertion-ring))) (setq this-command 'viper-insert-from-insertion-ring) ;; so that things will be undone properly (setq buffer-undo-list (cons nil buffer-undo-list)) @@ -2790,7 +2790,8 @@ On reaching beginning of line, stop and signal error." (defun viper-next-line-carefully (arg) (condition-case nil - (next-line arg) + ;; do not use forward-line! need to keep column + (with-no-warnings (next-line arg)) (error nil))) @@ -3089,7 +3090,8 @@ On reaching beginning of line, stop and signal error." (let ((val (viper-p-val arg)) (com (viper-getCom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) - (next-line val) + ;; do not use forward-line! need to keep column + (with-no-warnings (next-line val)) (if viper-ex-style-motion (if (and (eolp) (not (bolp))) (backward-char 1))) (setq this-command 'next-line) @@ -3132,7 +3134,8 @@ If point is on a widget or a button, simulate clicking on that widget/button." (let ((val (viper-p-val arg)) (com (viper-getCom arg))) (if com (viper-move-marker-locally 'viper-com-point (point))) - (previous-line val) + ;; do not use forward-line! need to keep column + (with-no-warnings (previous-line val)) (if viper-ex-style-motion (if (and (eolp) (not (bolp))) (backward-char 1))) (setq this-command 'previous-line) diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index 627d2ff1814..caeecd12c8a 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -651,17 +651,19 @@ reversed." (setq initial-str (format "%d,%d" reg-beg-line reg-end-line))) (setq com-str - (or string (viper-read-string-with-history - ":" - initial-str - 'viper-ex-history - ;; no default when working on region - (if initial-str - nil - (car viper-ex-history)) - map - (if initial-str - " [Type command to execute on current region]")))) + (if string + (concat initial-str string) + (viper-read-string-with-history + ":" + initial-str + 'viper-ex-history + ;; no default when working on region + (if initial-str + nil + (car viper-ex-history)) + map + (if initial-str + " [Type command to execute on current region]")))) (save-window-excursion ;; just a precaution (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) @@ -1101,7 +1103,7 @@ reversed." beg end cont val) (viper-add-keymap ex-read-filename-map - (if viper-emacs-p + (if (featurep 'emacs) minibuffer-local-completion-map read-file-name-map)) @@ -1556,7 +1558,7 @@ reversed." ;; setup buffer (if (setq wind (viper-get-visible-buffer-window buf)) () - (setq wind (get-lru-window (if viper-xemacs-p nil 'visible))) + (setq wind (get-lru-window (if (featurep 'xemacs) nil 'visible))) (set-window-buffer wind buf)) (if (viper-window-display-p) @@ -1876,7 +1878,7 @@ reversed." (condition-case nil (progn (pop-to-buffer (get-buffer-create "*info*")) - (info (if viper-xemacs-p "viper.info" "viper")) + (info (if (featurep 'xemacs) "viper.info" "viper")) (message "Type `i' to search for a specific topic")) (error (beep 1) (with-output-to-temp-buffer " *viper-info*" @@ -1885,7 +1887,7 @@ The Info file for Viper does not seem to be installed. This file is part of the standard distribution of %sEmacs. Please contact your system administrator. " - (if viper-xemacs-p "X" "") + (if (featurep 'xemacs) "X" "") )))))) ;; Ex source command. Loads the file specified as argument or `~/.viper' diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 1b05ef7189d..1b1e07a0a0c 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -49,10 +49,6 @@ (interactive) (message "Viper version is %s" viper-version)) -;; Is it XEmacs? -(defconst viper-xemacs-p (featurep 'xemacs)) -;; Is it Emacs? -(defconst viper-emacs-p (not viper-xemacs-p)) ;; Tell whether we are running as a window application or on a TTY ;; This is used to avoid compilation warnings. When emacs/xemacs forms can @@ -116,8 +112,8 @@ In all likelihood, you don't need to bother with this setting." (cond ((viper-window-display-p)) (viper-force-faces) ((viper-color-display-p)) - (viper-emacs-p (memq (viper-device-type) '(pc))) - (viper-xemacs-p (memq (viper-device-type) '(tty pc))))) + ((featurep 'emacs) (memq (viper-device-type) '(pc))) + ((featurep 'xemacs) (memq (viper-device-type) '(tty pc))))) ;;; Macros @@ -356,9 +352,9 @@ Use `M-x viper-set-expert-level' to change this.") ""))))) (defun viper-inactivate-input-method () - (cond ((and viper-emacs-p (fboundp 'inactivate-input-method)) + (cond ((and (featurep 'emacs) (fboundp 'inactivate-input-method)) (inactivate-input-method)) - ((and viper-xemacs-p (boundp 'current-input-method)) + ((and (featurep 'xemacs) (boundp 'current-input-method)) ;; XEmacs had broken quil-mode for some time, so we are working around ;; it here (setq quail-mode nil) @@ -370,7 +366,7 @@ Use `M-x viper-set-expert-level' to change this.") (force-mode-line-update)) )) (defun viper-activate-input-method () - (cond ((and viper-emacs-p (fboundp 'activate-input-method)) + (cond ((and (featurep 'emacs) (fboundp 'activate-input-method)) (activate-input-method default-input-method)) ((featurep 'xemacs) (if (fboundp 'quail-mode) (quail-mode 1))))) @@ -475,7 +471,7 @@ is non-nil." :group 'viper) (defcustom viper-use-replace-region-delimiters (or (not (viper-has-face-support-p)) - (and viper-xemacs-p (eq (viper-device-type) 'tty))) + (and (featurep 'xemacs) (eq (viper-device-type) 'tty))) "*If non-nil, Viper will always use `viper-replace-region-end-delimiter' and `viper-replace-region-start-delimiter' to delimit replacement regions, even on color displays. By default, the delimiters are used only on TTYs." @@ -1018,13 +1014,13 @@ Should be set in `~/.viper' file." (defun viper-restore-cursor-type () (condition-case nil - (if viper-xemacs-p + (if (featurep 'xemacs) (set (make-local-variable 'bar-cursor) nil) (setq cursor-type default-cursor-type)) (error nil))) (defun viper-set-insert-cursor-type () - (if viper-xemacs-p + (if (featurep 'xemacs) (set (make-local-variable 'bar-cursor) 2) (setq cursor-type '(bar . 2)))) diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el index bf3f0eefb39..788feaf86e6 100644 --- a/lisp/emulation/viper-macs.el +++ b/lisp/emulation/viper-macs.el @@ -826,7 +826,7 @@ name from there." (defun viper-char-array-to-macro (array) (let ((vec (vconcat array)) macro) - (if viper-xemacs-p + (if (featurep 'xemacs) (setq macro (mapcar 'character-to-event vec)) (setq macro vec)) (vconcat (mapcar 'viper-event-key macro)))) diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index e95e80aa4e0..7a47d321890 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -79,7 +79,7 @@ or a tripple-click." ;; time interval in millisecond within which successive clicks are ;; considered related (defcustom viper-multiclick-timeout (if (viper-window-display-p) - (if viper-xemacs-p + (if (featurep 'xemacs) mouse-track-multi-click-time double-click-time) 500) @@ -227,7 +227,7 @@ is ignored." ) ; if ;; XEmacs doesn't have set-text-properties, but there buffer-substring ;; doesn't return properties together with the string, so it's not needed. - (if viper-emacs-p + (if (featurep 'emacs) (set-text-properties 0 (length result) nil result)) result )) @@ -273,7 +273,7 @@ See `viper-surrounding-word' for the definition of a word in this case." 'viper-mouse-catch-frame-switch)) (not (eq (key-binding viper-mouse-up-insert-key-parsed) 'viper-mouse-click-insert-word)) - (and viper-xemacs-p (not (event-over-text-area-p click))))) + (and (featurep 'xemacs) (not (event-over-text-area-p click))))) () ; do nothing, if binding isn't right or not over text ;; turn arg into a number (cond ((integerp arg) nil) @@ -364,7 +364,7 @@ this command." 'viper-mouse-catch-frame-switch)) (not (eq (key-binding viper-mouse-up-search-key-parsed) 'viper-mouse-click-search-word)) - (and viper-xemacs-p (not (event-over-text-area-p click))))) + (and (featurep 'xemacs) (not (event-over-text-area-p click))))) () ; do nothing, if binding isn't right or not over text (let ((previous-search-string viper-s-string) click-word click-count) @@ -507,19 +507,19 @@ bindings in the Viper manual." () (setq button-spec (cond ((memq 1 key) - (if viper-emacs-p + (if (featurep 'emacs) (if (eq 'up event-type) "mouse-1" "down-mouse-1") (if (eq 'up event-type) 'button1up 'button1))) ((memq 2 key) - (if viper-emacs-p + (if (featurep 'emacs) (if (eq 'up event-type) "mouse-2" "down-mouse-2") (if (eq 'up event-type) 'button2up 'button2))) ((memq 3 key) - (if viper-emacs-p + (if (featurep 'emacs) (if (eq 'up event-type) "mouse-3" "down-mouse-3") (if (eq 'up event-type) @@ -528,18 +528,18 @@ bindings in the Viper manual." "%S: invalid button number, %S" key-var key))) meta-spec (if (memq 'meta key) - (if viper-emacs-p "M-" 'meta) - (if viper-emacs-p "" nil)) + (if (featurep 'emacs) "M-" 'meta) + (if (featurep 'emacs) "" nil)) shift-spec (if (memq 'shift key) - (if viper-emacs-p "S-" 'shift) - (if viper-emacs-p "" nil)) + (if (featurep 'emacs) "S-" 'shift) + (if (featurep 'emacs) "" nil)) control-spec (if (memq 'control key) - (if viper-emacs-p "C-" 'control) - (if viper-emacs-p "" nil))) + (if (featurep 'emacs) "C-" 'control) + (if (featurep 'emacs) "" nil))) - (setq key-spec (if viper-emacs-p + (setq key-spec (if (featurep 'emacs) (vector (intern (concat diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index 7073cd019dd..c757eb63aef 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -64,48 +64,34 @@ (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p))) -;;; XEmacs support - - -(viper-cond-compile-for-xemacs-or-emacs - (progn ; xemacs - (fset 'viper-overlay-p (symbol-function 'extentp)) - (fset 'viper-make-overlay (symbol-function 'make-extent)) - (fset 'viper-overlay-live-p (symbol-function 'extent-live-p)) - (fset 'viper-move-overlay (symbol-function 'set-extent-endpoints)) - (fset 'viper-overlay-start (symbol-function 'extent-start-position)) - (fset 'viper-overlay-end (symbol-function 'extent-end-position)) - (fset 'viper-overlay-get (symbol-function 'extent-property)) - (fset 'viper-overlay-put (symbol-function 'set-extent-property)) - (fset 'viper-read-event (symbol-function 'next-command-event)) - (fset 'viper-characterp (symbol-function 'characterp)) - (fset 'viper-int-to-char (symbol-function 'int-to-char)) - (if (viper-window-display-p) - (fset 'viper-iconify (symbol-function 'iconify-frame))) - (cond ((viper-has-face-support-p) - (fset 'viper-get-face (symbol-function 'get-face)) - (fset 'viper-color-defined-p (symbol-function 'valid-color-name-p)) - ))) - (progn ; emacs - (fset 'viper-overlay-p (symbol-function 'overlayp)) - (fset 'viper-make-overlay (symbol-function 'make-overlay)) - (fset 'viper-overlay-live-p (symbol-function 'overlayp)) - (fset 'viper-move-overlay (symbol-function 'move-overlay)) - (fset 'viper-overlay-start (symbol-function 'overlay-start)) - (fset 'viper-overlay-end (symbol-function 'overlay-end)) - (fset 'viper-overlay-get (symbol-function 'overlay-get)) - (fset 'viper-overlay-put (symbol-function 'overlay-put)) - (fset 'viper-read-event (symbol-function 'read-event)) - (fset 'viper-characterp (symbol-function 'integerp)) - (fset 'viper-int-to-char (symbol-function 'identity)) - (if (viper-window-display-p) - (fset 'viper-iconify (symbol-function 'iconify-or-deiconify-frame))) - (cond ((viper-has-face-support-p) - (fset 'viper-get-face (symbol-function 'internal-get-face)) - (fset 'viper-color-defined-p (symbol-function 'x-color-defined-p)) - ))) - ) - +(defalias 'viper-overlay-p + (if (featurep 'xemacs) 'extentp 'overlayp)) +(defalias 'viper-make-overlay + (if (featurep 'xemacs) 'make-extent 'make-overlay)) +(defalias 'viper-overlay-live-p + (if (featurep 'xemacs) 'extent-live-p 'overlayp)) +(defalias 'viper-move-overlay + (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay)) +(defalias 'viper-overlay-start + (if (featurep 'xemacs) 'extent-start-position 'overlay-start)) +(defalias 'viper-overlay-end + (if (featurep 'xemacs) 'extent-end-position 'overlay-end)) +(defalias 'viper-overlay-get + (if (featurep 'xemacs) 'extent-property 'overlay-get)) +(defalias 'viper-overlay-put + (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) +(defalias 'viper-read-event + (if (featurep 'xemacs) 'next-command-event 'read-event)) +(defalias 'viper-characterp + (if (featurep 'xemacs) 'characterp 'integerp)) +(defalias 'viper-int-to-char + (if (featurep 'xemacs) 'int-to-char 'identity)) +(defalias 'viper-get-face + (if (featurep 'xemacs) 'get-face 'internal-get-face)) +(defalias 'viper-color-defined-p + (if (featurep 'xemacs) 'valid-color-name-p 'x-color-defined-p)) +(defalias 'viper-iconify + (if (featurep 'xemacs) 'iconify-frame 'iconify-or-deiconify-frame)) ;; CHAR is supposed to be a char or an integer (positive or negative) @@ -201,7 +187,7 @@ (defsubst viper-get-saved-cursor-color-in-replace-mode () (or (funcall - (if viper-emacs-p 'frame-parameter 'frame-property) + (if (featurep 'emacs) 'frame-parameter 'frame-property) (selected-frame) 'viper-saved-cursor-color-in-replace-mode) (if (and (eq viper-current-state 'emacs-mode) viper-emacs-state-cursor-color) @@ -211,7 +197,7 @@ (defsubst viper-get-saved-cursor-color-in-insert-mode () (or (funcall - (if viper-emacs-p 'frame-parameter 'frame-property) + (if (featurep 'emacs) 'frame-parameter 'frame-property) (selected-frame) 'viper-saved-cursor-color-in-insert-mode) (if (and (eq viper-current-state 'emacs-mode) viper-emacs-state-cursor-color) @@ -221,7 +207,7 @@ (defsubst viper-get-saved-cursor-color-in-emacs-mode () (or (funcall - (if viper-emacs-p 'frame-parameter 'frame-property) + (if (featurep 'emacs) 'frame-parameter 'frame-property) (selected-frame) 'viper-saved-cursor-color-in-emacs-mode) viper-vi-state-cursor-color)) @@ -249,8 +235,8 @@ ;; testing for sufficiently high Emacs versions. (defun viper-check-version (op major minor &optional type-of-emacs) (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) - (and (cond ((eq type-of-emacs 'xemacs) viper-xemacs-p) - ((eq type-of-emacs 'emacs) viper-emacs-p) + (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs)) + ((eq type-of-emacs 'emacs) (featurep 'emacs)) (t t)) (cond ((eq op '=) (and (= emacs-minor-version minor) (= emacs-major-version major))) @@ -267,7 +253,7 @@ (defun viper-get-visible-buffer-window (wind) - (if viper-xemacs-p + (if (featurep 'xemacs) (get-buffer-window wind t) (get-buffer-window wind 'visible))) @@ -724,13 +710,14 @@ (defsubst viper-file-checked-in-p (file) (and (featurep 'vc-hooks) ;; CVS files are considered not checked in + ;; FIXME: Should this deal with more than CVS? (not (memq (vc-backend file) '(nil CVS))) (if (fboundp 'vc-state) (and (not (memq (vc-state file) '(edited needs-merge))) (not (stringp (vc-state file)))) ;; XEmacs has no vc-state - (not (vc-locking-user file))) + (if (featurep 'xemacs)(not (vc-locking-user file)))) )) ;; checkout if visited file is checked in @@ -787,7 +774,7 @@ (setq viper-replace-overlay (viper-make-overlay beg end (current-buffer))) ;; never detach (viper-overlay-put - viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil) + viper-replace-overlay (if (featurep 'emacs) 'evaporate 'detachable) nil) (viper-overlay-put viper-replace-overlay 'priority viper-replace-overlay-priority) ;; If Emacs will start supporting overlay maps, as it currently supports @@ -795,7 +782,7 @@ ;; just have keymap attached to replace overlay. ;;(viper-overlay-put ;; viper-replace-overlay - ;; (if viper-xemacs-p 'keymap 'local-map) + ;; (if (featurep 'xemacs) 'keymap 'local-map) ;; viper-replace-map) ) (if (viper-has-face-support-p) @@ -811,8 +798,8 @@ (viper-set-replace-overlay (point-min) (point-min))) (if (or (not (viper-has-face-support-p)) viper-use-replace-region-delimiters) - (let ((before-name (if viper-xemacs-p 'begin-glyph 'before-string)) - (after-name (if viper-xemacs-p 'end-glyph 'after-string))) + (let ((before-name (if (featurep 'xemacs) 'begin-glyph 'before-string)) + (after-name (if (featurep 'xemacs) 'end-glyph 'after-string))) (viper-overlay-put viper-replace-overlay before-name before-glyph) (viper-overlay-put viper-replace-overlay after-name after-glyph)))) @@ -843,11 +830,11 @@ ;; never detach (viper-overlay-put viper-minibuffer-overlay - (if viper-emacs-p 'evaporate 'detachable) + (if (featurep 'emacs) 'evaporate 'detachable) nil) ;; make viper-minibuffer-overlay open-ended ;; In emacs, it is made open ended at creation time - (if viper-xemacs-p + (if (featurep 'xemacs) (progn (viper-overlay-put viper-minibuffer-overlay 'start-open nil) (viper-overlay-put viper-minibuffer-overlay 'end-open nil))) @@ -860,7 +847,7 @@ (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) 1) (1+ (buffer-size))) (setq viper-minibuffer-overlay - (if viper-xemacs-p + (if (featurep 'xemacs) (viper-make-overlay 1 (1+ (buffer-size)) (current-buffer)) ;; make overlay open-ended (viper-make-overlay @@ -983,7 +970,7 @@ (defun viper-read-key-sequence (prompt &optional continue-echo) (let (inhibit-quit event keyseq) (setq keyseq (read-key-sequence prompt continue-echo)) - (setq event (if viper-xemacs-p + (setq event (if (featurep 'xemacs) (elt keyseq 0) ; XEmacs returns vector of events (elt (listify-key-sequence keyseq) 0))) (if (viper-ESC-event-p event) @@ -1078,7 +1065,7 @@ (defun viper-key-to-emacs-key (key) (let (key-name char-p modifiers mod-char-list base-key base-key-name) - (cond (viper-xemacs-p key) + (cond ((featurep 'xemacs) key) ((symbolp key) (setq key-name (symbol-name key)) @@ -1086,10 +1073,10 @@ (string-to-char key-name)) ;; Emacs doesn't recognize `return' and `escape' as events on ;; dumb terminals, so we translate them into characters - ((and viper-emacs-p (not (viper-window-display-p)) + ((and (featurep 'emacs) (not (viper-window-display-p)) (string= key-name "return")) ?\C-m) - ((and viper-emacs-p (not (viper-window-display-p)) + ((and (featurep 'emacs) (not (viper-window-display-p)) (string= key-name "escape")) ?\e) ;; pass symbol-event as is @@ -1123,14 +1110,15 @@ ;; LIS is assumed to be a list of events of characters (defun viper-eventify-list-xemacs (lis) - (mapcar - (lambda (elt) - (cond ((viper-characterp elt) (character-to-event elt)) - ((eventp elt) elt) - (t (error - "viper-eventify-list-xemacs: can't convert to event, %S" - elt)))) - lis)) + (if (featurep 'xemacs) + (mapcar + (lambda (elt) + (cond ((viper-characterp elt) (character-to-event elt)) + ((eventp elt) elt) + (t (error + "viper-eventify-list-xemacs: can't convert to event, %S" + elt)))) + lis))) ;; Smoothes out the difference between Emacs' unread-command-events @@ -1142,7 +1130,7 @@ ;; into an event. Below, we delete nil from event lists, since nil is the most ;; common symbol that might appear in this wrong context. (defun viper-set-unread-command-events (arg) - (if viper-emacs-p + (if (featurep 'emacs) (setq unread-command-events (let ((new-events diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index c0118250167..65d40e8bad7 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -690,7 +690,7 @@ It also can't undo some Viper settings." (setq default-major-mode (viper-standard-value 'default-major-mode viper-saved-non-viper-variables)) - (if viper-emacs-p + (if (featurep 'emacs) (setq-default mark-even-if-inactive (viper-standard-value @@ -701,7 +701,7 @@ It also can't undo some Viper settings." (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) (viper-delocalize-var 'minor-mode-map-alist)) (viper-delocalize-var 'require-final-newline) - (if viper-xemacs-p (viper-delocalize-var 'bar-cursor)) + (if (featurep 'xemacs) (viper-delocalize-var 'bar-cursor)) ;; deactivate all advices done by Viper. @@ -788,7 +788,7 @@ It also can't undo some Viper settings." ;; In emacs, we have to advice handle-switch-frame ;; This advice is undone earlier, when all advices matchine "viper-" are ;; deactivated. - (if viper-xemacs-p + (if (featurep 'xemacs) (remove-hook 'mouse-leave-frame-hook 'viper-remember-current-frame)) ) ; end viper-go-away @@ -981,7 +981,7 @@ It also can't undo some Viper settings." ))) ;; International input methods - (if viper-emacs-p + (if (featurep 'emacs) (eval-after-load "mule-cmds" '(progn (defadvice inactivate-input-method (after viper-mule-advice activate) @@ -1022,7 +1022,7 @@ It also can't undo some Viper settings." require-final-newline t) ;; don't bark when mark is inactive - (if viper-emacs-p + (if (featurep 'emacs) (setq mark-even-if-inactive t)) (setq scroll-step 1) @@ -1094,12 +1094,12 @@ It also can't undo some Viper settings." "Use `read-file-name' for reading arguments." (interactive (cons (read-file-name "Find file: " nil default-directory) ;; XEmacs: if Mule & prefix arg, ask for coding system - (cond ((and viper-xemacs-p (featurep 'mule)) + (cond ((and (featurep 'xemacs) (featurep 'mule)) (list (and current-prefix-arg (read-coding-system "Coding-system: ")))) ;; Emacs: do wildcards - ((and viper-emacs-p (boundp 'find-file-wildcards)) + ((and (featurep 'emacs) (boundp 'find-file-wildcards)) (list find-file-wildcards)))) )) @@ -1108,12 +1108,12 @@ It also can't undo some Viper settings." (interactive (cons (read-file-name "Find file in other window: " nil default-directory) ;; XEmacs: if Mule & prefix arg, ask for coding system - (cond ((and viper-xemacs-p (featurep 'mule)) + (cond ((and (featurep 'xemacs) (featurep 'mule)) (list (and current-prefix-arg (read-coding-system "Coding-system: ")))) ;; Emacs: do wildcards - ((and viper-emacs-p (boundp 'find-file-wildcards)) + ((and (featurep 'emacs) (boundp 'find-file-wildcards)) (list find-file-wildcards)))) )) @@ -1123,12 +1123,12 @@ It also can't undo some Viper settings." (interactive (cons (read-file-name "Find file in other frame: " nil default-directory) ;; XEmacs: if Mule & prefix arg, ask for coding system - (cond ((and viper-xemacs-p (featurep 'mule)) + (cond ((and (featurep 'xemacs) (featurep 'mule)) (list (and current-prefix-arg (read-coding-system "Coding-system: ")))) ;; Emacs: do wildcards - ((and viper-emacs-p (boundp 'find-file-wildcards)) + ((and (featurep 'emacs) (boundp 'find-file-wildcards)) (list find-file-wildcards)))) )) @@ -1159,7 +1159,7 @@ It also can't undo some Viper settings." ;; catch frame switching event (if (viper-window-display-p) - (if viper-xemacs-p + (if (featurep 'xemacs) (add-hook 'mouse-leave-frame-hook 'viper-remember-current-frame) (defadvice handle-switch-frame (before viper-frame-advice activate) @@ -1227,7 +1227,7 @@ These two lines must come in the order given. (cons 'mode-line-buffer-identification (list (default-value 'mode-line-buffer-identification))) (cons 'global-mode-string (list global-mode-string)) - (if viper-emacs-p + (if (featurep 'emacs) (cons 'mark-even-if-inactive (list mark-even-if-inactive))) ))) diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog index 09882be34b8..929df097790 100644 --- a/lisp/erc/ChangeLog +++ b/lisp/erc/ChangeLog @@ -1,3 +1,22 @@ +2007-11-01 Michael Olson <mwolson@gnu.org> + + * erc-compat.el (erc-set-write-file-functions): New compatibility + function to set the write hooks appropriately. + + * erc-log.el (erc-log-setup-logging): Use + erc-set-write-file-functions. This fixes a byte-compiler warning. + + * erc-stamp.el: Silence byte-compiler warning about + erc-fill-column. + + * erc.el (erc-with-all-buffers-of-server): Bind the result of + mapcar to a variable in order to silence a byte-compiler warning. + +2007-10-29 Michael Olson <mwolson@gnu.org> + + * erc-ibuffer.el (erc-modified-channels-alist): Use + eval-when-compile, and explain why we are doing this. + 2007-10-25 Dan Nicolaescu <dann@ics.uci.edu> * erc-ibuffer.el (erc-modified-channels-alist): Pacify @@ -8,7 +27,27 @@ * erc-track.el (erc-modified-channels-update): Use mapc rather than mapcar. -2007-09-18 Exal de Jesus Garcia Carrillo <exal@gmx.de> (tiny change) +2007-10-12 Diane Murray <disumu@x3y2z1.net> + + * erc.el (erc-join-channel): Prompt for channel key if C-u or + another prefix-arg was typed. + + * NEWS: Noted this change. + +2007-10-07 Michael Olson <mwolson@gnu.org> + + * erc.el (erc-cmd-ME'S): New command that handles the case where + someone types "/me's". It concatenates the text " 's" to the + beginning of the input and then sends the result like a normal + "/me" command. + (erc-command-regexp): Permit single-quote character. + +2007-09-30 Aidan Kehoe <kehoea@parhasard.net> (tiny change) + + * erc-log.el (erc-save-buffer-in-logs): Prevent spurious warnings + when looking at a log file and concurrently saving to it. + +2007-09-18 Exal de Jesus Garcia Carrillo <exal@gnu.org> (tiny change) * erc.texi (Special-Features): Fix small typo. diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 47bdd94ade2..d6591415867 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -50,6 +50,9 @@ See `erc-encoding-coding-alist'." (defalias 'erc-delete-dups 'delete-dups) (defalias 'erc-replace-regexp-in-string 'replace-regexp-in-string) +(defun erc-set-write-file-functions (new-val) + (set (make-local-variable 'write-file-functions) new-val)) + (defvar erc-emacs-build-time (if (stringp emacs-build-time) emacs-build-time diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el index e4de3c1fe50..76c2d2b18b1 100644 --- a/lisp/erc/erc-ibuffer.el +++ b/lisp/erc/erc-ibuffer.el @@ -71,7 +71,9 @@ (string-match qualifier (or erc-server-announced-name erc-session-server))))) -(defvar erc-modified-channels-alist) +;; Silence the byte-compiler +(eval-when-compile + (defvar erc-modified-channels-alist)) (define-ibuffer-column erc-modified (:name "M") (if (and (boundp 'erc-track-mode) diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 1733b3d1b00..8b5e07a383e 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -268,14 +268,7 @@ The current buffer is given by BUFFER." (with-current-buffer buffer (auto-save-mode -1) (setq buffer-file-name nil) - (cond ((boundp 'write-file-functions) - (set (make-local-variable 'write-file-functions) - '(erc-save-buffer-in-logs))) - ((boundp 'local-write-file-hooks) - (setq local-write-file-hooks '(erc-save-buffer-in-logs))) - (t - (set (make-local-variable 'write-file-hooks) - '(erc-save-buffer-in-logs)))) + (erc-set-write-file-functions '(erc-save-buffer-in-logs)) (when erc-log-insert-log-on-open (ignore-errors (insert-file-contents (erc-current-logfile)) (move-marker erc-last-saved-position @@ -415,7 +408,8 @@ You can save every individual message by putting this function on (or buffer (setq buffer (current-buffer))) (when (erc-logging-enabled buffer) (let ((file (erc-current-logfile buffer)) - (coding-system erc-log-file-coding-system)) + (coding-system erc-log-file-coding-system) + (inhibit-clash-detection t)) ; needed for XEmacs (save-excursion (with-current-buffer buffer (save-restriction diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 3b7f5ba18f2..64b04051d91 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -264,6 +264,10 @@ property to get to the POSth column." (list 'space ':align-to pos))) (insert string)) +;; Silence byte-compiler +(eval-when-compile + (defvar erc-fill-column)) + (defun erc-insert-timestamp-right (string) "Insert timestamp on the right side of the screen. STRING is the timestamp to insert. The function is a possible value diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 2c5786adff3..fab8f7ca1b9 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1680,13 +1680,16 @@ nil." ;; Make the evaluation have the correct order (let ((pre (make-symbol "pre")) (pro (make-symbol "pro"))) - `(let ((,pro ,process) - (,pre ,pred)) - (mapcar (lambda (buffer) - (with-current-buffer buffer - ,@forms)) - (erc-buffer-list ,pre - ,pro))))) + `(let* ((,pro ,process) + (,pre ,pred) + (res (mapcar (lambda (buffer) + (with-current-buffer buffer + ,@forms)) + (erc-buffer-list ,pre + ,pro)))) + ;; Silence the byte-compiler by binding the result of mapcar to + ;; a variable. + res))) (put 'erc-with-all-buffers-of-server 'lisp-indent-function 1) (put 'erc-with-all-buffers-of-server 'edebug-form-spec '(form form body)) @@ -3014,6 +3017,11 @@ LINE has the format \"USER ACTION\"." (t nil))) (put 'erc-cmd-ME 'do-not-parse-args t) +(defun erc-cmd-ME\'S (line) + "Do a /ME command, but add the string \" 's\" to the beginning." + (erc-cmd-ME (concat " 's" line))) +(put 'erc-cmd-ME\'S 'do-not-parse-args t) + (defun erc-cmd-LASTLOG (line) "Show all lines in the current buffer matching the regexp LINE. @@ -3669,7 +3677,7 @@ If `point' is at the beginning of a channel name, use that as default." (set-buffer (process-buffer erc-server-process)) erc-channel-list))) (completing-read "Join channel: " table nil nil nil nil chnl)) - (when erc-prompt-for-channel-key + (when (or current-prefix-arg erc-prompt-for-channel-key) (read-from-minibuffer "Channel key (RET for none): " nil)))) (erc-cmd-JOIN channel (when (>= (length key) 1) key))) @@ -5033,7 +5041,7 @@ Specifically, return the position of `erc-insert-marker'." erc-input-marker (erc-end-of-input-line))) -(defvar erc-command-regexp "^/\\([A-Za-z]+\\)\\(\\s-+.*\\|\\s-*\\)$" +(defvar erc-command-regexp "^/\\([A-Za-z']+\\)\\(\\s-+.*\\|\\s-*\\)$" "Regular expression used for matching commands in ERC.") (defun erc-send-input (input) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 0000cae5adf..02556661b1b 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -319,7 +319,7 @@ in the minibuffer: (before translate-multiple-dots (filename &optional directory) activate) (setq filename (eshell-expand-multiple-dots filename)))" - (while (string-match "\\.\\.\\(\\.+\\)" path) + (while (string-match "\\(?:^\\|/\\)\\.\\.\\(\\.+\\)\\(?:$\\|/\\)" path) (let* ((extra-dots (match-string 1 path)) (len (length extra-dots)) replace-text) diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 5d68fdf9437..2e95aaefae0 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -258,7 +258,7 @@ the form: (eshell-glob-entries (file-name-as-directory ".") paths)) (if message-shown (message nil))) - (or (and matches (nreverse matches)) + (or (and matches (sort matches #'string<)) (if eshell-error-if-no-glob (error "No matches found: %s" glob) glob)))) @@ -267,6 +267,7 @@ the form: (defvar matches) (defvar message-shown)) +;; FIXME does this really need to abuse matches, message-shown? (defun eshell-glob-entries (path globs &optional recurse-p) "Glob the entries in PATHS, possibly recursing if RECURSE-P is non-nil." (let* ((entries (ignore-errors diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 0a8c8be697f..8b7338f8833 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -778,38 +778,36 @@ This is done after all necessary filtering has been done." (setq string (funcall (car functions) string)) (setq functions (cdr functions)))) (if (and string oprocbuf (buffer-name oprocbuf)) - (let ((obuf (current-buffer)) - opoint obeg oend) - (set-buffer oprocbuf) - (setq opoint (point)) - (setq obeg (point-min)) - (setq oend (point-max)) - (let ((buffer-read-only nil) - (nchars (length string)) - (ostart nil)) - (widen) - (goto-char eshell-last-output-end) - (setq ostart (point)) - (if (<= (point) opoint) - (setq opoint (+ opoint nchars))) - (if (< (point) obeg) - (setq obeg (+ obeg nchars))) - (if (<= (point) oend) - (setq oend (+ oend nchars))) - (insert-before-markers string) - (if (= (window-start (selected-window)) (point)) - (set-window-start (selected-window) - (- (point) nchars))) - (if (= (point) eshell-last-input-end) - (set-marker eshell-last-input-end - (- eshell-last-input-end nchars))) - (set-marker eshell-last-output-start ostart) - (set-marker eshell-last-output-end (point)) - (force-mode-line-update)) - (narrow-to-region obeg oend) - (goto-char opoint) - (eshell-run-output-filters) - (set-buffer obuf))))) + (let (opoint obeg oend) + (with-current-buffer oprocbuf + (setq opoint (point)) + (setq obeg (point-min)) + (setq oend (point-max)) + (let ((buffer-read-only nil) + (nchars (length string)) + (ostart nil)) + (widen) + (goto-char eshell-last-output-end) + (setq ostart (point)) + (if (<= (point) opoint) + (setq opoint (+ opoint nchars))) + (if (< (point) obeg) + (setq obeg (+ obeg nchars))) + (if (<= (point) oend) + (setq oend (+ oend nchars))) + (insert-before-markers string) + (if (= (window-start (selected-window)) (point)) + (set-window-start (selected-window) + (- (point) nchars))) + (if (= (point) eshell-last-input-end) + (set-marker eshell-last-input-end + (- eshell-last-input-end nchars))) + (set-marker eshell-last-output-start ostart) + (set-marker eshell-last-output-end (point)) + (force-mode-line-update)) + (narrow-to-region obeg oend) + (goto-char opoint) + (eshell-run-output-filters)))))) (defun eshell-run-output-filters () "Run the `eshell-output-filter-functions' on the current output." diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index fb226cf51fb..7338756e3f8 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -335,39 +335,39 @@ Used only on systems which do not support async subprocesses.") PROC is the process for which we're inserting output. STRING is the output." (when (buffer-live-p (process-buffer proc)) - (set-buffer (process-buffer proc)) - (let ((entry (assq proc eshell-process-list))) - (when entry - (setcar (nthcdr 3 entry) - (concat (nth 3 entry) string)) - (unless (nth 4 entry) ; already being handled? - (while (nth 3 entry) - (let ((data (nth 3 entry))) - (setcar (nthcdr 3 entry) nil) - (setcar (nthcdr 4 entry) t) - (eshell-output-object data nil (cadr entry)) - (setcar (nthcdr 4 entry) nil)))))))) + (with-current-buffer (process-buffer proc) + (let ((entry (assq proc eshell-process-list))) + (when entry + (setcar (nthcdr 3 entry) + (concat (nth 3 entry) string)) + (unless (nth 4 entry) ; already being handled? + (while (nth 3 entry) + (let ((data (nth 3 entry))) + (setcar (nthcdr 3 entry) nil) + (setcar (nthcdr 4 entry) t) + (eshell-output-object data nil (cadr entry)) + (setcar (nthcdr 4 entry) nil))))))))) (defun eshell-sentinel (proc string) "Generic sentinel for command processes. Reports only signals. PROC is the process that's exiting. STRING is the exit message." (when (buffer-live-p (process-buffer proc)) - (set-buffer (process-buffer proc)) - (unwind-protect - (let* ((entry (assq proc eshell-process-list))) -; (if (not entry) -; (error "Sentinel called for unowned process `%s'" -; (process-name proc)) - (when entry - (unwind-protect - (progn - (unless (string= string "run") - (unless (string-match "^\\(finished\\|exited\\)" string) - (eshell-insertion-filter proc string)) - (eshell-close-handles (process-exit-status proc) 'nil - (cadr entry)))) - (eshell-remove-process-entry entry)))) - (run-hook-with-args 'eshell-kill-hook proc string)))) + (with-current-buffer (process-buffer proc) + (unwind-protect + (let* ((entry (assq proc eshell-process-list))) +; (if (not entry) +; (error "Sentinel called for unowned process `%s'" +; (process-name proc)) + (when entry + (unwind-protect + (progn + (unless (string= string "run") + (unless (string-match "^\\(finished\\|exited\\)" string) + (eshell-insertion-filter proc string)) + (eshell-close-handles (process-exit-status proc) 'nil + (cadr entry)))) + (eshell-remove-process-entry entry)))) + (run-hook-with-args 'eshell-kill-hook proc string))))) (defun eshell-process-interact (func &optional all query) "Interact with a process, using PROMPT if more than one, via FUNC. diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 26a0231bf1a..968a115c5d1 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -516,7 +516,7 @@ argument BUFFER-NAME is nil, it defaults to *Colors*." (let ((lc (nthcdr (1- (display-color-cells)) list))) (if lc (setcdr lc nil))))) - (with-output-to-temp-buffer (or buffer-name "*Colors*") + (with-help-window (or buffer-name "*Colors*") (save-excursion (set-buffer standard-output) (setq truncate-lines t) diff --git a/lisp/faces.el b/lisp/faces.el index 1ced221692d..99285f9ad53 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1264,7 +1264,7 @@ arg, prompt for a regular expression." (error "No faces matching \"%s\"" regexp)) (setq max-length (1+ max-length) line-format (format "%%-%ds" max-length)) - (with-output-to-temp-buffer "*Faces*" + (with-help-window "*Faces*" (save-excursion (set-buffer standard-output) (setq truncate-lines t) @@ -1305,8 +1305,7 @@ arg, prompt for a regular expression." (while (not (eobp)) (insert-char ?\s max-length) (forward-line 1)))) - (goto-char (point-min))) - (print-help-return-message)) + (goto-char (point-min)))) ;; If the *Faces* buffer appears in a different frame, ;; copy all the face definitions from FRAME, ;; so that the display will reflect the frame that was selected. @@ -1352,7 +1351,7 @@ If FRAME is omitted or nil, use the selected frame." (setq face 'default)) (if (not (listp face)) (setq face (list face))) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (save-excursion (set-buffer standard-output) (dolist (f face) @@ -1399,8 +1398,7 @@ If FRAME is omitted or nil, use the selected frame." (re-search-backward ": \\([^:]+\\)" nil t) (help-xref-button 1 'help-face attr))) (insert "\n"))))) - (terpri))) - (print-help-return-message)))) + (terpri)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1543,6 +1541,12 @@ See `defface' for information about SPEC. If SPEC is nil, do nothing." ;; When we reset the face based on its spec, then it is unmodified ;; as far as Custom is concerned. (put (or (get face 'face-alias) face) 'face-modified nil) +;;; ;; Clear all the new-frame defaults for this face. +;;; ;; face-spec-reset-face won't do it right. +;;; (let ((facevec (cdr (assq face face-new-frame-defaults)))) +;;; (dotimes (i (length facevec)) +;;; (unless (= i 0) +;;; (aset facevec i 'unspecified)))) ;; Set each frame according to the rules implied by SPEC. (dolist (frame (frame-list)) (face-spec-set face spec frame)))) @@ -1583,28 +1587,6 @@ If there is neither a user setting nor a default for FACE, return nil." (get face 'saved-face) (face-default-spec face))) -(defsubst face-normalize-spec (spec) - "Return a normalized face-spec of SPEC." - (let (normalized-spec) - (while spec - (let ((attribute (car spec)) - (value (car (cdr spec)))) - ;; Support some old-style attribute names and values. - (case attribute - (:bold (setq attribute :weight value (if value 'bold 'normal))) - (:italic (setq attribute :slant value (if value 'italic 'normal))) - ((:foreground :background) - ;; Compatibility with 20.x. Some bogus face specs seem to - ;; exist containing things like `:foreground nil'. - (if (null value) (setq value 'unspecified))) - (t (unless (assq attribute face-x-resources) - (setq attribute nil)))) - (when attribute - (push attribute normalized-spec) - (push value normalized-spec))) - (setq spec (cdr (cdr spec)))) - (nreverse normalized-spec))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Frame-type independent color support. @@ -1669,6 +1651,140 @@ If omitted or nil, that stands for the selected frame's display." (t (> (tty-color-gray-shades display) 2))))) +(defun read-color (&optional prompt convert-to-RGB-p allow-empty-name-p msg-p) + "Read a color name or RGB hex value: #RRRRGGGGBBBB. +Completion is available for color names, but not for RGB hex strings. +If the user inputs an RGB hex string, it must have the form +#XXXXXXXXXXXX or XXXXXXXXXXXX, where each X is a hex digit. The +number of Xs must be a multiple of 3, with the same number of Xs for +each of red, green, and blue. The order is red, green, blue. + +In addition to standard color names and RGB hex values, the following +are available as color candidates. In each case, the corresponding +color is used. + + * `foreground at point' - foreground under the cursor + * `background at point' - background under the cursor + +Checks input to be sure it represents a valid color. If not, raises +an error (but see exception for empty input with non-nil +ALLOW-EMPTY-NAME-P). + +Optional arg PROMPT is the prompt; if nil, uses a default prompt. + +Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts +an input color name to an RGB hex string. Returns the RGB hex string. + +Optional arg ALLOW-EMPTY-NAME-P controls what happens if the user +enters an empty color name (that is, just hits `RET'). If non-nil, +then returns an empty color name, \"\". If nil, then raises an error. +Programs must test for \"\" if ALLOW-EMPTY-NAME-P is non-nil. They +can then perform an appropriate action in case of empty input. + +Interactively, or with optional arg MSG-P non-nil, echoes the color in +a message." + (interactive "i\np\ni\np") ; Always convert to RGB interactively. + (let* ((completion-ignore-case t) + (colors (append '("foreground at point" "background at point") + (defined-colors))) + (color (completing-read (or prompt "Color (name or #R+G+B+): ") + colors)) + hex-string) + (cond ((string= "foreground at point" color) + (setq color (foreground-color-at-point))) + ((string= "background at point" color) + (setq color (background-color-at-point)))) + (unless color + (setq color "")) + (setq hex-string + (string-match "^#?\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)) + (if (and allow-empty-name-p (string= "" color)) + "" + (when (and hex-string (not (eq (aref color 0) ?#))) + (setq color (concat "#" color))) ; No #; add it. + (unless hex-string + (when (or (string= "" color) (not (test-completion color colors))) + (error "No such color: %S" color)) + (when convert-to-RGB-p + (let ((components (x-color-values color))) + (unless components (error "No such color: %S" color)) + (unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color) + (setq color (format "#%04X%04X%04X" + (logand 65535 (nth 0 components)) + (logand 65535 (nth 1 components)) + (logand 65535 (nth 2 components)))))))) + (when msg-p (message "Color: `%s'" color)) + color))) + +;; Commented out because I decided it is better to include the +;; duplicates in read-color's completion list. + +;; (defun defined-colors-without-duplicates () +;; "Return the list of defined colors, without the no-space versions. +;; For each color name, we keep the variant that DOES have spaces." +;; (let ((result (copy-sequence (defined-colors))) +;; to-be-rejected) +;; (save-match-data +;; (dolist (this result) +;; (if (string-match " " this) +;; (push (replace-regexp-in-string " " "" +;; this) +;; to-be-rejected))) +;; (dolist (elt to-be-rejected) +;; (let ((as-found (car (member-ignore-case elt result)))) +;; (setq result (delete as-found result))))) +;; result)) + +(defun face-at-point () + "Return the face of the character after point. +If it has more than one face, return the first one. +Return nil if it has no specified face." + (let* ((faceprop (or (get-char-property (point) 'read-face-name) + (get-char-property (point) 'face) + 'default)) + (face (cond ((symbolp faceprop) faceprop) + ;; List of faces (don't treat an attribute spec). + ;; Just use the first face. + ((and (consp faceprop) (not (keywordp (car faceprop))) + (not (memq (car faceprop) + '(foreground-color background-color)))) + (car faceprop)) + (t nil)))) ; Invalid face value. + (if (facep face) face nil))) + +(defun foreground-color-at-point () + "Return the foreground color of the character after point." + ;; `face-at-point' alone is not sufficient. It only gets named faces. + ;; Need also pick up any face properties that are not associated with named faces. + (let ((face (or (face-at-point) + (get-char-property (point) 'read-face-name) + (get-char-property (point) 'face)))) + (cond ((and face (symbolp face)) + (let ((value (face-foreground face nil 'default))) + (if (member value '("unspecified-fg" "unspecified-bg")) + nil + value))) + ((consp face) + (cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face))) + ((memq ':foreground face) (cadr (memq ':foreground face))))) + (t nil)))) ; Invalid face value. + +(defun background-color-at-point () + "Return the background color of the character after point." + ;; `face-at-point' alone is not sufficient. It only gets named faces. + ;; Need also pick up any face properties that are not associated with named faces. + (let ((face (or (face-at-point) + (get-char-property (point) 'read-face-name) + (get-char-property (point) 'face)))) + (cond ((and face (symbolp face)) + (let ((value (face-background face nil 'default))) + (if (member value '("unspecified-fg" "unspecified-bg")) + nil + value))) + ((consp face) + (cond ((memq 'background-color face) (cdr (memq 'background-color face))) + ((memq ':background face) (cadr (memq ':background face))))) + (t nil)))) ; Invalid face value. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Background mode. @@ -1752,8 +1868,7 @@ according to the `background-mode' and `display-type' frame parameters." ;; be unmodified, so we can avoid consing in the common case. (dolist (face (face-list)) (when (not (face-spec-match-p face - (face-normalize-spec - (face-user-default-spec face)) + (face-user-default-spec face) (selected-frame))) (push face locally-modified-faces))) ;; Now change to the new frame parameters @@ -1836,11 +1951,6 @@ Value is the new frame created." (x-handle-reverse-video frame parameters) (frame-set-background-mode frame) (face-set-after-frame-default frame) - ;; Arrange for the kill and yank functions to set and check the clipboard. - (modify-frame-parameters - frame '((interprogram-cut-function . x-select-text))) - (modify-frame-parameters - frame '((interprogram-paste-function . x-cut-buffer-or-selection-value))) ;; Make sure the tool-bar is ready to be enabled. The ;; `tool-bar-lines' frame parameter will not take effect ;; without this call. @@ -1943,10 +2053,6 @@ created." (with-selected-frame frame (tty-handle-reverse-video frame (frame-parameters frame)) - ;; Make sure the kill and yank functions do not touch the X clipboard. - (modify-frame-parameters frame '((interprogram-cut-function . nil))) - (modify-frame-parameters frame '((interprogram-paste-function . nil))) - (unless (terminal-parameter frame 'terminal-initted) (set-terminal-parameter frame 'terminal-initted t) (set-locale-environment nil frame) diff --git a/lisp/files.el b/lisp/files.el index 6b0bd26efe8..a7dd79b8a88 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -450,7 +450,7 @@ use `before-save-hook'.") (defcustom enable-local-variables t "Control use of local variables in files you visit. -The value can be t, nil, :safe, or something else. +The value can be t, nil, :safe, :all, or something else. A value of t means file local variables specifications are obeyed if all the specified variable values are safe; if any values are @@ -1964,6 +1964,7 @@ since only a single case-insensitive search through the alist is made." ("\\.ins\\'" . tex-mode) ;Installation files for TeX packages. ("\\.ltx\\'" . latex-mode) ("\\.dtx\\'" . doctex-mode) + ("\\.org\\'" . org-mode) ("\\.el\\'" . emacs-lisp-mode) ("\\.\\(scm\\|stk\\|ss\\|sch\\)\\'" . scheme-mode) ("\\.l\\'" . lisp-mode) @@ -2821,8 +2822,8 @@ is specified, returning t if it is specified." ;; If caller wants only the safe variables, ;; install only them. (dolist (elt result) - (unless (or (memq (car elt) unsafe-vars) - (memq (car elt) risky-vars)) + (unless (or (member elt unsafe-vars) + (member elt risky-vars)) (hack-one-local-variable (car elt) (cdr elt)))) ;; Query, except in the case where all are known safe ;; if the user wants no quuery in that case. diff --git a/lisp/follow.el b/lisp/follow.el index 50760cd9909..3edc62e5784 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -2163,6 +2163,7 @@ This prevents `mouse-drag-region' from messing things up." ;;{{{ The end (defun follow-unload-function () + "Unload Follow mode library." (easy-menu-remove-item nil '("Tools") "Follow") (follow-stop-intercept-process-output) (dolist (group '((before @@ -2189,10 +2190,9 @@ This prevents `mouse-drag-region' from messing things up." (intern (concat "follow-" (symbol-name fun)))) (ad-update fun)) (error nil)))))) + ;; continue standard processing nil) -(defvar follow-unload-function 'follow-unload-function) - ;; ;; We're done! ;; diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index de0af040849..7ac757f24e2 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,178 @@ +2007-11-05 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-citation-line-function) + (message-insert-formatted-citation-line): Fix spelling of + `message-insert-formated-citation-line'. + +2007-11-03 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-highlight): Mark as risky local variable. + +2007-11-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnml.el (nnml-request-rename-group): Bind file-name-coding-system to + nnmail-pathname-coding-system. + + * gnus-group.el (gnus-group-rename-group): Encode non-ASCII group name + that a user enters; decode group names in messages. + + * gnus-msg.el (gnus-inews-do-gcc): Encode non-ASCII group names. + +2007-11-01 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-util.el (mm-charset-eval-alist): Mark as risky local variable. + + * gnus.el (gnus-group-charter-alist): Mark as risky local variable. + + * gnus-art.el (gnus-button-alist, gnus-header-button-alist): Mark as + risky local variable. + + * gnus-group.el (gnus-group-icon-list): Mark as risky local variable. + +2007-11-01 Teodor Zlatanov <tzz@lifelogs.com> + + * encrypt.el: Improve documentation to fix function name typo. + Reported by Daiki Ueno <ueno@unixuser.org>. + +2007-11-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-next-page): Honor gnus-article-over-scroll + even if the point is not in the last page of an article. + (gnus-article-prev-page): Honor gnus-article-over-scroll when moving + back to the previous page. + +2007-10-30 Reiner Steib <Reiner.Steib@gmx.de> + + * qp.el (quoted-printable-decode-string): Fix typo in doc string. + +2007-10-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-ems.el (gnus-x-splash): Work even if there's no scroll bar. + +2007-10-29 Stefan Monnier <monnier@iro.umontreal.ca> + + * message.el (message-check-news-body-syntax): Avoid + mm-string-as-multibyte. + (message-hide-headers): Don't assume (point-min)==1. + +2007-10-28 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-remove-blank-cited-lines): Fix if remove is + given. + (message-bogus-address-regexp): New variable. + (message-bogus-recipient-p): New function. + (message-check-recipients): New command. + (message-syntax-checks): Add `bogus-recipient'. + (message-fix-before-sending): Add `bogus-recipient'. + + * gnus-art.el (gnus-button-mid-or-mail-heuristic-alist): Add "alpine". + (gnus-treat-emphasize, gnus-treat-body-boundary): Don't test + window-system. + +2007-10-28 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus.el: Bump version to Gnus v5.13. + +2007-10-28 Miles Bader <miles@gnu.org> + + * nnheader.el (nnheader-uniquify-message-id): Make sure this is defined + at compile-time too. + +2007-10-27 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-msg.el (gnus-message-setup-hook): Add + `message-remove-blank-cited-lines' to options. + +2007-10-26 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-remove-blank-cited-lines): New function. + Suggested by Karl Pl,Ad(Bsterer. + +2007-10-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * hashcash.el (mail-add-payment): Replace mapcar called for effect with + mapc. + + * imap.el (imap-open): Replace mapcar called for effect with mapc. + (top-level): Use mapc to set functions to be traced for debugging. + + * legacy-gnus-agent.el (gnus-agent-convert-agentview): Replace mapcar + called for effect with while loop. + + * message.el (message-talkative-question): Replace mapcar called for + effect with mapc. + + * mm-util.el: Use mapc instead of mapcar to make compatible functions. + (mm-find-mime-charset-region, mm-find-charset-region): Replace mapcar + called for effect with dolist. + + * mml.el (mml-insert-mime): Replace mapcar called for effect with mapc. + + * nndiary.el: Use dolist instead of mapcar to add diary headers to + gnus-extra-headers and nnmail-extra-headers. + + * nnimap.el (nnimap-request-update-info-internal): Replace mapcar + called for effect with dolist. + (top-level): Use mapc to set functions to be traced for debugging. + + * nnmail.el (nnmail-read-incoming-hook): Doc fix. + (nnmail-split-fancy-with-parent): Replace mapcar called for effect with + dolist. + + * nnmaildir.el (nnmaildir--delete-dir-files, nnmaildir-request-close): + Replace mapcar called for effect with mapc. + (nnmaildir--scan, nnmaildir-request-scan, nnmaildir-retrieve-groups) + (nnmaildir-request-update-info, nnmaildir-request-delete-group) + (nnmaildir-retrieve-headers, nnmaildir-request-set-mark) + (nnmaildir-close-group): Replace mapcar called for effect with dolist. + + * nnrss.el (nnrss-make-hash-index): Use gnus-remove-if instead of + remove-if that's a cl function. + + * webmail.el (webmail-debug): Replace mapcar called for effect with + dolist. + + * gnus-xmas.el (gnus-group-add-icon): Replace mapcar called for effect + with mapc. + +2007-10-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-read-agentview, gnus-agent-save-alist) + (gnus-agent-expire-unagentized-dirs): Replace mapcar called for effect + with while loop. + + * gnus-art.el: Use mapc instead of mapcar to make gnus-article-* + functions from article-* functions. + (gnus-multi-decode-header): Replace mapcar called for effect with + dolist. + + * gnus-bookmark.el (gnus-bookmark-bmenu-list) + (gnus-bookmark-show-details): Replace mapcar called for effect with + while loop. + + * gnus-diary.el (gnus-diary-update-group-parameters): Replace mapcar + called for effect with while loop. + + * gnus-group.el (gnus-group-suspend): Replace mapcar called for effect + with dolist. + + * gnus-registry.el (gnus-registry-split-fancy-with-parent): Replace + mapcar called for effect with dolist. + + * gnus-spec.el (gnus-correct-length): Make it simple and fast. + + * gnus-sum.el (gnus-multi-decode-encoded-word-string) + (gnus-build-sparse-threads, gnus-summary-limit-include-expunged): + Replace mapcar called for effect with dolist. + (gnus-simplify-buffer-fuzzy): Replace mapcar called for effect with + mapc. + + * gnus-topic.el (gnus-topic-find-groups, gnus-topic-move-group): + Replace mapcar called for effect with dolist. + (gnus-topic-list): Replace mapcar called for effect with mapc. + + * gnus.el: Use mapc instead of mapcar to add autoloads. + 2007-10-23 Richard Stallman <rms@gnu.org> * gnus-group.el (gnus-group-highlight): Mark as risky. @@ -7,6 +182,17 @@ * gnus.el (gnus-server-to-method): Return method found first in gnus-newsrc-alist. + * gnus-art.el (gnus-article-highlight-signature) + (gnus-insert-prev-page-button, gnus-insert-next-page-button): Make a + button overlay without the front stickiness. + +2007-10-22 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-agent.el (gnus-agent-expire-group-1): The check for an unsorted + overview buffer needed a catch to receive its throw. + (gnus-agent-flush-cache): Declared as interactive to make this function + easier to use. + 2007-10-20 Reiner Steib <Reiner.Steib@gmx.de> * html2text.el (html2text-fix-paragraph): Use `forward-line' instead of @@ -22,13 +208,26 @@ * gnus-util.el (gnus-string<): New function. * gnus-sum.el (gnus-article-sort-by-author) - (gnus-article-sort-by-subject): Use it. + (gnus-article-sort-by-recipient, gnus-article-sort-by-subject): Use it. 2007-10-15 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-win.el (gnus-configure-windows): Focus on the frame for which the frame-focus tag is set in gnus-buffer-configuration. +2007-10-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-add-button): Make a button overlay without + the front stickiness. + +2007-10-11 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-button-alist): Exclude newline in RFC2396-compliant + url pattern; remove duplicate one. + (gnus-article-extend-url-button): New function. + (gnus-article-add-buttons): Use it. + (gnus-button-push): Use concatenated url that it makes. + 2007-10-04 Juanma Barranquero <lekktu@gmail.com> * sieve-manage.el (sieve-manage-interactive-login): Doc fix. @@ -48,11 +247,50 @@ 2007-10-08 Reiner Steib <Reiner.Steib@gmx.de> * mm-util.el (mm-charset-synonym-alist): Alias gbk to cp936. + Fix comment about "iso8859-1". + +2007-10-08 Daiki Ueno <ueno@unixuser.org> + + * mm-decode.el (mm-possibly-verify-or-decrypt): Replace PARTS with the + ones returned from the verify-function. + + * mm-uu.el (mm-uu-pgp-signed-extract-1): Call + mml2015-extract-cleartext-signature if extraction failed. + +2007-10-07 Daiki Ueno <ueno@unixuser.org> + + * mm-uu.el (mm-uu-pgp-signed-extract-1): Delete the first line + beginning with "-----BEGIN PGP SIGNED MESSAGE-----" if extraction + failed. 2007-10-04 Reiner Steib <Reiner.Steib@gmx.de> * Relicense "GPLv2 or later" files to "GPLv3 or later". +2007-09-27 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sum.el (gnus-summary-kill-thread): Allow universal prefix zero + to mark a thread as expirable. Add variable `hide' to handle hiding of + thread for both the null and zero (kill/expire thread) universal prefix + cases. + (gnus-summary-expire-thread): Add new function to expire a thread, + using gnus-summary-kill-thread. + (gnus-summary-mode-map, gnus-summary-thread-map): Add 'M-C-e' and 'T e' + shortcuts for gnus-summary-expire-thread. + (gnus-summary-mode-map, gnus-summary-thread-map): Remove `M-C-e' and `T + e' bindings for gnus-summary-expire-thread. Add `T E' binding. + +2007-09-25 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-store-extra-entry): Allow for nil + extras value, so an extras entry can be deleted. + (gnus-registry-delete-extra-entry): Use it. + (gnus-registry-fetch-extra-flags, gnus-registry-has-extra-flag) + (gnus-registry-store-extra-flags, gnus-registry-delete-extra-flags) + (gnus-registry-delete-all-extra-flags): Allow for arbitrary flag symbol + storage through the gnus-registry, and provide an appropriate API for + it. + 2007-09-13 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-sum.el (gnus-newsgroup-maximum-articles): Move from gnus.el. @@ -84,14 +322,73 @@ (nnmbox-save-mail): Quote lines looking like delimiters at the right positions; make sure article ends with newline. + * message.el (message-display-abbrev): Don't infloop when a user + inserts SPC in the beginning of header. + +2007-09-12 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-unfollowed-groups): Add INBOX to the + list of groups not followed by default. Fix type to be regexp. + (gnus-registry-grep-in-list): Fix inverted parameters to string-match. + +2007-09-06 Tassilo Horn <tassilo@member.fsf.org> + + * hmac-def.el (define-hmac-function): Switch from old-style to + new-style backquotes. + + * md4.el (md4-make-step): likewise. + +2007-09-06 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-gnus-to-newsrc-format): Use a unibyte buffer and + raw-text coding system when saving .newsrc file, which may contain + non-ASCII group names. + 2007-09-05 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-cus.el (gnus-score-extra): New widget. (gnus-score-extra-convert): New function. (gnus-score-customize): Use it for Extra. +2007-08-31 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-extract-cleartext-signature): New function. + (mml2015-mailcrypt-clear-verify): Use it. + (mml2015-gpg-clear-verify): Use it. + (mml2015-pgg-clear-verify): Use it. + (mml2015-epg-clear-verify): Replace the current part with the output + from GnuPG; don't extract the plaintext by itself. + + * mm-uu.el (mm-uu-pgp-beginning-signature): Abolish. + (mm-uu-pgp-signed-extract-1): Bind coding-system-for-read when calling + mml2015-clear-verify-function; don't touch the armor headers or + dash-escaped text here. + +2007-08-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-edit-part): Don't jump to nonexistent part. + (gnus-mime-view-part-as-type-internal): Default to text/plain for text + parts, or application/octet-stream as a last resort. + (gnus-mime-view-part-as-type): Don't toggle display. + (gnus-mime-view-part-as-charset): Don't turn off display before + querying charset. + + * mm-view.el (mm-inline-text-html-render-with-w3): Don't add XEmacs + stuff to undisplayer function in Emacs. + (mm-inline-text-html-render-with-w3m): Remove Emacs/W3 stuff. + + * mml.el (mml-generate-mime-1): Prefer utf-8 when encoding + text/calendar parts. + 2007-08-23 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-art.el (gnus-mime-display-single): Use utf-8 by default for + decoding text/calendar parts. + + * message.el (message-forward-make-body-mime): Always mark body as + having no illegible text; remove signed-or-encrypted argument. + (message-forward-make-body): Don't pass signed-or-encrypted arg to it. + * mml.el (mml-generate-mime): Make sure it uses multibyte temp buffer. (mml-generate-mime-1): Don't encode body if it is specified to be in raw form; don't make buffer be unibyte when inserting multibyte string. @@ -110,6 +407,14 @@ 2007-08-17 Katsumi Yamaoka <yamaoka@jpl.org> + * imap.el (imap-logout-timeout): New variable. + (imap-logout, imap-logout-wait): New functions. + (imap-kerberos4-open, imap-gssapi-open, imap-close): Use them. + + * nnimap.el (nnimap-logout-timeout): New server variable. + (nnimap-open-server, nnimap-close-server): Bind imap-logout-timeout to + nnimap-logout-timeout. + * gnus-art.el (gnus-article-summary-command-nosave) (gnus-article-read-summary-keys): Don't use 3rd arg of pop-to-buffer. @@ -124,20 +429,118 @@ (gnus-list-of-read-articles, gnus-sequence-of-unread-articles): Limit the range of articles according to gnus-maximum-newsgroup. +2007-08-14 Tassilo Horn <tassilo@member.fsf.org> + + * gnus-art.el (gnus-sticky-article): Fixed problems described in + <b4mps1qitio.fsf@jpl.org> on ding. Thanks to Katsumi. + Don't perform gnus-configure-windows here; reuse existing sticky + article buffer. + + * gnus-sum.el (gnus-summary-display-article): Setup article buffer if + it doesn't exist in gnus-article-mode. + +2007-08-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-decoded-group-names): New variable. + (gnus-agent-decoded-group-name): New function. + (gnus-agent-group-path, gnus-agent-group-pathname): Use it. + (gnus-agent-expire-group-1): Use it; decode group name in messages. + +2007-08-12 Tassilo Horn <tassilo@member.fsf.org> + + * gnus-sum.el (gnus-summary-article-map, gnus-summary-make-menu-bar): + Add binding for gnus-sticky-article. + (gnus-summary-exit): Don't kill sticky article buffers. + + * gnus-art.el (gnus-sticky-article-mode): New mode to generate a sticky + article buffer. + (gnus-sticky-article, gnus-kill-sticky-article-buffer) + (gnus-kill-sticky-article-buffers): New commands. + 2007-08-10 Katsumi Yamaoka <yamaoka@jpl.org> * nntp.el (nntp-xref-number-is-evil): New server variable. (nntp-find-group-and-number): If it is non-nil, don't trust article numbers in the Xref header. +2007-08-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-read-group): New function. + (gnus-agent-flush-group, gnus-agent-expire-group) + (gnus-agent-regenerate-group): Use it. + (gnus-agent-expire-unagentized-dirs): Bind file-name-coding-system to + nnmail-pathname-coding-system. + 2007-08-06 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-ems.el (gnus-x-splash): Bind inhibit-read-only to t. + * gnus-sum.el (gnus-summary-insert-articles): Mark inserted articles + that are unread as unread, and also as selected so that information of + marks having been changed by a user may be updated when exiting group. + 2007-08-04 Reiner Steib <Reiner.Steib@gmx.de> * gnus-art.el (article-hide-headers): Bind inhibit-read-only to t. +2007-08-03 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-display-single): Pass part number that is + calculated ignoring signature parts to gnus-treat-article. + +2007-08-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-security-verify-or-decrypt): Don't narrow to + a point here in order to keep the window start. + (gnus-insert-mime-security-button): Make a button overlay without the + front stickiness. + (gnus-mime-display-security): Goto the end of a button. + + * gnus-group.el (gnus-group-name-at-point): Fix regexps. + +2007-08-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-name-at-point): Rewrite; rename from + group-name-at-point. + (gnus-group-completing-read): New function that offers decoded + non-ASCII group names for completion. + (gnus-fetch-group, gnus-group-read-ephemeral-group) + (gnus-group-jump-to-group, gnus-group-make-group-simple) + (gnus-group-unsubscribe-group, gnus-group-fetch-charter) + (gnus-group-fetch-control): Use it. + (gnus-fetch-group): Use group-name-at-point for the initial value + rather than the default value; use gnus-alive-p. + + * gnus-msg.el (gnus-group-mail, gnus-group-news, gnus-group-post-news) + (gnus-summary-mail-other-window, gnus-summary-news-other-window) + (gnus-summary-post-news): Use gnus-group-completing-read. + + * gnus-sum.el (gnus-select-newsgroup): Decode group name in error msg. + (gnus-read-move-group-name): Decode group name for completion. + +2007-07-31 Ted Zlatanov <tzz@lifelogs.com> + + * gnus-srvr.el (gnus-server-close-all-servers): Close servers not only + in gnus-inserted-opened-servers but also in gnus-server-alist (Katsumi + Yamaoka slightly modified the code). + +2007-07-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnmail.el (nnmail-group-names-not-encoded-p): New variable. + (nnmail-split-incoming): Bind it. + + * nnml.el (nnml-group-name-charset): New function. + (nnml-decoded-group-name): Use it; don't decode group name if + nnmail-group-names-not-encoded-p is non-nil. + (nnml-encoded-group-name): New function. + (nnml-group-pathname): Inline nnml-decoded-group-name. + (nnml-request-expire-articles): Decode group name in message. + (nnml-request-delete-group): Ditto; bind file-name-coding-system to + nnmail-pathname-coding-system. + (nnml-save-mail, nnml-active-number): Work with decoded group names and + not decoded ones according to nnmail-group-names-not-encoded-p. + (nnml-generate-active-info): Use nnml-encoded-group-name. + 2007-08-08 Glenn Morris <rgm@gnu.org> * gmm-utils.el, gnus-async.el, gnus-msg.el, gnus-score.el @@ -148,20 +551,125 @@ * Relicense all FSF files to GPLv3 or later. -2007-07-24 Katsumi Yamaoka <yamaoka@jpl.org> +2007-07-23 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-msg.el (gnus-summary-supersede-article) - (gnus-summary-resend-message-edit): Add Gcc header. - (gnus-summary-resend-bounced-mail): Ditto; search whole body for parent - article's Message-ID; refer parent article in summary buffer. - - * message.el (message-bounce): Call mime-to-mml. + * gnus-sum.el (gnus-summary-move-article): Make + gnus-summary-respool-article work. 2007-07-21 Reiner Steib <Reiner.Steib@gmx.de> * mm-uu.el (mm-uu-type-alist): Refer to mm-uu-configure-list in doc string. +2007-07-20 Micha,Ak(Bl Cadilhac <michael@cadilhac.name> + + * nnrss.el (nnrss-ignore-article-fields): New variable. List of fields + that should be ignored when comparing distant RSS articles with local + ones. + (nnrss-make-hash-index): New function. Create a hash index according + to the ignored fields. + (nnrss-check-group): Use it. + +2007-07-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-group-pathname): Take notice of the method. + + * gnus-art.el (article-decode-group-name): Decode Xref header too. + + * gnus-group.el (gnus-group-make-group): Encode group name here unless + the new optional argument ENCODED is non-nil. + (gnus-group-make-doc-group): Use gnus-group-name-charset to determine + coding system for encoding group name. + (gnus-group-make-rss-group): Pass un-encoded group name to + gnus-group-make-group. + (gnus-group-set-info): Tell gnus-group-make-group that group name is + encoded. + + * gnus-sum.el (gnus-summary-move-article, gnus-read-move-group-name): + Encode group name to which articles are moved or copied. + (gnus-summary-edit-article): Use gnus-group-name-charset to determine + coding system for encoding Newsgroup, Followup-To and Xref headers. + + * nnagent.el (nnagent-request-set-mark): Use unibyte buffer to compose + marks; use nnheader-file-coding-system to write a file. + (nnagent-retrieve-headers): Bind file-name-coding-system to + nnmail-pathname-coding-system. + + * nnmail.el (nnmail-insert-xref): Don't break non-ASCII group name. + + * nnml.el (nnml-decoded-group-name, nnml-group-pathname): New functions. + (nnml-request-article, nnml-request-create-group) + (nnml-request-rename-group, nnml-find-id) + (nnml-possibly-change-directory, nnml-possibly-create-directory) + (nnml-save-mail, nnml-active-number, nnml-marks-changed-p) + (nnml-save-marks): Use nnml-group-pathname instead of + nnmail-group-pathname. + + (nnml-request-create-group, nnml-request-expire-articles) + (nnml-request-move-article, nnml-request-delete-group) + (nnml-deletable-article-p, nnml-possibly-create-directory) + (nnml-get-nov-buffer, nnml-generate-nov-databases-directory) + (nnml-open-marks): Bind file-name-coding-system to + nnmail-pathname-coding-system. + + (nnml-request-article): Pass server argument to nnml-find-group-number. + (nnml-request-create-group, nnml-active-number, nnml-save-marks): Pass + server argument to nnml-possibly-create-directory. + (nnml-request-accept-article): Pass server argument to + nnml-active-number and nnml-save-mail. + (nnml-find-group-number): Pass server argument to nnml-find-id. + (nnml-request-update-info): Pass server argument to + nnml-marks-changed-p. + + (nnml-find-id, nnml-find-group-number, nnml-possibly-create-directory) + (nnml-save-mail, nnml-active-number): Add server argument. + + (nnml-request-delete-group): Warn if group is missing. + (nnml-get-nov-buffer): Decode group name. + (nnml-generate-active-info): Encode group name. + (nnml-open-marks): Decode group name in messages. + +2007-07-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-part-wrapper): Work with the nearest part + if it is not specified. + (gnus-article-pipe-part, gnus-article-save-part) + (gnus-article-interactively-view-part, gnus-article-copy-part) + (gnus-article-view-part-as-charset, gnus-article-view-part-externally) + (gnus-article-inline-part, gnus-article-save-part-and-strip) + (gnus-article-replace-part, gnus-article-delete-part) + (gnus-article-view-part-as-type): Pass raw prefix argument to + gnus-article-part-wrapper. + +2007-07-18 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-save-active): Bind + nnheader-file-coding-system to gnus-agent-file-coding-system. + + * gnus-cache.el (gnus-cache-save-buffers) + (gnus-cache-possibly-enter-article, gnus-cache-request-article) + (gnus-cache-retrieve-headers, gnus-cache-change-buffer) + (gnus-cache-possibly-remove-article, gnus-cache-articles-in-group) + (gnus-cache-braid-nov, gnus-cache-braid-heads) + (gnus-cache-generate-active, gnus-cache-rename-group) + (gnus-cache-delete-group, gnus-cache-update-file-total-fetched-for) + (gnus-cache-update-overview-total-fetched-for): Bind + file-name-coding-system to nnmail-pathname-coding-system. + (gnus-cache-decoded-group-names, gnus-cache-unified-group-names): New + variables. + (gnus-cache-decoded-group-name): New function. + (gnus-cache-file-name): Use it. + (gnus-cache-generate-active): Use non-decoded group name for active. + + * gnus-util.el (gnus-write-buffer): Bind file-name-coding-system at the + right place. + (gnus-write-active-file): Don't break non-ASCII group names. + + * nntp.el (nntp-marks-changed-p): Bind file-name-coding-system to + nnmail-pathname-coding-system. + + * gnus-uu.el (gnus-uu-decode-save): Typo. + 2007-07-16 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-srvr.el (gnus-server-font-lock-keywords): Quote faces. @@ -173,11 +681,63 @@ 2007-07-13 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-agent.el (gnus-agent-rename-group, gnus-agent-delete-group) + (gnus-agent-fetch-articles, gnus-agent-unfetch-articles) + (gnus-agent-crosspost, gnus-agent-backup-overview-buffer) + (gnus-agent-flush-group, gnus-agent-flush-cache) + (gnus-agent-fetch-headers, gnus-agent-load-alist) + (gnus-agent-read-agentview, gnus-agent-expire-group-1) + (gnus-agent-retrieve-headers, gnus-agent-request-article) + (gnus-agent-regenerate-group) + (gnus-agent-update-files-total-fetched-for) + (gnus-agent-update-view-total-fetched-for): Bind + file-name-coding-system to nnmail-pathname-coding-system. + (gnus-agent-group-pathname): Don't encode file names by + nnmail-pathname-coding-system. + (gnus-agent-save-local): Bind file-name-coding-system correctly; bind + coding-system-for-write instead of buffer-file-coding-system to + gnus-agent-file-coding-system. + + * gnus-msg.el (gnus-inews-make-draft, gnus-inews-insert-archive-gcc): + Decode group name. + + * gnus-srvr.el (gnus-browse-foreign-server): Make group names unibyte. + + * gnus-start.el (gnus-update-active-hashtb-from-killed) + (gnus-read-newsrc-el-file): Make group names unibyte. + + * nnmail.el (nnmail-group-pathname): Don't encode file names by + nnmail-pathname-coding-system. + + * nnrss.el (nnrss-file-coding-system): Doc fix; make it begin with *. + (nnrss-request-delete-group): Bind file-name-coding-system to + nnmail-pathname-coding-system. + (nnrss-read-server-data, nnrss-read-group-data): Bind + file-name-coding-system correctly. + (nnrss-check-group): Pass nnrss-file-coding-system to md5. + + * nntp.el: Require gnus-group for the function gnus-group-name-charset. + (nntp-server-to-method-cache): New variable. + (nntp-group-pathname): New function that decodes non-ASCII group names. + (nntp-possibly-create-directory, nntp-marks-changed-p) + (nntp-save-marks, nntp-open-marks): Use it. + (nntp-possibly-create-directory, nntp-open-marks): + Bind file-name-coding-system to nnmail-pathname-coding-system. + (nntp-open-marks): Decode group names when bootstrapping marks. + + * rfc2047.el (rfc2047-encode-message-header): Make XEmacs decode + Newsgroups and Folowup-To headers. + +2007-07-13 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-srvr.el (gnus-server-agent-face, gnus-server-opened-face) (gnus-server-closed-face, gnus-server-denied-face) (gnus-server-offline-face): Remove variable. (gnus-server-font-lock-keywords): Use faces that are not aliases. + * gnus-util.el (gnus-message-with-timestamp-1): Use log-message instead + of modifying message-stack directly for XEmacs. + * mm-util.el (mm-decode-coding-string, mm-encode-coding-string) (mm-decode-coding-region, mm-encode-coding-region): Don't modify string if the coding-system argument is nil for XEmacs. @@ -190,6 +750,18 @@ (rfc2047-encode-parameter): Use rfc2045-encode-string to quote or not to quote the parameter value. +2007-07-06 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-name-charset): Allow a method of the short + form in gnus-group-name-charset-method-alist. + + * gnus-eform.el (gnus-edit-form): Add optional argument layout which + overrides the default layout edit-form. + + * gnus-win.el (gnus-buffer-configuration): Add edit-server. + + * gnus-srvr.el (gnus-server-edit-server): Use edit-server layout. + 2007-07-04 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-sum.el (gnus-summary-catchup): Don't recognize cached articles @@ -199,11 +771,39 @@ * gnus-start.el (gnus-level-unsubscribed): Improve doc string. +2007-07-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnagent.el (nnagent-request-set-mark): Also set the marks for the + original back end that keeps marks in the local system. + 2007-06-26 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-art.el (gnus-article-summary-command-nosave) - (gnus-article-read-summary-keys): Don't set the 3rd arg of - pop-to-buffer for XEmacs. + * gnus-art.el (gnus-article-summary-command-nosave): Don't set the 3rd + arg of pop-to-buffer for XEmacs. + (gnus-article-read-summary-keys): Ditto; don't restore window + configuration if summary command ends up with neither article buffer + nor summary buffer; describe bindings if summary keys end with C-h. + +2007-06-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-fix-before-sending): Skip raw message part to be + forwarded while checking illegible text. + (message-forward-make-body-mime, message-forward-make-body): Mark + signed or encrypted raw message as having no illegible text. + +2007-06-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-util.el (gnus-add-timestamp-to-message): New user option. + (gnus-message-with-timestamp-1): New macro. + (gnus-message-with-timestamp): New function. + (gnus-message): Use them. + + * nnheader.el (nnheader-message): Use them. + +2007-06-16 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Add newlines to + .newsrc.eld file. 2007-06-14 Katsumi Yamaoka <yamaoka@jpl.org> @@ -218,14 +818,26 @@ 2007-06-08 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-ems.el (gnus-x-splash): Fix calculation; error in tty. + +2007-06-07 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-ems.el (gnus-x-splash): Make it work. * gnus-start.el (gnus-1): Relax restrictions that prevent gnus-x-splash from being used. - * gnus-art.el (gnus-article-summary-command-nosave): Correct the order - of the arguments passed to pop-to-buffer. - (gnus-article-read-summary-keys): Ditto. +2007-06-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-insert-mime-button): Make a button overlay without + the front stickiness. + (gnus-article-summary-command-nosave): Correct the order of the + arguments passed to pop-to-buffer. + (gnus-article-read-summary-keys): Ditto; make it work properly when the + summary command ends up with the article buffer. + + * mm-decode.el (mm-insert-part): Separate the extracted parts that have + the same faces. 2007-06-07 Juanma Barranquero <lekktu@gmail.com> @@ -244,29 +856,182 @@ (gnus-mime-view-part-internally): Fix predicate function passed to completing-read. - * mm-decode.el (mm-image-fit-p): Return t if argument is not an image; - return t if image size is just the same as window size. + * mm-decode.el (mm-image-fit-p): Return t if argument is not an image. + + * gnus.el (gnus-update-message-archive-method): Add :version. + +2007-06-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus.el (gnus-update-message-archive-method): New variable. + + * gnus-start.el (gnus-setup-news): Update saved "archive" method + according to gnus-message-archive-method if + gnus-update-message-archive-method is non-nil. + +2007-05-29 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-limit-to-address): New function. Suggested + by Loic Dachary <loic@dachary.org>. + (gnus-summary-limit-map, gnus-summary-make-menu-bar): Add it. 2007-05-28 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-pop-to-buffer): Add switch-function argument. (message-mail): Pass switch-function argument to it. +2007-05-25 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-decode.el (mm-file-name-rewrite-functions): Make it customizable. + Improve doc string. + +2007-05-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-header-from, gnus-header-subject, gnus-header-name) + (gnus-header-content) + * gnus-cite.el (gnus-cite-10) + * gnus-srvr.el (gnus-server-closed) + * gnus.el (gnus-group-mail-1, gnus-group-mail-1-empty) + (gnus-group-mail-2, gnus-group-mail-2-empty, gnus-group-mail-3) + (gnus-group-mail-3-empty, gnus-group-mail-low) + (gnus-group-mail-low-empty, gnus-splash) + * message.el (message-header-to, message-header-cc) + (message-header-subject, message-header-other, message-header-name) + (message-header-xheader, message-separator, message-cited-text) + (message-mml): Lighten colors of faces used for dark background. + +2007-05-24 Simon Josefsson <simon@josefsson.org> + + * nnimap.el (nnimap-need-unselect-to-notice-new-mail): Change default + to t as an experiment. Suggested by Greg Troxel <gdt@work.lexort.com>. + 2007-05-24 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-narrow-to-headers-or-head): Ignore mail-header-separator in the body. +2007-05-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-decode.el (mm-image-fit-p): Return t if image size is just the + same as window size. + +2007-05-22 Kevin Ryde <user42@zip.com.au> + + * message.el (message-font-lock-keywords): Use message-header-xheader + face for "X-Foo", its apparent intended purpose. Move "X-" pattern + ahead of the anything pattern, to get it recognised. + +2007-05-12 Micha,Ak(Bl Cadilhac <michael@cadilhac.name> + + * gnus-sum.el (gnus-articles-to-read) + (gnus-summary-insert-old-articles): Don't truncate group name for + `read-string'. + + * gnus-util.el (gnus-limit-string): Delete this function. + + * gnus-sum.el (gnus-simplify-subject-fully): Use + `truncate-string-to-width' instead. + +2007-05-11 Micha,Ak(Bl Cadilhac <michael@cadilhac.name> + + * gnus-sum.el (gnus-summary-next-group-on-exit): New variable. Tell + if, on summary exit, the next group has to be selected. + (gnus-summary-exit): Use it. + 2007-05-10 Reiner Steib <Reiner.Steib@gmx.de> * gnus-art.el (gnus-article-mode): Fix comment about displaying non-break space. -2007-05-09 Didier Verna <didier@xemacs.org> +2007-05-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnfolder.el (nnfolder-request-group, nnfolder-request-create-group): + Check if group is not a directory. + (nnfolder-request-expire-articles): Don't delete articles if the target + group is not available. + + * nnml.el (nnml-request-create-group): Properly check if group is not a + file. + (nnml-request-expire-articles): Don't delete articles if the target + group is not available. + + * rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings): + Don't quote characters that are within parentheses. + +2007-05-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-auto-select-on-ephemeral-exit): New variable. + (gnus-handle-ephemeral-exit): Select article according to it. + +2007-05-08 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-insert-formated-citation-line): Remove newline. + (message-citation-line-format): Add final \n here so that the user can + avoid a blank line. + +2007-05-03 Dan Christensen <jdc@uwo.ca> + + * nndoc.el (nndoc-type-alist, nndoc-lanl-gov-announce-type-p) + (nndoc-transform-lanl-gov-announce, nndoc-generate-lanl-gov-head): + Update lanl/arXiv support. + +2007-05-02 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-diary.el, nndiary.el: Remove the description comment (nndiary is - now properly documented in the Gnus manual). Fix the spelling of "Back - End". + * gnus.el: Bump version number. + +2007-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-version-number): Bump version. + +2007-05-01 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no> + + * gnus.el: No Gnus v0.6 is released. + +2007-04-27 Didier Verna <didier@xemacs.org> + + * gnus-util.el (gnus-orify-regexp): Moved and renamed to ... + * gmm-utils.el (gmm-regexp-concat): here. + * message.el: Don't require 'gnus-util. + (message-dont-reply-to-names): Handle name change above. + * gnus-sum.el (gnus-ignored-from-addresses): Ditto. + +2007-04-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-charset-synonym-alist): Don't make it a user option + since the initial value varies according to the system. + +2007-04-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-charset-synonym-alist): Defcustom. + +2007-04-25 NAKAJI Hiroyuki <nakaji@jp.freebsd.org> (tiny change) + + * mm-util.el (mm-charset-synonym-alist): Map iso8859-1 to iso-8859-1. + +2007-04-24 Didier Verna <didier@xemacs.org> + + Improve the type of gnus-ignored-from-addresses. + * gnus-util.el (gnus-orify-regexp): New function. + * message.el (gnus-util): Require it. + * message.el (message-dont-reply-to-names): Use gnus-orify-regexp. + * gnus-sum.el (gnus-ignored-from-addresses): New function. + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use it. + +2007-04-24 Didier Verna <didier@xemacs.org> + + * gnus-sum.el: + * gnus-utils.el: Fix some trailing whitespaces. + +2007-04-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-msg.el (gnus-summary-resend-message-edit): Add Gcc header. + (gnus-summary-resend-bounced-mail): Ditto; search whole body for parent + article's Message-ID; refer parent article in summary buffer. + + * message.el (message-bounce): Call mime-to-mml. + +2007-04-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-msg.el (gnus-summary-supersede-article): Add Gcc header. 2007-04-19 Katsumi Yamaoka <yamaoka@jpl.org> @@ -274,12 +1039,35 @@ (gnus-mime-view-part-as-charset): Use it; redisplay subpart currently displayed of multipart/alternative part if it is invoked from summary buffer. - (gnus-article-part-wrapper): Select article window. * mm-view.el (mm-inline-text-html-render-with-w3m) (mm-inline-text-html-render-with-w3m-standalone) (mm-inline-render-with-function): Use mail-parse-charset by default. +2007-04-18 Levin Du <zslevin@gmail.com> (tiny change) + + * parse-time.el (parse-time-string-chars): Check if CHAR + is less than the length of parse-time-syntax. + +2007-04-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-uu.el (gnus-uu-digest-mail-forward): Pull articles processed + from gnus-newsgroup-processable. + +2007-04-16 Didier Verna <didier@xemacs.org> + + * gnus-msg.el (gnus-configure-posting-styles): Handle + message-signature-directory properly with :file syntax. Reported by + "Leo". + +2007-04-11 Didier Verna <didier@xemacs.org> + + New user option: message-signature-directory. + * gnus-msg.el (gnus-configure-posting-styles): Support it. + * message.el (message-insert-signature): Ditto. + * message.el (message-signature-file): Doc update. + * message.el (message-signature-directory): New. + 2007-04-10 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-msg.el (gnus-inews-yank-articles): Use @@ -302,6 +1090,9 @@ 2007-03-31 Reiner Steib <Reiner.Steib@gmx.de> + * message.el (message-fill-column): New variable. + (message-mode): Use it. Add comment on a possible new hook. + * nnmail.el (nnmail-spool-file): Mark as obsolete. (nnmail-get-new-mail): Reformat. @@ -312,8 +1103,37 @@ 2007-03-27 Thien-Thi Nguyen <ttn@gnu.org> - * message.el (message-yank-original): Fix bug: - Don't switch point and mark unnecessarily. + * message.el (message-yank-original): Don't switch point and mark + unnecessarily to put point and mark as documented. + +2007-03-27 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-put-addresses-in-ecomplete): Only fetch headers + from the message heads. + +2007-03-25 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-art.el (gnus-article-set-window-start): Do nothing when the + article buffer does not have a window. This may not be the best + solution but is certainly better than setting the start of the null, + that is the current, window. + +2007-03-24 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-draft.el (gnus-draft-setup-hook): New hook. + (gnus-draft-setup): Run it. + + * gnus-score.el (gnus-inhibit-slow-scoring): New variable, renamed from + gnus-score-fast-scoring. Allow regexp. + (gnus-score-headers): Use it. + + * gnus-util.el (gnus-emacs-version): Include "no MULE" in no-MULE + XEmacs. + + * gnus-art.el (gnus-article-browse-html-article): Fix typo in doc + string. + (gnus-button-alist): Also catch `<f1> k ...'. + (gnus-treat-display-x-face): Fix doc string. 2007-03-25 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> @@ -321,10 +1141,11 @@ evaluation of gnus-extended-version to ensure correct generation of the User-Agent header when message-generate-headers-first is used. -2007-03-24 Reiner Steib <Reiner.Steib@gmx.de> +2007-03-24 Simon Josefsson <simon@josefsson.org> - * gnus-art.el (gnus-button-alist): Also catch `<f1> k ...'. - (gnus-treat-display-x-face): Fix doc string. + * hashcash.el (hashcash-generate-payment-async): Don't crash if + hashcash-path is nil. Don't call callback with incorrect number of + parameters if val is 0. 2007-03-20 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> @@ -350,6 +1171,43 @@ (message-mail-other-window): Adjust argument of message-setup. (message-mail-other-frame): Ditto. +2007-03-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (font-lock-set-defaults): Autoload it for Emacs. + (gnus-message-citation-mode): Require font-lock for XEmacs; make sure + to turn font-lock on when turning gnus-message-citation-mode on. + +2007-03-06 Daiki Ueno <ueno@unixuser.org> + + * mml-smime.el (mml-smime-use): New variable; default to use openssl. + (mml-smime-function-alist): New variable; add epg as the backend. + * mml-sec.el (mml-smime-sign): Don't require mml-smime, autoload + mml-smime- functions instead. + * mm-view.el: Require smime. + +2007-03-05 Didier Verna <didier@xemacs.org> + + * gnus-topic.el (gnus-topic-hierarchical-parameters): Perform merging + instead of just inheritance for posting styles. + * gnus.el (gnus-group-fast-parameter): Fix typo in comment. + +2007-02-24 John Paul Wallington <jpw@pobox.com> + + * tls.el (tls-certtool-program): Fix custom type. + +2007-02-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (gnus-message-search-citation-line): Use point-at-bol + and point-at-eol instead of line-(beginning|end)-position. + + * assistant.el (assistant-parse-buffer): Ditto. + +2007-02-28 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-find-usable-key): New function. + (mml2015-epg-sign): Use it. + (mml2015-epg-encrypt): Use it. + 2007-02-28 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-make-in-reply-to): Quote name containing @@ -357,12 +1215,36 @@ if there are special characters. Reported by NAKAJI Hiroyuki <nakaji@jp.freebsd.org>. +2007-02-27 Didier Verna <didier@xemacs.org> + + Include the group parameters as well as the topic ones in the + inheritance filter process. + * gnus-topic.el (gnus-topic-hierarchical-parameters): New optional + argument GROUP-PARAMS-LIST. + * gnus-topic.el (gnus-group-topic-parameters): Use it. + 2007-02-27 Katsumi Yamaoka <yamaoka@jpl.org> * nntp.el (nntp-never-echoes-commands) (nntp-open-connection-functions-never-echo-commands): New variables. (nntp-send-command): Use them. +2007-02-20 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-verify): Simplified. + +2007-02-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * mml.el (mml-content-disposition-alist): New user option. + (mml-content-disposition): New function. + (mml-insert-mime-headers, mml-minibuffer-read-disposition): Use it. + (mml-attach-file, mml-dnd-attach-file): Pass file name to it. + +2007-02-19 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-verify): Convert LF to CRLF before signature + verification. + 2007-02-15 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * nnweb.el (nnweb-google-parse-1): Fix date parsing to also match on @@ -372,6 +1254,57 @@ * smiley.el (smiley-regexp-alist): Add "dead" smiley. +2007-02-14 Micha,Ak(Bl Cadilhac <michael@cadilhac.name> + + * nntp.el (nntp-send-command): Don't wait for echoes when + nntp-open-ssl-stream is used. + +2007-02-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (gnus-test-font-lock-add-keywords) + (gnus-message-add-citation-keywords) + (gnus-message-remove-citation-keywords): Remove. + (gnus-message-citation-mode): Instead of modifying font-lock-keywords + directly, make the variables in font-lock-defaults buffer-local, add + gnus-message-citation-keywords to them and then update the value of + font-lock-keywords. + +2007-02-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-cite-original-1): Don't call + gnus-article-highlight-citation. + + * gnus-cite.el (gnus-cite-parse): Work with two or more MS-type + citations; fix line count. + +2007-02-08 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (gnus-test-font-lock-add-keywords): New function. + (gnus-message-add-citation-keywords) + (gnus-message-remove-citation-keywords): Use it; fix the emulating + versions of font-lock-add-keywords and font-lock-remove-keywords to + work with XEmacs correctly. + +2007-02-07 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (gnus-cite-face-list): Set the values of + gnus-message-max-citation-depth and gnus-message-citation-keywords. + (gnus-message-max-citation-depth): Use defvar rather than defconst. + (gnus-message-cite-prefix-regexp): New variable. + (gnus-message-search-citation-line): Use it; protect against long + citation prefix; fill match data with nil rather than 0 for XEmacs; set + the 0th match data for Emacs. + (gnus-message-citation-keywords): Set LAXMATCH flag in every HIGHLIGHT. + (gnus-message-add-citation-keywords): Append keywords rather than + prepending; emulate font-lock-add-keywords if it is not available. + (gnus-message-remove-citation-keywords): Emulate + font-lock-remove-keywords if it is not available. + + * gnus-msg.el (gnus-message-highlight-citation): Default to t. + + * message.el (message-cite-prefix-regexp): Set the value of + gnus-message-cite-prefix-regexp. + 2007-02-01 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * nnweb.el (nnweb-google-parse-1): Update parser. @@ -398,11 +1331,32 @@ * gnus-art.el (gnus-signature-limit): Fix custom choice. +2007-01-22 Daiki Ueno <ueno@unixuser.org> + + * mm-util.el (mm-inhibit-file-name-handlers): Add epa-file-handler. + + * mm-decode.el (mm-save-part-to-file): Use `mm-write-region' instead of + `write-region' to respect `mm-inhibit-file-name-handlers'. + 2007-01-19 Reiner Steib <Reiner.Steib@gmx.de> * nnsoup.el (nnsoup-directory, nnsoup-packer, nnsoup-packet-directory): Use gnus-home-directory instead of "~/" or "$HOME". +2007-01-17 Teodor Zlatanov <tzz@lifelogs.com> + + * encrypt.el (encrypt-insert-file-contents): Add better prompt + to mention filename. + Add comments at beginning regarding usage. + (encrypt-write-file-contents): Change interactive so a string is + acceptable. If the file has no associated model, show an error instead + of a nonsense prompt. + +2007-01-16 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * spam.el (spam-bsfilter-ham-switch): Fix typo. + Thanks to Yoshihiko Yamada for kind notification of this typo. + 2007-01-12 Kenichi Handa <handa@m17n.org> * uudecode.el (uudecode-decode-region-internal): Make it work in a @@ -410,34 +1364,76 @@ 2007-01-14 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-score.el (gnus-score-fast-scoring): New variable. + (gnus-score-headers): Use it. + * gnus-sum.el (gnus-auto-select-first): Improve doc string. -2007-01-07 Reiner Steib <Reiner.Steib@gmx.de> + * message.el (message-cite-original-1): Call + gnus-article-highlight-citation if requested. + (message-make-from): Allow name and address as optional arguments. + + * gnus-cite.el (gnus-article-highlight-citation): Add SAME-BUFFER arg. - * gnus-soup.el: Add missing :group in previous change. + * gnus-art.el (gnus-article-browse-html-article): Add warning about web + bugs to doc string. + (gnus-button-alist): Add mid\\|message-id. + (gnus-button-fetch-group): Extend for use in + `browse-url-browser-function'. + (gnus-button-url-regexp): Try to catch paired parentheses like in + Wikipedia URLs. -2007-01-05 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-sum.el (gnus-summary-reparent-children): Another doc string fix. + Suggested by Simon Krahnke <overlord@gmx.li>. + +2007-01-13 Romain Francoise <romain@orebokech.com> + + * nnml.el (nnml-use-compressed-files): Fix typo in docstring. + Update copyright. + +2007-01-13 Patric Mueller <bhaak@bigfoot.com> (tiny change) + + * gnus-sum.el (gnus-summary-reparent-children): Fix typo in doc string. + +2007-01-09 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-unfollowed-groups) + (gnus-registry-split-fancy-with-parent): Fix documentation. + +2007-01-08 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * spam-report.el (spam-report-gmane-internal): Speed up spam reporting + from nnweb groups. + +2006-12-31 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * spam-report.el (spam-report-gmane-internal): Add necessary "/" to + Xref urls. Erase buffer before requesting head. + + * mm-decode.el (mm-display-external): Use itimer function for XEmacs. + +2007-01-07 Reiner Steib <Reiner.Steib@gmx.de> * gnus-soup.el (gnus-soup): New custom group. Make user variables customizable. -2007-01-03 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> +2007-01-05 Daiki Ueno <ueno@unixuser.org> - * nnweb.el (nnweb-gmane-create-mapping): Put back code to merge the - headers read from disk with the ones newly found in the current search. - This should no longer cause problems, because the article numbers in - Gmane's `nov.php' output are ignored since the previous change. + * mml2015.el (mml2015-epg-sign): Ask user whether to skip or abort if + no signing key is found. + (mml2015-epg-encrypt): Ask user whether to skip or abort if + no encrypting and/or signing key is found. -2006-01-03 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> +2007-01-03 Reiner Steib <Reiner.Steib@gmx.de> - * nnweb.el (nnweb-gmane-create-mapping): Keep the mapping stable for - solid groups. + * spam-report.el (spam-report-gmane-spam): Remove redundant message. -2006-01-03 Lars Magne Ingebrigtsen <larsi@gnus.org> +2007-01-01 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> - * nnweb.el (nnweb-gmane-create-mapping): Use the article number from - the headers when creating the mapping to avoid mismappings. - (nnweb-gmane-create-mapping): Always nix out old mapping. + * nnweb.el (nnweb-gmane-create-mapping): Put back code to merge the + headers read from disk with the ones newly found in the current search. + This should no longer cause problems, because the article numbers in + Gmane's `nov.php' output are ignored since the previous change. 2007-01-02 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> @@ -447,10 +1443,48 @@ * mm-decode.el (mm-display-external): Use itimer function for XEmacs. +2007-01-01 Romain Francoise <romain@orebokech.com> + + * gnus-sum.el (gnus-summary-make-menu-bar): Fix typo. + +2006-12-31 Steve Youngs <steve@sxemacs.org> + + * gnus-cite.el: Load easy-mmode at compile time for (S)XEmacs to get + `define-minor-mode' macro definition expanded properly. + (gnus-message-citation-mode): This is now OK for (S)XEmacs so don't + exclude it there. + + * gnus-msg.el (gnus-message-highlight-citation): Revert Reiner's patch + of 2006-12-30. The default is nil on (S)XEmacs already because of the + `fboundp' test. + (gnus-message-citation-mode): Revert Reiner's patch of 2006-12-30. + This is OK to autoload in (S)XEmacs now. + +2006-12-30 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-summary-limit-to-singletons): New command and + keystroke. + (gnus-summary-limit-to-singletons): Fix typo. + + * spam-report.el (spam-report-gmane-internal): Fall back on Xref if all + else fails. + 2006-12-30 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> - * gnus-sum.el (gnus-summary-insert-dormant-articles): Fix typo in - message. + * gnus-cite.el (turn-off-gnus-message-citation-mode): Fix typo in + docstring. + + * gnus-sum.el (gnus-summary-insert-ticked-articles): New command. + (gnus-summary-make-menu-bar, gnus-summary-buffer-map): Bind it. + (gnus-summary-insert-dormant-articles): Fix typo in message. + +2006-12-30 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-msg.el (gnus-message-highlight-citation): Ensure default to be + nil for XEmacs. + (gnus-message-citation-mode): Don't autoload in XEmacs. + + * gnus-cite.el (gnus-message-citation-mode): Don't define in XEmacs. 2006-12-29 Jouni K. Sepp,Ad(Bnen <jks@iki.fi> @@ -462,16 +1496,51 @@ * spam.el: Revert to make-obsolete-variable because define-obsolete-variable-alias is not supported in Emacs 21. + * spam.el (spam-ifile-path, spam-ifile-database-path) + (spam-bogofilter-path): Use define-obsolete-variable-alias instead of + make-obsolete-variable. + (spam-bsfilter-path, spam-bsfilter-program) + (spam-spamassassin-path, spam-spamassassin-program) + (spam-sa-learn-path, spam-sa-learn-program): Rename variables. Don't + use "path" inappropriately. + (spam-check-spamassassin, spam-spamassassin-register-with-sa-learn) + (spam-check-bsfilter, spam-bsfilter-register-with-bsfilter): Use new + variable names. + 2006-12-28 Daiki Ueno <ueno@unixuser.org> * gnus-sum.el (gnus-summary-next-article): Make sure we are in the summary buffer. -2006-12-27 Reiner Steib <Reiner.Steib@gmx.de> + * password.el (password-cache-remove): Use clear-string to burn + password, if available. - * spam.el (spam-ifile-path, spam-ifile-database-path) - (spam-bogofilter-path): Use define-obsolete-variable-alias instead of - make-obsolete-variable. +2006-12-26 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-msg.el (gnus-message-citation-mode): Fix autoload. + + * gnus-cite.el (gnus-message-highlight-citation): Move to gnus-msg.el. + + * gnus-msg.el (gnus-setup-message): Add gnus-message-citation-mode. + (gnus-message-highlight-citation): Move defcustom here from + gnus-cite.el. + (gnus-message-citation-mode): Autoload. + + * gnus-cite.el: Adjust Oliver's code to Gnus namespace. Add some + checks to make it compile with XEmacs. + (gnus-message-citation-mode): New minor mode. + (gnus-message-max-citation-depth, gnus-message-citation-keywords) + (gnus-message-highlight-citation): New variables. + (gnus-message-search-citation-line) + (gnus-message-add-citation-keywords) + (gnus-message-remove-citation-keywords) + (turn-on-gnus-message-citation-mode) + (turn-off-gnus-message-citation-mode): New functions. + +2006-12-26 Oliver Scholz <epameinondas@gmx.de> + + * gnus-cite.el: Enable highlighting of different citation levels in + message-mode. 2006-12-26 Reiner Steib <Reiner.Steib@gmx.de> @@ -502,11 +1571,42 @@ them directly in the unibyte buffer that causes unexpected conversion in Emacs 23 (unicode). +2006-12-21 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * message.el (message-generate-hashcash): Fix custom type. + +2006-12-20 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-recenter): Remove debug messages. + 2006-12-20 Reiner Steib <Reiner.Steib@gmx.de> * gnus-group.el (gnus-group-tool-bar-gnome): Exchange connect and disconnect icons. Add help text. +2006-12-20 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-extra-header-to-number): CRM114 spam score is + negated to be consistent with the others we handle. + +2006-12-19 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-article-setup-buffer): Actually set the local + version of gnus-summary-buffer to something, so that we can use two + article buffers at the same time. + +2006-12-18 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-necessary-extra-headers): Make spam-use-regex-headers + trigger all the extra headers. + (spam-extra-header-to-number): Don't require spam-use-crm114 for header + sorting. + +2006-12-14 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * nnweb.el (nnweb-gmane-create-mapping): Keep the mapping stable for + solid groups. + 2006-12-13 Reiner Steib <Reiner.Steib@gmx.de> * legacy-gnus-agent.el: Add Copyright notice. @@ -515,6 +1615,15 @@ * gnus-sum.el (gnus-make-thread-indent-array): Fix last change. +2006-12-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnweb.el (nnweb-gmane-search): Placeholder TOPDOC setting. + + * gnus-sum.el (gnus-summary-recenter): Force setting the window start + to make it work reliably in CVS Emacs. + (gnus-summary-limit-strange-charsets-predicate) + (gnus-summary-limit-to-predicate): New functions. + 2006-12-08 Chong Yidong <cyd@stupidchicken.com> * gnus-sum.el (gnus-make-thread-indent-array): New optional arg @@ -534,16 +1643,35 @@ * mm-url.el (mm-url-predefined-programs): Call curl with correct options. +2006-12-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * spam-report.el (spam-report-url-ping-plain): Wait for output to avoid + DOS-ing the recipient. + + * nnweb.el (nnweb-gmane-create-mapping): Use the article number from + the headers when creating the mapping to avoid mismappings. + (nnweb-gmane-create-mapping): Always nix out old mapping. + +2006-11-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-signed-or-encrypted-p): Bind mm-decrypt-option + and mm-verify-option to never. + 2006-11-30 Katsumi Yamaoka <yamaoka@jpl.org> - * mml2015.el (mml2015-pgg-clear-verify): Replace encode-coding-string - with mm-encode-coding-string. + * message.el (message-signed-or-encrypted-p): New function. + (message-forward-make-body): Use it. + + * mml2015.el (mml2015-pgg-clear-verify, mml2015-epg-clear-verify): + Replace encode-coding-string with mm-encode-coding-string. 2006-11-29 Katsumi Yamaoka <yamaoka@jpl.org> * nneething.el (nneething-decode-file-name): Replace decode-coding-string with mm-decode-coding-string. + * gnus-int.el (gnus-open-server): Say failed server's name. + 2006-11-24 Juanma Barranquero <lekktu@gmail.com> * gnus-agent.el (gnus-agent-expire-unagentized-dirs) @@ -560,10 +1688,26 @@ (gnus-valid-select-methods, total-expire, gnus-summary-line-format) (gnus-group-read-only-p): Fix space/tab mixup in docstrings. +2006-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-summary-limit-to-headers): New command and + keystroke. + (gnus-summary-limit-to-bodies): Implement headersp. + +2006-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * dns.el (query-dns): Protect against "Process dns deleted" strings. + 2006-11-21 Katsumi Yamaoka <yamaoka@jpl.org> * mm-util.el (mm-string-to-multibyte): Alias to identity in XEmacs. +2006-11-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-generate-hashcash): Expand range of values to + include `opportunistic'. + (message-send-mail): Use it. + 2006-11-18 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * mm-uu.el (mm-uu-pgp-signed-extract-1): Make last fix more thorough @@ -587,6 +1731,15 @@ `customize-variable'. (gnus-getenv-nntpserver): Don't autoload. +2006-11-14 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el: Revert to 7.82 (removed changes since 2006-10-16). + +2006-11-14 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-sendmail-extra-arguments): New variable. + (message-send-mail-with-sendmail): Use it. + 2006-11-14 Katsumi Yamaoka <yamaoka@jpl.org> * mml.el (mml-generate-mime-1): Use mm-string-as-unibyte instead of @@ -595,16 +1748,39 @@ * mm-decode.el (mm-insert-part): Use mm-string-to-multibyte instead of mm-string-as-multibyte. +2006-11-14 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-sign): Prefix "pgp-" to a micalg value. + Reported by Werner Koch <wk@gnupg.org>. + +2006-11-14 Daiki Ueno <ueno@p360> + + * mml2015.el: Autoload epa-select-keys when compiling. + +2006-11-13 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-sign): Save the signing keys in + message-options. + (mml2015-epg-encrypt): Save the recipient keys in message-options. + +2006-11-13 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-encrypt): Removed backward compatibility for + EasyPG (< 0.0.6). + (mml2015-always-trust): New user option. + (mml2015-epg-passphrase-callback): Display key ID on the passphrase + prompt. + +2006-11-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * nntp.el (nntp-authinfo-force): New variable. + (nntp-send-authinfo): Use it. + 2006-11-09 Reiner Steib <Reiner.Steib@gmx.de> - * message.el: Merge from the trunk to fix the bug WRT double encoded - subjects. - (message-replacement-char): New variable. - (message-fix-before-sending): Use it. - (message-simplify-subject): New function to remove duplicate code. - (message-reply, message-followup): Use it. - (message-simplify-subject-functions): New variable. - (message-strip-subject-encoded-words): New function. + * message.el (message-strip-subject-encoded-words): Allow _not_ to + decode encoded words. Improve prompt. Add comment about forwarding. + (message-replacement-char): Move up. 2006-11-08 Wolfgang Jenkner <wjenkner@inode.at> (tiny change) @@ -612,6 +1788,19 @@ instead of gnus-intersection because arguments of gnus-sorted-nunion must be sorted. This avoids corruption of gnus-newsgroup-unreads. +2006-11-07 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-strip-subject-encoded-words): Reformat prompt. + (message-simplify-subject-functions): Enable + message-strip-subject-encoded-words by default. + +2006-11-06 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-strip-subject-encoded-words): New function + (message-simplify-subject-functions): New variable. + (message-simplify-subject): Use it. Fix typo in doc string. + Support message-strip-subject-encoded-words. + 2006-11-03 Juanma Barranquero <lekktu@gmail.com> * gnus-diary.el (gnus-diary-delay-format-function): @@ -647,6 +1836,12 @@ * gnus-agent.el (gnus-agent-make-mode-line-string): Make it compatible with Emacs 21 and XEmacs. +2006-10-27 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-parse-address): New function for better parsing, + catching errors, etc. + (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use it. + 2006-10-26 Reiner Steib <Reiner.Steib@gmx.de> * mm-view.el: Add interactive arg to html2text autoload. @@ -655,6 +1850,27 @@ * gnus-sum.el (gnus-summary-move-article): Use no-encode for `B B'. +2006-10-24 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list): New + variables. + (mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions. + (mm-charset-synonym-alist): Move some entries to + mm-codepage-iso-8859-list. + + * gnus.el (gnus-getenv-nntpserver, gnus-select-method): Autoload. + +2006-10-23 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-citation-line-format) + (message-insert-formated-citation-line): Fix implementation of %E, %N + and %n according to the doc string. + +2006-10-20 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use + car-safe to avoid bad parses. + 2006-10-20 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-group.el (gnus-group-make-doc-group): Work for non-ASCII group @@ -664,12 +1880,32 @@ 2006-10-19 Katsumi Yamaoka <yamaoka@jpl.org> - * message.el (message-headers-to-generate): Fix typo in docstring. + * gnus-draft.el (gnus-draft-edit-message): Make sure to remove Date + header. + + * message.el (message-draft-headers): Add Date. + (message-headers-to-generate): Fix typo in docstring. + + * nndraft.el (nndraft-required-headers): New variable. + (nndraft-generate-headers): Use it. + + * gnus-registry.el (gnus-registry-wash-for-keywords): Bind `word'. + +2006-10-16 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-wash-for-keywords) + (gnus-registry-find-keywords): New functions to allow easy searching of + articles that are in the registry. + +2006-10-16 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use + ietf-drums-parse-address instead of gnus-extract-address-components. + Reported by Damien Elmes <damien@repose.cx>. 2006-10-19 Reiner Steib <Reiner.Steib@gmx.de> * gnus.el (gnus-mime): Remove unused custom group. - (gnus-getenv-nntpserver, gnus-select-method): Autoload. 2006-10-13 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> @@ -693,36 +1929,50 @@ 2006-10-04 Reiner Steib <Reiner.Steib@gmx.de> + * mm-util.el (mm-charset-synonym-alist, mm-charset-override-alist): Add + iso-8859-8/windows-1255 and iso-8859-9/windows-1254. + + * nnheader.el (nnheader-find-file-noselect): Inhibit version-control. + + * message.el (message-replacement-char): New variable. + (message-fix-before-sending): Use it. + (message-simplify-subject): New function to remove duplicate code. + (message-reply, message-followup): Use it. + * gnus-sum.el (gnus-summary-make-menu-bar): Clarify gnus-summary-limit-to-articles. -2006-10-04 Romain Francoise <romain@orebokech.com> +2006-10-03 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-util.el (gnus-alist-to-hashtable, gnus-hashtable-to-alist): - Moved here (and renamed) from gnus-registry.el. + * gnus-util.el (gnus-with-local-quit): New macro. - * gnus-registry.el: Require gnus-util. - Use `gnus-alist-to-hashtable' and `gnus-hashtable-to-alist'. + * gnus-demon.el (gnus-demon): Replace with-local-quit with it. -2006-10-04 Reiner Steib <Reiner.Steib@gmx.de> +2006-10-02 Teodor Zlatanov <tzz@lifelogs.com> - * pop3.el (pop3-authentication-scheme): Clarify doc. - (pop3-movemail): Warn about pop3-leave-mail-on-server. + * gnus-util.el (gnus-string-remove-all-properties): Another fix to + ignore non-string data. -2006-10-04 Dave Love <fx@gnu.org> +2006-09-29 Teodor Zlatanov <tzz@lifelogs.com> - * pop3.el (pop3-authentication-scheme): Add custom version. + * gnus-util.el (gnus-string-remove-all-properties): Fix to ignore + non-string data (needs to be done in the registry too). -2006-10-04 Jesper Harder <harder@ifa.au.dk> +2006-09-28 Teodor Zlatanov <tzz@lifelogs.com> - * pop3.el (pop3-leave-mail-on-server): Don't quote nil in - doc string. Improve doc string. + * gnus-registry.el (gnus-registry-save, gnus-registry-cache-save) + (gnus-registry-remove-alist-text-properties, gnus-registry-action) + (gnus-registry-split-fancy-with-parent) + (gnus-registry-fetch-simplified-message-subject-fast) + (gnus-registry-fetch-sender-fast, gnus-registry-store-extra-entry): + Remove text properties on ingress into the registry and when it's saved. + (gnus-registry-clean-empty-function): Fix bug with cleaning the + registry from entries with no groups. -2006-10-03 Katsumi Yamaoka <yamaoka@jpl.org> +2006-09-28 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-util.el (gnus-with-local-quit): New macro. - - * gnus-demon.el (gnus-demon): Replace with-local-quit with it. + * gnus-util.el (gnus-string-remove-all-properties): Add utility + function to remove string properties. 2006-09-28 Reiner Steib <Reiner.Steib@gmx.de> @@ -733,10 +1983,35 @@ * gnus-draft.el (gnus-draft-mode): Don't call `mml-mode'. +2006-09-27 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-insert-prev-page-button) + (gnus-insert-next-page-button): Simplify. Reformat. + +2006-09-27 Maxime Edouard Robert Froumentin <max@lapin-bleu.net> + + * gnus-art.el (gnus-insert-prev-page-button) + (gnus-insert-next-page-button): Apply gnus-article-button-face. + 2006-09-25 Chong Yidong <cyd@stupidchicken.com> * gnus-demon.el (gnus-demon): Use with-local-quit to avoid hangs. +2006-09-20 Maxime Edouard Robert Froumentin <max@lapin-bleu.net> + + (gnus-insert-mime-button, gnus-insert-mime-security-button): Apply + gnus-article-button-face to MIME and security buttons. + +2006-09-20 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-button-url-regexp): Try to make the value more + readable. + +2006-09-20 Steve Youngs <steve@sxemacs.org> + + * gnus-art.el (gnus-article-browse-html-parts): They're files, so use + `browse-url-of-file' instead of `browse-url'. + 2006-09-19 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * nnslashdot.el (nnslashdot-request-article): Update end-of-article @@ -744,31 +2019,67 @@ 2006-09-16 Katsumi Yamaoka <yamaoka@jpl.org> - * message.el (message-cite-original-without-signature): Use nobody by - default for the value of From header. - (message-cite-original): Ditto. + * message.el (message-cite-original-1): Use nobody by default for the + value of From header. (message-reply): Ditto. +2006-09-11 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-clear-decrypt): Don't append verify results + to the gnus-info. This fixes a bug of inline-PGP message verification. + Reported by Michael Piotrowski <mxp@dynalabs.de>. + 2006-09-09 Reiner Steib <Reiner.Steib@gmx.de> * pop3.el (pop3-leave-mail-on-server): Mention problem of duplicate mails in the doc string. Add some URLs in comment. + (pop3-movemail): Warn about pop3-leave-mail-on-server. 2006-09-07 Katsumi Yamaoka <yamaoka@jpl.org> * rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings): Fix backslashes handling and the way to find boundaries of quoted strings. +2006-09-07 Daiki Ueno <ueno@unixuser.org> + + * mml1991.el (mml1991-epg-encrypt): Simply throw an error if + mml1991-encrypt-to-self is set and mml1991-signers is not set. + * mml2015.el (mml2015-epg-encrypt): Simply throw an error if + mml2015-encrypt-to-self is set and mml2015-signers is not set. + 2006-09-06 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-art.el (gnus-button-regexp, gnus-button-marker-list) - (gnus-button-last): Move up. Convert comments into doc strings. + * gnus-art.el (gnus-button-marker-list): Move up. Convert comment into + doc string. + (gnus-button-regexp, gnus-button-last): Remove unused variables. + +2006-09-06 Simon Josefsson <jas@extundo.com> + + * mml2015.el (mml2015-use): Doc fix, mention epg. + +2006-09-06 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-use): Default to epg, if available. + +2006-09-06 Daiki Ueno <ueno@unixuser.org> + + * mml1991.el (mml1991-epg-sign): Don't lookup a private key by + message-sender. + (mml1991-epg-encrypt): Ditto. + * mml2015.el (mml2015-epg-sign): Don't lookup a private key by + message-sender. + (mml2015-epg-encrypt): Ditto. 2006-09-04 Chong Yidong <cyd@stupidchicken.com> * message.el (message-send-mail-with-sendmail): Look for sendmail in several common directories. +2006-09-05 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-encrypt): Expand group configuration. + * mml1991.el (mml1991-epg-encrypt): Expand group configuration. + 2006-09-04 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (article-decode-encoded-words): Make it fast. @@ -810,16 +2121,36 @@ (rfc2047-decode-address-region): New function. (rfc2047-decode-address-string): New function. -2006-08-23 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> - - [ Backported bug fix from No Gnus. ] - - * gnus.el (gnus-find-method-for-group): On killed/unknown groups, try - looking up the method using GROUP's prefix before inventing a new one. - It is used on killed/unknown groups in various places where returning - an all-new method isn't expected by the caller. - - * gnus-util.el (gnus-group-server): Copy required macro from No Gnus. +2006-08-31 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-caesar-buffer-body): Allow rotating headers. + + * gnus-sum.el (gnus-summary-caesar-message): Allow rotating headers. + + * message.el (message-insert-formated-citation-line): Fix %f. + Reported by Torsten Bronger <bronger@physik.rwth-aachen.de> . + +2006-08-18 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-bookmark.el (gnus-bookmark-file-coding-system): New variable. + (gnus-bookmark-mouse-available-p): New macro. + (gnus-bookmark-bmenu-list): Use it; use gnus-mouse-2. + (gnus-bookmark-bmenu-show-infos): Use it. + (gnus-bookmark-insert-details): Use it; use gnus-mouse-2. + (gnus-bookmark-bmenu-hide-infos): Ditto. + (gnus-bookmark-remove-properties): New function. + (gnus-bookmark-set, gnus-bookmark-make-cell): Use it. + (gnus-bookmark-set-bookmark-name): Don't use 2nd arg of split-string. + (gnus-bookmark-write-file): Bind coding-system-for-write. + (gnus-bookmark-insert-file-format-version-stamp): Add coding cookie. + (gnus-bookmark-jump): Make completing-read work with XEmacs; activate + group before selecting it. + (gnus-bookmark-get-bookmark): Use assoc instead of assoc-string. + (gnus-bookmark-bmenu-mode-map): Bind `q' to bury-buffer instead of + quit-window if it is not available; use gnus-mouse-2 and bind it to + gnus-bookmark-bmenu-select-by-mouse. + (gnus-bookmark-show-details): Remove unused variable `details-list'. + (gnus-bookmark-bmenu-select-by-mouse): New function. 2006-08-13 Romain Francoise <romain@orebokech.com> @@ -849,11 +2180,66 @@ * nnheader.el (nnheader-insert-head): Make it work with Mac as well. +2006-07-28 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-epg-sign): If mml2015-signers is not set, use the + first matching secret key. + (mml2015-epg-encrypt): Ditto. + + * mml1991.el (mml1991-epg-sign): If mml1991-signers is not set, use the + first matching secret key. + (mml1991-epg-encrypt): Ditto. + + * mml2015.el (mml2015-encrypt-to-self): New user option. + (mml2015-epg-encrypt): Append mml2015-signers to recipients list if + mml2015-epg-encrypt-to-self is set. + + * mml1991.el (mml1991-encrypt-to-self): New variable. + (mml1991-epg-encrypt): Append mml1991-signers to recipients list if + mml1991-epg-encrypt-to-self is set. + + * mml2015.el (mml2015-signers): New user option. + (mml2015-epg-sign): Reflect the value of mml2015-signers. + (mml2015-epg-encrypt): Allow to select signing keys. + + * mml1991.el (mml1991-signers): New variable. + (mml1991-epg-sign): Reflect the value of mml1991-signers. + (mml1991-epg-encrypt): Allow to select signing keys. + 2006-07-27 Katsumi Yamaoka <yamaoka@jpl.org> * nnheader.el (nnheader-insert-head): Make it work even if the file uses CRLF for the line-break code. +2006-07-25 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el: Require mml-sec instead of password. + (mml2015-verbose): Inherit the default value from mml-secure-verbose. + (mml2015-cache-passphrase): Inherit the default value from + mml-secure-cache-passphrase. + (mml2015-passphrase-cache-expiry): Inherit the default value from + mml-secure-passphrase-cache-expiry. + + * mml1991.el: Require mml-sec instead of password. + (mml1991-verbose): Inherit the default value from mml-secure-verbose. + (mml1991-cache-passphrase): Inherit the default value from + mml-secure-cache-passphrase. + (mml1991-passphrase-cache-expiry): Inherit the default value from + mml-secure-passphrase-cache-expiry. + + * mml-sec.el: Require password. + (mml-secure-verbose): New user option. + (mml-secure-cache-passphrase): New user option. + (mml-secure-passphrase-cache-expiry): New user option. + +2006-07-24 Daiki Ueno <ueno@unixuser.org> + + * pgg-def.el (pgg-truncate-key-identifier): Truncate the key ID to 8 + letters from the end. Thanks to "David Smith" <davidsmith@acm.org> and + andreas@altroot.de (Andreas V,Av(Bgele) + + FIXME: Use `tiny change'? + 2006-07-19 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * mm-url.el (mm-url-insert-file-contents): Inhibit Connection: close @@ -861,25 +2247,17 @@ * nnweb.el (nnweb-google-create-mapping): Update regexp. +2006-07-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-select-newsgroup): Setup the article buffer + correctly. This fixes a bug caused by the 2006-05-12 change. + 2006-07-18 Karl Fogel <kfogel@red-bean.com> * nnmail.el (nnmail-article-group): If splitting raises an error, give some information about the error when saying that the `bogus' mail group will be used. -2006-07-18 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> - - [ Backported bug fixes from No Gnus. ] - - * nnweb.el (nnweb-google-parse-1): Update regexp for author and date. - (nnweb-google-search): Respect nnweb-max-hits as upper bound. - (nnweb-request-article): Do proper xwfu encoding when fetching articles - by message-id. - - * gnus-srvr.el (gnus-browse-unsubscribe-group): Don't subscribe - unsubscribed groups as if they were killed ones. It causes duplicate - entries in gnus-newsrc-alist. - 2006-07-17 Reiner Steib <Reiner.Steib@gmx.de> * gnus-sum.el (gnus-summary-delete-article): Don't use TAB in doc @@ -893,24 +2271,133 @@ * gnus-start.el (gnus-subscribe-options-newsgroup-method): Doc fix. +2006-07-10 Daiki Ueno <ueno@unixuser.org> + + * mml1991.el (mml1991-function-alist): Add epg. + (mml1991-epg-passphrase-callback, mml1991-epg-sign) + (mml1991-epg-encrypt): New functions. + +2006-07-10 Daiki Ueno <ueno@unixuser.org> + + * mml2015.el (mml2015-verbose): New variable. + (mml2015-cache-passphrase): Ditto. + (mml2015-passphrase-cache-expiry): Ditto. + (mml2015-function-alist): Add epg. + (mml2015-epg-passphrase-callback, mml2015-epg-decrypt) + (mml2015-epg-clear-decrypt, mml2015-epg-verify) + (mml2015-epg-clear-verify, mml2015-epg-sign, mml2015-epg-encrypt): New + functions. + +2006-07-08 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * message.el (message-cite-original-1): Preserve region when removing + quoted text due to X-No-Archive in order to avoid bogus attribution + when citing multiple messages. + +2006-06-27 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * gnus-group.el (gnus-group-sort-by-unread): Fix typo. Reported by + Kenneth Jacker <khj@be.cs.appstate.edu>. + 2006-06-26 Reiner Steib <Reiner.Steib@gmx.de> * gnus-diary.el (gnus-user-format-function-d) (gnus-user-format-function-D): Autoload. -2006-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + * imap.el (Commentary): Fix typo. - * gnus-group.el (gnus-group-select-group): Doc fix. - [ See 2004-05-19 change on the trunk. ] + * gnus-util.el (kill-empty-logs, gnus-byte-compile): Remove anonymous + 2006-04-22 contribution. + +2006-06-26 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * gnus.el (gnus-valid-select-methods): Revert last change for nnweb. + It didn't really fix the bogosity I'm seeing with solid web groups. + +2006-06-26 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * gnus.el (gnus-valid-select-methods): Declare nnweb with 'address. + Since revision 6.95 (2003-01-05) of gnus-group.el, solid web groups are + created using server names. If we use the feature without declaring + it, Gnus does not properly manage server and group state. + + * nnweb.el (nnweb-google-search): Respect nnweb-max-hits as upper + bound. + +2006-06-25 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * gnus.el (gnus-find-method-for-group): On killed/unknown groups, try + looking up the method using GROUP's prefix before inventing a new one. + It is used on killed/unknown groups in various places where returning + an all-new method isn't expected by the caller. + + * gnus-util.el (gnus-group-server): Fix for empty virtual server names + and match semantics of gnus-group-real-prefix. + +2006-06-22 Reiner Steib <Reiner.Steib@gmx.de> + + * nnmail.el (nnmail-broken-references-mailers): New variable. + (nnmail-ignore-broken-references): New function generalizing + nnmail-fix-eudora-headers. + (nnmail-fix-eudora-headers): Now obsolete. + + * gnus-art.el (gnus-button-handle-custom): Support + `customize-apropos*'. + +2006-06-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (article-hide-headers): Inhibit read-only stuff. + + * gnus-group.el (gnus-fetch-group): Document ARTICLES and select those + articles. + +2006-06-21 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-cite-reply-above): New variable. + (message-yank-original): Use it. 2006-06-20 Katsumi Yamaoka <yamaoka@jpl.org> * rfc2231.el (rfc2231-parse-string): Allow `*'s in parameter values. +2006-06-20 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-bookmark.el (gnus-bookmark-jump): Don't mark unrelated articles + as read. + + * gnus-group.el (gnus-group-quick-select-group): Add GROUP argument. + +2006-06-19 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-bookmark.el: Fix Copyright, keywords, whitespace, etc. + (gnus-bookmark-default-file): Use gnus-directory. + (gnus-bookmark-bmenu-file-column, gnus-bookmark-use-annotations): + Remove "*" in doc string. + (gnus-bookmark-write-file): Simplify. + (gnus-bookmark-maybe-sort-alist): Use `when'. + (gnus-bookmark-get-bookmark): Fix typo in doc string. + (gnus-bookmark-set-bookmark-name, gnus-bookmark-get-bookmark): Add + FIXME about Emacs 21 and XEmacs compatibility. + (gnus-bookmark-set-bookmark-name): Use `gnus-replace-in-string' for + compatibility. + (gnus-bookmark-bmenu-mode): Use `gnus-run-mode-hooks' for + compatibility. + (gnus-bookmark-menu-heading): Fix version. + +2006-06-19 Bastien Guerry <bzg@altern.org> + + * gnus-bookmark.el: New file. + 2006-06-19 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-syntax-checks): Doc fix. +2006-06-17 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * gnus-srvr.el (gnus-browse-unsubscribe-group): Don't subscribe + unsubscribed groups as if they were killed ones. It causes duplicate + entries in gnus-newsrc-alist. + 2006-06-16 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-syntax-checks): Doc fix. @@ -922,18 +2409,42 @@ * gnus-art.el (gnus-display-mime): Make sure body ends with newline. +2006-06-11 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-toggle-truncate-lines): Fix code. + +2006-06-11 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-truncate-lines): Default to the value of + default-truncate-lines. + 2006-06-06 Katsumi Yamaoka <yamaoka@jpl.org> * mm-util.el (mm-mime-mule-charset-alist): Use unicode-precedence-list to fill the utf-8 entry. -2006-06-05 Dan Christensen <jdc@uwo.ca> +2006-06-01 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> - * gnus-sum.el (gnus-summary-read-group-1): When summary is unthreaded, - respect display group parameter and gnus-summary-expunge-below. - (gnus-articles-to-read): Remove unused reference to display group - parameter. - [ Merge 2004-07-06 change from the trunk. ] + * nnweb.el (nnweb-google-parse-1): Update regexp for author and date. + +2006-05-30 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-agent.el (directory-files-and-attributes): Move all the way + forward (the third and final move). + (gnus-agent-read-agentview): Trap reconstruction errors due to + nonexistant directory. Handle by returning nil. + +2006-05-30 Didier Verna <didier@xemacs.org> + + * message.el (message-dont-reply-to-names): Update the custom type. + * message.el (message-dont-reply-to-names): New defsubst: potentially + convert a list of regexps into a single one. + * message.el (message-get-reply-headers): Use it. + * nnmail.el (nnmail-fancy-expiry-target): Ditto. + +2006-05-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (directory-files-and-attributes): Move forward. 2006-05-29 Reiner Steib <Reiner.Steib@gmx.de> @@ -946,64 +2457,162 @@ * gnus-ml.el (gnus-mailing-list-message): Use gnus-url-mailto instead of doing it manually. +2006-05-29 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-toggle-truncate-lines): Fix typo in + comment. + 2006-05-29 Kevin Greiner <kevin.greiner@compsol.cc> - * gnus-agent.el (gnus-agent-possibly-synchronize-flags): A server - must be explicitly online rather than "not explicitly offline" for - its flags to be synchronized. + * gnus-agent.el (Added gnus-agent-flush*) to purge agent info. + (gnus-agent-read-agentview): Fixed handling of end-of-file error. (gnus-agent-read-local): All symbols allocated in my-obarray (gnus-agent-set-local): Skip invalid entries (min and/or max is nil). (gnus-agent-regenerate-group): Check numeric names to see if they are messages or groups. + (gnus-agent-total-fetched-for): Ignore 'dummy.group' (there should be a + better way of do this...) + + * gnus-cache.el (gnus-agent-total-fetched-for): Ignore + 'dummy.group' (there should be a better way of do this...) 2006-05-29 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-save-all-headers): Mention it might be overridden. (gnus-saved-headers): Ditto. - (gnus-default-article-saver): Doc fix; add - gnus-summary-write-body-to-file; mention functions may have properties. - (gnus-article-save-coding-system): New variable. + (gnus-default-article-saver): Mention functions may have properties. (gnus-article-save): Override gnus-save-all-headers and gnus-saved-headers by :headers property which saver function may have. + (gnus-summary-save-in-file): Add :headers property. + (gnus-summary-write-to-file): Ditto. + + * gnus-sum.el (gnus-summary-save-article): Bind + gnus-prompt-before-saving to t when saving many articles in a file; + always show all headers. + +2006-05-26 Reiner Steib <Reiner.Steib@gmx.de> + + * deuglify.el (gnus-outlook-rearrange-article): Add missing citation + marks. + + * message.el (message-indent-citation): Add optional arguments to allow + using it outside of message buffers. + + * gnus-art.el (gnus-article-unfold-long-headers): New variable. + (gnus-article-treat-unfold-headers): Use it. + (gnus-article-truncate-lines): New variable. + (gnus-article-mode): Use it. + (gnus-article-toggle-truncate-lines): New function. + + * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): Add + gnus-article-toggle-truncate-lines. + + * uudecode.el (uudecode-decode-region-external): nil isn't a valid + coding system in XEmacs, use binary. + +2006-05-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-enrich-utf-8-by-mule-ucs): Don't edit + after-load-alist. + + * gnus-art.el (gnus-summary-save-in-file): Use property to specify + this function should save decoded articles. + (gnus-summary-write-to-file): Use property to specify this function + should save decoded articles and specify gnus-summary-save-in-file + should be used to save articles other than the first one when saving + many articles. + (gnus-summary-save-body-in-file): Use property to specify this + function should save decoded articles. + (gnus-summary-write-body-to-file): Use property to specify this + function should save decoded articles and specify + gnus-summary-save-body-in-file should be used to save articles other + than the first one when saving many articles. + + * gnus-sum.el (gnus-summary-save-article): Simplify. + +2006-05-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-default-article-saver): Add + gnus-summary-write-body-to-file. + (gnus-article-save-coding-system): Don't use coding system object + in XEmacs. (gnus-read-save-file-name): Add optional `dir-var' argument which specifies directory in which files are saved; work even if optional `variable' argument is not specified. - (gnus-summary-save-in-file): Add properties :decode and :headers. - (gnus-summary-write-to-file): Add properties :decode, :function, and - :headers; read file name. - (gnus-summary-save-body-in-file): Add :decode property; add optional - `overwrite' argument. - (gnus-summary-write-body-to-file): New function; add properties - :decode and :function. - (gnus-output-to-file): Add coding cookie and encode text according - to gnus-article-save-coding-system; don't use mm-append-to-file. + (gnus-summary-write-to-file): Read file name. + (gnus-summary-save-body-in-file): Add optional `overwrite' argument. + (gnus-summary-write-body-to-file): New function. * gnus-sum.el (gnus-newsgroup-last-directory): New variable. (gnus-summary-local-variables): Add it. (gnus-summary-save-map): Add gnus-summary-write-article-body-file. - (gnus-summary-save-article): Require gnus-art; save decoded articles - if function that gnus-default-article-saver specifies has `:decode' - property; bind gnus-prompt-before-saving to t when saving many - articles in a file; move point to article which will be saved. + (gnus-summary-save-article): Remove optional `decode' argument; + determine whether to decode articles by the value of + gnus-default-article-saver; when saving many files using + gnus-summary-write-to-file or gnus-summary-write-body-to-file, use + it first and use gnus-summary-save-in-file or + gnus-summary-save-body-in-file thereafter unless + gnus-prompt-before-saving is always; move point to article which + will be saved. + (gnus-summary-save-article-file): Revert. + (gnus-summary-write-article-file): Revert. + (gnus-summary-save-article-body-file): Revert. (gnus-summary-write-article-body-file): New function. 2006-05-26 Reiner Steib <Reiner.Steib@gmx.de> - * uudecode.el (uudecode-decode-region-external): Fix previous commit. + * gnus-art.el (gnus-article-browse-html-article): Remove comment. -2006-05-26 Katsumi Yamaoka <yamaoka@jpl.org> +2006-05-24 Katsumi Yamaoka <yamaoka@jpl.org> - * mm-util.el (mm-enrich-utf-8-by-mule-ucs): Don't edit - after-load-alist. + * gnus-art.el (gnus-default-article-saver): Doc fix. + (gnus-article-save-coding-system): Move from gnus-sum.el, rename + from gnus-summary-save-article-coding-system, and default to a + certain coding system. + (gnus-output-to-file): Add coding cookie and encode text according + to gnus-article-save-coding-system; don't use mm-append-to-file. -2006-05-22 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-sum.el (gnus-summary-save-article-coding-system): Move to + gnus-art.el and rename to gnus-article-save-coding-system. + (gnus-summary-save-article): Require gnus-art; don't show all + headers if it decodes articles; don't add coding cookie here; + don't bind mm-text-coding-system-for-write. + (gnus-summary-save-article-file): Save decoded articles. + (gnus-summary-write-article-file): When saving many files, use + gnus-summary-write-to-file first and gnus-summary-save-in-file + thereafter unless gnus-prompt-before-saving is always. + (gnus-summary-save-article-body-file): Save decoded articles. - * uudecode.el (uudecode-decode-region-external): nil isn't a valid - coding system in XEmacs, use binary. +2006-05-23 Reiner Steib <Reiner.Steib@gmx.de> - * mail-source.el (mail-sources): Fix custom type. + * nnrss.el (nnrss-check-group): Bind hash-index. - * imap.el (Commentary): Fix typo. +2006-05-23 Micha,Ak(Bl Cadilhac <michael.cadilhac@lrde.org> + + * nnrss.el (nnrss-check-group): Use the md5sum of the whole RSS item as + its hash index. Store this hash in `nnrss-group-data'. + (nnrss-read-group-data): Update accordingly. + +2006-05-23 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-button-alist): Improve gnus-button-handle-symbol + entry. + + * gnus-sum.el (gnus-summary-make-menu-bar): Add + gnus-article-browse-html-article. + +2006-05-23 Hynek Schlawack <hynek@ularx.de> + + * gnus-sum.el (gnus-summary-mime-map): Add + gnus-article-browse-html-article. +2006-05-23 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-save-article-coding-system): Offer some + suitable coding systems in customize. + +2006-05-22 Reiner Steib <Reiner.Steib@gmx.de> + + * mail-source.el (mail-sources): Fix custom type. 2006-05-18 Reiner Steib <Reiner.Steib@gmx.de> @@ -1015,6 +2624,41 @@ (gmm-image-search-load-path): Use it. (gmm-image-load-path-for-library): Use it. Sync with `mh-compat.el'. +2006-05-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-save-article-coding-system): New + variable. + (gnus-summary-save-article): Add optional `decode' argument. If + it is set and gnus-summary-save-article-coding-system is non-nil, + save decoded article. + (gnus-summary-write-article-file): Save decoded article if + gnus-summary-save-article-coding-system is non-nil. + + * ecomplete.el (ecomplete-database-file-coding-system): Fix custom + type. + +2006-05-16 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (easy-menu-define): Use :active instead of :enable. + +2006-05-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-setup-buffer): Go to summary buffer + first to test gnus-single-article-buffer which may be buffer-local. + + * gnus-sum.el (gnus-summary-setup-buffer): Make + gnus-single-article-buffer buffer-local and nil in ephemeral + group; make gnus-article-buffer, gnus-article-current, and + gnus-original-article-buffer always buffer-local. + (gnus-summary-exit): Kill article buffer belonging to ephemeral + group. + (gnus-handle-ephemeral-exit): Don't move to next summary line. + +2006-05-08 Reiner Steib <Reiner.Steib@gmx.de> + + * nnml.el (nnml-request-compact-group): Compressed files might not + have .gz extension. + 2006-05-04 Stefan Monnier <monnier@iro.umontreal.ca> * mm-decode.el (mm-dissect-buffer): Remove spurious double assignment. @@ -1022,17 +2666,63 @@ (mm-display-part): Simplify. (mm-inlinable-p): Add optional arg `type'. +2006-05-03 Stefan Monnier <monnier@iro.umontreal.ca> + * gnus-art.el (gnus-mime-view-part-as-type): Add optional PRED arg. (gnus-mime-view-part-externally, gnus-mime-view-part-internally): Try harder to show the attachment internally or externally using gnus-mime-view-part-as-type. -2006-05-04 Reiner Steib <Reiner.Steib@gmx.de> +2006-05-02 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-art.el (gnus-mime-view-part-as-type-internal): Try to fetch - `filename' from Content-Disposition if Content-Type doesn't - provide `name'. - (gnus-mime-view-part-as-type): Set default instead of initial-input. + * message.el (message-from-style, message-signature-separator) + (message-user-organization-file, message-send-mail-function) + (message-citation-line-function, message-yank-prefix) + (message-indent-citation-function, message-signature) + (message-signature-file, message-signature-insert-empty-line): + Remove autoloads. + + * gnus-art.el (gnus-buttonized-mime-types): Remove + "multipart/signed". Revert 2006-04-26 change. + +2006-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-version-number): Bump version. + +2006-05-01 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no> + + * gnus.el: No Gnus v0.5 is released. + +2006-04-30 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * nnweb.el (nnweb-request-article): Do proper xwfu encoding when + fetching articles by message-id. + +2006-04-30 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (hashcash): Require hashcash as normal. + + * ecomplete.el (ecomplete-highlight-match-line): Use + point-at-eol. + (ecomplete-highlight-match-line): Use `highlight', because that + face exists in both Emacs and XEmacs. + + * message.el (message-display-abbrev): Use point-at-bol. + + * mail-source.el: Don't require timer/timer-funcs. + + * gnus-async.el: Ditto. + + * password.el: Ditto. + + * mm-url.el: Ditto. + + * mm-util.el: Require timer/timer-funcs. + +2006-04-23 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * mm-url.el (mm-url-insert-file-contents): Don't set Connection: + Close. 2006-04-28 Katsumi Yamaoka <yamaoka@jpl.org> @@ -1050,26 +2740,34 @@ 2006-04-26 Reiner Steib <Reiner.Steib@gmx.de> - * deuglify.el (gnus-outlook-deuglify-unwrap-min) - (gnus-outlook-deuglify-unwrap-max): Remove autoload. + * message.el (message-user-organization-file): Check several + locations of the organization file. - * mml-sec.el (mml-secure-method): New internal variable. - (mml-secure-sign, mml-secure-encrypt, mml-secure-message-sign) - (mml-secure-message-sign-encrypt, mml-secure-message-encrypt): - New functions using mml-secure-method. Sync from the trunk. + * gnus-sum.el (gnus-summary-mime-map, gnus-summary-make-menu-bar): + Add gnus-article-view-part-as-type. - * mml.el (mml-mode-map): Add key bindings for those functions. - (mml-menu): Simplify security menu entries. Suggested by Jesper - Harder <harder@myrealbox.com>. Sync from the trunk. + * gnus-art.el (gnus-article-view-part-as-type): New function. * message.el (message-valid-fqdn-regexp): Add TLDs .cat, jobs, .mobi and .travel. Remove .nato, .bitnet and .uucp. - (message-in-body-p): New function. Sync from the trunk. - * mml.el (mml-mode, mml-dnd-protocol-alist) - (mml-dnd-attach-options, mml-dnd-attach-file) - (mml-attach-file, mml-attach-buffer, mml-attach-external): - Sync DND support and use of message-in-body-p from the trunk. + * mml.el: Simplify autoload. + (mml-mode): defvar dnd-protocol-alist instead of using + symbol-value. + (mml-default-directory): New variable. + (mml-minibuffer-read-file): Use it. + (mml-dnd-protocol-alist, mml-dnd-attach-options): Adjust :version. + + * message.el (message-citation-line-format): New variable. + (message-insert-formated-citation-line): New function. + (message-citation-line-function): Add + `message-insert-formated-citation-line' to custom type. + + * mm-decode.el (mm-verify-option): Add gnus-buttonized-mime-types + to doc string. + + * gnus-art.el (gnus-buttonized-mime-types): Add "multipart/signed" + depending on mm-verify-option. 2006-04-26 Katsumi Yamaoka <yamaoka@jpl.org> @@ -1083,12 +2781,10 @@ lines at the top of body; use gnus-newsgroup-charset if there's no Charset header. -2006-04-25 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> - - * nnweb.el (nnweb-google-wash-article): Sync up to new Google HTML. - 2006-04-25 Katsumi Yamaoka <yamaoka@jpl.org> + * message.el (message-self-insert-commands): Doc fix. + * mm-uu.el (mm-uu-pgp-signed-test): Erase prompt. (mm-uu-pgp-encrypted-test): Ditto. (mm-uu-pgp-encrypted-extract-1): Make sure there's a blank line @@ -1098,6 +2794,47 @@ * mm-decode.el (mm-automatic-display): Don't make application/pgp element match to application/pgp-*. +2006-04-23 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * nnweb.el (nnweb-google-wash-article): Sync up to new Google + HTML. + +2006-04-23 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mail-source.el (mail-source-call-script): Message the error + string. + +2006-04-22 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-util.el (gnus-byte-compile): Use it. + +2006-04-22 xyblor <fake@invalid.email> (Tiny change.) + + * gnus-util.el (kill-empty-logs): New function. + +2006-04-22 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-mail-alias-type): Doc fix. + (message-mail-alias-type-p): New function. + (message-send): Use it. + (message-mode): Ditto. + (message-strip-forbidden-properties): Ditto. + + * ecomplete.el (ecomplete-database-file-coding-system): New + variable. + (ecomplete-save): Use it. + (ecomplete-setup): Use it. + +2006-04-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-self-insert-commands): New variable. + (message-strip-forbidden-properties): Use it. + +2006-04-22 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-put-addresses-in-ecomplete): Use a regexp + that doesn't make XEmacs choke. + 2006-04-20 Reiner Steib <Reiner.Steib@gmx.de> * gnus-util.el (gnus-replace-in-string): @@ -1105,67 +2842,299 @@ 2006-04-20 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-group.el: Bind tool-bar-mode instead of tool-bar-map. - - * gnus-sum.el: Ditto. - * gnus-util.el (gnus-select-frame-set-input-focus): Use select-frame-set-input-focus if it is available in XEmacs; use definition defined in Emacs 22 for old Emacsen. +2006-04-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-view.el (mm-inline-text): Use equal instead of equalp. + +2006-04-18 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-cache-save): Remove text + properties when saving via the temp buffer. + +2006-04-18 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-generate-hashcash): Honor custom type. + +2006-04-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-generate-hashcash): Default to non-nil when + hashcash is found. + + * gnus-sum.el (gnus-summary-expire-articles-now): Clarify prompt. + (gnus-refer-thread-limit): Increase default to 500. + + * mm-view.el (mm-inline-text): Supply delsp to flow-fill. + + * flow-fill.el (fill-flowed): Allow delete-space. + +2006-04-18 Reiner Steib <Reiner.Steib@gmx.de> + + * deuglify.el (gnus-outlook-deuglify-unwrap-min) + (gnus-outlook-deuglify-unwrap-max, gnus-outlook-display-hook): + Remove autoloads. + +2006-04-18 Simon Josefsson <jas@extundo.com> + + * message.el (message-generate-hashcash): Default to. + +2006-04-18 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2231.el (rfc2231-parse-string): Decode encoded value after + concatenating segments rather than before concatenating them. + 2006-04-17 Reiner Steib <Reiner.Steib@gmx.de> - [ Merge from Gnus trunk. ] + * gnus-group.el: Move comment to gnus-group-update-tool-bar. - * mm-util.el (mm-charset-synonym-alist): Improve doc string. - (mm-charset-override-alist): New variable. - (mm-charset-to-coding-system): Use it. - (mm-codepage-setup): New helper function. - (mm-charset-eval-alist): New variable. - (mm-charset-to-coding-system): Use mm-charset-eval-alist. - Warn about unknown charsets. Add allow-override. - Use `mm-charset-override-alist' only when decoding. - (mm-detect-mime-charset-region): Use :mime-charset. + * imap.el (imap-quote-specials): New function. + (imap-login-auth): Quote specials. - * mm-bodies.el (mm-decode-body, mm-decode-string): - Call `mm-charset-to-coding-system' with allow-override argument. +2006-04-17 Lars Magne Ingebrigtsen <larsi@gnus.org> - * message.el (message-tool-bar-zap-list, message-tool-bar) - (message-tool-bar-gnome, message-tool-bar-retro): New variables. - (message-tool-bar-local-item-from-menu): Remove. - (message-tool-bar-map): Replace by `message-make-tool-bar'. - (message-make-tool-bar): New function. - (message-mode): Use `message-make-tool-bar'. + * rfc2231.el (rfc2231-parse-string): Sort the parameters first. - * gnus-sum.el (gnus-summary-tool-bar) - (gnus-summary-tool-bar-gnome, gnus-summary-tool-bar-retro) - (gnus-summary-tool-bar-zap-list): New variables. - (gnus-summary-make-tool-bar): Complete rewrite using - `gmm-tool-bar-from-list'. + * message.el (message-forward-make-body-plain): Allow + message-forward-ignored-headers to be a list. + (message-remove-ignored-headers): Factor out into function. + (message-forward-make-body-mml): Use it. + * rfc2231.el (rfc2231-parse-string): Remove dead code. + (rfc2231-parse-string): Allow concatanation of parameters that + aren't contiguous. The test case is + (mail-header-parse-content-type "message/external-body; + name*0*=us-ascii''~%2ffoo%2fbar%2fbaz%2fxyzzy%2f; + access-type=LOCAL-FILE; + name*1*=plugh%2fhello-sailor%2fbing.pdf") - * gnus-group.el (gnus-group-tool-bar, gnus-group-tool-bar-gnome) - (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): - New variables. - (gnus-group-make-tool-bar): Complete rewrite using - `gmm-tool-bar-from-list'. - (gnus-group-tool-bar-update): New function. +2006-04-17 Stefan Monnier <monnier@iro.umontreal.ca> - * gmm-utils.el: New file. + * nntp.el (nntp-accept-process-output): Return the value of + `nnheader-accept-process-output'. + +2006-04-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-article-treat-types): Add text/x-patch. + (gnus-button-alist): Recognize more diff formats. + (gnus-button-patch): Strip directory. + +2006-04-17 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-util.el (gnus-select-frame-set-input-focus): Check for + Emacs 22 when setting focus. + +2006-04-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-article-treat-types): Do treatment of + text/x-verbatim parts. + (gnus-button-patch): New command. + + * ietf-drums.el (ietf-drums-parse-address): Attempt parsing + addresses that contain invalid characters. + +2006-04-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-put-addresses-in-ecomplete): Use + gnus-replace-in-string. + (message-is-yours-p): Use the more correct + mail-header-parse-address instead of + mail-extract-address-components. + (message-put-addresses-in-ecomplete): Fix typo. + + * gnus-sum.el (gnus-summary-limit-to-bodies): New command and + keystroke. + + * gnus-art.el (gnus-treatment-function-alist): Change order of + newsgroups/generic header folding to avoid double-folding. + + * message.el (message-hidden-headers): Add X-Draft-From. + + * gnus-sum.el (gnus-summary-repeat-search-article-forward): New + command. + (gnus-summary-repeat-search-article-backward): New command. + + * gnus-topic.el (gnus-topic-display-missing-topic): Skip past + groups in the parent topic. + +2006-04-16 Jo,Ac(Bo Cachopo <joao.cachopo@inesc-id.pt> (tiny change) + + * spam.el (spam-necessary-extra-headers): Add X-CRM114-Status. + (spam-extra-header-to-number): Return the CRM114 number as a + number instead of a string. + +2006-04-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-face-properties-alist): Moved here from + gnus-fun. + + * gnus-fun.el (gnus-face-properties-alist): Move to gnus-art. + +2006-04-15 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-strip-forbidden-properties): Only display on + self-insert-command. + + * hashcash.el (hashcash-insert-payment-async): Remove dead code; + reindent. + (hashcash-insert-payment-async-2): Make sure the buffer is alive. + +2006-04-15 NAKAJI Hiroyuki <nakaji@takamatsu-nct.ac.jp> (tiny change) + + * smiley.el (smiley-style): Fix typo. + +2006-03-23 Kenichi Handa <handa@m17n.org> + + * rfc2231.el (rfc2231-encode-string): Use mm-disable-multibyte + instead of set-buffer-multibyte. + +2006-03-23 Kenichi Handa <handa@m17n.org> + + * rfc2231.el (rfc2231-decode-encoded-string): Work on unibyte + buffer and then decode the buffer text if necessary. + (rfc2231-encode-string): Be sure to work on multibyte buffer at + first, and after mm-encode-body, change the buffer to unibyte. + +2006-04-15 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * hashcash.el (hashcash-insert-payment-async-2): Use + message-goto-eoh instead of doing it manually. + (mail-add-payment): Use message-narrow-to-header instead of trying + to do the same itself. + + * message.el (message-hidden-headers): Add Face. + + * gnus-sum.el (gnus-summary-reparent-thread): Factor out + reparenting code. + (gnus-summary-reparent-children): Refactored out code. + (gnus-summary-thread-map): New keystroke. + (gnus-summary-reparent-children): Make into command. + + * smiley.el (smiley-style): Default to `medium' if using a large + font. + + * gnus-sum.el (unmorse-region): Remove autoload, because morse.el + does it itself. + + * message.el (message-point-in-header-p): Simplify definition. + +2006-04-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnagent.el (nnagent-request-set-mark): Silence log file + writing. + (nnagent-request-set-mark): Use write-region instead of + append-to-file. + + * gnus-sum.el (gnus-read-header): Fudge article number if using a + strange select method. + + * ecomplete.el (ecomplete-display-matches): Get highlightling + right. + (ecomplete-display-matches): Use literals. + (ecomplete-display-matches): Disable message logging. + + * message.el (message-display-abbrev): Small optimization. + + * ecomplete.el (ecomplete-display-matches): Allow automatic + display. + + * message.el (message-strip-forbidden-properties): Display + abbrevs. + (message-display-abbrev): Get automatic display right. + + * ecomplete.el (ecomplete-display-matches): Use M-n/M-p + keystrokes. + +2006-04-13 Romain Francoise <romain@orebokech.com> + + TODO: Backport to v5-10! + + * gnus-util.el (gnus-alist-to-hashtable, gnus-hashtable-to-alist): + Moved here (and renamed) from gnus-registry.el. + + * gnus-registry.el: Require gnus-util. + Use `gnus-alist-to-hashtable' and `gnus-hashtable-to-alist'. + +2006-04-13 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-catchup-current): Change + if-then-else-if-then-else into cond. + (gnus-group-catchup): Indent. + (group-name-at-point): New function. + (gnus-fetch-group): Provide default from thing at point. + +2006-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-display-abbrev): Fix regexp. + + * ecomplete.el (ecomplete-highlight-match-line): Reimplement + choosing. + (ecomplete-highlight-match-line): Fix up code rewrite, remove + dead variables. + + * message.el (message-newline-and-indent): Remove debugging. + (message-display-abbrev): Use new implementation. + +2006-04-12 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-mode): Set + cursor-in-non-selected-windows to nil. + + * smiley.el: Revert previous change. + (smiley-data-directory): defvar it before using it in the + defcustom of `smiley-style'. + +2006-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-newline-and-indent): New function. + + * ecomplete.el: Implement more bits. + + * message.el (message-put-addresses-in-ecomplete): Clean up the + string. + + * ecomplete.el (ecomplete-add-item): Chop off decimals. + + * gnus-sum.el (gnus-summary-save-parts): Bind + gnus-summary-save-parts-counter and use it to make unique file + names. + + * gnus-art.el (gnus-ignored-headers): Add some more headers. + + * ietf-drums.el (ietf-drums-parse-addresses): Take a RAWP + parameter to say whether to actually parse the individual + addresses. + + * message.el (message-put-addresses-in-ecomplete): New function. + (ecomplete): Require. + (message-mail-alias-type): Add ecomplete as an option. 2006-04-12 Ralf Angeli <angeli@iwi.uni-sb.de> * flow-fill.el (fill-flowed): Remove trailing space from blank quoted lines. -2006-04-12 Reiner Steib <Reiner.Steib@gmx.de> +2006-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * smiley.el (smiley-style): Move definition later to avoid a + compilation warning. - * gnus-art.el (gnus-article-mode): - Set cursor-in-non-selected-windows to nil. +2006-04-12 Kenichi Handa <handa@m17n.org> + + * rfc2231.el (rfc2231-decode-encoded-string): Work on unibyte + buffer and then decode the buffer text if necessary. + (rfc2231-encode-string): Be sure to work on multibyte buffer at + first, and after mm-encode-body, change the buffer to unibyte. + Use mm-disable-multibyte instead of set-buffer-multibyte. 2006-04-12 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-art.el (gnus-mime-view-part-as-charset): Ignore charset - that the part specifies. + * gnus-art.el (gnus-mime-copy-part): Find name parameter in + Content-Type header instead of Content-Disposition header. + (gnus-mime-inline-part): Ditto. + (gnus-mime-view-part-as-charset): Ignore charset that the part + specifies. * mm-decode.el (mm-display-part): Work with external parts and usual parts similarly. @@ -1173,48 +3142,149 @@ * mm-extern.el (mm-inline-external-body): Use mm-display-part instead of gnus-display-mime. + * mm-util.el (mm-decompress-buffer): Use mm-with-unibyte-buffer + instead of with-temp-buffer. + * gnus-uu.el (gnus-uu-save-article): Put mml tags instead of part tag to summarized topics part in order to encode non-ASCII text. 2006-04-11 Reiner Steib <Reiner.Steib@gmx.de> + * smiley.el (smiley-style): New variable. + (smiley-directory): New function. + (smiley-data-directory): Derive from `smiley-style' using + `smiley-directory'. + (smiley-regexp-alist): Add new entries. + * gnus-art.el (gnus-button-valid-localpart-regexp): Exclude `@'. + (gnus-article-browse-delete-temp): Add :version. 2006-04-11 Arne J,Ax(Brgensen <arne@arnested.dk> * gnus-sieve.el (gnus-sieve-generate): Delete from the start of the sieve region. +2006-04-11 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-version-number): Bump version. + 2006-04-11 Reiner Steib <Reiner.Steib@gmx.de> - * gnus.el: Gnus v5.10.8 is released. + * gnus.el: No Gnus v0.4 is released. 2006-04-11 Lars Magne Ingebrigtsen <larsi@gnus.org> - * nnslashdot.el (nnslashdot-retrieve-headers-1): Fix up to new layout. + * nnslashdot.el (nnslashdot-retrieve-headers-1): Fix up to new + layout. * rfc2047.el (rfc2047-decode-encoded-words): Don't message about unknown charset. - * message.el (message-header-synonyms): Add Original-To to the default. + * message.el (message-header-synonyms): Add Original-To to the + default. - * gnus-sum.el (gnus-get-newsgroup-headers-xover): Group is an + * gnus-sum.el (gnus-get-newsgroup-headers-xover): group is an optional parameter. 2006-04-06 Reiner Steib <Reiner.Steib@gmx.de> * gnus-fun.el (gnus): Require it for gnus-directory. +2006-04-06 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-fun.el (gnus-face-properties-alist): Add :version. + +2006-04-05 Daiki Ueno <ueno@unixuser.org> + + * pgg-gpg.el (pgg-gpg-process-filter): Fix. + +2006-04-05 Simon Josefsson <jas@extundo.com> + + * password.el (password-reset): New function. + +2006-04-05 Daiki Ueno <ueno@unixuser.org> + + * pgg-gpg.el (pgg-gpg-encrypt-region, pgg-gpg-sign-region): Wait + for BEGIN_SIGNING too, new in GnuPG 1.4.3. + 2006-04-04 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * nnweb.el (nnweb-google-create-mapping): Update regexp. Some whitespace was matched into the url, which broke browsing hits > 100 when mm-url-use-external was nil. +2006-04-04 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Check + gnus-extra-headers for 'Newsgroups. + + * message.el (message-tool-bar-gnome): Check if `flyspell-mode' is + bound. + +2006-04-04 Daiki Ueno <ueno@unixuser.org> + + * pgg-gpg.el: Clean up process buffers every time gpg processes + complete. + +2006-04-03 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-fun.el (gnus-convert-image-to-face-command): Fix typo in + doc string. + +2006-04-03 Daiki Ueno <ueno@unixuser.org> + + * pgg-gpg.el (pgg-gpg-process-filter) + (pgg-gpg-wait-for-completion): Check if buffer is alive. + + * pgg-gpg.el (pgg-gpg-process-sentinel): Don't remove GNUPG: + lines, temporary fix. + 2006-03-31 Reiner Steib <Reiner.Steib@gmx.de> * gnus-group.el (gnus-group-update-tool-bar): Add :initialize and :set. +2006-03-29 Daiki Ueno <ueno@unixuser.org> + + * pgg-gpg.el (pgg-gpg-start-process): Don't bind + default-enable-multibyte-characters. This reverts the change from + revision 6.17 which is no longer necessary because the passphrase + is sent separately now. GnuPG messages are unreadable under + multibyte locales with default-enable-multibyte-characters set to + nil. + +2006-03-28 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-tool-bar-gnome): Move "spell". + +2006-03-27 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Don't use + XEmacs-only `replace-in-string'. Use `gnus-group-real-name' + instead. + +2006-03-27 Karl Kleinpaste <karl@charcoal.com> + + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Improve + newsgroups handling for NNTP overviews which don't include + Newsgroups. + +2006-03-26 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * message.el (message-resend): Bind message-generate-hashcash to nil. + +2006-03-26 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * hashcash.el (hashcash-already-paid-p): Bind case-fold-search + when searching for already-paid recipients. + +2006-03-27 Daiki Ueno <ueno@unixuser.org> + + * pgg-gpg.el: Invoke gpg asynchronous, to avoid querying for + passphrases when it is not needed. + (pgg-gpg-use-agent): Add, to hard code that pgg shouldn't wait for + passphrase stuff from gpg, should only be necessary when you use + gpg with a smartcard. + 2006-03-23 Katsumi Yamaoka <yamaoka@jpl.org> * mml.el (mml-insert-mime): Ignore cached contents of @@ -1223,44 +3293,55 @@ * mm-decode.el (mm-get-part): Add optional 'no-cache' argument. (mm-insert-part): Ditto. -2006-03-22 Katsumi Yamaoka <yamaoka@jpl.org> +2006-03-23 Simon Josefsson <jas@extundo.com> - * gnus-sum.el (gnus-map-articles): Don't funcall symbol macro. - Reported by Ralf Wachinger <rwachinger@gmx.de>. + * pgg-gpg.el (pgg-gpg-update-agent): Add again, with fixes from + Reiner. + (pgg-gpg-use-agent-p): Use it again. -2006-03-23 Kenichi Handa <handa@m17n.org> +2006-03-23 Simon Josefsson <jas@extundo.com> - * rfc2231.el (rfc2231-encode-string): Use mm-disable-multibyte - instead of set-buffer-multibyte. + * pgg-gpg.el (pgg-gpg-update-agent): Remove, doesn't work with + older emacsen. + (pgg-gpg-use-agent-p): Don't use it. -2006-03-23 Kenichi Handa <handa@m17n.org> +2006-03-23 Reiner Steib <Reiner.Steib@gmx.de> - * rfc2231.el (rfc2231-decode-encoded-string): Work on unibyte - buffer and then decode the buffer text if necessary. - (rfc2231-encode-string): Be sure to work on multibyte buffer at - first, and after mm-encode-body, change the buffer to unibyte. + * pgg-gpg.el (pgg-gpg-update-agent): Only use make-network-process + if we can. -2006-03-21 Daniel Pittman <daniel@rimspace.net> +2006-03-22 Sascha Wilde <wilde@sha-bang.de> - * nnimap.el (nnimap-request-update-info-internal): Optimize. - Don't `gnus-uncompress-range' to avoid excessive memory usage. + * pgg-gpg.el (pgg-gpg-use-agent): Disable by default. + (pgg-gpg-update-agent): New function. + (pgg-gpg-use-agent-p): New function. + (pgg-gpg-process-region, pgg-gpg-encrypt-region) + (pgg-gpg-encrypt-symmetric-region, pgg-gpg-decrypt-region) + (pgg-gpg-sign-region): Use it. -2006-03-21 Reiner Steib <Reiner.Steib@gmx.de> +2006-03-22 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-agent.el (gnus-agent-queue-mail): Fix custom tag for `t'. + * gnus-sum.el (gnus-map-articles): Don't funcall symbol macro. + Reported by Ralf Wachinger <rwachinger@gmx.de>. - * spam.el (spam-mark-new-messages-in-spam-group-as-spam): - Add comment on version. +2006-03-21 Simon Josefsson <jas@extundo.com> -2006-03-20 Teodor Zlatanov <tzz@lifelogs.com> + * pgg-gpg.el: Ideas below based on patch from Sascha Wilde + <wilde@sha-bang.de>. + (pgg-gpg-use-agent): New variable. + (pgg-gpg-process-region): Use it. + (pgg-gpg-encrypt-region): Likewise. + (pgg-gpg-encrypt-symmetric-region): Likewise. + (pgg-gpg-decrypt-region): Likewise. + (pgg-gpg-sign-region): Likewise. + (pgg-gpg-possibly-cache-passphrase): Don't cache a nil password. - * spam.el (spam-mark-new-messages-in-spam-group-as-spam): New variable. - (spam-mark-junk-as-spam-routine): Use it. Allow to disable - assigning the spam-mark to new messages. +2006-03-21 Reiner Steib <Reiner.Steib@gmx.de> -2006-03-20 Adam Sj,Ax(Bgren <asjo@koldfront.dk> + * gnus-agent.el (gnus-agent-queue-mail): Fix custom tag for `t'. - (spam-ham-copy-or-move-routine): Don't declare `todo' twice. + * spam.el (spam-mark-new-messages-in-spam-group-as-spam): + Add comment on version. 2006-03-20 Reiner Steib <Reiner.Steib@gmx.de> @@ -1281,6 +3362,26 @@ * gnus-util.el (gnus-tool-bar-update): Bind tool-bar-mode. +2006-03-16 Reiner Steib <Reiner.Steib@gmx.de> + + * gmm-utils.el (gmm-image-load-path-for-library): Prefer user's + images in image-load-path. [Sync with image.el at 2006-03-16T16:55:26Z!wohler@newt.com, in + Emacs.] + +2006-03-15 Reiner Steib <Reiner.Steib@gmx.de> + + * gmm-utils.el (gmm-image-load-path-for-library): Pass value of + path rather than symbol. Always return list of directories. + Guarantee that image directory comes first. [Sync with image.el, + , in Emacs2006-03-15T17:06:16Z!wohler@newt.com.] + + * message.el (message-make-tool-bar): Adjust to new API of + `gmm-image-load-path-for-library'. + + * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. + + * gnus-group.el (gnus-group-make-tool-bar): Ditto. + 2006-03-15 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> * gnus-art.el (gnus-article-only-boring-p): @@ -1288,6 +3389,11 @@ intangible text. Reported by Ralf Wachinger <rwnewsmampfer@geekmail.de>. +2006-03-14 Reiner Steib <Reiner.Steib@gmx.de> + + * gmm-utils.el (gmm-image-load-path-for-library): Fix typo. Use + `defun' instead of `gmm-defun-compat'. + 2006-03-14 Simon Josefsson <jas@extundo.com> * message.el (message-unique-id): Don't use message-number-base36 @@ -1334,17 +3440,70 @@ * gnus-topic.el (gnus-topic-prepare-topic): Add gnus-tool-bar-update. + * gnus-group.el (gnus-group-redraw-when-idle) + (gnus-group-redraw-check): Remove. + (gnus-group-make-tool-bar): Remove gnus-group-redraw-check. + 2006-03-08 Katsumi Yamaoka <yamaoka@jpl.org> * nnmail.el (nnmail-split-it): Invert match-partial-words behavior if optional last element is specified in splits (FIELD VALUE...). +2006-03-07 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-make-tool-bar): Rename gmm-image-load-path + to gmm-image-load-path-for-library. Call with no-error argument. + (message-tool-bar-gnome): Rename "mail/attach" to "attach". + + * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. + + * gnus-group.el (gnus-group-make-tool-bar): Ditto. + + * gmm-utils.el (gmm-image-load-path): Remove alias. + +2006-03-06 Reiner Steib <Reiner.Steib@gmx.de> + + * gmm-utils.el (gmm-image-load-path): Add alias. + + * nnml.el (nnml-generate-nov-databases-directory): Rename from + nnml-generate-nov-databases-1. + (nnml-generate-nov-databases): Use it. + (nnml-generate-nov-databases-directory): Document no-active + argument. + + * gmm-utils.el (gmm-image-load-path-for-library): Return single + directory if path is t. Add no-error. + + * gnus-group.el (gnus-group-make-tool-bar): Use add-hook. + Suggested by Stefan Monnier <monnier@iro.umontreal.ca>. + + * gnus-art.el (gnus-article-browse-delete-temp-files): Simplify + resetting gnus-article-browse-html-temp-list. + + * gmm-utils.el (gmm-image-load-path-for-library): Sync with + mh-compat.el at 2006-03-04T21:23:21Z!wohler@newt.com in Emacs. Rename `gmm-image-load-path'. + Add example to docstring. Rename local variables. Move error + checks to default case in cond and simplify. + 2006-03-06 Katsumi Yamaoka <yamaoka@jpl.org> * mm-view.el (mm-w3m-cid-retrieve-1): Check carefully whether handle is multipart when calling it recursively. (mm-w3m-cid-retrieve): Display warning if retrieving fails. +2006-03-03 Daniel Pittman <daniel@rimspace.net> + + * nnimap.el (nnimap-request-update-info-internal): Optimize. + Don't `gnus-uncompress-range' to avoid excessive memory usage. + +2006-03-03 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-tool-bar-gnome): Check if gnus-topic.el + is loaded. + + * gnus-sum.el (gnus-summary-tool-bar-gnome): Check if spam.el is + loaded. + 2006-03-03 Reiner Steib <Reiner.Steib@gmx.de> * mm-util.el (mm-with-unibyte-current-buffer): Change "Emacs 23" @@ -1360,69 +3519,154 @@ * gnus-sum.el (gnus-summary-set-display-table): Don't nix out characters 160 through 255 in Emacs 23. +2006-03-02 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-browse-html-temp-list): Rename from + gnus-article-browse-html-temp. + (gnus-article-browse-delete-temp): Make it customizable. Add + `file'. Adjust doc string. + (gnus-article-browse-delete-temp-files): Add argument. Allow + query for each file. Adjust doc string. + (gnus-article-browse-html-parts): Add + `gnus-article-browse-delete-temp-files' to + `gnus-summary-prepare-exit-hook' and `gnus-exit-gnus-hook'. + +2006-03-02 Hynek Schlawack <hynek@ularx.de> + + * gnus-art.el (gnus-article-browse-html-temp) + (gnus-article-browse-delete-temp): New variables. + (gnus-article-browse-delete-temp-files): New function. + (gnus-article-browse-html-parts): Use it. + +2006-03-02 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-group.el (gnus-group-redraw-check): Remove redundant tests. + + * gmm-utils.el (gmm-image-load-path): Mention ../etc search in doc + string. + + * gnus-sum.el (gnus-summary-tool-bar-gnome): Don't use + gnus-summary-insert-new-articles when unplugged. Remove + gnus-summary-search-article-forward. + + * gmm-utils.el (gmm-tool-bar-style): Test tool-bar-mode and + display-visual-class instead of display-color-cells. + 2006-03-02 Katsumi Yamaoka <yamaoka@jpl.org> * mml.el (mml-generate-mime-1): Encode parts other than text/* or message/* containing non-ASCII text properly. +2006-03-01 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el: Require gmm-utils, remove autoloads. + (message-tool-bar): Set default based on + gmm-tool-bar-style. + (message-tool-bar-gnome): Add gmm-customize-mode. + + * gnus-sum.el (gnus-summary-tool-bar): Set default based on + gmm-tool-bar-style. + (gnus-summary-tool-bar-gnome): Add gmm-customize-mode. + + * gnus-group.el (gnus-group-tool-bar): Set default based on + gmm-tool-bar-style. + (gnus-group-tool-bar-gnome): Add gmm-customize-mode. + + * gmm-utils.el (gmm-image-directory): Rename variable from + gmm-image-load-path. + (gmm-image-load-path): Use gmm-image-directory. + (gmm-customize-mode): New function. + (gmm-tool-bar-style): New variable. + + * gnus-group.el (gnus-group-redraw-when-idle): Rename from + gnus-group-redraw-line-number. + (gnus-group-redraw-check): Simplify. + (gnus-group-tool-bar-update): Remove redraw check. + (gnus-group-make-tool-bar): Add redraw check. + +2006-03-01 Michael Piotrowski <mxp@dynalabs.de> (tiny change) + + * gnus-art.el (gnus-button): Add missing parentheses. + 2006-02-28 Katsumi Yamaoka <yamaoka@jpl.org> * mm-util.el (mm-with-unibyte-current-buffer): Add note. -2006-02-28 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> +2006-02-28 Reiner Steib <Reiner.Steib@gmx.de> - * nnweb.el (nnweb-gmane-create-mapping): Don't choke on ^M. + * gnus-art.el (gnus-button): New face. + (gnus-article-button-face): Use it. -2006-02-28 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-sum.el (gnus-summary-tool-bar-gnome): Add + gnus-summary-next-page. Re-order. - * nnweb.el (nnweb-type-definition, nnweb-gmane-search): - Use new nov.php. + * gnus-group.el (gnus-group-tool-bar-gnome): prev-node and + next-node are now included. + (gnus-group-redraw-line-number): New internal variable. + (gnus-group-redraw-check): Helper function for updating the tool + bar. + (gnus-group-tool-bar-update): Add gnus-group-redraw-check. -2006-02-28 Andreas Seltenreich <uwi7@stud.uni-karlsruhe.de> + * gmm-utils.el (gmm-tool-bar-item): Add TODO about modifiers. - * nnweb.el (nnweb-type-definition, nnweb-gmane-create-mapping) - (nnweb-gmane-wash-article, nnweb-gmane-search): Fix Gmane web - groups. Kudos to Olly Betts <olly@survex.com> for providing NOV - output on the server side. - (nnweb-google-create-mapping): Update regexps and add some - progress indication. + * spam.el (spam-spamassassin-score-regexp): New internal variable. + (spam-extra-header-to-number, spam-check-spamassassin-headers): + Use it to match format of Spamassassin 3.0 and later. Reported by + IRIE Tetsuya <irie@t.email.ne.jp>. + (spam-check-bogofilter) + (spam-bogofilter-register-with-bogofilter): Fix args of + `gnus-error' calls. 2006-02-28 Reiner Steib <Reiner.Steib@gmx.de> - * message.el (message-user-fqdn): Remove useless * in doc string. - * gnus-draft.el (gnus-draft-send): Bind message-signature to avoid unnecessary interaction when sending queued mails. Reported by TAKAHASHI Yoshio <tkh@jp.fujitsu.com>. -2006-02-28 Lars Magne Ingebrigtsen <larsi@gnus.org> +2006-02-27 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-sequence-of-unread-articles): Return nil if + first or last are nil. + +2006-02-24 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de> + + * nnweb.el (nnweb-gmane-create-mapping): Don't choke on ^M. + +2006-02-24 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus-int.el (gnus-open-server): Respect gnus-batch-mode. - Merge of 2006-02-20 change from the trunk. -2006-02-28 Lars Magne Ingebrigtsen <larsi@gnus.org> +2006-02-24 Lars Magne Ingebrigtsen <larsi@gnus.org> * dns.el (query-dns): Protect more against buggy tcp output. - Merge of 2006-02-20 change from the trunk. -2006-02-27 Reiner Steib <Reiner.Steib@gmx.de> +2006-02-24 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-sum.el (gnus-sequence-of-unread-articles): Return nil if - first or last are nil. + * nnweb.el (nnweb-type-definition, nnweb-gmane-search): Use new + nov.php. -2006-02-24 Simon Josefsson <jas@extundo.com> +2006-02-24 Andreas Seltenreich <uwi7@stud.uni-karlsruhe.de> - * flow-fill.el (fill-flowed): Flow-fill unquoted lines too. - Merge of 2005-10-26 change from the trunk. + * nnweb.el (nnweb-type-definition, nnweb-gmane-create-mapping) + (nnweb-gmane-wash-article, nnweb-gmane-search): Fix Gmane web + groups. Kudos to Olly Betts <olly@survex.com> for providing NOV + output on the server side. + (nnweb-google-create-mapping): Update regexps and add some + progress indication. -2006-02-23 Lars Magne Ingebrigtsen <larsi@gnus.org> +2006-02-23 Reiner Steib <Reiner.Steib@gmx.de> - * flow-fill.el (fill-flowed): Bind adaptive-fill-mode to nil. - Remove space stuffing, and only do quotes that actually start with - ">" at the beginning of the lines. - Merge of 2005-11-17 and 2004-07-25 from the trunk. + * gnus-group.el (gnus-group-tool-bar-gnome): Fix + gnus-agent-toggle-plugged. Re-order icons. + (gnus-group-tool-bar-gnome): Add + gnus-group-{prev,next}-unread-group. + (gnus-group-tool-bar-gnome): Re-order icons. -2006-02-23 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-sum.el (gnus-summary-tool-bar-gnome): Move + gnus-summary-insert-new-articles. + + * message.el (message-tool-bar-gnome, message-tool-bar-retro): Fix + comments. * utf7.el (utf7-utf-16-coding-system): Fix comment. utf-16-be is also available in Emacs 21.3. @@ -1439,16 +3683,78 @@ * mm-view.el (mm-fill-flowed): Add :version. -2006-02-23 Ralf Angeli <angeli@iwi.uni-sb.de> +2006-02-23 Katsumi Yamaoka <yamaoka@jpl.org> - * mm-view.el (mm-fill-flowed): New variable. - (mm-inline-text): Use it. + * gmm-utils.el (gmm-image-load-path): Don't modify image-load-path + and load-path. + +2006-02-22 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el: Autoload gmm-image-load-path. + (message-tool-bar-retro): Prepend "gnus/" subdirectory to some + icon file names. Use old Emacs 21 "mail_send.xpm" icon for + consitency. + + * gmm-utils.el (gmm-image-load-path): Also search in + "../etc/images". Don't set gmm-image-load-path if we don't find + the image. + +2006-02-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * gmm-utils.el (gmm-image-load-path): Don't make + `gmm-image-load-path' include subdirectories which the second arg + `image' might specify. + + * gnus-group.el (gnus-group-tool-bar-retro): Prepend the "gnus/" + subdirectory to icon file names. + + * gnus-sum.el (gnus-summary-tool-bar-retro): Ditto. + +2006-02-21 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-group.el (gnus-group-make-tool-bar): Add IMAGE argument to + gmm-image-load-path calls. + + * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. + + * message.el (message-make-tool-bar): Ditto. + + * mml.el (mml-preview): Added comment concerning tool bar icons. + + * gnus-group.el (gnus-group-tool-bar-gnome): Use new icon names. + (gnus-group-make-tool-bar): Use `gmm-image-load-path'. + + * gnus-sum.el (gnus-summary-tool-bar-gnome): Use new icon names. + (gnus-summary-make-tool-bar): Use `gmm-image-load-path'. + + * message.el (message-tool-bar-gnome): Use new icon names. + (message-make-tool-bar): Use `gmm-image-load-path'. + + * gmm-utils.el (gmm-defun-compat, gmm-image-search-load-path): New + functions from MH-E. + (gmm-image-load-path): New variable from MH-E. + (gmm-image-load-path): New function from MH-E. Added arguments + LIBRARY, IMAGE and PATH. Don't modify paths. Don't use + *-image-load-path-called-flag. + +2006-02-21 Milan Zamazal <pdm@brailcom.org> + + * mm-view.el (mm-view-pkcs7-verify): Implement using smime.el. 2006-02-21 Wolfram Fenske <wolfram.fenske@student.uni-magdeburg.de> (tiny change) * nnimap.el (nnimap-request-move-article): Change folder back to source group before deleting. +2006-02-20 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-util.el (mm-charset-override-alist): Fix type in doc string. + + * gnus-art.el (mm-url-insert-file-contents-external): Autoload + mm-url. + + * mm-uu.el (mm-uu-type-alist): Improve `LaTeX'. + 2006-02-20 Katsumi Yamaoka <yamaoka@jpl.org> * rfc2047.el (rfc2047-charset-to-coding-system): Don't check the @@ -1473,17 +3779,37 @@ * gnus-art.el (article-strip-banner): Use gnus-extract-address-components instead of - mail-header-parse-addresses to make it work with non-ASCII text. + mail-header-parse-addresses to make it work with non-ASCII text; + remove mail-encode-encoded-word-string. * rfc2231.el (rfc2231-parse-string): Attempt to parse parameter values which are surrounded with \"...\"; make it never cause a Lisp error; give up parsing of parameters if it failed in extracting type. +2006-02-14 Arne J,Ax(Brgensen <arne@arnested.dk> + + * smime.el (smime-cert-by-ldap-1): Fix bug where + `smime-ldap-search' returns results without userCertificates. + 2006-02-15 Katsumi Yamaoka <yamaoka@jpl.org> + * mm-util.el (mm-make-temp-file): Don't catch file-error in Emacs. + +2006-02-14 Reiner Steib <Reiner.Steib@gmx.de> + + * spam.el (spam-check-spamassassin-headers): Adapt format for + Spamassassin 3.0 or later. Reported by ARISAWA Akihiro + <ari@mbf.ocn.ne.jp>. + (spam-list-of-processors): Add spam-use-gmane. + +2006-02-14 Katsumi Yamaoka <yamaoka@jpl.org> + * mm-util.el (mm-make-temp-file): Import the Emacs 22 version of - make-temp-file; make it work with Emacs 20 and XEmacs as well. + make-temp-file; make it work with XEmacs as well. + + * gnus-art.el (gnus-article-browse-html-parts): Use the 3rd arg of + mm-make-temp-file. * mm-decode.el (mm-display-external): Use the 3rd arg of mm-make-temp-file. @@ -1497,6 +3823,18 @@ (gnus-draft-check-draft-articles): New function. (gnus-draft-edit-message, gnus-draft-send-message): Use it. +2006-02-13 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-browse-html-parts): + `hs-show-html-list' should read `gnus-article-browse-html-parts'. + Don't use suffix argument for mm-make-temp-file for Emacs 21 + compatibility. Remove useless `format'. + +2006-02-13 Andreas Seltenreich <uwi7@stud.uni-karlsruhe.de> + + * nnweb.el (nnweb-google-wash-article): Update regexps. + (nnweb-group-alist): Use defvoo instead of defvar. + 2006-02-13 Katsumi Yamaoka <yamaoka@jpl.org> * nnoo.el (nnoo-declare): Don't generate duplicate entries when @@ -1504,8 +3842,24 @@ 2006-02-10 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-group.el (gnus-group-make-tool-bar): Remove duplicate check + for `tool-bar-mode' and don't check it's default-value. + + * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. + + * message.el (message-make-tool-bar): Ditto. + + * gnus-art.el (gnus-article-browse-html-parts): Remove useless + `substring'. Shorten tmp-file name. + * gnus.el: Remove bogus comment. +2006-02-10 Hynek Schlawack <hynek@ularx.de> + + * gnus-art.el (gnus-article-browse-html-parts): New function. + (gnus-article-browse-html-article): New function for viewing html + articles with a browser. + 2006-02-09 Daiki Ueno <ueno@unixuser.org> * mml2015.el (mml2015-pgg-sign): Enable pgg-text-mode. @@ -1581,10 +3935,6 @@ Update copyright notices of all files in the gnus directory. -2006-02-03 Reiner Steib <Reiner.Steib@gmx.de> - - * gnus-util.el (gnus-error): Describe `args'. - 2006-02-03 Andreas Seltenreich <uwi7@stud.uni-karlsruhe.de> * nnweb.el (nnweb-request-group): Avoid growing overview files. @@ -1615,20 +3965,13 @@ (nnweb-possibly-change-server, nnweb-request-group): Remove some initialisations. Let nnoo do the work. -2006-01-31 Romain Francoise <romain@orebokech.com> - - * message.el (message-alternative-emails): Improve docstring. - (message-setup-1): Call `message-use-alternative-email-as-from' - after `message-setup-hook' to give it precedence over posting - styles, etc. - (message-use-alternative-email-as-from): Add docstring. - Remove the original From header if present. - 2006-01-31 Katsumi Yamaoka <yamaoka@jpl.org> * mm-uu.el (mm-uu-emacs-sources-extract, mm-uu-diff-extract): Say the part has been decoded. + * mm-view.el (mm-display-inline-fontify): Get decoded part rightly. + 2006-01-31 Kevin Ryde <user42@zip.com.au> * mailcap.el (mailcap-viewer-passes-test): Don't put "(nil t)" into @@ -1636,6 +3979,15 @@ will invert the meaning of a "nil" test previously determined by mailcap-mailcap-entry-passes-test. +2006-01-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el: Bind tool-bar-mode instead of tool-bar-map when + compiling. + + * gnus-sum.el: Ditto. + + * message.el: Don't bind tool-bar-map when compiling. + 2006-01-30 Reiner Steib <Reiner.Steib@gmx.de> * nnweb.el (nnweb-google-parse-1): Clarify some comments. @@ -1646,11 +3998,57 @@ (nnweb-google-create-mapping, nnweb-google-search): Adapt to current Google Groups. +2006-01-26 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-make-tool-bar): Add checks for XEmacs + and tool-bar-mode. + + * gnus-group.el (gnus-group-make-tool-bar): Add checks for XEmacs + and tool-bar-mode. + + * message.el (message-tool-bar-update): Simplify. + (message-make-tool-bar): Add checks for XEmacs and tool-bar-mode. + + * gnus-sum.el (gnus-summary-tool-bar-update): Check for + gnus-summary-buffer. + (gnus-summary-tool-bar-gnome): Use "reply-author" icon for + gnus-summary-reply. + + * gmm-utils.el (gmm): Add :version. + 2006-01-26 Katsumi Yamaoka <yamaoka@jpl.org> * Makefile.in (clean): New rule. (distclean): Use it. +2006-01-26 Steve Youngs <steve@sxemacs.org> + + * gmm-utils.el (gmm-tool-bar-item, gmm-tool-bar-zap-list): Don't + autoload. + +2006-01-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * gmm-utils.el (gmm-verbose): Add :group. + +2006-01-25 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el: Change some comments WRT tool-bars. + + * gnus-sum.el (gnus-summary-tool-bar) + (gnus-summary-tool-bar-gnome, gnus-summary-tool-bar-retro) + (gnus-summary-tool-bar-zap-list): New variables. + (gnus-summary-make-tool-bar): Complete rewrite using + `gmm-tool-bar-from-list'. + + * gnus-group.el (gnus-group-tool-bar, gnus-group-tool-bar-gnome) + (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): New + variables. + (gnus-group-make-tool-bar): Complete rewrite using + `gmm-tool-bar-from-list'. + (gnus-group-tool-bar-update): New function. + + * message.el (message-mode-field-menu): Add "Show hidden Headers". + 2006-01-25 Katsumi Yamaoka <yamaoka@jpl.org> * mm-uu.el (mm-uu-dissect-text-parts): Ignore it if a given part @@ -1664,10 +4062,28 @@ mailcap-viewer-passes-test and mailcap-mailcap-entry-passes-test look for. +2006-01-24 Reiner Steib <Reiner.Steib@gmx.de> + + * gmm-utils.el (gmm-tool-bar-item): Add "Separator". + (gmm-tool-bar-from-list): Suppress tooltip for `gmm-ignore'. + + * message.el (message-tool-bar-gnome): Use gmm-ignore. + 2006-01-24 Katsumi Yamaoka <yamaoka@jpl.org> - * mm-uu.el (mm-uu-dissect-text-parts): Reduce the number of - recursive calls. + * gnus-art.el (gnus-mime-security-button-commands): New variable. + (gnus-mime-security-button-menu): New definition. + (gnus-mime-security-button-map): Use them. + (gnus-mime-security-button-menu): New function. + (gnus-insert-mime-security-button): Addition to help echo. + (gnus-mime-security-run-function, gnus-mime-security-save-part) + (gnus-mime-security-pipe-part): New functions. + + * mm-uu.el (mm-uu-buttonize-original-text-parts): Remove. + (mm-uu-dissect-text-parts): Revert a part of 2006-01-23 change. + + * mm-decode.el (mm-handle-set-disposition): Remove. + (mm-handle-set-description): Remove. 2006-01-24 Katsumi Yamaoka <yamaoka@jpl.org> @@ -1679,6 +4095,30 @@ * gnus-art.el (gnus-article-wash-html-with-w3m-standalone): Use mm-w3m-standalone-supports-m17n-p to alter w3m usage. +2006-01-23 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-tool-bar-zap-list): Use + gmm-tool-bar-zap-list as custom type. + (message-tool-bar-update): New function. + (message-tool-bar, message-tool-bar-gnome) + (message-tool-bar-retro): Add message-tool-bar-update. + (message-tool-bar-gnome): Add flyspell-buffer. + + * gnus-util.el (gnus-error): Describe `args'. + + * gmm-utils.el (gmm-error): Describe `args'. + (gmm-tool-bar-zap-list): New widget. + (gmm-tool-bar-from-list): Improve description of `zap-list'. + +2006-01-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-uu.el (mm-uu-buttonize-original-text-parts): New variable. + (mm-uu-dissect-text-parts): Buttonize original text parts; reduce + the number of recursive calls. + + * mm-decode.el (mm-handle-set-disposition): New macro. + (mm-handle-set-description): New macro. + 2006-01-23 Katsumi Yamaoka <yamaoka@jpl.org> * mm-uu.el (mm-uu-dissect-text-parts): Decode content transfer @@ -1686,15 +4126,53 @@ 2006-01-20 Reiner Steib <Reiner.Steib@gmx.de> + * message.el (message-tool-bar-zap-list, message-tool-bar) + (message-tool-bar-gnome, message-tool-bar-retro): New variables. + (message-tool-bar-local-item-from-menu): Remove. + (message-tool-bar-map): Replace by `message-make-tool-bar'. + (message-make-tool-bar): New function. + (message-mode): Use `message-make-tool-bar'. + + * gmm-utils.el: New file. + (gmm-verbose, gmm-message, gmm-error): From gnus-utils.el. + (gmm-lazy): New widget copied from `nnmail.el'. + (gmm-tool-bar-from-list): New function for creating customizable + tool bars. + (gmm-tool-bar-from-list): Fix typos in doc string. Remove debug + output. + (gmm): Add :prefix to defgroup. + +2006-01-20 Per Abrahamsen <abraham@dina.kvl.dk> + + * gmm-utils.el (gmm-widget-p): New function. + +2006-01-20 Reiner Steib <Reiner.Steib@gmx.de> + * mml.el (mml-attach-file): Describe `description' in doc string. (mml-menu): Add Emacs MIME manual and PGG manual. -2006-01-19 Reiner Steib <Reiner.Steib@gmx.de> +2006-01-20 Richard M. Stallman <rms@gnu.org> + + * mm-url.el (mm-url-load-url): Require url-parse and url-vars. + +2006-01-20 Kevin Greiner <kevin.greiner@compsol.cc> + + * nntp.el (nntp-end-of-line): Doc fix. + +2006-01-20 Chong Yidong <cyd@stupidchicken.com> + + * imap.el (imap-open): Handle case where buffer is a buffer + object. + +2005-01-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-delay.el (gnus-delay): Don't autoload. + It's useless and could trigger a bug in cus-dep.el causing ldefs-boot + to be re-loaded when customizing the `gnus-delay' group. - * spam.el (spam-group-ham-mark-p, spam-group-spam-mark-p) - (spam-group-spam-marks, spam-list-articles, spam-group-ham-marks): - Revert 2006-01-08 change because the functions will be used in No - Gnus. +2005-01-20 Chong Yidong <cyd@stupidchicken.com> + + * message.el (message-insert-citation-line): Use newlines. 2006-01-19 Katsumi Yamaoka <yamaoka@jpl.org> @@ -1702,6 +4180,10 @@ * mm-uu.el (mm-uu-dissect-text-parts): Dissect dissected parts. +2006-01-19 Mark D. Baushke <mdb@gnu.org> + + * pgg-gpg.el (pgg-gpg-encrypt-region): Add --textmode to gpg args. + 2006-01-17 Katsumi Yamaoka <yamaoka@jpl.org> * mm-decode.el (mm-inlined-types): Add application/pgp. @@ -1716,9 +4198,6 @@ (nnrss-opml-import): Query whether to subscribe to each entry. * gnus-art.el: - * gnus-cus.el: - * gnus-group.el: - * gnus-start.el: * gnus-sum.el: * mm-uu.el: * mm-view.el: Update copyright. @@ -1731,19 +4210,11 @@ * ChangeLog: Fix and update copyright. -2006-01-16 Katsumi Yamaoka <yamaoka@jpl.org> +2006-01-13 Romain Francoise <romain@orebokech.com> - * mm-uu.el (mm-uu-text-plain-type): New variable. - (mm-uu-pgp-signed-extract-1): Use it. - (mm-uu-pgp-encrypted-extract-1): Use it. - (mm-uu-dissect): Use it; allow two optional arguments; one is a - flag specifying whether there's no message header; the other is - for a MIME type and parameters; bind mm-uu-text-plain-type with - the later one. - (mm-uu-dissect-text-parts): New function. - - * gnus-art.el (gnus-display-mime): Use mm-uu-dissect-text-parts to - dissect text parts. + * message.el (message-forward-subject-name-subject): Prefer the + address to 'nowhere' if the sender has no name. + Fix typo. Update copyright year. 2006-01-13 Katsumi Yamaoka <yamaoka@jpl.org> @@ -1757,6 +4228,11 @@ gnus-article-wash-html-with-w3m-standalone. (mm-inline-text-html-render-with-w3m-standalone): New function. +2006-01-12 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-uu.el (mm-uu-type-alist): Fix previous message-marks commit. + Improve LaTeX. + 2006-01-10 Katsumi Yamaoka <yamaoka@jpl.org> * nnrss.el (nnrss-wash-html-in-text-plain-parts): New variable. @@ -1794,6 +4270,12 @@ fetch a feed. Suggested by Mark Plaksin <happy@mcplaksin.org>. (nnrss-insert-w3): Ditto. +2005-12-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-uu.el (gnus-uu-digest-mail-forward): Reverse the order of + the articles to be forwarded including the case where neither a + number of articles nor a region is specified. + 2005-12-21 Katsumi Yamaoka <yamaoka@jpl.org> * nnrss.el (nnrss-request-article): Fix last change; fill @@ -1805,34 +4287,31 @@ in text/plain part. (nnrss-check-group): Don't add excessive newline to dc:subject. -2005-12-19 Katsumi Yamaoka <yamaoka@jpl.org> - - * gnus-art.el (gnus-article-delete-text-of-type): Enable it to - remove MIME buttons associated with multipart/alternative parts. - (gnus-mime-display-alternative): Tag buttons using `article-type' - text property. - - * gnus-msg.el (gnus-copy-article-buffer): Remove MIME buttons - associated with multipart/alternative parts. - 2005-12-19 Mark Plaksin <happy@mcplaksin.org> (tiny change) * nnrss.el (nnrss-check-group): Put the RSS dc:subject in the article. -2005-12-18 Lars Magne Ingebrigtsen <larsi@gnus.org> +2005-12-18 Reiner Steib <Reiner.Steib@gmx.de> + + * nnml.el: Don't require gnus-bcklg. Autoload it. + (nnml-use-compressed-files, nnml-save-mail): Support other + comression programs such as bzip2. + +2005-12-17 Lars Magne Ingebrigtsen <larsi@gnus.org> * dns.el (query-dns): Make sure we check the buffer size before removing tcp headers. -2006-01-08 Chong Yidong <cyd@stupidchicken.com> +2005-12-16 Katsumi Yamaoka <yamaoka@jpl.org> - * spam.el (spam-group-ham-mark-p, spam-group-spam-mark-p) - (spam-group-spam-marks): Delete functions. - (spam-list-articles): Just call spam-group-ham-marks directly. - (spam-group-ham-marks): Simplify. + * gnus-art.el (gnus-article-delete-text-of-type): Enable it to + remove MIME buttons associated with multipart/alternative parts. + (gnus-mime-display-alternative): Tag buttons using `article-type' + text property. -2005-12-16 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-msg.el (gnus-copy-article-buffer): Remove MIME buttons + associated with multipart/alternative parts. * gnus-art.el (gnus-signature-separator): Fix custom type. @@ -1843,6 +4322,22 @@ (mm-inline-override-types): Ditto. (mm-automatic-external-display): Ditto. +2005-12-15 Reiner Steib <Reiner.Steib@gmx.de> + + * spam-report.el (spam-report-user-mail-address) + (spam-report-user-agent): New variables. + (spam-report-url-ping-plain): Use spam-report-user-agent. + +2005-12-14 Ralf Angeli <angeli@iwi.uni-sb.de> + + * gnus-art.el (gnus-button-handle-custom): Do not just use + `customize-apropos' for any "M-x customize-*" button but the + function called for. Accept both the function name and its + argument in order to achieve this. + (gnus-button-alist): Remove support for "custom:" URL's. Pass + function name to `gnus-button-handle-custom' in case of "M-x + customize-*" buttons. + 2005-12-12 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-buttonized-mime-types): Mention addition of @@ -1852,6 +4347,21 @@ * mm-decode.el (mm-discouraged-alternatives): Add xref to gnus-buttonized-mime-types in doc string. +2005-12-08 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-decode.el (mm-discouraged-alternatives): Fix custom type. + Suggest image/.* in the doc string. + +2005-12-12 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-uu.el (mm-uu-type-alist): Don't depend on message.el for + message-marks (Debian bug #342521). + +2005-12-12 Simon Josefsson <jas@extundo.com> + + * password.el (password-read-from-cache): Add. + (password-read): Use it. + 2005-12-12 Katsumi Yamaoka <yamaoka@jpl.org> * rfc2047.el (rfc2047-charset-to-coding-system): Recognize @@ -1862,34 +4372,14 @@ 2005-12-09 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-start.el (gnus-no-server-1): Mention - `gnus-level-default-subscribed' in doc string. + * pop3.el (pop3-stream-type): Fix custom version. -2005-12-09 Reiner Steib <Reiner.Steib@gmx.de> - - * gnus-start.el (gnus-start-draft-setup): Enforce - `gnus-draft-mode' for nndraft:drafts at startup. - - * gnus.el (gnus-splash): Change custom group. - (gnus-group-get-parameter, gnus-group-parameter-value): Describe - allow-list argument. - - * gnus-agent.el (gnus-agent-article-alist-save-format): Format doc - string. + * mm-uu.el (mm-uu-type-alist): Simplify uu regexp. 2005-12-09 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change) * mm-decode.el (mm-display-external): Add missing cdr. -2005-12-12 Richard M. Stallman <rms@gnu.org> - - * mm-url.el (mm-url-load-url): Require url-parse and url-vars. - -2005-12-08 Reiner Steib <Reiner.Steib@gmx.de> - - * mm-decode.el (mm-discouraged-alternatives): Fix custom type. - Suggest image/.* in the doc string. - 2005-12-07 Katsumi Yamaoka <yamaoka@jpl.org> * mm-decode.el (mm-display-external): Use nametemplate (defined in @@ -1901,27 +4391,58 @@ 2005-12-06 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-art.el (gnus-default-article-saver): Add user-defined - `function' to custom type. + * nntp.el (nntp-marks-directory): Fix custom group. + + * gnus-fun.el (gnus-face-from-file): Decrease quant in smaller + steps when < 10. + + * gnus-start.el (gnus-no-server-1): Mention + `gnus-level-default-subscribed' in doc string. 2005-12-02 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change) * mm-view.el (mm-inline-text-html-render-with-w3m): Fix misplaced parens. -2005-11-29 Reiner Steib <Reiner.Steib@gmx.de> +2005-11-26 Dave Love <fx@gnu.org> - * gnus-cache.el (gnus-cache-rename-group): Wrap doc strings and - long lines. - (gnus-cache-delete-group): Wrap doc strings. + * tls.el (open-tls-stream): Rename arg SERVICE to PORT. + (tls-program, tls-success): Provide openssl alternative. - * gnus-agent.el (gnus-agent-rename-group) - (gnus-agent-delete-group): Wrap doc strings. + * starttls.el: Doc fixes. + (starttls-open-stream-gnutls, starttls-open-stream): Rename arg + SERVICE to PORT. + + * pop3.el (pop3-open-server) <ssl>: Clarify a loop. Deal with + port null or service name. + (starttls-negotiate): Autoload. + +2005-11-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-kill-to-signature): Fix interactive spec. + +2005-11-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * pop3.el (pop3-open-server): Recognize a string as a service name. 2005-11-24 Pascal Rigaux <pixel@mandriva.com> (tiny change) * rfc2231.el (rfc2231-parse-string): Support non-ascii chars. +2005-11-23 Dave Love <fx@gnu.org> + + Add pop3s, pop3/starttls. + + * pop3.el (pop3-authentication-scheme): Clarify doc. + (open-tls-stream, starttls-open-stream): Autoload. + (pop3-stream-type): New. + (pop3-open-server): Use it. + + * mail-source.el (mail-sources): Fix some :types. Add stream type + for POP. + (mail-source-keyword-map): Add :stream for POP. + (mail-source-fetch-pop): Use pop3-stream-type. + 2005-11-22 Katsumi Yamaoka <yamaoka@jpl.org> * nnmail.el (nnmail-fancy-expiry-target): Use current-time instead @@ -1932,154 +4453,116 @@ * nnmail.el (nnmail-fancy-expiry-target): Protect against invalid date header. +2005-11-19 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-sum.el (gnus-fetch-old-headers): Updated docs to warn that + it can seriously impact performance as it bypasses the agent's + local caches. + +2005-11-19 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-agent.el (gnus-agent-possibly-synchronize-flags): A server + must be explicitly online rather than "not explicitly offline" for + its flags to be synchronized. + + * gnus-sum.el (gnus-summary-remove-process-mark): Always return t so + that gnus-uu-unmark-thread will function correctly. + + * gnus-group.el (gnus-total-fetched-for): Reduced cutoff so that + 1024K is instead displayed as 1M. + +2005-11-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * flow-fill.el (fill-flowed): Bind adaptive-fill-mode to nil. + 2005-11-16 Boris Samorodov <bsam@ipt.ru> (tiny change) * imap.el (imap-kerberos4-open): Ignore SSL stuff. -2005-11-14 Kevin Greiner <kevin.greiner@compsol.cc> +2005-11-13 Kevin Greiner <kevin.greiner@compsol.cc> - * gnus-agent.el (gnus-agent-article-alist-save-format): Changed - internal variable to a custom variable. Changed default value - from compressed(2) to uncompressed(1). - (gnus-agent-read-agentview): Reversed revision 7.8 to restore - support for uncompressed agentview files. Taken together, reading - the agentview file should now be 6-7 times faster. - (gnus-agent-long-article, - gnus-agent-short-article, gnus-agent-score): Renamed category - keywords to match gnus-cus. - (gnus-agent-summary-fetch-series): Modified to protect against - gnus-agent-summary-fetch-group clearing processable flags. - (gnus-agent-synchronize-group-flags): Update live group buffer as - synchronization may occur due to the user toggling the plugged - status. - (gnus-agent-braid-nov): Now tests new nov entries - for duplicates which are removed. The invalid sort check then - triggers a rescan after the sort as sorting may have moved - duplicate entries such that they can be cheaply detected. - (gnus-agent-read-local): Trivial fix to format of + * gnus-agent.el (gnus-agent-read-local): Trivial fix to format of error message to display actual error condition. (gnus-agent-save-local): Avoid saving symbols that are bound to nil as they simply result in a warning message in gnus-agent-read-local. - (gnus-agent-fetch-group-1): Clear downloadable flag when article - successfully downloaded. - (gnus-agent-regenerate-group): Use - gnus-agent-synchronize-group-flags to reset read status in both - gnus and server. - - * nntp.el (nntp-end-of-line): Doc fix. - (nntp-authinfo-rejected): New error condition. - (nntp-wait-for): Use new error condition to signal authentication - error. - (nntp-retrieve-data): Rethrow new error condition to break out of - recursive call to nntp-send-authinfo. 2005-11-13 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-start.el (gnus-dribble-read-file): Use make-local-variable rather than make-variable-buffer-local for file-precious-flag. +2005-11-12 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-agent.el (gnus-agent-braid-nov): Now tests new nov entries + for duplicates which are removed. The invalid sort check then + triggers a rescan after the sort as sorting may have moved + duplicate entries such that they can be cheaply detected. + 2005-11-13 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-start.el (gnus-dribble-read-file): Quote file-precious-flag. +2005-11-12 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-agent.el (gnus-agent-article-alist-save-format): Changed + internal variable to a custom variable. Changed default value + from compressed(2) to uncompressed(1). + (gnus-agent-read-agentview): Reversed revision 7.8 to restore + support for uncompressed agentview files. Taken together, reading + the agentview file should now be 6-7 times faster. + 2005-11-11 Jan Nieuwenhuizen <janneke@gnu.org> * gnus-start.el (gnus-dribble-read-file): Set file-precious-flag, as a buffer-local variable. This avoids creating truncated dribble files as a result of a hang up, eg. -2005-11-04 Ken Manheimer <ken.manheimer@gmail.com> - - * pgg-pgp.el (pgg-pgp-encrypt-region, pgg-pgp-decrypt-region) - (pgg-pgp-encrypt-symmetric-region, pgg-pgp-encrypt-symmetric) - (pgg-pgp-encrypt, pgg-pgp-decrypt-region, pgg-pgp-decrypt) - (pgg-pgp-sign-region, pgg-pgp-sign): Add optional 'passphrase' - argument to all these routines, so the passphrase can be managed - externally and passed in to the system. - (pgg-pgp-decrypt-region, pgg-pgp-sign-region): Use new name for - pgg-add-passphrase-to-cache function. - - * pgg-pgp5.el (pgg-pgp5-encrypt-region, pgg-pgp5-decrypt-region) - (pgg-pgp5-encrypt-symmetric-region, pgg-pgp5-encrypt-symmetric) - (pgg-pgp5-encrypt, pgg-pgp5-decrypt-region, pgg-pgp5-decrypt) - (pgg-pgp5-sign-region, pgg-pgp5-sign): Add optional 'passphrase' - argument to all these routines, so the passphrase can be managed - externally and passed in to the system. - (pgg-pgp5-sign-region): Use new name of pgg-add-passphrase-to-cache - function. +2005-12-09 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-start.el (gnus-start-draft-setup): Enforce + `gnus-draft-mode' for nndraft:drafts at startup. -2005-10-29 Ken Manheimer <ken.manheimer@gmail.com> - - * pgg-gpg.el (pgg-gpg-select-matching-key): Fix: look at the right - part of the decoded armor to find the key-identifier. - (pgg-gpg-lookup-key-owner): New function to return the - human-readable identifier of a key owner. - (pgg-gpg-lookup-id-from-key-owner): Make it easy to identify the - key itself. - (pgg-gpg-decrypt-region): Prompt with the key owner (rather than - the key value) if we have a key and can match it against a secret - key. Also, added a note pointing out fact that the prompt only - indicates the first matching key. - - * pgg.el (pgg-decrypt): Passing along 'passphrase' in call to - pgg-decrypt-region. - (pgg-pending-timers): A new hash for tracking the passphrase cache - timers, so that new ones supercede old ones. - (pgg-add-passphrase-to-cache): Rename from - `pgg-add-passphrase-cache' to reduce confusion (all callers - changed). Modified to cancel old timers when new ones are added. - (pgg-remove-passphrase-from-cache): Rename from - `pgg-remove-passphrase-cache' to reduce confusion (all callers - changed). Modified to cancel old timers when their keys are - removed from the cache. - (pgg-cancel-timer): In Emacs, an alias for cancel-timer; in - XEmacs, an indirection to delete-itimer. - (pgg-read-passphrase-from-cache, pgg-read-passphrase): - Extract pgg-read-passphrase-from-cache from pgg-read-passphrase so - users can only check cache without risk of prompting. Correct bug in - notruncate behavior. - (pgg-read-passphrase-from-cache, pgg-read-passphrase) - (pgg-add-passphrase-cache, pgg-remove-passphrase-cache): - Add informative docstrings. - (pgg-decrypt): Convey provided passphrase in subordinate call to - pgg-decrypt-region. - -2005-10-20 Ken Manheimer <ken.manheimer+emacs@gmail.com> - - * pgg.el (pgg-encrypt-region, pgg-encrypt-symmetric-region) - (pgg-encrypt-symmetric, pgg-encrypt, pgg-decrypt-region) - (pgg-decrypt, pgg-sign-region, pgg-sign): Add optional - 'passphrase' argument, so the passphrase can be managed externally - and then passed in to the system. - - * pgg.el (pgg-read-passphrase, pgg-add-passphrase-cache) - (pgg-remove-passphrase-cache): Add optional 'notruncate' argument, - so the passphrase cache can be used reliably with identifiers - besides a pgp packet's key id. - - * pgg-gpg.el (pgg-pgp-encrypt-region) - (pgg-pgp-encrypt-symmetric-region, pgg-pgp-encrypt-symmetric) - (pgg-pgp-encrypt, pgg-pgp-decrypt-region, pgg-pgp-decrypt) - (pgg-pgp-sign-region, pgg-pgp-sign): Add optional 'passphrase' - argument to all these routines, so the passphrase can be managed - externally and passed in to the system. - - * pgg-gpg.el (pgg-gpg-possibly-cache-passphrase): Add optional - 'notruncate' argument, so the passphrase cache can be used - reliably with identifiers besides a pgp packet's key id. - -2005-10-29 Sascha Wilde <swilde@sha-bang.de> - - * pgg-gpg.el (pgg-gpg-encrypt-symmetric-region): New function for - symmetric encryption. - (pgg-gpg-symmetric-key-p): New function to check for an symmetric - encrypted session key. - (pgg-gpg-decrypt-region): When decrypting a symmetric encrypted - message ask for the passphrase in a proper way. - - * pgg.el (pgg-encrypt-symmetric, pgg-encrypt-symmetric-region): - New user commands for symmetric encryption. + * gnus.el (gnus-splash): Change custom group. + (gnus-group-get-parameter, gnus-group-parameter-value): Describe + allow-list argument. + + * gnus-agent.el (gnus-agent-article-alist-save-format): Format doc + string. + +2005-12-06 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-default-article-saver): Add user-defined + `function' to custom type. + +2005-10-30 Chong Yidong <cyd@stupidchicken.com> + + * imap.el (imap-open): Handle case where buffer is a buffer + object. + +2005-11-29 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-cache.el (gnus-cache-rename-group): Wrap doc strings and + long lines. + (gnus-cache-delete-group): Wrap doc strings. + + * gnus-agent.el (gnus-agent-rename-group) + (gnus-agent-delete-group): Wrap doc strings. + + +2005-11-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-1): Add "native" to + gnus-predefined-server-alist. + + * gnus.el (gnus-method-to-server): Don't add "native" to the + lists here, because that leads to problems when + gnus-select-method is bound. + +2005-11-09 Simon Josefsson <jas@extundo.com> + + * gnus-sum.el (gnus-article-sort-by-date-reverse): Remove, + use (not sort-by-date) instead. 2005-11-30 Stefan Monnier <monnier@iro.umontreal.ca> @@ -2127,6 +4610,27 @@ * message.el (message-generate-headers): Downcase the argument given to message-check-element. +2005-11-08 Kevin Greiner <kevin.greiner@compsol.cc> + + * nntp.el (nntp-authinfo-rejected): New error condition. + (nntp-wait-for): Use new error condition to signal authentication + error. + (nntp-retrieve-data): Rethrow new error condition to break out of + recursive call to nntp-send-authinfo. + +2005-11-08 Romain Francoise <romain@orebokech.com> + + * gnus-sum.el (gnus-summary-catchup-and-goto-prev-group): New function. + (gnus-summary-exit-map): Bind to `Z p'. + (gnus-summary-make-menu-bar): Add menu item. + +2005-11-02 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-treat-custom): Add `first'. + (gnus-treat-*): Add `first' in all doc strings. + + * gnus-group.el (gnus-group-compact-group): Fix typo. + 2005-11-01 Katsumi Yamaoka <yamaoka@jpl.org> * gnus.el (gnus-parameters-case-fold-search): New variable. @@ -2140,7 +4644,26 @@ 2005-10-31 Katsumi Yamaoka <yamaoka@jpl.org> - * mml.el (mml-preview): Doc fix. + * mm-util.el (mm-special-display-p): New function. + + * mml.el (mml-preview): Use it; doc fix. + +2005-10-29 Romain Francoise <romain@orebokech.com> + + * message.el (message-fix-before-sending): Fix comment. + +2005-10-29 Jari Aalto <jari.aalto@cante.net> + + * gnus-sum.el (gnus-article-sort-by-date-reverse): New function. + +2005-10-29 Jari Aalto <jari.aalto@cante.net> + + * score-mode.el (gnus-score-edit-done-hook): Introduce variable. + Used in gnus-score.el. + +2005-10-28 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-util.el (mm-codepage-setup): Remove bogus alias test. 2005-10-27 Reiner Steib <Reiner.Steib@gmx.de> @@ -2156,6 +4679,24 @@ Courier IMAP ("some version from 2004"). Mostly based on similar code in the same function. +2005-10-26 Didier Verna <didier@xemacs.org> + + * gnus-group.el (gnus-group-compact-group): invalidate original + article buffer. + * gnus-srvr.el (gnus-server-compact-server): ditto. + * nnml.el (nnml-request-compact-group): handle self Xref: field in + NOV database and in article itself. + Invalidate article backlog. + +2005-10-26 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-uu.el (mm-uu-hide-markers): Fix XEmacs case. + +2005-10-26 Simon Josefsson <jas@extundo.com> + + * flow-fill.el (fill-flowed): Flow-fill unquoted lines too, revert + part of 2004-07-25 change. + 2005-10-26 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-display-completion-list): New function. @@ -2186,10 +4727,21 @@ * gnus-score.el (gnus-default-adaptive-score-alist): Set defaults depending on gnus-score-decay-constant. -2005-10-25 Lars Magne Ingebrigtsen <larsi@gnus.org> + * encrypt.el (encrypt-insert-file-contents) + (encrypt-write-file-contents): Don't use `gnus-message'. - * nnslashdot.el (nnslashdot-request-article) - (nnslashdot-retrieve-headers-1): Update to new HTML. + * mm-uu.el (mm-uu-verbatim-marks-extract): Add four start and end + arguments. + (mm-uu-type-alist): Add message-marks and insert-marks. Pass + arguments to mm-uu-verbatim-marks-extract. + (mm-uu-hide-markers): New variable. + (mm-uu-extract): Use face similar to `gnus-cite-3'. + + * gnus-fun.el (gnus-convert-image-to-x-face-command) + (gnus-convert-image-to-face-command): Use "convert" by default to + allow other input image formats. + (gnus-x-face-from-file, gnus-face-from-file): Adjust doc strings + accordingly. 2005-10-23 Simon Josefsson <jas@extundo.com> @@ -2197,6 +4749,12 @@ with latest GNU SASL. (imap-gssapi-open): Ignore 'Trying ...' messages from GNU SASL. +2005-10-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnslashdot.el (nnslashdot-retrieve-headers-1): Update to new + HTML. + (nnslashdot-request-article): Ditto. + 2005-10-20 Hiroshi Fujishima <hiroshi.fujishima@gmail.com> (tiny change) * mail-source.el (mail-source-fetch-pop): Require pop3. @@ -2214,6 +4772,9 @@ * message.el (message-tool-bar-local-item-from-menu): Fix comment. + * mm-bodies.el (mm-decode-string): Call + `mm-charset-to-coding-system' with allow-override argument. + 2005-10-19 Katsumi Yamaoka <yamaoka@jpl.org> * rfc2047.el (rfc2047-allow-incomplete-encoded-text): New variable. @@ -2247,27 +4808,52 @@ * message.el (message-expand-group): Pass the common prefix substring of completion to `display-completion-list'. -2005-10-09 Daniel Brockman <daniel@brockman.se> +2005-10-13 Reiner Steib <Reiner.Steib@gmx.de> - * format-spec.el (format-spec): Propagate text properties of % spec. + * mml-sec.el (mml-secure-method): New internal variable. + (mml-secure-sign, mml-secure-encrypt, mml-secure-message-sign) + (mml-secure-message-sign-encrypt, mml-secure-message-encrypt): New + functions using mml-secure-method. -2005-01-21 Derek Atkins <warlord@MIT.EDU> (tiny change) + * mml.el (mml-mode-map): Add key bindings for those functions. + (mml-menu): Simplify security menu entries. Suggested by Jesper + Harder <harder@myrealbox.com>. + (mml-attach-file, mml-attach-buffer, mml-attach-external): Goto + end of message if point is the headers of the message. - * pgg-pgp.el (pgg-pgp-decrypt-region): Use passphrase cache. + * message.el (message-in-body-p): New function. -2005-10-08 Simon Josefsson <jas@extundo.com> + * assistant.el: Autoload gnus-util and netrc. - * pgg-parse.el (top-level): Don't require custom, it is - autoloaded. (To sync with No Gnus.) + * mm-util.el (mm-charset-to-coding-system): Add allow-override. + Use `mm-charset-override-alist' only when decoding. -2005-05-09 Georg C. F. Greve <greve@gnu.org> (tiny change) + * mm-bodies.el (mm-decode-body): Call + `mm-charset-to-coding-system' with allow-override argument. - * pgg-gpg.el (pgg-gpg-possibly-cache-passphrase): Fix PIN caching. + * gnus-art.el (gnus-mime-view-part-as-type-internal): Try to fetch + `filename' from Content-Disposition if Content-Type doesn't + provide `name'. + (gnus-mime-view-part-as-type): Set default instead of + initial-input. -2005-10-08 Simon Josefsson <jas@extundo.com> +2005-10-09 Daniel Brockman <daniel@brockman.se> + + * format-spec.el (format-spec): Propagate text properties of % spec. + +2005-10-12 Reiner Steib <Reiner.Steib@gmx.de> - * pgg-def.el (top-level): Don't require custom, it is - autoloaded. (To sync with No Gnus.) + * gnus-art.el (gnus-treat-predicate): Add `first'. + +2005-10-11 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-util.el (mm-charset-synonym-alist): Improve doc string. + (mm-charset-override-alist): New variable. + (mm-charset-to-coding-system): Use it. + (mm-codepage-setup): New helper function. + (mm-charset-eval-alist): New variable. + (mm-charset-to-coding-system): Use mm-charset-eval-alist. Warn + about unknown charsets. 2005-10-04 David Hansen <david.hansen@gmx.net> @@ -2276,6 +4862,13 @@ 2005-10-04 Reiner Steib <Reiner.Steib@gmx.de> + * mm-uu.el (mm-uu-verbatim-marks-extract, mm-uu-latex-extract): + Rename x-gnus-verbatim to x-verbatim. + (mm-uu-type-alist): Fix regexp for verbatim-marks. + + * mm-decode.el (mm-automatic-display): Rename x-gnus-verbatim to + x-verbatim. + * mm-url.el (mm-url-predefined-programs): Add switches for curl. * gnus-util.el (gnus-remove-duplicates): Remove. @@ -2290,6 +4883,22 @@ * mm-util.el (mm-delete-duplicates): Use `delete-dups' if available, else use implementation from `delete-dups'. + * message.el (message-insert-expires): New function. + (message-mode-map): Add key binding. + (message-mode-field-menu): Add menu entry. + (message-mode): Document it. + (message-make-expires-date): Use `message-make-date'. + +2005-10-04 Josh Huber <huber@alum.wpi.edu> + + * message.el (message-make-expires-date): New function. + +2005-10-04 Katsumi Yamaoka <yamaoka@jpl.org> + + * Makefile.in (list-installed-shadows): New entry. + (install): Use it. + (remove-installed-shadows): New entry. + 2005-10-02 Katsumi Yamaoka <yamaoka@jpl.org> * time-date.el: Autoload parse-time-string, XEmacs needs it. @@ -2302,8 +4911,18 @@ (mm-viewer-completion-map, mm-viewer-completion-map): Move initialization inside declaration. +2005-09-29 Simon Josefsson <jas@extundo.com> + + * spam.el: Load hashcash when compiling, to avoid warnings. Don't + autoload mail-check-payment. + (spam-check-hashcash): Define unconditionally, since hashcash.el + is part of Gnus now. Ignore errors from payment checking. + 2005-09-28 Reiner Steib <Reiner.Steib@gmx.de> + * message.el (message-bold-region, message-unbold-region): Rename + from `bold-region' and `unbold-region'. + * message.el: Remove useless autoloads. 2005-09-28 Simon Josefsson <jas@extundo.com> @@ -2322,8 +4941,20 @@ (mm-uu-diff-groups-regexp): Change default value. (mm-uu-type-alist): Add doc string. (mm-uu-configure): Add doc string. Make it interactive. + (mm-uu-tex-groups-regexp): New variable. + (mm-uu-latex-extract, mm-uu-latex-test): New functions. + (mm-uu-type-alist): Add LaTeX documents. + (mm-uu-verbatim-marks-extract): Use "text/x-gnus-verbatim" instead + of "text/verbatim". (mm-uu-diff-groups-regexp): Fix missing quotes from previous commit. + * mm-decode.el (mm-automatic-display): Use "text/x-gnus-verbatim" + instead of "text/verbatim". + + * message.el (message-mark-inserted-region) + (message-mark-insert-file): Use slrn style marks when called with + prefix argument. + 2005-09-27 Simon Josefsson <jas@extundo.com> * message.el (message-idna-to-ascii-rhs-1): Reformat. @@ -2348,7 +4979,10 @@ * gnus-art.el (gnus-mime-display-single): Don't modify text if it has been decoded. - * mm-decode.el (mm-insert-part): Don't modify text if it has been + * mm-decode.el (mm-automatic-display): Add text/verbatim. + (mm-insert-part): Don't modify text if it has been decoded. + + * mm-uu.el (mm-uu-verbatim-marks-extract): Say text has been decoded. * mm-view.el (mm-inline-text): Don't strip text props unless @@ -2384,6 +5018,36 @@ * gnus-agent.el (gnus-agent-synchronize-flags): Explain why the default value is nil. + * mm-uu.el (mm-uu-type-alist): Added slrn style verbatim-marks. + (mm-uu-verbatim-marks-extract): New function. + (mm-uu-extract): New face. + (mm-uu-copy-to-buffer): Use it. + + * spam-report.el (spam-report-gmane-ham): Renamed from + `spam-report-gmane-unspam'. + (spam-report-gmane-internal): Renamed from `spam-report-gmane'. + Simplify use of UNSPAM argument. Fetch "X-Report-Unspam" header. + + * spam.el (spam-report-gmane-spam, spam-report-gmane-ham): + Autoload. + (spam-report-gmane-unregister-routine): Renamed + `spam-report-gmane-unspam' to `spam-report-gmane-ham'. + +2005-09-21 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-use-gmane, spam-report-gmane-register-routine) + (spam-report-gmane-unregister-routine): Add support for gmane + unregistration. + + * spam-report.el (spam-report-gmane-unspam) + (spam-report-gmane-spam): Add new wrappers around spam-report-gmane. + (spam-report-gmane): Change to take a single article and do unspam + registration. + +2005-09-19 Reiner Steib <Reiner.Steib@gmx.de> + + * mm-url.el (mm-url-decode-entities): Fix regexp. + 2005-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus-agent.el (gnus-agent-synchronize-flags): Switch the @@ -2391,9 +5055,39 @@ switches to something else, then the function should be fixed not be exceedingly slow. +2005-09-20 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-start.el (gnus-activate-group): If the server is nil, don't + fail hard. + + * spam-report.el: Add better Keywords line. + + * spam.el: Add Maintainer and better Keywords line. + 2005-09-19 Reiner Steib <Reiner.Steib@gmx.de> - * mm-url.el (mm-url-decode-entities): Fix regexp. + * gnus-art.el (gnus-article-replace-part) + (gnus-mime-replace-part): New functions. + (gnus-mime-action-alist, gnus-mime-button-commands) + (gnus-mime-save-part-and-strip): Added file argument. + (gnus-article-part-wrapper): Added interactive argument. + + * gnus-sum.el (gnus-summary-mime-map): Add + `gnus-article-replace-part'. + +2005-09-19 Didier Verna <didier@xemacs.org> + + The nnml compaction feature: + * nnml.el (nnml-request-compact-group): New function. + * nnml.el (nnml-request-compact): New function. + * gnus-int.el (gnus-request-compact-group): New function. + * gnus-int.el (gnus-request-compact): New function. + * gnus-group.el (gnus-group-compact-group): New function. + * gnus-group.el (gnus-group-group-map): Bind it to 'G z'. + * gnus-group.el (gnus-group-make-menu-bar): Add an entry for it. + * gnus-srvr.el (gnus-server-compact-server): New function. + * gnus-srvr.el (gnus-server-mode-map): Bind it to 'z'. + * gnus-srvr.el (gnus-server-make-menu-bar): Add an entry for it. 2005-09-18 Deepak Goel <deego@gnufans.org> @@ -2404,6 +5098,10 @@ * gnus.el (gnus-group-startup-message): Bind image-load-path. +2005-09-15 Romain Francoise <romain@orebokech.com> + + * message.el (message-fill-paragraph): Clarify docstring. + 2005-09-14 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-mime-display-part): Protect against broken @@ -2414,6 +5112,31 @@ * gnus-sum.el (gnus-summary-edit-article-done): Remove text props before parsing header. +2005-09-11 Jari Aalto <jari.aalto@cante.net> + + * html2text.el: (html2text-replace-list): Add new entities. + +2005-09-11 Romain Francoise <romain@orebokech.com> + + * message.el (message-alternative-emails): Improve docstring. + (message-setup-1): Call `message-use-alternative-email-as-from' + after `message-setup-hook' to give it precedence over posting + styles, etc. + (message-use-alternative-email-as-from): Add docstring. Remove + the original From header if present. + + * nnml.el (nnml-compressed-files-size-threshold): New variable. + (nnml-save-mail): Use it. + + * gnus-uu.el (gnus-uu-mark-series): Return number of marked + articles. Add new argument `silent'. + (gnus-uu-mark-all): Report the total number of marked articles. + +2005-09-10 Romain Francoise <romain@orebokech.com> + + * gnus-uu.el (gnus-message-process-mark): Use gnus-message. + (gnus-uu-mark-series): Likewise. + 2005-09-10 Reiner Steib <Reiner.Steib@gmx.de> * spam-report.el (spam-report-gmane): Fix generation of spam @@ -2432,13 +5155,16 @@ This is only used if `spam-report-gmane-use-article-number' is nil. (spam-report-gmane-spam-header): Remove. Not used anymore. + * gnus-sum.el (gnus-thread-sort-by-recipient): New function to + make `gnus-summary-sort-by-recipient' work with threading. + * nnweb.el (nnweb-google-wash-article): Print a message if article is not available. 2005-09-07 TSUCHIYA Masatoshi <tsuchiya@namazu.org> - * gnus-art.el (gnus-mime-display-single): Decode text/* parts - content before displaying. + * gnus-art.el (gnus-mime-display-single): Revert 2004-10-07 + change. Decode text/* parts content before displaying. 2005-09-06 Reiner Steib <Reiner.Steib@gmx.de> @@ -2460,8 +5186,22 @@ * gnus-art.el (gnus-signature-limit) (gnus-article-mime-part-function): Ditto. +2005-09-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * mml.el (mml-mode): Silence the byte compiler. + + * gnus-art.el (gnus-article-jump-to-part): Redisplay the article + using `(sit-for 0)' before moving the point to the specified part; + skip unbuttonized parts. + (gnus-article-part-wrapper): Don't use save-window-excursion; don't + return to the summary window if gnus-auto-select-part is non-nil. + 2005-09-04 Reiner Steib <Reiner.Steib@gmx.de> + * mml.el (mml-dnd-protocol-alist, mml-dnd-attach-options): New + variables. + (mml-dnd-attach-file, mml-mode): Use them. + * nnweb.el (nnweb-type-definition, nnweb-google-wash-article): Make fetching article by MID work again for Google Groups. Added FIXME concerning gnus-group-make-web-group. @@ -2470,15 +5210,17 @@ Don't depend on Gnus by using mail-extract-address-components if gnus-extract-address-components is not bound. - * gnus.el (gnus-user-agent): Use list of symbols instead of - symbols. Display full version number for (S)XEmacs. Optionally - display (S)XEmacs codename. +2005-09-04 Lars Magne Ingebrigtsen <larsi@gnus.org> - * gnus-util.el (gnus-emacs-version): Update for new - `gnus-user-agent'. + * gnus-art.el (gnus-mime-display-security): Don't display the + signature, but only the signed part. - * gnus-msg.el (gnus-extended-version): Make it possible to omit - Gnus version. +2005-09-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-thread-hide-subtree): Doc fix. + + * gnus-msg.el (gnus-inews-insert-gcc): Fix the mistake of using + list, not listp. 2005-09-02 Hrvoje Niksic <hniksic@xemacs.org> @@ -2489,12 +5231,34 @@ De-canonicalize CRLF for all text content types, not just text/plain. -2005-09-02 Katsumi Yamaoka <yamaoka@jpl.org> +2005-09-01 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-sum.el (gnus-thread-hide-subtree): Doc fix. + * gnus-art.el (gnus-article-part-wrapper): Error if there's no + valid article; point arrow and cursor at the MIME button. - * gnus-msg.el (gnus-inews-insert-gcc): Fix the mistake of using - list, not listp. +2005-08-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-save-part-and-strip): Clarify prompt. + Suggested by Dan Christensen <jdc@uwo.ca>. + + * mm-decode.el (mm-save-part): Enable change of prompt. + +2005-08-29 Jari Aalto <jari.aalto@cante.net> + + * gnus-msg.el (gnus-inews-add-send-actions): Made + `message-post-method' lambda parameter ARG `&optional'. + +2005-08-29 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-mime-map): Added + gnus-article-save-part-and-strip, gnus-article-delete-part and + gnus-article-jump-to-part. + + * gnus-art.el (gnus-article-edit-article): Added quiet argument. + (gnus-article-edit-part): Use it. + (gnus-article-part-wrapper): Added no-handle argument. + (gnus-article-save-part-and-strip, gnus-article-delete-part): New + functions. 2005-08-29 Romain Francoise <romain@orebokech.com> @@ -2502,6 +5266,19 @@ docstring. (gnus-face-from-file): Likewise. +2005-08-29 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-mime-save-part-and-strip): Don't prompt. + (gnus-mime-delete-part): Don't prompt if `gnus-expert-user' is + non-nil. + (gnus-auto-select-part): New variable. + (gnus-article-jump-to-part): New function. + (gnus-article-edit-part, gnus-mime-save-part-and-strip) + (gnus-mime-delete-part): Allow selecting specified part after + deleting or stripping parts. + (gnus-article-jump-to-part): Don't use `read-number'. Use last + part if argument is bogus. + 2005-08-31 Juanma Barranquero <lekktu@gmail.com> * gnus-art.el (w3m-minor-mode-map): @@ -2548,22 +5325,40 @@ (pgg-insert-url-with-w3): Require url, to get url-insert-file-contents regardless of where it is defined. +2005-08-13 Romain Francoise <romain@orebokech.com> + + * message.el (message-cite-original-1): New function. + (message-cite-original): Use it. + (message-cite-original-without-signature): Ditto. + +2005-08-08 Romain Francoise <romain@orebokech.com> + + * message.el (message-yank-empty-prefix): New variable. + (message-indent-citation): Use it. + (message-cite-original-without-signature): Respect X-No-Archive. + 2005-08-08 Simon Josefsson <jas@extundo.com> * pgg.el: Autoload url-insert-file-contents instead of loading w3/url. (pgg-insert-url-with-w3): Don't load url here. +2005-08-07 Jesper Harder <harder@phys.au.dk> + + * message.el (message-kill-to-signature): Don't insert newline at + bol. + (message-newline-and-reformat): Bind fill-paragraph-function to nil. + +2005-08-06 Romain Francoise <romain@orebokech.com> + + * message.el (message-user-fqdn): Fix typo in docstring. + 2005-08-05 Daiki Ueno <ueno@unixuser.org> * mml2015.el (mml2015-pgg-sign): Make sure micalg is correct. * pgg-parse.el (pgg-parse-hash-algorithm-alist): Add SHA-2. -2005-08-06 Romain Francoise <romain@orebokech.com> - - * message.el: Fix typo in docstring. - 2005-08-05 Katsumi Yamaoka <yamaoka@jpl.org> * mm-bodies.el (mm-encode-body): Use coding system rather than @@ -2572,12 +5367,6 @@ * mm-util.el (mm-find-mime-charset-region): Attempt to reduce the number of charsets if utf-8 is available (XEmacs). -2005-08-04 Lars Magne Ingebrigtsen <larsi@gnus.org> - - * gnus-art.el (article-unsplit-urls): Don't anchor urls to the - start of the lines. - (gnus-picon-databases): Add /usr/share/picons. - 2005-08-04 Reiner Steib <Reiner.Steib@gmx.de> * gnus-art.el (gnus-button-valid-localpart-regexp): New variable @@ -2587,9 +5376,6 @@ for news:localpart@domain buttons. (gnus-button-ctan-directory-regexp): Update. - * message.el (message-kill-buffer): Raise the current frame. - (message-bury): Use `window-dedicated-p'. - 2005-08-02 Katsumi Yamaoka <yamaoka@jpl.org> * sieve-manage.el (sieve-manage-interactive-login): Use @@ -2647,9 +5433,8 @@ (gnus-article-beginning-of-window): New macro. (gnus-article-next-page-1): Use it. (gnus-article-prev-page): Ditto. - (gnus-mime-save-part-and-strip): Use insert-buffer-substring - instead of insert-buffer. - (gnus-mime-delete-part): Ditto. + (gnus-article-edit-part): Use insert-buffer-substring instead of + insert-buffer. (gnus-article-edit-exit): Ditto. * gnus-util.el (gnus-beginning-of-window): Remove. @@ -2661,18 +5446,44 @@ to have the url package without w3. Reported by Daiki Ueno <ueno@unixuser.org> and Luigi Panzeri <matley@muppetslab.org>. -2005-07-21 Stefan Monnier <monnier@iro.umontreal.ca> +2005-07-20 Didier Verna <didier@xemacs.org> - * mml.el (mml-minibuffer-read-disposition): Don't use inline by default - for text/rtf. Display default in prompt. Pass default for M-n. + * gnus-diary.el: Remove the description comment (nndiary is now + properly documented in the Gnus manual). + Fix the spelling of "Back End". + * nndiary.el: Ditto. + Fix the copyright notice. - * mm-uu.el (mm-uu-copy-to-buffer): Use with-current-buffer. +2005-07-18 Romain Francoise <romain@orebokech.com> + + * gnus-sum.el (gnus-summary-to-prefix, + gnus-summary-newsgroup-prefix): New variables. + (gnus-summary-from-or-to-or-newsgroups): Use them. + +2005-07-17 Romain Francoise <romain@orebokech.com> + + * mml2015.el (mml2015-clean-buffer): Prefix buffer name with a + space as it's generally not especially interesting to the user. 2005-07-16 Romain Francoise <romain@orebokech.com> + * nnfolder.el (nnfolder-save-buffer): Bind `copyright-update' to + nil to avoid prompting and file modification if one of the + messages at the top of the nnfolder file contains a copyright + notice. + Update copyright notice. + * gnus-uu.el (gnus-uu-save-article): Use `message-make-date' instead of `current-time-string' as the latter creates a time string that is not RFC 2822 compliant (it lacks the zone). + Update copyright notice. + +2005-07-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * mml.el (mml-minibuffer-read-disposition): Don't use inline by default + for text/rtf. Display default in prompt. Pass default for M-n. + + * mm-uu.el (mm-uu-copy-to-buffer): Use with-current-buffer. 2005-07-16 Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -2689,10 +5500,22 @@ * gnus-util.el (gnus-beginning-of-window): New function. (gnus-end-of-window): New function. +2005-07-14 Hiroshi Fujishima <hiroshi.fujishima@gmail.com> (tiny change) + + * gnus-score.el (gnus-score-edit-all-score): Set + gnus-score-edit-exit-function to gnus-score-edit-done and call + gnus-message. + +2005-07-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-button-mailto): Remove + save-selected-window-window hackery because it relies on + save-selected-window internals. + 2005-07-13 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-salt.el (gnus-pick-mode): Remove the 5th arg of - gnus-add-minor-mode. + add-minor-mode. (gnus-binary-mode): Ditto. * gnus-topic.el (gnus-topic-mode): Ditto. @@ -2730,7 +5553,7 @@ 2005-06-30 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (article-display-face): Correct the position in - which Faces are inserted; use dolist. + which Faces are inserted. 2005-06-29 Didier Verna <didier@xemacs.org> @@ -2740,13 +5563,22 @@ 2005-06-29 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-nocem.el (gnus-nocem-verifyer): Default to pgg-verify. + (gnus-fill-real-hashtb): Use hash table instead of obarray. (gnus-nocem-check-article): Fetch the Type header. (gnus-nocem-message-wanted-p): Fix the way to examine types. (gnus-nocem-verify-issuer): Use functionp instead of fboundp. - (gnus-nocem-enter-article): Make sure gnus-nocem-hashtb is initialized. + (gnus-nocem-enter-article): Use hash tables rather than obarrays; + make sure gnus-nocem-hashtb is initialized. + (gnus-nocem-alist-to-hashtb): Use hash table instead of obarray. + (gnus-nocem-unwanted-article-p): Ditto. * pgg.el (pgg-verify): Return the verification result. +2005-06-27 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-mime-copy-part): Check whether coding-system + is ascii. + 2005-06-24 Juanma Barranquero <lekktu@gmail.com> * gnus-art.el (gnus-article-mode): Set `nobreak-char-display', not @@ -2770,8 +5602,18 @@ * mm-extern.el (mm-extern-local-file, mm-inline-external-body): * pop3.el (pop3-user): Don't use `format' on `error' arguments. +2005-06-16 Arne J,Ax(Brgensen <arne@arnested.dk> + + * smime.el (smime-cert-by-ldap-1): Detect PEM format without + header by looking for magic "MII" at the beginnig. + 2005-06-16 Miles Bader <miles@gnu.org> + * assistant.el (assistant-field): Remove "-face" suffix from face name. + (assistant-field-face): New backward-compatibility alias for renamed + face. + (assistant-render-text): Use renamed assistant-field face. + * spam.el (spam): Remove "-face" suffix from face name. (spam-face): New backward-compatibility alias for renamed face. (spam-face, spam-initialize): Use renamed spam face. @@ -2906,6 +5748,11 @@ * mm-view.el (mm-inline-text): Turn off adaptive-fill-mode while executing enriched-decode. +2005-06-07 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-find-buffer-file-coding-system): Don't examine + charset of tar files. + 2005-06-04 Luc Teirlinck <teirllm@auburn.edu> * gnus-art.el (article-update-date-lapsed): Use `save-match-data'. @@ -2919,13 +5766,23 @@ * gnus-art.el (gnus-emphasis-alist): Disable the strikethru thingy. +2005-06-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * pop3.el (pop3-apop): Run md5 in the binary mode. + + * starttls.el (starttls-set-process-query-on-exit-flag): + Use eval-and-compile. + +2005-05-31 Simon Josefsson <jas@extundo.com> + + * smime.el (smime-replace-in-string): Define. + (smime-cert-by-ldap-1): Use it. + 2005-05-31 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (article-display-x-face): Replace process-kill-without-query by gnus-set-process-query-on-exit-flag. - * gnus-group.el: Bind gnus-cache-active-hashtb when compiling. - * gnus-util.el (gnus-set-process-query-on-exit-flag): Alias to set-process-query-on-exit-flag or process-kill-without-query. @@ -2954,21 +5811,30 @@ (nntp-open-ssl-stream): Ditto. (nntp-open-tls-stream): Ditto. -2005-05-31 Simon Josefsson <jas@extundo.com> + * starttls.el (starttls-set-process-query-on-exit-flag): Alias to + set-process-query-on-exit-flag or process-kill-without-query. + (starttls-open-stream-gnutls): Use it instead of + process-kill-without-query. + (starttls-open-stream): Ditto. - * imap.el (imap-ssl-open): Use imap-process-connection-type, - instead of hard coding to nil. +2005-05-31 Ulf Stegemann <ulf@zeitform.de> (tiny change) -2005-05-31 Kevin Greiner <kgreiner@xpediantsolutions.com> + * smime.el (smime-cert-by-ldap-1): Don't use + replace-regexp-in-string. - * gnus-group.el: Require gnus-sum and autoload functions to - resolve warnings when gnus-group.el compiled alone. +2005-05-31 Arne J,Ax(Brgensen <arne@arnested.dk> + + * smime-ldap.el (smime-ldap-search): Add compatibility for XEmacs. + + * smime.el (smime-cert-by-ldap-1): Handle certificates distributed + in PEM format. Adjust to the XEmacs compability. 2005-05-30 Reiner Steib <Reiner.Steib@gmx.de> + * encrypt.el (encrypt-xor-process-buffer): Replace `string-to-int' + by `string-to-number'. * gnus-agent.el (gnus-agent-regenerate-group) - (gnus-agent-fetch-articles): Replace `string-to-int' by - `string-to-number'. + (gnus-agent-fetch-articles): Ditto. * gnus-art.el (gnus-button-fetch-group): Ditto. * gnus-cache.el (gnus-cache-generate-active) (gnus-cache-articles-in-group): Ditto. @@ -3063,7 +5929,9 @@ * dig.el (dig): Add :group. - * gnus-art.el (gnus-inhibit-mime-unbuttonizing): Add :group. + * dns-mode.el (dns-mode): Add :group. + + * encrypt.el (encrypt): Add :group. * gnus-cite.el (gnus-cite-attribution-face): Add :group. (gnus-cite-face-1, gnus-cite-face-2, gnus-cite-face-3): Ditto. @@ -3101,8 +5969,20 @@ (gnus-summary-high-read-face, gnus-summary-low-read-face): Ditto. (gnus-summary-normal-read-face, gnus-splash-face): Ditto. + * hashcash.el (hashcash): New custom group. + (hashcash-default-payment): Add :group. + (hashcash-payment-alist): Ditto. + (hashcash-default-accept-payment): Ditto. + (hashcash-accept-resources): Ditto. + (hashcash-path): Ditto. + (hashcash-extra-generate-parameters): Ditto. + (hashcash-double-spend-database): Ditto. + (hashcash-in-news): Ditto. + * message.el (message-minibuffer-local-map): Add :group. + * netrc.el (netrc): Add :group. + * sieve-manage.el (sieve-manage-log): Add :group. (sieve-manage-default-user): Diito. (sieve-manage-server-eol, sieve-manage-client-eol): Ditto. @@ -3122,6 +6002,17 @@ * spam.el (spam, spam-face): Add :group. +2005-05-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nntp.el (nntp-next-result-arrived-p): Some news servers may + return \n.\n.\n at the end of articles. Protect against that. + (nntp-with-open-group): Allow debugging. + + * nnheader.el (mail-header-set-extra): Make into a function + because I just could't understand how to quote the list properly. + + * dns.el (query-dns-cached): New function. + 2005-05-26 Lute Kamstra <lute@gnu.org> * score-mode.el (gnus-score-mode): Use run-mode-hooks. @@ -3130,7 +6021,10 @@ * gnus-art.el: Don't autoload mail-extract-address-components. - * gnus.el: Use eval-and-compile to autoload message-y-or-n-p. + * gnus.el: Remove duplicated autoload for message-y-or-n-p; use + eval-and-compile to evaluate it. + + * hashcash.el: Don't autoload executable-find. * nndb.el: Don't declare the nndb back end two or more times; don't autoload news-reply-mode, news-setup, cancel-timer and telnet. @@ -3138,54 +6032,76 @@ * nntp.el: Autoload format-spec instead of format; use eval-and-compile to evaluate autoload forms. - * spam-report.el (spam-report-process-queue): Use gnus-point-at-eol. +2005-05-09 Georg C. F. Greve <greve@gnu.org> (tiny change) + + * pgg-gpg.el (pgg-gpg-possibly-cache-passphrase): Fix PIN caching. + +2005-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-version-number): Bump version. + +2005-05-01 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no> + + * gnus.el: No Gnus v0.3 is released. 2005-04-28 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-art.el (gnus-article-edit-part): Disable undo. + +2005-04-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-date-ut): Don't delete X-Sent header when + gnus-article-date-lapsed-new-header is t if date timer is active; + skip headers in which the original date value is empty. + (gnus-article-save-original-date): Redefine it as a macro. + (gnus-display-mime): Use it. + +2005-04-22 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-art.el (article-date-ut): Support converting date in forwarded parts as well. - (gnus-article-save-original-date): New macro. + (gnus-article-save-original-date): New function. (gnus-display-mime): Use it. -2005-04-28 David Hansen <david.hansen@physik.fu-berlin.de> +2005-04-22 David Hansen <david.hansen@physik.fu-berlin.de> * nnrss.el (nnrss-check-group, nnrss-request-article): Support the enclosure element of <item>. -2005-04-24 Teodor Zlatanov <tzz@lifelogs.com> +2005-04-21 Reiner Steib <Reiner.Steib@gmx.de> - * spam-report.el (spam-report-unplug-agent) - (spam-report-plug-agent, spam-report-deagentize) - (spam-report-agentize, spam-report-url-ping-temp-agent-function): - support for the Agent in spam-report: when unplugged, report to a - file; when plugged, submit all the requests. - [Added missing offline functionality from trunk.] + * message.el (message-kill-buffer-query): Renamed from + `message-kill-buffer-query-if-modified'. Added :version. -2005-04-24 Reiner Steib <Reiner.Steib@gmx.de> +2005-04-19 Katsumi Yamaoka <yamaoka@jpl.org> - * spam-report.el (spam-report-url-to-file) - (spam-report-requests-file): New function and variable for offline - reporting. - (spam-report-url-ping-function): Add `spam-report-url-to-file' - and user defined function. - (spam-report-process-queue): New function. - Process requests from `spam-report-requests-file'. - (spam-report-url-ping-mm-url): Autoload. - [Added missing offline functionality from trunk.] + * mml.el (mml-preview): Bind gnus-message-buffer while setting the + window layout. + +2005-04-18 Katsumi Yamaoka <yamaoka@jpl.org> + + * mml.el: Autoload dnd when compiling. + +2005-04-18 Reiner Steib <Reiner.Steib@gmx.de> + + * mml.el (mml-mode, mml-dnd-attach-file): Use dnd-* instead of + x-dnd-*. 2005-04-18 Katsumi Yamaoka <yamaoka@jpl.org> * qp.el (quoted-printable-encode-region): Save excursion. +2005-04-14 Teodor Zlatanov <tzz@lifelogs.com> + + * message.el (message-kill-buffer-query-if-modified): Add new variable + so the user can kill a modified message buffer quickly. + (message-kill-buffer): Use it. + 2005-04-13 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-mime-inline-part): Use mm-string-to-multibyte. * qp.el (quoted-printable-encode-region): Use mm-string-to-multibyte. -2005-04-13 Miles Bader <miles@gnu.org> - - * mm-util.el (mm-string-to-multibyte): Use Gnus trunk definition. - 2005-04-12 Katsumi Yamaoka <yamaoka@jpl.org> * nnrss.el (nnrss-node-text): Replace CRLFs (which might be @@ -3193,19 +6109,43 @@ 2005-04-11 Lute Kamstra <lute@gnu.org> - * message.el (message-make-date): Handle byte-compiler warnings + * nnimap.el (nnimap-date-days-ago): Handle byte-compiler warnings differently. - * nnimap.el (nnimap-date-days-ago): Ditto. 2005-04-10 Stefan Monnier <monnier@iro.umontreal.ca> - * mm-util.el (mm-string-to-multibyte): New function. - (mm-detect-coding-region): Typo. + * mm-util.el (mm-detect-coding-region): Typo. 2005-04-11 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-article-read-summary-keys): Fix misplaced parens. +2005-04-06 D Goel <deego@gnufans.org> + + * spam-stat.el (spam-stat-score-buffer): Add a call to a + user-function allow user modifications of the scores. + (spam-stat-score-buffer-user): New function, to allow + user-computed modifications to the score. + (spam-stat-score-buffer-user-functions): list of additional + scoring functions + (spam-stat-error-holder): global temporary error holder + (spam-stat-split-fancy): use the new `spam-stat-error-holder' + variable + +2005-04-06 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-clean-empty-function) + (gnus-registry-trim, gnus-registry-fetch-groups) + (gnus-registry-delete-group): Groups that match + `gnus-registry-ignored-groups' are removed from the registry + entries, not just ignored for splitting. This helps clean up the + registry. Also, `gnus-registry-fetch-groups' is a convenient way + to get all the groups a message ID is in. + + * spam-stat.el (spam-stat-split-fancy-spam-threshold) + (spam-stat-split-fancy): Change "threshhold" to "threshold" + (spam-stat-score-buffer-user-functions): Add :number custom type. + 2005-04-06 Katsumi Yamaoka <yamaoka@jpl.org> * mm-util.el (mm-coding-system-p): Don't return binary for the nil @@ -3217,132 +6157,19 @@ failed. (nnrss-get-encoding): Return a compatible encoding according to nnrss-compatible-encoding-alist. - (nnrss-opml-export): Use dolist. (nnrss-find-el): Use consp instead of listp. - (nnrss-order-hrefs): Use dolist. - -2005-04-06 Arne J,Ax(Brgensen <arne@arnested.dk> - - * nnrss.el (nnrss-verbose): Remove. - (nnrss-request-group): Use `nnheader-message' instead. - -2005-04-06 Mark Plaksin <happy@usg.edu> (tiny change) - - * nnrss.el (nnrss-verbose): New variable. - (nnrss-request-group): Make it say nnrss is requesting a group. + (nnrss-opml-export, nnrss-order-hrefs, nnrss-find-el): Use dolist. 2005-04-06 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-agent.el (gnus-agent-group-path): Decode group name. - (gnus-agent-group-pathname): Ditto. - - * gnus-cache.el (gnus-cache-file-name): Decode group name. - - * gnus-group.el (gnus-group-line-format-alist): Use decoded group - name for only %g and %c. - (gnus-group-insert-group-line): Bind gnus-tmp-decoded-group - instead of gnus-tmp-group to decoded group name. - (gnus-group-make-group): Decode group name. - (gnus-group-delete-group): Ditto. - (gnus-group-make-rss-group): Exclude `/'s from group names; - register the group data after opening the nnrss group; unify - non-ASCII group names; encode group name. - (gnus-group-catchup-current): Decode group name. - (gnus-group-expire-articles-1): Ditto. - (gnus-group-set-current-level): Ditto. - (gnus-group-kill-group): Ditto. - - * gnus-spec.el (gnus-update-format-specifications): Flush the - group format spec cache if it doesn't support decoded group names. - - * mm-url.el (mm-url-predefined-programs): Add --silent arg to curl. - - * nnrss.el: Require rfc2047 and mml. - (nnrss-file-coding-system): New variable. - (nnrss-format-string): Redefine it as an inline function. - (nnrss-decode-group-name): New function. - (nnrss-string-as-multibyte): Remove. - (nnrss-retrieve-headers): Decode group name; don't use - nnrss-format-string. - (nnrss-request-group): Decode group name. - (nnrss-request-article): Decode group name; allow a Message-ID as - well as an article number; don't use nnrss-format-string; encode a - Message-ID string which may contain non-ASCII characters; use - mml-to-mime to compose a MIME article; use search-forward instead - of re-search-forward. - (nnrss-request-expire-articles): Decode group name. - (nnrss-request-delete-group): Delete entries in nnrss-group-alist - as well; decode group name. - (nnrss-get-encoding): Fix regexp. - (nnrss-fetch): Clarify error message. - (nnrss-read-server-data): Use insert-file-contents instead of load; - bind file-name-coding-system; use multibyte buffer. - (nnrss-save-server-data): Insert newline; bind - coding-system-for-write to the value of nnrss-file-coding-system; - bind file-name-coding-system; add coding cookie. - (nnrss-read-group-data): Use insert-file-contents instead of load; - bind file-name-coding-system; use multibyte buffer. - (nnrss-save-group-data): Bind coding-system-for-write to the - value of nnrss-file-coding-system; bind file-name-coding-system. - (nnrss-decode-entities-string): Rename from n-d-e-unibyte-string; - make it work with non-ASCII text. - (nnrss-opml-export): Use mm-set-buffer-file-coding-system instead - of set-buffer-file-coding-system. - (nnrss-find-el): Check carefully whether there's a list of string - which old xml.el may return rather than a string; make it work - with old xml.el as well. - -2005-04-06 Tsuyoshi AKIHO <akiho@kawachi.zaq.ne.jp> - - * gnus-sum.el (gnus-summary-walk-group-buffer): Decode group name. - - * nnrss.el (nnrss-get-encoding): New function. - (nnrss-fetch): Use unibyte buffer initially; bind - coding-system-for-read while performing mm-url-insert; remove ^Ms; - decode contents according to the encoding attribute. - (nnrss-save-group-data): Add coding cookie. - (nnrss-mime-encode-string): New function. - (nnrss-check-group): Use it to encode subject and author. - -2005-04-06 Maciek Pasternacki <maciekp@japhy.fnord.org> (tiny change) - - * nnrss.el (nnrss-fetch): Signal an error if w3-parse-buffer also - failed. - -2005-04-06 Joakim Verona <joakim@verona.se> (tiny change) - - * nnrss.el (nnrss-read-group-data): Fix off-by-one error. - -2005-04-06 Jesper Harder <harder@ifa.au.dk> - - * mm-util.el (mm-subst-char-in-string): Support inplace. - - * nnrss.el: Pedantic docstring and whitespace fixes (courtesy of - checkdoc.el). - (nnrss-request-article): Cleanup. - (nnrss-request-delete-group): Use nnrss-make-filename. - (nnrss-read-server-data): Use nnrss-make-filename; use load. - (nnrss-save-server-data): Use nnrss-make-filename; use gnus-prin1. - (nnrss-read-group-data): hash on description if link is missing; - use nnrss-make-filename; use load. - (nnrss-save-group-data): Use nnrss-make-filename; use gnus-prin1. - (nnrss-make-filename): New function. - (nnrss-close): New function. - (nnrss-check-group): Hash on description if link is missing. - (nnrss-get-namespace-prefix): Use string= to compare strings! - Reported by David D. Smith <davidsmith@acm.org>. - (nnrss-opml-export): Turn on sgml-mode. - -2005-04-06 Mark A. Hershberger <mah@everybody.org> - - * nnrss.el (nnrss-opml-import, nnrss-opml-export): New functions. + * time-date.el (time-to-seconds): Don't use the #xhhhh syntax + which Emacs 20 doesn't support. + (seconds-to-time, days-to-time, time-subtract, time-add): Ditto. 2005-04-04 Reiner Steib <Reiner.Steib@gmx.de> - * message.el (message-make-date): Add defvars in order to silence - the byte compiler inside the defun. - - * nnimap.el (nnimap-date-days-ago): Ditto. + * nnimap.el (nnimap-date-days-ago): Add defvars in order to + silence the byte compiler inside the defun * gnus-demon.el (parse-time-string): Add autoload. @@ -3352,84 +6179,13 @@ * nnultimate.el (parse-time): Require for `parse-time-string'. -2005-04-03 Katsumi Yamaoka <yamaoka@jpl.org> +2005-03-31 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-sum.el (gnus-summary-make-menu-bar): Avoid the - "Unrecognized menu descriptor" error in XEmacs. + * gnus-art.el (gnus-copy-article-ignored-headers): Update :version. -2005-03-25 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-score.el (gnus-adaptive-pretty-print): Ditto. - * message.el (message-resend): Bind rfc2047-encode-encoded-words. - - * mm-util.el (mm-replace-in-string): New function. - (mm-xemacs-find-mime-charset-1): Ignore errors while loading - latin-unity, which cannot be used with XEmacs 21.1. - - * rfc2047.el (rfc2047-encode-function-alist): Rename from - rfc2047-encoding-function-alist in order to avoid conflicting with - the old version. - (rfc2047-encode-message-header): Remove useless goto-char. - (rfc2047-encodable-p): Don't move point. - (rfc2047-syntax-table): Treat `(' and `)' as is. - (rfc2047-encode-region): Concatenate words containing non-ASCII - characters in structured fields; don't encode space-delimited - ASCII words even in unstructured fields; don't break words at - char-category boundaries; encode encoded words in structured - fields; treat text within parentheses as special; show the - original text when error has occurred; move point to the end of - the region after encoding, suggested by IRIE Tetsuya - <irie@t.email.ne.jp>; treat backslash-quoted characters as - non-special; check carefully whether to encode special characters; - fix some kind of misconfigured headers; signal a real error if - debug-on-quit or debug-on-error is non-nil; don't infloop, - suggested by Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>; assume - the close parenthesis may be included in the encoded word; encode - bogus delimiters. - (rfc2047-encode-string): Use mm-with-multibyte-buffer. - (rfc2047-encode-max-chars): New variable. - (rfc2047-encode-1): New function. - (rfc2047-encode): Use it; encode text so that it occupies the - maximum width within 76-column; work correctly on Q encoding for - iso-2022-* charsets; fold the line before encoding; don't append a - space if the encoded word includes close parenthesis. - (rfc2047-fold-region): Use existing whitespace for LWSP; make it - sure not to break a line just after the header name. - (rfc2047-b-encode-region): Remove. - (rfc2047-b-encode-string): New function. - (rfc2047-q-encode-region): Remove. - (rfc2047-q-encode-string): New function. - (rfc2047-encode-parameter): New function. - (rfc2047-encoded-word-regexp): Don't use shy group. - (rfc2047-decode-region): Follow rfc2047-encoded-word-regexp change. - (rfc2047-parse-and-decode): Ditto. - (rfc2047-decode): Treat the ascii coding-system as raw-text by default. - -2005-03-25 Lars Magne Ingebrigtsen <larsi@gnus.org> - - * rfc2047.el (rfc2047-encode-encoded-words): New variable. - (rfc2047-field-value): Strip props. - (rfc2047-encode-message-header): Disable header folding -- not - all headers can be folded, and this should be done by the message - composition mode. Probably. I think. - (rfc2047-encodable-p): Say that =? needs encoding. - (rfc2047-encode-region): Encode =? strings. - -2005-03-25 Jesper Harder <harder@ifa.au.dk> - - * rfc2047.el (rfc2047-encoded-word-regexp): Support RFC 2231 - language tags; remove unnecessary '+'. Reported by Stefan Wiens - <s.wi@gmx.net>. - (rfc2047-decode-string): Don't cons a string unnecessarily. - (rfc2047-parse-and-decode, rfc2047-decode): Use a character for - the encoding to avoid consing a string. - (rfc2047-decode): Use mm-subst-char-in-string instead of - mm-replace-chars-in-string. - -2005-03-25 TSUCHIYA Masatoshi <tsuchiya@namazu.org> - - * rfc2047.el (rfc2047-encode): Use uppercase letters to specify - encodings of MIME-encoded words, in order to improve - interoperability with several broken MUAs. + * smime.el (smime-ldap-host-list): Add :version. 2005-03-21 Reiner Steib <Reiner.Steib@gmx.de> @@ -3475,22 +6231,13 @@ 2005-03-13 Andrey Slusar <anrays@gmail.com> (tiny change) - * gnus.el: Don't try and mark `gnus-agent-save-groups' as an - autoloaded function. - -2005-03-13 Steve Youngs <steve@sxemacs.org> - - * mm-url.el: Require timer-funcs at compile time when in XEmacs - for `with-timeout'. - - * mail-source.el: Require timer-funcs at compile time when in + * gnus-async.el: Require timer-funcs at compile time when in XEmacs for `run-with-idle-timer'. - * gnus-async.el: Ditto. - -2005-03-16 Lute Kamstra <lute@gnu.org> +2005-03-13 Andrey Slusar <anrays@gmail.com> (tiny change) - * message.el (message-make-date): Require parse-time. + * gnus.el: Don't try and mark `gnus-agent-save-groups' as an + autoloaded function. 2005-03-10 Stefan Monnier <monnier@iro.umontreal.ca> @@ -3500,12 +6247,45 @@ * nnimap.el (nnimap-retrieve-headers-from-server): Fix off-by-one flaw. +2005-03-09 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-confirm-mail-reply-to-news): Add + gnus-expert-user to default. + +2005-03-08 Juergen Kreileder <jk@blackdown.de> (tiny change) + + * nnimap.el (nnimap-open-server): Ditto. + + * imap.el (imap-authenticate): Fix typo. + 2005-03-08 Bjorn Solberg <bjorn_ding@hekneby.org> (tiny change) * nnimap.el (nnimap-retrieve-headers-from-server): Sort NOV buffer (since IMAP server might return FETCH response out of order, and the nntp buffer must be sorted). +2005-03-06 Kevin Greiner <kevin.greiner@compsol.cc> + + * gnus-start.el (gnus-convert-old-newsrc): Fixed numeric + comparison on string. + + * gnus-agent.el (gnus-agent-long-article, + gnus-agent-short-article, gnus-agent-score): Renamed category + keywords to match gnus-cus. + (gnus-agent-summary-fetch-series): Modified to protect against + gnus-agent-summary-fetch-group clearing processable flags. + (gnus-agent-synchronize-group-flags): Update live group buffer as + synchronization may occur due to the user toggle the plugged + status. + (gnus-agent-fetch-group-1): Clear downloadable flag when article + successfully downloaded. + (gnus-agent-expire-group-1): Avoid using markers when the overview + is in ascending order; greatly improves performance. + (gnus-agent-regenerate-group): Use + gnus-agent-synchronize-group-flags to reset read status in both + gnus and server. + (gnus-agent-update-files-total-fetched-for): Fixed initial size. + 2005-03-04 Reiner Steib <Reiner.Steib@gmx.de> * message.el: Don't autoload former message-utils variables. @@ -3526,12 +6306,59 @@ * nnweb.el (nnweb-type-definition): Use groups.google.de instead of broken groups(-beta).google.com. +2005-03-03 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sum.el (gnus-summary-move-article): Pass move-is-internal + parameter to invoked gnus-request-move-article; remove the + redundant gnus-sum-hint-move-is-internal variable; apply the marks + all at once instead of once per article. + (gnus-summary-remove-process-mark): Accept a list of articles as + well as a single article for processing. + + * gnus-int.el (gnus-request-move-article): Add move-is-internal + parameter. + + * nnml.el (nnml-request-move-article): Add move-is-internal parameter. + + * nnmh.el (nnmh-request-move-article): Add move-is-internal parameter. + + * nnmbox.el (nnmbox-request-move-article): Add move-is-internal + parameter. + + * nnmaildir.el (nnmaildir-request-move-article): Add move-is-internal + parameter. + + * nnimap.el (nnimap-request-move-article): Add move-is-internal + parameter and remove the gnus-sum-hint-move-is-internal variable. + + * nnfolder.el (nnfolder-request-move-article): Add move-is-internal + parameter. + + * nndraft.el (nndraft-request-move-article): Add move-is-internal + parameter. + + * nndiary.el (nndiary-request-move-article): Add move-is-internal + parameter. + + * nndb.el (nndb-request-move-article): Add move-is-internal parameter. + + * nnbabyl.el (nnbabyl-request-move-article): Add move-is-internal + parameter. + + * nnagent.el (nnagent-request-move-article): Add move-is-internal + parameter. + 2005-03-01 Stefan Monnier <monnier@iro.umontreal.ca> * gnus-sum.el (gnus-summary-exit): Undo last change and fix it in a more conservative way. -2005-02-27 Arne J,Ax(Brgensen <arne@arnested.dk> +2005-02-26 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-sum.el (gnus-summary-exit): Move point after displaying the + buffer, so it moves the window's cursor. + +2005-02-26 Arne J,Ax(Brgensen <arne@arnested.dk> * mm-decode.el (mm-dissect-buffer): Pass the from field on to `mm-dissect-multipart' and receive the from field as an (optional) @@ -3540,10 +6367,16 @@ pass it on when we call `mm-dissect-buffer' on MIME parts. Fixes verification/decryption of signed/encrypted MIME parts. -2005-02-26 Stefan Monnier <monnier@iro.umontreal.ca> +2005-02-25 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-sum.el (gnus-summary-exit): Move point after displaying the - buffer, so it moves the window's cursor. + * gnus-sum.el (gnus-summary-move-article): Set + gnus-sum-hint-move-is-internal for gnus-request-move-article and + whatever it calls (right now, only nnimap-request-move article + respects it). + + * nnimap.el (nnimap-request-move-article): When + gnus-sum-hint-move-is-internal is set, don't do the extra + nnimap-request-article. 2005-02-24 Reiner Steib <Reiner.Steib@gmx.de> @@ -3558,12 +6391,43 @@ * gnus-group.el (gnus-group-clear-data): Mention process/prefix in doc string. +2005-02-22 Simon Josefsson <jas@extundo.com> + + * encrypt.el (encrypt-password-cache-expiry): Remove (use + `password-cache-expiry' instead). Reported by Arne J,Ax(Brgensen + <arne@arnested.dk>. + (encrypt): Add password-cache and password-cache-expiry as group + members. + 2005-02-22 Arne J,Ax(Brgensen <arne@arnested.dk> - * smime.el (smime-sign-buffer): Signal an error if - `smime-sign-region' fails. + * smime.el (smime-ldap-host-list): Doc fix. + (smime-ask-passphrase): Use `password-read-and-add' to read (and + cache) password. + (smime-sign-region): Use it. + (smime-decrypt-region): Use it. + (smime-sign-buffer): Signal an error if `smime-sign-region' fails. (smime-encrypt-buffer): Signal an error if `smime-encrypt-region' fails. + (smime-cert-by-ldap-1): Use `base64-encode-string' to convert + certificate from DER to PEM format rather than calling openssl. + + * mml-smime.el (mml-smime-encrypt-query): Remove obsolete comment. + + * mml-sec.el (mml-secure-message): Insert keyfile/certfile tags + for signing/encryption. + + * mml.el (mml-parse-1): Use them. + +2005-02-21 Arne J,Ax(Brgensen <arne@arnested.dk> + + * nnrss.el (nnrss-verbose): Removed. + (nnrss-request-group): Use `nnheader-message' instead. + +2005-02-19 Mark Plaksin <happy@usg.edu> (tiny change) + + * nnrss.el (nnrss-verbose): New variable. + (nnrss-request-group): Make it say nnrss is requesting a group. 2005-02-21 Reiner Steib <Reiner.Steib@gmx.de> @@ -3579,17 +6443,17 @@ * mml.el (mime-to-mml): Ditto. - * rfc2047.el (rfc2047-quote-decoded-words-containing-tspecials): - New variable. + * rfc2047.el (rfc2047-encode-parameter): Use ietf-drums-tspecials. + (rfc2047-quote-decoded-words-containing-tspecials): New variable. (rfc2047-decode-region): Quote decoded words containing special characters when rfc2047-quote-decoded-words-containing-tspecials is non-nil. 2005-02-16 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-registry.el (gnus-registry-delete-group): Minor bug fix. + * gnus-registry.el (gnus-registry-delete-group): Add minor bug fix. - * gnus.el (gnus-install-group-spam-parameters): Doc fix. + * gnus.el (gnus-install-group-spam-parameters): Add minor doc fix. 2005-02-15 Simon Josefsson <jas@extundo.com> @@ -3597,6 +6461,43 @@ * imap.el (imap-debug): Doc fix. +2005-02-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el: Avoid "Recursive load suspected" error in Emacs 21.1. + +2005-02-14 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus.el (spam-contents): Improve docs for spam-contents + parameter in its variable incarnation. + +2005-02-14 Simon Josefsson <jas@extundo.com> + + * smime-ldap.el: Use require instead of load-library for ldap. + (smime-ldap-search): Indent. + (smime-ldap-search-internal): Shorten line. + + * smime.el (smime-cert-by-dns): Add doc-string. + (smime-cert-by-ldap-1): Indent. + + * mml-smime.el (mml-smime-get-ldap-cert): Renamed from + mml-smime-get-dns-ldap. + (mml-smime-encrypt-query): Use new function. Default to ldap. + +2005-02-14 Arne J,Ax(Brgensen <arne@arnested.dk> + + * smime.el: Require smime-ldap. + (smime-ldap-host-list): New variable. + (smime-cert-by-ldap, smime-cert-by-ldap-1): New functions. + + * mml-smime.el (mml-smime-encrypt-query): New function. + (mml-smime-encrypt-query): Use it. + + * smime-ldap.el: New file. + +2005-02-13 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el: Remove garbage made while merging the Emacs trunk. + 2005-02-14 Reiner Steib <Reiner.Steib@gmx.de> * gnus-group.el (gnus-group-make-doc-group): Mention prefix @@ -3615,15 +6516,95 @@ Change Emacs release version from 21.4 to 22.1 throughout. Change Emacs development version from 21.3.50 to 22.0.50. +2005-02-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-copy-part): Don't decode compressed parts. + + * mm-util.el (mm-coding-system-to-mime-charset): Make it work with + non-Mule XEmacs as well. + (mm-decompress-buffer): Signal an error intentionally if it does + not decompress compressed data because auto-compression-mode is + disabled. + +2005-02-11 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-delete-group): Fix bug: leaves + an ID in the registry even if it has no groups. + +2005-02-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-jka-compr-maybe-uncompress): Remove; + merge it into mm-decompress-buffer. + (gnus-mime-copy-part): Use the MIME part charset, the value which + a user specified or gnus-newsgroup-charset for decoding, like + gnus-mime-inline-part does; set buffer-file-coding-system to tell + save-buffer what was used. Suggested by Kevin Ryde + <user42@zip.com.au>. + (gnus-mime-inline-part): Allow the name parameter as well as the + filename parameter; force decompressing of compressed data; always + display contents being not decoded as unibyte. + + * mm-view.el (mm-display-inline-fontify): Allow the name parameter + as well as the filename parameter. + + * mm-util.el (mm-decompress-buffer): Merge + gnus-mime-jka-compr-maybe-uncompress. + (mm-find-buffer-file-coding-system): Doc fix; force decompressing + of compressed data. + 2005-02-08 Simon Josefsson <jas@extundo.com> * imap.el (imap-log): Doc fix. +2005-02-07 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-inline-part): Decode parts according to + the coding cookies; decompress compressed parts. + + * mml.el (mml-generate-mime-1): Add the charaset parameter according + to the value which a user specified manually or the coding cookie. + + * mm-util.el (mm-string-to-multibyte): New function. + (mm-detect-mime-charset-region): Work with Emacs 22 as well. + (mm-coding-system-to-mime-charset): New function. + (mm-decompress-buffer): New function. + (mm-find-buffer-file-coding-system): New function. + + * mm-view.el (mm-insert-inline): Make sure a part ends with a newline. + (mm-display-inline-fontify): Rewrite for decoding and decompressing + parts. + +2005-02-07 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * mm-view.el (mm-display-inline-fontify): Decode a part according + to the charset parameter. + 2005-02-03 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-mime-inline-part): Show the raw contents if a prefix arg is neither nil nor a number, as info specifies. +2005-02-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * nntp.el (nntp-marks-changed-p): Use time-less-p to compare the + timestamps. + +2005-02-02 Jari Aalto <jari.aalto@cante.net> + + * gnus-sum.el (gnus-list-of-unread-articles): Improve active + groups error checking and notify user. + +2005-02-02 Jari Aalto <jari.aalto@poboxes.com> + + * message.el (message-send-mail-function): Check existence of + sendmail-program first before using default value + `message-send-mail-with-sendmail'. Otherwise use more generic + `smtpmail-send-it'. + +2005-02-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * nntp.el (nntp-request-update-info): Always return nil. + 2005-01-30 Stefan Monnier <monnier@iro.umontreal.ca> * gnus-art.el (gnus-article-mode): Turn off the "\ " non-break space. @@ -3644,11 +6625,46 @@ * gnus-art.el (gnus-article-prepare): Remove message-strip-forbidden-properties from the local hook. +2005-01-27 Simon Josefsson <jas@extundo.com> + + * password.el (password-cache-add): Only start one timer per key. + Reported by Derek Atkins <warlord@MIT.EDU>. + +2005-01-26 Steve Youngs <steve@sxemacs.org> + + * run-at-time.el: Removed. It is no longer needed as + timer-funcs.el in the xemacs-base package has a working version of + `run-at-time'. + + * password.el: Require timer-funcs instead of run-at-time in + XEmacs. + Remove `password-run-at-time' macro. + (password-cache-add): Use `run-at-time' instead of + `password-run-at-time'. + + * mail-source.el: Require timer-funcs instead of itimer in XEmacs + for `run-with-idle-timer'. + + * gnus-demon.el: Require timer-funcs instead of itimer in XEmacs + for `run-at-time'. + + * mm-url.el: Require timer-funcs at compile time when in XEmacs + for `with-timeout'. + 2005-01-24 Katsumi Yamaoka <yamaoka@jpl.org> * mml.el (mml-generate-mime-1): Convert string into unibyte when inserting " *mml*" buffer's contents into a unibyte temp buffer. +2005-01-24 Harald Meland <harald.meland@usit.uio.no> (tiny change) + + * mail-source.el (mail-source-fetch-imap): Search for ^From case + sensitively. + +2005-01-21 Derek Atkins <warlord@MIT.EDU> (tiny change) + + * pgg-pgp.el (pgg-pgp-decrypt-region): Use passphrase cache. + 2005-01-20 Katsumi Yamaoka <yamaoka@jpl.org> * mm-decode.el (mm-insert-part): Switch the multibyteness of data @@ -3656,11 +6672,91 @@ rather than the type of contents. Suggested by ARISAWA Akihiro <ari@mbf.ocn.ne.jp>. + * nnrss.el (nnrss-find-el): Check carefully whether there's a list + of string which old xml.el may return rather than a string. + +2005-01-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-idna-message): Silence byte compiler. + +2005-01-16 Simon Josefsson <jas@extundo.com> + + * gnus-sum.el (gnus-summary-idna-message): Fail gracefully if + idn/idna.el isn't available. + (gnus-summary-idna-message): Doc fix. Suggested by Michael Cook + <michael@waxrat.com>. + + * hashcash.el: Remove non-FSF copyright header. + + * hashcash.el (hashcash-extra-generate-parameters): New variable. + (hashcash-generate-payment): Use it. + (hashcash-generate-payment-async): Use it. + +2005-01-15 Simon Josefsson <jas@extundo.com> + + * message.el (message-idna-to-ascii-rhs): Decode Reply-To too. + Suggested by Raymond Scholz <ray-2005@zonix.de>. + + * gnus-sum.el (gnus-summary-wash-map): Bind "W i" to + gnus-summary-idna-message. + (gnus-summary-make-menu-bar): Add De-IDNA menu entry. + (gnus-summary-idna-message): New function. + +2005-01-13 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-msg.el (gnus-confirm-mail-reply-to-news): Change default to + gnus-novice-user. + +2005-01-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnrss.el (nnrss-request-delete-group): Delete entries in + nnrss-group-alist as well. + (nnrss-save-server-data): Insert newline. + +2005-01-10 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus.el (gnus-user-agent): Use list of symbols instead of + symbols. Display full version number for (S)XEmacs. Optionally + display (S)XEmacs codename. + + * gnus-util.el (gnus-emacs-version): Update for new + `gnus-user-agent'. + + * gnus-msg.el (gnus-extended-version): Make it possible to omit + Gnus version. + 2005-01-05 Reiner Steib <Reiner.Steib@gmx.de> * spam.el (spam-face): New face. Don't use `gnus-splash-face' which is unreadable in some setups. +2005-01-06 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-spec.el (gnus-update-format-specifications): Flush the + group format spec cache if it doesn't support decoded group names. + +2005-01-03 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-score.el (gnus-decay-scores, gnus-score-load-file): Allow + to apply decay on score files matching a regexp. + +2004-12-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-line-format-alist): Keep the forward + compatibility in %g and %c. + +2004-12-29 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-line-format-alist): Use decoded group + name for only %g and %c. + (gnus-group-insert-group-line): Bind gnus-tmp-decoded-group instead + of gnus-tmp-group to decoded group name. + (gnus-group-make-rss-group): Exclude `/'s from group names. + +2004-12-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnrss.el (nnrss-get-encoding): Fix regexp. + 2004-12-27 Simon Josefsson <jas@extundo.com> * mm-bodies.el (mm-body-encoding): Don't permit 7-bit to be used when @@ -3673,17 +6769,95 @@ * gnus-sum.el (gnus-summary-mode-map): Likewise. +2004-12-26 Tsuyoshi AKIHO <akiho@kawachi.zaq.ne.jp> + + * gnus-sum.el (gnus-summary-walk-group-buffer): Decode group name. + +2004-12-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnrss.el: Require rfc2047 and mml. + (nnrss-file-coding-system): New variable. + (nnrss-format-string): Redefine it as an inline function. + (nnrss-decode-group-name): New function. + (nnrss-string-as-multibyte): Remove. + (nnrss-retrieve-headers): Decode group name; don't use + nnrss-format-string. + (nnrss-request-group): Decode group name. + (nnrss-request-article): Decode group name; allow a Message-ID as + well as an article number; don't use nnrss-format-string; encode a + Message-ID string which may contain non-ASCII characters; use + mml-to-mime to compose a MIME article. + (nnrss-request-expire-articles): Decode group name. + (nnrss-request-delete-group): Decode group name. + (nnrss-fetch): Clarify error message. + (nnrss-read-server-data): Use insert-file-contents instead of load; + bind file-name-coding-system; use multibyte buffer. + (nnrss-save-server-data): Bind coding-system-for-write to the + value of nnrss-file-coding-system; bind file-name-coding-system; + add coding cookie. + (nnrss-read-group-data): Use insert-file-contents instead of load; + bind file-name-coding-system; use multibyte buffer. + (nnrss-save-group-data): Bind coding-system-for-write to the + value of nnrss-file-coding-system; bind file-name-coding-system. + (nnrss-decode-entities-string): Rename from n-d-e-unibyte-string; + make it work with non-ASCII text. + (nnrss-find-el): Make it work with old xml.el as well. + +2004-12-26 Tsuyoshi AKIHO <akiho@kawachi.zaq.ne.jp> + + * nnrss.el (nnrss-get-encoding): New function. + (nnrss-fetch): Use unibyte buffer initially; bind + coding-system-for-read while performing mm-url-insert; remove ^Ms; + decode contents according to the encoding attribute. + (nnrss-save-group-data): Add coding cookie. + (nnrss-mime-encode-string): New function. + (nnrss-check-group): Use it to encode subject and author. + +2004-12-23 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-check-BBDB): Don't get the symbol-value of an + imaginary variable. + 2004-12-22 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-spec.el (gnus-spec-tab): Make a Lisp form which works correctly even if there are wide characters. +2004-12-21 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-check-BBDB): Fix the BBDB caching code to use + downcased symbol names; make a new cache instead of reusing + bbdb-hashtable. + 2004-12-21 Katsumi Yamaoka <yamaoka@jpl.org> * rfc2231.el (rfc2231-parse-string): Decode encoded value after concatenating segments rather than before concatenating them. Suggested by ARISAWA Akihiro <ari@mbf.ocn.ne.jp>. + * message.el (message-get-reply-headers): Bind `extra'. + +2004-12-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-extra-wide-headers): New variable. + (message-get-reply-headers): Use it. + +2004-12-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-group-path): Decode group name. + (gnus-agent-group-pathname): Ditto. + + * gnus-cache.el (gnus-cache-file-name): Decode group name. + + * gnus-group.el (gnus-group-make-group): Decode group name. + (gnus-group-make-rss-group): Register the group data after opening + the nnrss group. + +2004-12-17 Paul Jarc <prj@po.cwru.edu> + + * nnmaildir.el (nnmaildir-request-expire-articles): Articles moved + by expiry now get marked as read. + 2004-12-17 Katsumi Yamaoka <yamaoka@jpl.org> * mm-util.el (mm-xemacs-find-mime-charset): New macro. @@ -3702,6 +6876,34 @@ * gnus-cache.el (gnus-cache-delete-group): Use it. +2004-12-16 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-make-rss-group): Unify non-ASCII group + names. + +2004-12-16 Simon Josefsson <jas@extundo.com> + + * hashcash.el (hashcash-payment-alist): Fix custom :type. + +2004-12-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-url.el (mm-url-predefined-programs): Add --silent arg to curl. + + * gnus-group.el (gnus-group-expire-articles-1): Decode group name. + (gnus-group-set-current-level): Decode group name. + +2004-12-15 Maciek Pasternacki <maciekp@japhy.fnord.org> (tiny change) + + * nnrss.el (nnrss-fetch): Signal an error if w3-parse-buffer also + failed. + +2004-12-14 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-delete-group): Decode group name. + (gnus-group-make-rss-group): Encode group name. + (gnus-group-catchup-current): Decode group name. + (gnus-group-kill-group): Decode group name. + 2004-12-08 Stefan Monnier <monnier@iro.umontreal.ca> * gnus-art.el (gnus-narrow-to-page): Don't hardcode point-min. @@ -3715,6 +6917,53 @@ gnus-message-archive-method. Suggested by Lute Kamstra <lute@gnu.org>. +2004-12-10 Arnaud Giersch <arnaud.giersch@free.fr> (tiny change) + + * gnus-sum.el (gnus-summary-exit-no-update): Don't clear the + global counterparts of the buffer-local variables. + +2004-11-16 Romain Francoise <romain@orebokech.com> + + * gnus-sum.el (gnus-summary-exit): Don't clear the global + counterparts of the buffer-local variables. + +2004-11-25 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-forbidden-properties): Fixed typo in doc + string. + +2004-11-25 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-util.el (gnus-replace-in-string): Added doc string. + + * nnmail.el (nnmail-split-header-length-limit): Increase to 2048 + to avoid problems when splitting mails with many recipients. + +2004-11-22 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-sum.el (gnus-summary-exit): Remove redundant and harmful + pop-to-buffer, covered by the subsequent gnus-configure-windows. + +2004-12-05 Nelson Ferreira <nelson.ferreira@ieee.org> + + * spam-stat.el (spam-stat-save): Load the hashtable from disk only + if there is no hashtable in memory or file modification time is + newer than cached timestamp. + +2004-12-03 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-limit-to-recipient): Implement + not-matching option. + +2004-12-02 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-summary-limit-to-recipient): New function. + Suggested David Mazieres in analogy to rmail-summary-by-recipients. + (gnus-summary-limit-map, gnus-summary-make-menu-bar): Add it. + (gnus-article-sort-by-recipient, gnus-summary-sort-by-recipient): + New functions. Suggested by Uwe Brauer <oub@mat.ucm.es>. + (gnus-summary-mode-map, gnus-summary-make-menu-bar): Add it. + 2004-12-02 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-forward-make-body-mml): Remove headers @@ -3725,16 +6974,36 @@ * message.el (message-forward-make-body-plain): Always remove headers according to message-forward-ignored-headers. +2004-12-01 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Remove the + gnus-summary-limit pop for now, it has problems with ham marks for + me. + +2004-11-29 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Use gnus-summary-limit + correctly. + +2004-11-28 Carl Henrik Lunde <chlunde+bugs+@ping.uio.no> (tiny change) + + * format-spec.el (format-spec): Message the char. + +2004-11-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-art.el (gnus-split-methods): Reformat comments. + + * spam.el (spam-summary-prepare-exit): Remove article limits + before exiting the summary buffer. + 2004-11-26 Katsumi Yamaoka <yamaoka@jpl.org> * nnrss.el (nnrss-string-as-multibyte): Redefine it as a macro in order to silence the byte compiler. - * pop3.el (pop3-md5): Define it before being used. - * spam.el: Fix the way to silence the byte compiler, which - complained about bbdb-buffer, bbdb-create-internal, - bbdb-search-simple, mail-check-payment, spam-BBDB-register-routine, + complained about bbdb-buffer, bbdb-create-internal, bbdb-records, + bbdb-search-simple, spam-BBDB-register-routine, spam-enter-ham-BBDB, spam-stat-buffer-change-to-non-spam, spam-stat-buffer-change-to-spam, spam-stat-buffer-is-non-spam, spam-stat-buffer-is-spam, spam-stat-load, @@ -3771,21 +7040,40 @@ * spam.el (spam-blackhole-good-server-regex): Ditto. -2004-11-25 Reiner Steib <Reiner.Steib@gmx.de> +2004-11-25 Katsumi Yamaoka <yamaoka@jpl.org> - * message.el (message-forbidden-properties): Fix typo in doc string. + * mml.el (mml-preview): Widen the message buffer before copying + the contents to the preview buffer; sort headers before previewing. -2004-11-25 Lars Magne Ingebrigtsen <larsi@gnus.org> + * message.el (message-hidden-headers): Fix the way to avoid a bug + in the `repeat' widget in Emacs 21.3 or earlier. - * message.el (message-strip-forbidden-properties): - Bind buffer-read-only (etc) to nil. +2004-11-25 Katsumi Yamaoka <yamaoka@jpl.org> -2004-11-25 Reiner Steib <Reiner.Steib@gmx.de> + * message.el (message-hidden-headers): Default to "^References:". + Improve customization type. Suggested by Reiner Steib + <Reiner.Steib@gmx.de>. - * gnus-util.el (gnus-replace-in-string): Add doc string. +2004-11-25 Romain Francoise <romain@orebokech.com> - * nnmail.el (nnmail-split-header-length-limit): Increase to 2048 - to avoid problems when splitting mails with many recipients. + * message.el (message-strip-forbidden-properties): Remove check for + obsolete `message-hidden' text property, hidden headers are not + accessible in the buffer anymore. + +2004-11-22 Romain Francoise <romain@orebokech.com> + + * message.el (message-header-format-alist): Add `From' in list + so that it can be sorted. + (message-fix-before-sending): Widen and sort headers before + sending. + (message-hide-headers): Use narrowing to hide headers by moving + them to the top of the buffer and narrowing to the region + underneath. + +2004-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-strip-forbidden-properties): Bind + buffer-read-only (etc) to nil. 2004-11-23 Katsumi Yamaoka <yamaoka@jpl.org> @@ -3796,22 +7084,77 @@ * nnfolder.el (nnfolder-request-create-group): Save current buffer. -2004-11-22 Stefan Monnier <monnier@iro.umontreal.ca> +2004-11-19 Lars Magne Ingebrigtsen <larsi@gnus.org> - * gnus-sum.el (gnus-summary-exit): Remove redundant and harmful - pop-to-buffer, covered by the subsequent gnus-configure-windows. + * dns.el (query-dns): Use sit-for to time instead of + accept-process-output, since that doesn't seem to work on udp + sockets. + +2004-11-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Encode bogus delimiters. + +2004-11-15 Jesper Harder <harder@ifa.au.dk> + + * pop3.el (pop3-leave-mail-on-server): Don't quote nil in + doc string. Improve doc string. + +2004-11-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * nntp.el (nntp-request-update-info): Return nil if + nntp-marks-is-evil is true so that gnus-get-unread-articles-in-group + may not call gnus-activate-group which uselessly issues the GROUP + commands for all nntp groups and wastes time. Reported by Romain + Francoise <romain@orebokech.com>. -2004-11-14 Luc Teirlinck <teirllm@auburn.edu> + * gnus-start.el (gnus-get-unread-articles): Remove redundant test. - * nnfolder.el (nnfolder-save-marks): Add missing format field in - call to `error'. - * nnml.el (nnml-save-marks): Ditto. +2004-11-15 Simon Josefsson <jas@extundo.com> + + * gnus-art.el (gnus-header-button-alist): Handle URLs in OpenPGP: + headers separately. + (gnus-button-openpgp): New function, inspired by Jochen K,A|(Bpper + <jochen-+It19tn3Rl9sbm7dSapR3bNAH6kLmebB@public.gmane.org>. 2004-11-14 Reiner Steib <Reiner.Steib@gmx.de> * gnus-start.el (gnus-convert-old-newsrc): Assign legacy-gnus-agent to 5.10.7. +2004-11-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (article-unsplit-urls): Don't anchor urls to the + start of the lines. + +2004-11-14 Magnus Henoch <mange@freemail.hu> + + * hashcash.el (hashcash-default-payment): Change default to 20 + (hashcash-default-accept-payment): Change default to 20 + (hashcash-process-alist): New variable + (hashcash-generate-payment-async): Add + (hashcash-already-paid-p): Add + (hashcash-insert-payment): Don't generate payments twice + (hashcash-insert-payment-async): Add + (hashcash-insert-payment-async-2): Add + (hashcash-cancel-async): Add + (hashcash-wait-async): Add + (hashcash-processes-running-p): Add + (hashcash-wait-or-cancel): Add + (mail-add-payment): New optional argument. Conditionally start + asynchronous calculation. + (mail-add-payment-async): Add + + * message.el (message-send-mail): Wait for asynchronous hashcash + results. Don't clobber existing X-Hashcash headers. + (message-setup-1): Call mail-add-payment-async when + message-generate-hashcash is non-nil. + +2004-11-11 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change) + + * message.el (message-use-alternative-email-as-from): Examine the + From header as well; use message-make-from in order to include a + user's full name. + 2004-11-10 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-emphasis-alist): Don't hide asterisks by @@ -3820,12 +7163,26 @@ (gnus-emphasis-custom-value-to-external): New function. (gnus-emphasis-custom-value-to-internal): New function. +2004-11-09 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * dns.el (query-dns): Resolve reverse addresses. + +2004-10-23 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-get-new-news): Use it. + + * gnus-start.el (gnus-check-reasonable-setup): New function. + 2004-11-07 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-msg.el (gnus-configure-posting-styles): Don't cause the "Args out of range" error. Reported by Arnaud Giersch <arnaud.giersch@free.fr>. +2004-11-07 Stefan Wiens <s.wi@gmx.net> (tiny change) + + * gnus-sum.el (gnus-summary-clear-local-variables): Use symbolp. + 2004-11-04 Richard M. Stallman <rms@gnu.org> * spam.el (spam group): Add :version. @@ -3838,35 +7195,11 @@ article buffer with a draft file. This is a temporary measure against the 2004-08-22 change to gnus-article-edit-mode. -2004-11-02 Ilya N. Golubev <gin@mo.msk.ru>. - - * mm-util.el (mm-mime-mule-charset-alist): Add the windows-1251 - entry. - 2004-11-02 Katsumi Yamaoka <yamaoka@jpl.org> * html2text.el (html2text-get-attr): Remove unused argument `tag'. (html2text-format-tags): Remove unused variable `attr'. - * mm-util.el (mm-enrich-utf-8-by-mule-ucs): Fix cleaning of - after-load-alist. - - * mm-util.el (mm-enrich-utf-8-by-mule-ucs): New function run when - Mule-UCS is loaded under XEmacs. - (mm-mime-mule-charset-alist): Avoid duplicated entries. - - * mm-util.el (mm-coding-system-p): Return a coding-system. - (mm-mime-mule-charset-alist): Use shift_jis instead of - iso-2022-jp-2 for the katakana-jisx0201 mule charset; add new - entries for the mime charsets iso-2022-jp-3 and shift_jis. - (mm-coding-system-priorities): Use shift_jis and iso-8859-1 - instead of japanese-shift-jis and iso-latin-1 respectively in - order to share the default value with both Emacs and XEmacs-mule. - (mm-mule-charset-to-mime-charset): - Make mm-coding-system-priorities effective. - (mm-sort-coding-systems-predicate): Canonicalize coding-systems - while predicating of candidates upon the priorities. - 2004-11-01 Reiner Steib <Reiner.Steib@gmx.de> * gnus-msg.el (gnus-summary-resend-default-address): Add :version. @@ -3955,6 +7288,20 @@ * html2text.el (html2text-format-tag-list): Add "strong" and "em". +2004-10-29 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-hashtb): Create the registry + when package is loaded. + + * spam.el (spam-summary-score-preferred-header): Add global preference + for people who want to override the default SpamAssassin over + Bogofilter preference (when both are set). + (spam-necessary-extra-headers): Add spam-use-bogofilter as an option. + (spam-user-format-function-S): Check + spam-summary-score-preferred-header. + (spam-extra-header-to-number): Add X-Bogosity header parsing. + (spam-user-format-function-S): Format the score correctly. + 2004-10-29 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-msg.el (gnus-configure-posting-styles): Work with empty @@ -3976,526 +7323,523 @@ * gnus-spec.el (gnus-update-format-specifications): Return a list of updated types. +2004-10-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-check-reasonable-setup): Use fboundp instead + of boundp to check if display-warning is available. + +2004-10-26 Teodor Zlatanov <tzz@lifelogs.com> + + * nnimap.el (nnimap-open-connection): Fix prog1/prog2 bug. + 2004-10-26 Katsumi Yamaoka <yamaoka@jpl.org> * nnspool.el (nnspool-spool-directory): Use news-path if the news-directory variable is not bound. - * gnus-group.el (gnus-group-line-format-alist): Convert the value - of gnus-tmp-news-method into string if it may be passed to - gnus-correct-length which takes only a string argument. + * gnus-start.el (gnus-check-reasonable-setup): Use an alternative + function instead of display-warning if it is not available. + +2004-10-26 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-agent.el (gnus-agent-expire-group-1): Fix last merge from + v5-10: Use `point-at-bol'. + +2004-10-26 Simon Josefsson <jas@extundo.com> + + * hashcash.el: Fix URL in comment, reported by Cheng Gao + <chenggao@gmail.com>. 2004-10-25 Reiner Steib <Reiner.Steib@gmx.de> * html2text.el (html2text-buffer-head): Remove. Use `goto-char' instead. -2004-10-24 Kevin Greiner <kevin.greiner@compsol.cc> +2004-10-25 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-start.el (gnus-convert-old-newsrc): Fix numeric - comparison on string. + * nnimap.el (nnimap-remove-server-from-buffer-alist): Add function + to remove a server from the nnimap-server-buffer-alist. + (nnimap-open-connection, nnimap-close-server): Use it. + + * gnus-encrypt.el: Remove file in favor of encrypt.el. 2004-10-21 Katsumi Yamaoka <yamaoka@jpl.org> * mm-view.el (mm-display-inline-fontify): Inhibit font-lock when running the major-mode function. -2004-10-21 Kevin Greiner <kevin.greiner@compsol.cc> - - * gnus-start.el (gnus-convert-old-newsrc): Two of the converters - have been backported to 'Gnus v5.11' from 'No Gnus v0.2'. Added a - boolean check to not apply converters that apply to future - versions of gnus. - 2004-10-19 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-sum.el (gnus-update-summary-mark-positions): Search for dummy marks in the right way. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> +2004-10-18 David Edmondson <dme@dme.org> - * nnagent.el (nnagent-request-type): Bind gnus-agent to nil to - avoid infinite recursion via gnus-get-function. + * mm-view.el (mm-w3m-cid-retrieve-1): Don't use recursive call + excessively. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> +2004-10-18 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-agent.el (gnus-agent-synchronize-group-flags): - When necessary, pass full group name to gnus-request-set-marks. - (gnus-agent-synchronize-group-flags): Add support for sync'ing - tick marks. - (gnus-agent-synchronize-flags-server): Be silent when writing file. + * gnus-util.el (gnus-split-references): Accept a nil references + string and go on blissfully. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * gnus-registry.el (gnus-registry-split-fancy-with-parent): Catch + cases where the references string is non-nil but has no references. - * gnus-agent.el (gnus-agent-synchronize-group-flags): - Replace gnus-request-update-info with explicit code to sync the - in-memory info read flags with the marks being sync'd to the backend. + * encrypt.el: Add autoload tags. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * spam.el (spam-resolve-registrations-routine): Remove article + from unregistration list too. Reported by David Hanak + <dhanak@isis.vanderbilt.edu> - * gnus-agent.el (gnus-agent-possibly-synchronize-flags): Ignore servers - that are offline. Avoids having gnus-agent-toggle-plugged first ask if - you want to open a server and then, even when you responded with no, - asking if you want to synchronize the server's flags. - (gnus-agent-synchronize-flags-server): Rewrite read loop to handle - multi-line expressions. - (gnus-agent-synchronize-group-flags): New internal function. - Updates marks in memory (in the info structure) AND in the backend. - (gnus-agent-check-overview-buffer): Fix range of - deletion to remove entire duplicate line. Fixes merged article - number bug. +2004-10-18 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-util.el (gnus-remassoc): Fix typo in documentation. + * gnus-art.el (gnus-copy-article-ignored-headers): Default to + nil. Changed custom type. - * nnagent.el (nnagent-request-set-mark): - Use gnus-agent-synchronize-group-flags, not backend's request-set-mark - method, to ensure that synchronization updates marks in the - backend and in the info (in memory) structure. +2004-10-17 Reiner Steib <Reiner.Steib@gmx.de> -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * gnus-art.el (gnus-copy-article-ignored-headers): New variable. - * gnus-agent.el (gnus-agent-synchronize-flags-server): Do nothing - unless plugged. Disable the agent so that an open failure causes - an error. + * gnus-sum.el (gnus-summary-move-article): Use it. -2004-10-18 Reiner Steib <Reiner.Steib@gmx.de> +2004-10-15 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-agent.el (gnus-agent-fetched-hook): Add :version. - (gnus-agent-go-online): Change :version. - (gnus-agent-expire-unagentized-dirs) - (gnus-agent-auto-agentize-methods): Add :version. + * encrypt.el: Add autoload cookies. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * spam.el (spam-backend-article-list-property) + (spam-backend-get-article-todo-list) + (spam-backend-put-article-todo-list, ) + (spam-summary-prepare-exit, spam-resolve-registrations-routine): + Resolve registrations separately. + (spam-register-routine): Format comments. + (spam-unregister-routine, spam-register-routine): Always call with + specific-articles, no default list. + (spam-summary-prepare-exit): Use the spam-classifications function. - * legacy-gnus-agent.el - (gnus-agent-convert-to-compressed-agentview-prompt): - New function. Used internally to only display 'gnus converting - files' message when actually necessary. + * netrc.el (autoload, netrc-parse): Use encrypt.el instead of + gnus-encrypt.el. - * gnus-sum.el: Remove (require 'gnus-agent) as required - methods now autoloaded. + * encrypt.el: copied from gnus-encrypt.el - * gnus-int.el (gnus-request-move-article): - Use gnus-agent-unfetch-articles in place of gnus-agent-expire to - improve performance. + * gnus-encrypt.el: commented that it's obsolete -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> +2004-10-15 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-agent.el (gnus-agent-cat-groups): Rewrite avoiding defsetf - to avoid run-time CL dependencies. - (gnus-agent-unfetch-articles): New function. - (gnus-agent-fetch-headers): Use gnus-agent-braid-nov to validate - article numbers even when local .overview file is missing. - (gnus-agent-read-article-number): New function. Only accepts - 27-bit article numbers. - (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): - Use gnus-agent-read-article-number. - (gnus-agent-braid-nov): Rewrote to validate article numbers coming - from backend while recognizing that article numbers in .overview - must be valid. + * gnus-score.el (gnus-adaptive-pretty-print): New variable. + (gnus-score-save): Use it. - * gnus-start.el (gnus-convert-old-newsrc): Change message text as - some users confused by references to .newsrc when they only have a - .newsrc.eld file. - (gnus-convert-mark-converter-prompt) - (gnus-convert-converter-needs-prompt): Fix use of property list. + * message.el (message-bury): Use `window-dedicated-p'. -2004-10-18 Katsumi Yamaoka <yamaoka@jpl.org> +2004-10-15 Simon Josefsson <jas@extundo.com> - * gnus-agent.el (gnus-agent-restore-gcc): Use ^ and regexp-quote. + * pop3.el (top-level): Don't require nnheader. + (pop3-read-timeout): Add. + (pop3-accept-process-output): Add. + (pop3-read-response, pop3-retr): Use it. -2004-10-18 Lars Magne Ingebrigtsen <larsi@gnus.org> +2004-10-14 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-start.el (gnus-get-unread-articles-in-group): Don't do - stuff for non-living groups. + * spam.el (spam-register-routine): Move comment. + (spam-verify-bogofilter): Use 'unknown for the initial + spam-bogofilter-valid state, not 'never. -2004-10-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + * netrc.el (netrc-machine-user-or-password): Add convenience wrapper + for netrc-machine. - * gnus-agent.el (gnus-agent-synchronize-flags): Default to nil. - (gnus-agent-regenerate-group): Using nil messages aren't valid. + * nnimap.el (nnimap-open-connection): Use + netrc-machine-user-or-password. -2004-10-18 Lars Magne Ingebrigtsen <larsi@gnus.org> +2004-10-17 Richard M. Stallman <rms@gnu.org> - * gnus-agent.el (gnus-agent-read-agentview): - Inline gnus-uncompress-range. + * gnus-registry.el (gnus-registry-unload-hook): + Set as a variable with add-hook. -2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + * nnspool.el (nnspool-spool-directory): Use news-directory instead + of news-path. - * legacy-gnus-agent.el - (gnus-agent-convert-to-compressed-agentview): Fix typos with - help from Florian Weimer <fw@deneb.enyo.de> + * spam-stat.el (spam-stat-unload-hook): Set as a variable w/ add-hook. - * gnus-agent.el (gnus-agentize): - gnus-agent-send-mail-real-function no longer set to current value - of message-send-mail-function but rather a lambda that calls - message-send-mail-function. The change makes the agent real-time - responsive to user changes to message-send-mail-function. + * spam.el: Delete duplicate `provide'. + (spam-unload-hook): Set as a variable with add-hook. -2004-10-18 Reiner Steib <Reiner.Steib@gmx.de> +2004-10-15 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-start.el (gnus-get-unread-articles): Fix last commit. + * pop3.el (pop3-leave-mail-on-server): Describe possible problems + in the doc string. -2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + * message.el (message-ignored-news-headers) + (message-ignored-supersedes-headers) + (message-ignored-resent-headers) + (message-forward-ignored-headers): Improve custom type. - * gnus-cache.el (gnus-cache-rename-group): New function. - (gnus-cache-delete-group): New function. +2004-10-13 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-agent.el (gnus-agent-rename-group): New function. - (gnus-agent-delete-group): New function. - (gnus-agent-save-group-info): Use gnus-command-method when - `method' parameter is nil. Don't write nil entries into the - active file. - (gnus-agent-get-group-info): New function. - (gnus-agent-get-local): Add optional parameters to avoid calling - gnus-group-real-name and gnus-find-method-for-group. - (gnus-agent-set-local): Delete stored entry if either min, or max, - are nil. - (gnus-agent-fetch-session): Reword error/quit messages. - On quit, use gnus-agent-regenerate-group to record existance of any - articles fetched to disk before the quit occurred. + * message.el (message-tokenize-header): Fix 2004-09-06 change + which used point-min in the wrong place. - * gnus-int.el (gnus-request-delete-group): - Use gnus-cache-delete-group and gnus-agent-delete-group to keep the - local disk in sync with the server. - (gnus-request-rename-group): - Use gnus-cache-rename-group and gnus-agent-rename-group to keep the - local disk in sync with the server. +2004-10-12 Simon Josefsson <jas@extundo.com> - * gnus-start.el (gnus-get-unread-articles): - Cosmetic simplification to logic. + * tls.el (tls-certtool-program): New variable. + (tls-certificate-information): New function, based on + ssl-certificate-information. - * gnus-group.el (gnus-group-delete-group): No longer update - gnus-cache-active-altered as gnus-request-delete-group now keeps - the cache in sync. - (gnus-group-list-active): Let the agent store a server's active - list if currently plugged. +2004-10-12 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-util.el (gnus-rename-file): New function. + * compface.el: Move the version of ELisp-based uncompface program + to the contrib directory because of the copyright problem. -2004-10-18 Katsumi Yamaoka <yamaoka@jpl.org> +2004-10-12 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-agent.el (gnus-agent-regenerate-group): Activate the group - when the group's active is not available. + * message.el (message-kill-buffer): Raise the current frame. -2004-10-18 Katsumi Yamaoka <yamaoka@jpl.org> +2004-10-10 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-agent.el (gnus-agent-read-agentview): Add a missing arg to - error. + * gnus-sum.el: Mention that multibyte characters don't work as marks. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * gnus.el (message-y-or-n-p): Autoload. - * gnus-start.el (gnus-convert-old-newsrc): Only write the conversion - message to newsrc-dribble when an actual conversion is performed. + * pop3.el (pop3-maildrop, pop3-mailhost, pop3-port) + (pop3-password-required, pop3-authentication-scheme) + (pop3-leave-mail-on-server): Made customizable. + (pop3): New custom group. + (pop3-retr): Remove `sleep-for' statements. + Suggested by Dave Love <fx@gnu.org>. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * nnheader.el (nnheader-read-timeout): Explain 1.0 timeout for + Windows/DOS. - * gnus-agent.el (gnus-agent-read-local): - Bind nnheader-file-coding-system to gnus-agent-file-coding-system to - avoid the implicit assumption that they will always be equal. - (gnus-agent-save-local): Bind buffer-file-coding-system, not - coding-system-for-write, as the with-temp-file macro first prints - to a buffer then saves the buffer. + * imap.el (imap-parse-flag-list, imap-parse-body-extension) + (imap-parse-body): Fix incorrect use of `assert'. Suggested by + Dave Love <fx@gnu.org>. -2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + * mml.el (mml-minibuffer-read-disposition): Require match. + Suggested by Dave Love <fx@gnu.org>. - * legacy-gnus-agent.el (): New. Provides converters that are only - loaded when gnus-convert-old-newsrc needs to call them. +2004-10-11 Reiner Steib <Reiner.Steib@gmx.de> - * gnus-agent.el (gnus-agent-read-agentview): Remove support for - old file versions. - (gnus-group-prepare-hook): Remove function that converted list - form of gnus-agent-expire-days to group properties. + * gnus-group.el (gnus-group-delete-group): Change "\t." to " " in + doc string. - * gnus-start.el (gnus-convert-old-newsrc): Register new - converters to handle old agent file formats. Added logic for a - "backup before upgrading warning". - (gnus-convert-mark-converter-prompt): Developers can mark - functions as needing (default), or not needing, - gnus-convert-old-newsrc's "backup before upgrading warning". - (gnus-convert-converter-needs-prompt): Tests whether the user - should be protected from potentially irreversable changes by the - function. +2004-10-08 Katsumi Yamaoka <yamaoka@jpl.org> -2004-10-18 Kevin Greiner <kgreiner@xpediantsolutions.com> + * mm-uu.el (mm-uu-dissect-text-parts): Support all text/* types. - * gnus-int.el (gnus-request-accept-article): Inform the agent that - articles are being added to a group. - (gnus-request-replace-article): Inform the agent that articles - need to be uncached as the cached contents are no longer valid. +2004-10-07 TSUCHIYA Masatoshi <tsuchiya@namazu.org> - * gnus-agent.el (gnus-agent-file-header-cache): Remove. - (gnus-agent-possibly-alter-active): Avoid null in numeric comparison. - (gnus-agent-set-local): Refuse to save null in local object table. - (gnus-agent-regenerate-group): The REREAD parameter can now be a - list of articles that will be marked as unread. + * gnus-art.el (gnus-mime-display-single): Call `mm-display-inline' + instead of calling `mm-insert-inline', to decode text/* parts + before displaying them. -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> +2004-10-07 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-range.el (gnus-sorted-range-intersection): Now accepts - single-interval range of the form (min . max). Previously the - range had to look like ((min . max)). Likewise, return - (min . max) rather than ((min . max)). - (gnus-range-map): Use gnus-range-normalize to accept - single-interval range. + * mm-uu.el (mm-uu-text-plain-type): New variable. + (mm-uu-pgp-signed-extract-1): Use it. + (mm-uu-pgp-encrypted-extract-1): Use it. + (mm-uu-dissect): Allow MIME type and parameters as an optional arg; + bind mm-uu-text-plain-type with that value. + (mm-uu-dissect-text-parts): Pass MIME type and parameters to + mm-uu-dissect. - * gnus-sum.el (gnus-summary-highlight-line): Articles stored in - the cache, but not the agent, now appear with their usual face. +2004-10-06 Katsumi Yamaoka <yamaoka@jpl.org> -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * gnus-group.el (gnus-update-group-mark-positions): + * gnus-sum.el (gnus-update-summary-mark-positions): + * message.el (message-check-news-body-syntax): + * gnus-msg.el (gnus-debug): Use mm-string-as-multibyte instead + of string-as-multibyte. - * gnus-sum.el (gnus-adjust-marks): Now correctly handles a list of - marks consisting of a single range {for example, (3 . 5)} rather - than a list of a single range { ((3 . 5)) }. +2004-10-05 Juri Linkov <juri@jurta.org> -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * gnus-group.el (gnus-update-group-mark-positions): + * gnus-sum.el (gnus-update-summary-mark-positions): + * message.el (message-check-news-body-syntax): + * gnus-msg.el (gnus-debug): Use `string-as-multibyte' to convert + 8-bit unibyte values to a multibyte string for search functions. - * gnus-sum.el (gnus-adjust-marks): Avoid splicing null INTO the - uncompressed list. +2004-10-06 Katsumi Yamaoka <yamaoka@jpl.org> -2004-10-18 Kevin Greiner <kevin.greiner@compsol.cc> + * mm-uu.el (mm-uu-dissect): Allow optional arg. + (mm-uu-dissect-text-parts): New function. - * gnus-draft.el (gnus-group-send-queue): Pass the group name - "nndraft:queue" along to gnus-draft-send. - Use gnus-agent-prompt-send-queue. - (gnus-draft-send): Rebind gnus-agent-queue-mail to nil when group - is "nndraft:queue". Suggested by Gaute Strokkenes - <gs234@srcf.ucam.org> + * gnus-art.el (gnus-display-mime): Use mm-uu-dissect-text-parts to + dissect text parts. - * gnus-group.el (gnus-group-catchup): Use new - gnus-sequence-of-unread-articles, not - gnus-list-of-unread-articles, to avoid exhausting memory with huge - numbers of articles. Use gnus-range-map to avoid having to - uncompress the unread list. - (gnus-group-archive-directory) - (gnus-group-recent-archive-directory): Fix invalid ange-ftp reference. + * gnus-sum.el (gnus-summary-insert-subject): Remove redundant setq. + (gnus-summary-force-verify-and-decrypt): Revert 2004-08-18 change. - * gnus-range.el (gnus-range-map): Iterate over list or sequence. - (gnus-sorted-range-intersection): Intersection of two ranges - without requiring that they first be uncompressed. + * mm-decode.el (mm-dissect-singlepart): Revert 2004-08-18 change. - * gnus-start.el (gnus-activate-group): Unless blocked by the - caller, possibly expand the active range to include both cached - and agentized articles. - (gnus-convert-old-newsrc): Rewrote in anticipation of having - multiple version-dependent converters. - (gnus-groups-to-gnus-format): Replace gnus-agent-save-groups with - gnus-agent-save-active. - (gnus-save-newsrc-file): Save dirty agent range limits. + * gnus-topic.el (gnus-topic-hierarchical-parameters): Use + gnus-current-topics instead of gnus-current-topic. - * gnus-sum.el (gnus-select-newgroup): Replace inline code with - gnus-agent-possibly-alter-active. - (gnus-adjust-marked-articles): Faster handling of simple lists. +2004-10-06 Jesper Harder <harder@ifa.au.dk> -2004-10-18 David Edmondson <dme@dme.org> + * gnus-sum.el (gnus-summary-show-article): Use with-current-buffer. - * mm-view.el (mm-w3m-cid-retrieve-1): Don't use recursive call - excessively. +2004-10-05 Jesper Harder <harder@ifa.au.dk> -2004-10-18 Reiner Steib <Reiner.Steib@gmx.de> + * nnsoup.el (nnsoup-read-active-file): Use dolist, mapc or last + where approriate. - * mml.el (mml-preview): Use `pop-to-buffer'. + * nnml.el (nnml-generate-active-info): do. - * message.el (message-goto-mail-followup-to): Insert after "To". - (message-carefully-insert-headers): Add comment. + * nndiary.el (nndiary-generate-active-info): do. - * gnus-sum.el (gnus-summary-make-menu-bar): Add help texts. + * gnus-topic.el (gnus-topic-hierarchical-parameters): do. + (gnus-topic-move): do. - * gnus-art.el (gnus-button-alist): - Improve `gnus-button-handle-library' entry. + * gnus-sum.el (gnus-data-enter-list, gnus-summary-process-mark-set) + (gnus-summary-set-local-parameters, gnus-summary-read-document): do. - * gnus-art.el (gnus-button-alist): Fix regexp for manual links. + * gnus-srvr.el (gnus-server-prepare) + (gnus-server-open-all-servers): do. - * gnus-group.el (gnus-group-get-new-news-this-group): Add doc-string. + * gnus-msg.el (gnus-summary-cancel-article) + (gnus-summary-resend-message) + (gnus-summary-mail-crosspost-complaint): do. - * gnus-start.el (gnus-activate-group): Add doc-string. + * gnus-move.el (gnus-change-server): do. - * gnus-art.el (gnus-button-handle-man, gnus-button-alist): Try to - handle manual section. + * gnus-group.el (gnus-group-unmark-all-groups) + (gnus-group-set-current-level): do. - * imap.el (imap-store-password): New variable. - (imap-interactive-login): Use it. - Suggested by Mark Plaksin <happy@mcplaksin.org>. +2004-10-04 Simon Josefsson <jas@extundo.com> - * gnus-art.el (gnus-button-alist, gnus-header-button-alist): - Allow / in mailto URLs. + * message.el (message-generate-hashcash): Doc fix. - * spam.el (spam-directory): Derive from `gnus-directory'. +2004-10-02 Kevin Greiner <kgreiner@compsol.cc> - * gnus-sum.el (gnus-pick-line-number): Add autoload. + * nnagent.el (nnagent-request-type): Bind gnus-agent to nil to + avoid infinite recursion via gnus-get-function. -2004-10-17 Richard M. Stallman <rms@gnu.org> +2004-10-02 Jesper Harder <harder@ifa.au.dk> - * gnus-registry.el (gnus-registry-unload-hook): - Set as a variable with add-hook. + * mm-partial.el (mm-partial-find-parts): Use with-current-buffer. - * nnspool.el (nnspool-spool-directory): Use news-directory instead - of news-path. + * nnfolder.el (nnfolder-generate-active-file): Use dolist. - * spam-stat.el (spam-stat-unload-hook): Set as a variable w/ add-hook. + * nnmail.el (nnmail-split-history): do. - * spam.el: Delete duplicate `provide'. - (spam-unload-hook): Set as a variable with add-hook. + * nnml.el (nnml-generate-nov-databases-1, nnml-request-rename-group) + (nnml-request-delete-group): do. -2004-10-15 Reiner Steib <Reiner.Steib@gmx.de> + * nnslashdot.el (nnslashdot-read-groups): do. - * pop3.el (pop3-leave-mail-on-server): Describe possible problems - in the doc string. + * nnsoup.el (nnsoup-delete-unreferenced-message-files): do. + (nnsoup-unpack-packets, nnsoup-make-active): Simplify. - * message.el (message-ignored-news-headers) - (message-ignored-supersedes-headers) - (message-ignored-resent-headers) - (message-forward-ignored-headers): Improve custom type. + * nnspool.el (nnspool-find-id): Use with-temp-buffer. + (nnspool-sift-nov-with-sed): Use last + (nnspool-retrieve-headers-with-nov): Use mapc. + (nnspool-request-newgroups): Use dolist. + (nnspool-request-group): Use last. -2004-10-15 Simon Josefsson <jas@extundo.com> + * nntp.el (nntp-read-server-type): Use dolist. - * pop3.el (top-level): Don't require nnheader. - (pop3-read-timeout): Add. - (pop3-accept-process-output): Add. - (pop3-read-response, pop3-retr): Use it. + * nnvirtual.el (nnvirtual-create-mapping) + (nnvirtual-update-read-and-marked): Use dolist. + (nnvirtual-convert-headers): Simplify. -2004-10-13 Katsumi Yamaoka <yamaoka@jpl.org> +2004-10-01 Kevin Greiner <kgreiner@compsol.cc> - * message.el (message-tokenize-header): Fix 2004-09-06 change - which used point-min in the wrong place. + * gnus-agent.el (gnus-agent-synchronize-group-flags): Added + support for sync'ing tick marks. -2004-10-11 Reiner Steib <Reiner.Steib@gmx.de> +2004-10-01 Katsumi Yamaoka <yamaoka@jpl.org> - * message.el (message-bury): Use `window-dedicated-p'. + * gnus-sum.el (gnus-summary-toggle-header): Make it work even if + there's no visible header. -2004-10-10 Reiner Steib <Reiner.Steib@gmx.de> +2004-10-01 Kevin Greiner <kgreiner@compsol.cc> - * gnus-sum.el: Mention that multibyte characters don't work as marks. + * gnus-agent.el (gnus-agent-synchronize-group-flags): When + necessary, pass full group name to gnus-request-set-marks. - * gnus.el (message-y-or-n-p): Autoload. +2004-10-01 Simon Josefsson <jas@extundo.com> - * pop3.el (pop3-maildrop, pop3-mailhost, pop3-port) - (pop3-password-required, pop3-authentication-scheme) - (pop3-leave-mail-on-server): Made customizable. - (pop3): New custom group. - (pop3-retr): Remove `sleep-for' statements. - Suggested by Dave Love <fx@gnu.org>. + * mailcap.el (mailcap-mime-data): Add pdf. Remove non-free + acroread. - * nnheader.el (nnheader-read-timeout): Explain 1.0 timeout for - Windows/DOS. +2004-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org> - * imap.el (imap-parse-flag-list, imap-parse-body-extension) - (imap-parse-body): Fix incorrect use of `assert'. Suggested by - Dave Love <fx@gnu.org>. + * spam-report.el (spam-report-gmane): Fix interactive. - * mml.el (mml-minibuffer-read-disposition): Require match. - Suggested by Dave Love <fx@gnu.org>. + * gnus-art.el (gnus-treat-body-boundary): Only do stuff under X. -2004-10-06 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-agent.el (gnus-agent-synchronize-flags-server): Be silent + when writing file. + (gnus-agent-synchronize-flags): Don't default to being + interactive. - * gnus-group.el (gnus-update-group-mark-positions): - * gnus-sum.el (gnus-update-summary-mark-positions): - * message.el (message-check-news-body-syntax): - * gnus-msg.el (gnus-debug): Use mm-string-as-multibyte instead - of string-as-multibyte. +2004-09-30 Simon Josefsson <jas@extundo.com> - * gnus-sum.el (gnus-summary-insert-subject): Remove redundant setq. + * message.el (message-generate-hashcash): Add. + (message-send-mail): Use it, call mail-add-payment. -2004-10-05 Juri Linkov <juri@jurta.org> +2004-09-29 Teodor Zlatanov <tzz@lifelogs.com> - * gnus-group.el (gnus-update-group-mark-positions): - * gnus-sum.el (gnus-update-summary-mark-positions): - * message.el (message-check-news-body-syntax): - * gnus-msg.el (gnus-debug): Use `string-as-multibyte' to convert - 8-bit unibyte values to a multibyte string for search functions. + * spam.el (spam-verify-bogofilter): Use -V, not -sV option. -2004-10-01 Katsumi Yamaoka <yamaoka@jpl.org> +2004-09-28 Kevin Greiner <kgreiner@compsol.cc> - * gnus-sum.el (gnus-summary-toggle-header): Make it work even if - there's no visible header. + * gnus-agent.el (gnus-agent-synchronize-group-flags): Replaced + gnus-requst-update-info with explicit code to sync the in-memory + info read flags with the marks being sync'd to the backend. -2004-10-01 Simon Josefsson <jas@extundo.com> + *gnus-util.el (gnus-pp): Added optional stream to match pp API. - * mailcap.el (mailcap-mime-data): Add pdf. Remove non-free - acroread. +2004-09-28 Teodor Zlatanov <tzz@lifelogs.com> -2004-09-29 Jesper Harder <harder@ifa.au.dk> + * spam.el (spam-verify-bogofilter): Add new function. + (spam-check-bogofilter) + (spam-bogofilter-register-with-bogofilter): Use it. + (spam-verify-bogofilter): Add small fixes. - * gnus.el (gnus-method-to-server): Oops, move it don't delete it. +2004-09-28 Simon Josefsson <jas@extundo.com> -2004-09-28 Jesper Harder <harder@ifa.au.dk> + * hashcash.el (hashcash-generate-payment): Revert. - * gnus-picon.el: Require cl. +2004-09-28 Teodor Zlatanov <tzz@lifelogs.com> - * mml-sec.el (mml-signencrypt-style): Don't depend on Gnus. + * gnus-registry.el (gnus-registry-split-fancy-with-parent): Use + gnus-extract-references instead of gnus-split-references. - * mml-smime.el: Require cl. Autoload message-fetch-field. + * gnus-util.el (gnus-extract-references): Add new function, analogous + to gnus-split-references but extracts only the message-ID without + anything extra. - * gnus-fun.el: Require gnus-ems and gnus-util. + * hashcash.el (hashcash-generate-payment) + (hashcash-check-payment): Do the right thing if hashcash-path is + nil (because the hashcash program could not be found). - * gnus-diary.el (gnus-diary-header-schedule): caddr -> car (cddr). + * spam.el (spam-use-hashcash): Remove comment. - * gnus-art.el (gnus-article-edit-mode): Define before first reference. +2004-09-27 Jesper Harder <harder@ifa.au.dk> - * gnus.el (gnus-method-to-server): Move defsubst before first use. + * gnus-cache.el (gnus-cache-possibly-remove-articles-1) + (gnus-cache-enter-article, gnus-cache-remove-article) + (gnus-cache-braid-heads, gnus-cache-generate-active): Use dolist. + + * gnus-async.el (gnus-async-prefetch-remove-group): do. - * spam.el (spam-check-spamoracle, spam-spamoracle-learn): - Fix format string mismatch. - * nnml.el (nnml-request-set-mark, nnml-save-marks): Do. - * nnfolder.el (nnfolder-request-set-mark, nnfolder-save-marks): Do. + * gnus-art.el (article-hide-boring-headers) + (article-translate-strings, article-display-face) + (gnus-article-mime-match-handle-first) + (gnus-article-highlight-headers) + (gnus-article-add-buttons-to-head): do. -2004-09-27 Reiner Steib <Reiner.Steib@gmx.de> +2004-09-27 Simon Josefsson <jas@extundo.com> - * gnus.el (gnus-version-number): Set to 5.11. + * hashcash.el: New version, from + http://users.actrix.co.nz/mycroft/hashcash.el. Previously in + ../contrib/. 2004-09-27 Katsumi Yamaoka <yamaoka@jpl.org> * mm-decode.el (mm-copy-to-buffer): Don't use set-buffer-multibyte. -2004-09-26 Christian Neukirchen <chneukirchen@yahoo.de> (tiny change) +2004-09-26 Jesper Harder <harder@ifa.au.dk> - * mm-util.el (mm-image-load-path): Handle nil in load-path. + * gnus-dup.el (gnus-dup-open): Use mapc. + (gnus-dup-enter-articles, gnus-dup-suppress-articles): Use dolist. -2004-09-26 Jesper Harder <harder@ifa.au.dk> + (gnus-dup-enter-articles): Remove excess ID's from gnus-dup-hashtb. + Reported by Stefan Wiens <s.wi@gmx.net>. - * gnus-msg.el (gnus-post-news): Use blank Newsgroups line if - GROUP is a virtual group. + * gnus.el (gnus-shutdown): Use dolist. - * mm-util.el (mm-charset-synonym-alist): Remove obsolete entries - for big5 and gb2312. + * gnus-undo.el (gnus-undo): Use mapc. - * rfc2047.el (rfc2047-pad-base64): Deal with more cases of invalid - padding. + * nnrss.el (nnrss-generate-active): do. - * mm-bodies.el (mm-7bit-chars): Don't include \r. + * message.el (message-cite-original-without-signature) + (message-cite-original): Use mapc. + (message-do-actions, message-make-forward-subject): Use dolist. - * mml.el (mml-compute-boundary-1): Don't uncompress files. +2004-09-25 Kevin Greiner <kgreiner@compsol.cc> - * rfc2047.el (rfc2047-qp-or-base64): New function to reduce - dependencies. - (rfc2047-encode): Use it. + * gnus-agent.el (gnus-agent-check-overview-buffer): Fixed range of + deletion to remove entire duplicate line. Fixes merged article + number bug. - * flow-fill.el: Typo. +2004-09-25 Kevin Greiner <kgreiner@compsol.cc> - * mml.el (mml-generate-mime-1): Don't use format=flowed with - inline PGP. + * gnus-agent.el (gnus-agent-possibly-synchronize-flags): Ignore + servers that are offline. Avoids having gnus-agent-toggle-plugged + first ask if you want to open a server and then, even when you + responded with no, asking if you want to synchronize the server's + flags. + (gnus-agent-synchronize-flags-server): Rewrote read loop to handle + multi-line expressions. + (gnus-agent-synchronize-group-flags): New internal function. + Updates marks in memory (in the info structure) AND in the + backend. - * gnus.el (gnus-getenv-nntpserver): Strip whitespace. + * gnus-util.el (gnus-remassoc): Fixed typo in documentation. - * gnus-cache.el (gnus-cache-save-buffers): Check if buffer is - alive. Reported by Laurent Martelli <laurent@aopsys.com>. + * nnagent.el (nnagent-request-set-mark): Use + gnus-agent-synchronize-group-flags, not backend's request-set-mark + method, to ensure that synchronization updates marks in the + backend and in the info (in memory) structure. - * html2text.el (html2text-replace-list): Add & and '. +2004-09-24 Katsumi Yamaoka <yamaoka@jpl.org> - * nnheader.el (nnheader-max-head-length): Increase to 8192. + * gnus-uu.el (gnus-uu-digest-mail-forward): Obey the process/prefix + convention fully; don't miss the root article of a thread; make + the X-Draft-From header with correct article numbers. - * message.el (message-clone-locals): Clone sendmail and smtp - variables. +2004-09-23 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-synchronize-flags-server): Do nothing + unless plugged. Disable the agent so that an open failure causes + an error. + + * gnus-int.el (gnus-request-set-mark, gnus-request-update-mark): + Reverted 2004-09-21 change. The backend must be opened while + synchronizing flags even when the backend stores the flags + locally. 2004-09-23 Reiner Steib <Reiner.Steib@gmx.de> * gnus-msg.el (gnus-configure-posting-styles): Narrow to headers in `header' match. Reported by Svend Tollak Munkejord. + * message.el (message-cite-original): Fix use of + `message-cite-articles-with-x-no-archive'. + +2004-09-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-win.el (gnus-buffer-configuration): Add mml-preview. + (gnus-window-to-buffer): Ditto. + + * mml.el (mml-preview-buffer): New variable. + (mml-preview): Manage window layout with gnus-buffer-configuration. + + * gnus-msg.el (gnus-setup-message): Put article numbers into the + X-Draft-From header even if those articles aren't quoted. + +2004-09-21 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-int.el (gnus-servers-that-use-local-marks): New variable. + (gnus-request-set-mark, gnus-request-update-mark): Use new + g-s-t-u-l-m to decide to use backend even when unplugged. + +2004-09-21 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-msg.el (gnus-inews-make-draft-meta-information): Don't add + a trailing whitespace. Suggested by Cheng Gao <chenggao@gmail.com>. + +2004-09-20 Simon Josefsson <jas@extundo.com> + + * mm-util.el (mm-charset-synonym-alist): Map "unicode" to + "utf-16-le". + 2004-09-20 Stefan Monnier <monnier@iro.umontreal.ca> * mm-decode.el (mm-copy-to-buffer): Preserve the data's unibyteness. -2004-09-20 Reiner Steib <Reiner.Steib@gmx.de> +2004-09-19 Reiner Steib <Reiner.Steib@gmx.de> * uudecode.el (uudecode-use-external): Add :version. @@ -4647,29 +7991,48 @@ * gnus-sum.el (gnus-fetch-old-headers): Add custom choices `t' and `invisible'. +2004-09-10 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-trim): Watch out for negatives + in gnus-registry-trim. + 2004-09-13 Simon Josefsson <jas@extundo.com> + * dns-mode.el: Add XEmacs auto-mode-alist autoload cookie. + * nnimap.el (nnimap-demule): Revert 2004-08-30 change. + * dns-mode.el (dns-mode): Fix menu for XEmacs, reported by Steve + Youngs <steve@youngs.au.com> and suggested by Katsumi Yamaoka + <yamaoka@jpl.org>. + (dns-mode-font-lock-keywords): Fix faces, reported by Steve Youngs + <steve@youngs.au.com> and suggested by Katsumi Yamaoka + <yamaoka@jpl.org>. + + * sieve.el (sieve-manage-mode): Ditto. + 2004-09-13 Reiner Steib <Reiner.Steib@gmx.de> * gnus-sum.el (gnus-summary-copy-article): Fix doc string. -2004-09-10 Miles Bader <miles@gnu.ai.mit.edu> +2004-09-11 Simon Josefsson <jas@extundo.com> - * nnimap.el (nnimap-open-connection): Remove extraneous end-paren. + * dns-mode.el: Add. -2004-09-10 Teodor Zlatanov <tzz@lifelogs.com> + * mm-view.el (mm-display-dns-inline): Add. - * nnimap.el (nnimap-open-connection): Allow 'imaps' as a synonym - for the 'imap' port in netrc files. + * mm-decode.el (mm-inline-media-tests): Add text/dns. + (mm-automatic-display): Ditto. - * gnus-registry.el (gnus-registry-trim): Watch out for negatives - in gnus-registry-trim. + * mailcap.el (mailcap-mime-data): Add text/dns. + (mailcap-mime-extensions): Map .soa to text/dns. -2004-09-10 Simon Josefsson <jas@extundo.com> +2004-09-10 Miles Bader <miles@gnu.ai.mit.edu> - * nndb.el (require): Remove tcp and duplicate cl. + * gnus-art.el (article-decode-mime-words, article-babel) + (gnus-article-highlight-signature, gnus-article-add-buttons) + (gnus-signature-toggle): Remove unnecessary bindings of + `inhibit-read-only' inherited from v5.10 merge. 2004-09-08 Reiner Steib <Reiner.Steib@gmx.de> @@ -4686,7 +8049,7 @@ * flow-fill.el (fill-flowed-display-column) (fill-flowed-encode-column): Ditto. -2004-09-06 Stefan Monnier <monnier@iro.umontreal.ca> +2004-09-06 Stefan <monnier@iro.umontreal.ca> * message.el (message-tokenize-header, message-send-mail-with-qmail): Use point-min rather than 1. @@ -4699,14 +8062,59 @@ (gnus-generate-vertical-tree): Usue `bobp' rather than compare to 1. (gnus-highlight-selected-tree): Use point-min rather than 1 and 2. +2004-09-10 Simon Josefsson <jas@extundo.com> + + * nndb.el (require): Remove tcp and duplicate cl. + +2004-09-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (directory-files-and-attributes): Move forward. + +2004-09-09 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (directory-files-and-attributes): Optionally + defined to support XEmacs. + +2004-09-09 Kevin Greiner <kgreiner@compsol.cc> + + * gnus-agent.el (gnus-agent-cat-groups): rewrote avoiding defsetf + to avoid run-time CL dependencies. + (gnus-agent-unfetch-articles): New function. + (gnus-agent-fetch-headers): Use gnus-agent-braid-nov to validate + article numbers even when local .overview file is missing. + (gnus-agent-read-article-number): New function. Only accepts + 27-bit article numbers. + (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): Use + gnus-agent-read-article-number. + (gnus-agent-braid-nov): Rewrote to validate article numbers coming + from backend while recognizing that article numbers in .overview + must be valid. + (gnus-agent-update-files-total-fetched-for): Use + directory-files-and-attributes to improve performance. + * gnus-int.el (gnus-request-move-article): Use + gnus-agent-unfetch-articles in place of gnus-agent-expire to + improve performance. + + * gnus-start.el (gnus-convert-old-newsrc): Changed message text as + some users confused by references to .newsrc when they only have a + .newsrc.eld file. + (gnus-convert-mark-converter-prompt, + gnus-convert-converter-needs-prompt): Fixed use of property list. + * legacy-gnus-agent.el (gnus-agent-convert-to-compressed-agentview-prompt): + New function. Used internally to only display 'gnus converting + files' message when actually necessary. + + * gnus-sum.el (): Removed (require 'gnus-agent) as required + methods now autoloaded. + 2004-09-03 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-sum.el (gnus-summary-insert-subject): Remove list identifiers. + * gnus-sum.el (gnus-summary-insert-subject): Remove list + identifiers. -2004-09-03 Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp> (tiny change) +2004-09-02 Reiner Steib <Reiner.Steib@gmx.de> - * spam-stat.el (spam-stat-reduce-size): Set spam-stat-dirty. - (spam-stat-save): Accept prefix argument. + * gnus-picon.el: Fix indentation and closing parenthesis. 2004-09-01 Simon Josefsson <jas@extundo.com> @@ -4723,43 +8131,2659 @@ * sha1-el.el: Renamed to sha1.el. +2004-08-30 Juanma Barranquero <lektu@terra.es> + + * ietf-drums.el (ietf-drums-remove-whitespace): Fix character constant. + +2004-08-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * nnimap.el (nnimap-demule): Avoid string-as-multibyte. + +2004-08-30 Kim F. Storm <storm@cua.dk> + + * nntp.el (nntp-authinfo-file): Add :group 'nntp. + + * nnimap.el (nnimap-authinfo-file, nnimap-prune-cache): + Add :group 'nnimap. + +2004-08-30 Andreas Schwab <schwab@suse.de> + + * rfc2231.el (rfc2231-parse-string): Restore whitespace syntax for + ?* and ?\;. + + * ietf-drums.el (ietf-drums-syntax-table): Set syntax of ?* ?\; + and ?\' to symbol instead of whitespace. + +2004-08-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-restore-gcc): Use ^ and regexp-quote. + + * gnus-sum.el (gnus-summary-morse-message): Use search-forward + instead of re-search-forward. + + * gnus-uu.el (gnus-uu-save-article): Ditto. + (gnus-uu-post-encode-uuencode): Ditto. + + * html2text.el (html2text-clean-list-items): Ditto. + (html2text-clean-dtdd): Ditto. + (html2text-format-tags): Ditto. + + * message.el (message-send-mail-with-sendmail): Fix regexp. + (message-fill-field-general): Use search-forward instead of + re-search-forward. + (unbold-region): Ditto. + + * nnrss.el (nnrss-request-article): Ditto. + + * nnslashdot.el (nnslashdot-request-article): Ditto. + + * nnweb.el (nnweb-gmane-wash-article): Ditto. + + * gnus-sum.el (gnus-summary-make-menu-bar): Avoid the + "Unrecognized menu descriptor" error in XEmacs. + +2004-08-26 Stefan Wiens <s.wi@gmx.net> (tiny change) + + * gnus-sum.el (gnus-read-header): Don't remove a header for the + parent article of a sparse article in the thread hashtb. + +2004-08-26 David Hedbor <dhedbor@real.com> (tiny change) + + * nnmail.el (nnmail-split-lowercase-expanded): New user option. + (nnmail-expand-newtext): Lowercase expanded entries if + nnmail-split-lowercase-expanded is non-nil. + +2004-08-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * nndoc.el (nndoc-type-alist): Fix regexp in the rfc822-forward + entry. + + * gnus-group.el (gnus-group-line-format-alist): Convert the value + of gnus-tmp-news-method into string under XEmacs. It will be + passed to gnus-correct-length which takes only a string argument. + +2004-08-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-util.el (gnus-bind-print-variables): New macro. + (gnus-prin1): Use it. + (gnus-prin1-to-string): Use it. + (gnus-pp): New function. + (gnus-pp-to-string): New function. + + * gnus-cus.el (gnus-agent-cat-prepare-category-field): Replace + pp-to-string with gnus-pp-to-string. + * gnus-eform.el (gnus-edit-form): Replace pp with gnus-pp. + * gnus-group.el (gnus-group-make-kiboze-group): Ditto. + * gnus-msg.el (gnus-debug): Ditto. + * gnus-score.el (gnus-score-save): Ditto. + * gnus-spec.el (gnus-update-format): Replace pp-to-string with + gnus-pp-to-string. + * legacy-gnus-agent.el (gnus-agent-unlist-expire-days): Replace pp + with gnus-pp. + * score-mode.el (gnus-score-pretty-print): Ditto. + * webmail.el (webmail-debug): Ditto. + +2004-08-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-display-face, article-display-x-face): Use + buffer-read-only. + +2004-08-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-hide-list-identifiers): Bind + inhibit-read-only as t. + +2004-08-22 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-mlspl.el (gnus-group-split-update): Fix docstring. + +2004-08-22 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-art.el: Use inhibit-read-only instead of buffer-read-only. + (gnus-narrow-to-page): Don't assume point-min == 1. + (gnus-article-edit-mode): Derive from message-mode. + + * gnus-score.el (gnus-score-find-bnews): Simplify and don't assume + point-min == 1. + + * imap.el (imap-parse-address-list, imap-parse-body-ext): + Disable incorrect use of `assert'. + + * message.el (message-mode): Set comment-start-skip. + + +2004-08-22 Sam Steingold <sds@gnu.org> + + * pop3.el (pop3-leave-mail-on-server): New user variable. + (pop3-movemail): Delete mail only when it is nil. + +2004-08-21 Reiner Steib <Reiner.Steib@gmx.de> + + * nntp.el (nntp-marks-is-evil): Fix typo in docstring. + + * mml.el (mml-preview): Use `pop-to-buffer'. + + * message.el (message-goto-mail-followup-to): Insert after "To". + (message-carefully-insert-headers): Add comment. + + * gnus.el: Remove unused variable `gnus-article-check-size'. + + * gnus-sum.el (gnus-summary-make-menu-bar): Add help texts. + + * gnus-art.el (gnus-button-alist): Improve + `gnus-button-handle-library' entry. + +2004-08-19 Sebastian Freundt <hroptatyr@gna.org> (tiny change) + + * nnmaildir.el (nnmaildir--emlink-p, nnmaildir--enoent-p): Use + downcase, since XEmacs capitalizes error messages differently. + +2004-08-18 Jesper Harder <harder@ifa.au.dk> + + * nntp.el: Add (require 'gnus) due to reference to + `gnus-directory'. Reported by Matt Swift <swift@alum.mit.edu>. + +2004-08-18 Florian Weimer <fw@deneb.enyo.de> + + * gnus-sum.el (gnus-summary-force-verify-and-decrypt): Bind + `mm-fill-flowed'. + + * mm-decode.el (mm-dissect-singlepart): Check it. + +2004-08-17 Teodor Zlatanov <tzz@lifelogs.com> + + * nnimap.el (nnimap-open-connection): Add 'imaps' synonym to + 'imap' for netrc parsing. + +2004-08-16 Reiner Steib <Reiner.Steib@gmx.de> + + * mailcap.el (mailcap-mime-data): Mark as risky. + +2004-08-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Assume the close parenthesis + may be included in the encoded word. + (rfc2047-encode): Don't append a space if the encoded word + includes close parenthesis. + +2004-08-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-1, rfc2047-encode): Improve encoding + of text within parentheses. + +2004-08-06 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-encrypt.el (gnus-encrypt-insert-file-contents) + (gnus-encrypt-write-file-contents): Make the password key the file + name PLUS the cipher, not just the cipher. Also remove failed + passwords from the cache. + +2004-08-06 Simon Josefsson <jas@extundo.com> + + * gnus-sum.el (gnus-article-loose-mime): Change default to t. Doc + fix. + +2004-08-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-fold-region): Use trailing whitespace as + LWSP. + +2004-08-04 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-split-fancy-with-parent): Try + to append in-reply-to: data to the references: header. + + * netrc.el: Remove old encryption support, autoload gnus-encrypt.el + (netrc-parse): Use gnus-encrypt.el functions. + + * gnus-encrypt.el: Add new file for encryption support; currently + does only a few GPG ciphers and an internal XOR cipher. + + * password.el: Add comments on using password-read-and-add. + (password-read-and-add): Add function to read and add the + password to the cache at once. + +2004-07-28 Simon Josefsson <jas@extundo.com> + + * pgg-pgp5.el (pgg-pgp5-encrypt-region): Accept sign + parameter (but don't use it, for now). + + * imap.el (imap-ssl-open): Use imap-process-connection-type, + instead of hard coding to nil. + +2004-07-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-view.el (mm-inline-image-emacs): Open lines under an image + as mm-inline-image-xemacs does. + +2004-07-26 Simon Josefsson <jas@extundo.com> + + * gnus-group.el (gnus-group-group-map, gnus-group-make-menu-bar): + Revert part of 2004-07-17 change below. + +2004-07-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Don't infloop. Suggested by + Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>. + +2004-07-25 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * flow-fill.el (fill-flowed): Remove space stuffing, and only do + quotes that actually start with ">" at the beginning of the + lines. + +2004-07-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Fix last change. + (rfc2047-encode-parameter): Remove useless concat. + +2004-07-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Check carefully whether to + encode special characters; fix some kind of misconfigured headers; + signal a real error if debug-on-quit or debug-on-error is non-nil. + (rfc2047-encode-max-chars): New variable. + (rfc2047-encode-1): Use it. + (rfc2047-encode-parameter): New function. + + * mml.el (mml-insert-parameter): Remove an excessive space. + +2004-07-17 Simon Josefsson <jas@extundo.com> + + * gnus-group.el (gnus-group-make-group-simple): Add, suggested by + Kai Grossjohann <kai@emptydomain.de>. + (gnus-group-group-map): Use it, instead of gnus-group-make-group. + (gnus-group-make-menu-bar): Ditto. + + * gnus-util.el (gnus-group-server): Add. + +2004-07-16 Jesper Harder <harder@ifa.au.dk> + + * message.el (message-clone-locals): Clone sendmail and smtp + variables. + +2004-07-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Fix last change. + +2004-07-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Treat backslash-quoted + characters as non-special. + +2004-07-09 Simon Josefsson <jas@extundo.com> + + * gnus-agent.el (gnus-agent-synchronize-flags): Revert to ask. + Users will lose all flag changes made while unplugged with + e.g. nntp unless flag synchronization happens, thus `nil' is not a + good default. See numerous reports on ding mailing list. + +2004-07-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * nndoc.el (nndoc-type-alist): Improve regexp for article-begin, + add generate-head-function and generate-article-function to the + rfc822-forward entry. + (nndoc-rfc822-forward-generate-article): New function. + (nndoc-rfc822-forward-generate-head): New function. + + * mm-decode.el (mm-dissect-buffer): Simplify cleaning of CTE. + +2004-07-06 Dan Christensen <jdc@uwo.ca> + + * gnus-sum.el (gnus-summary-read-group-1): When summary is unthreaded, + respect display group parameter and gnus-summary-expunge-below. + (gnus-articles-to-read): Remove unused reference to display group + parameter. + +2004-07-03 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnheader.el (nnheader-uniquify-message-id): New experimental + variable. + (nnheader-nov-read-message-id): Use it. + + * spam-report.el (spam-report-gmane): Add interactive. + +2004-07-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-encode.el (mm-content-transfer-encoding-defaults): Use + qp-or-base64 for the application/* types. + +2004-07-02 Joakim Verona <joakim@verona.se> (tiny change) + + * nnrss.el (nnrss-read-group-data): Fix off-by-one error. + +2004-06-30 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-trim): Don't allow a negative + trim value. + +2004-01-25 Paul Jarc <prj@po.cwru.edu> + + * nnmaildir.el (nnmaildir--condcase, nnmaildir--enoent-p): + New macro and function. + (nnmaildir--new-number, nnmaildir-request-set-mark): Use them. + +2004-06-29 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-enrich-utf-8-by-mule-ucs): Fix cleaning of + after-load-alist. + +2004-06-29 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-get-new-news-this-group): Don't + update info that isn't there. + +2004-06-29 Ilya N. Golubev <gin@mo.msk.ru>. + + * mm-util.el (mm-mime-mule-charset-alist): Add the windows-1251 + entry. + +2004-06-29 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-view.el (mm-inline-render-with-function): Use multibyte + buffer; decode html source by charset. + + * mm-encode.el (mm-content-transfer-encoding-defaults): Doc fix. + + * mm-util.el (mm-enrich-utf-8-by-mule-ucs): New function run when + Mule-UCS is loaded under XEmacs. + (mm-mime-mule-charset-alist): Avoid duplicated entries. + +2004-06-28 Jesper Harder <harder@ifa.au.dk> + + * nnheader.el (nnheader-max-head-length): Increase to 8192. + +2004-06-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-coding-system-p): Return a coding-system. + (mm-mime-mule-charset-alist): Use shift_jis instead of + iso-2022-jp-2 for the katakana-jisx0201 mule charset; add new + entries for the mime charsets iso-2022-jp-3 and shift_jis. + (mm-coding-system-priorities): Use shift_jis and iso-8859-1 + instead of japanese-shift-jis and iso-latin-1 respectively in + order to share the default value with both Emacs and XEmacs-mule. + (mm-mule-charset-to-mime-charset): Make + mm-coding-system-priorities effective. + (mm-sort-coding-systems-predicate): Canonicalize coding-systems + while predicating of candidates upon the priorities. + +2004-06-27 Jesper Harder <harder@ifa.au.dk> + + * gnus-sum.el (gnus-summary-make-menu-bar): Add + gnus-uu-invert-processable. + + * gnus.el: Autoload gnus-uu-invert-processable. + +2004-06-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-with-multibyte-buffer): New macro. + + * rfc2047.el (rfc2047-encode-string): Use it. + (rfc2047-encode-region): Move point to the end of the region after + encoding. Suggested by IRIE Tetsuya <irie@t.email.ne.jp>. + +2004-06-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (gnus-cite-parse): Don't ignore case when finding + ">From ". Thanks to Reiner Steib <Reiner.Steib@gmx.de>. + +2004-06-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cite.el (gnus-cite-ignore-quoted-from): New user option. + (gnus-cite-parse): Ignore quoted envelope From_. Suggested by + Karl Chen <quarl@nospam.quarl.org>. + +2004-06-23 Jesper Harder <harder@ifa.au.dk> + + * message.el (message-idna-to-ascii-rhs-1): Don't choke on + invalid addresses. + +2004-06-21 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el: Change section markers, revise TODO list. + (spam-backends): Make new master list of all installed backends. + (spam-summary-exit-behavior): Add new variable to determine how + messages moves are done at summary exit. + (spam-move-spam-nonspam-groups-only) + (spam-process-ham-in-nonham-groups) + (spam-process-ham-in-spam-groups): Remove variables, the + spam-summary-exit-behavior variable should be used to manage this + behavior. + (spam-old-ham-articles, spam-old-spam-articles): Remove. + (spam-old-articles): Add variable, replacing spam-old-ham-articles + and spam-old-spam-articles. + (spam-use-copy, spam-use-move, spam-use-gmane, spam-use-resend): + Add empty variables, placeholders for the backends they represent. + (spam-set-difference): Move, unchanged. + (spam-list-of-processors): Declare OBSOLETE, not used anymore + unless the user has a processor variable. + (spam-classifications, spam-classification-valid-p) + (spam-backend-properties, spam-backend-property-valid-p) + (spam-backend-function-type-valid-p) + (spam-process-type-valid-p, spam-list-articles): Add helper functions. + (spam-report-articles-gmane, spam-report-articles-resend): + Remove functions, they are not needed. + (spam-install-backend-super, spam-backend-list) + (spam-backend-check, spam-backend-valid-p, spam-backend-info) + (spam-backend-function, spam-backend-ham-registration-function) + (spam-backend-spam-registration-function) + (spam-backend-ham-unregistration-function) + (spam-backend-spam-unregistration-function) + (spam-backend-statistical-p, spam-backend-mover-p) + (spam-install-backend-alias, spam-install-checkonly-backend) + (spam-install-mover-backend, spam-install-nocheck-backend) + (spam-install-backend, spam-install-statistical-backend) + (spam-install-statistical-checkonly-backend): Add backend installation + support. + (spam-summary-prepare-exit): Rewrite to use the new backend code. + (spam-group-processor-p): Use the new backend code and respect the + summary exit behavior. + (spam-mark-spam-as-expired-and-move-routine): Remove. + (spam-summary-prepare): Change to use the new spam-old-articles + variable. + (spam-copy-or-move-routine, spam-copy-spam-routine) + (spam-move-spam-routine, spam-copy-ham-routine) + (spam-move-ham-routine): Add code to copy/move ham or spam. + (spam-fetch-field-fast): Improve doc and code, plus allow the + 'number request. + (spam-list-of-checks, spam-list-of-statistical-checks): Remove + variables. + (spam-split, spam-find-spam): Use the new backend code. + (spam-registration-functions): Remove variable. + (spam-unregister-routine): Add convenience wrapper. + (spam-log-undo-registration, spam-register-routine) + (spam-log-processing-to-registry) + (spam-log-unregistration-needed-p): Rename "check" to "backend" + where possible. + (spam-check-gmane-xref, spam-check-regex-headers) + (spam-check-blackholes, spam-check-stat, spam-check-ifile) + (spam-check-BBDB, spam-check-whitelist, spam-check-blacklist) + (spam-check-bogofilter-headers, spam-check-spamoracle) + (spam-check-spamassassin-headers, spam-check-bsfilter-headers) + (spam-check-crm114-headers): Use the spam-split-group that + spam-split prepares, no need to determine it every time. + + * nnimap.el (nnimap-retrieve-headers-progress): Add the message number + to the nnheader-parse-naked-head call. + + * nnheader.el (nnheader-generate-fake-message-id): Fix indentation. + + * gnus-sum.el (gnus-nov-parse-line): Add the message number to + the nnheader-nov-read-message-id call. + +2004-06-21 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-group.el (gnus-group-get-new-news-this-group): Don't call + gnus-activate-group twice. Suggested by Markus Peter + <warp@spin.de>. + +2004-06-18 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-time-format): Exchange the order of + day and month in the default value; fix customization type. + (article-date-ut): Use add-text-properties. + (article-make-date-line): Use message-make-date instead of + current-time-string. + + * message.el (message-fetch-field): Don't use set-text-properties. + (message-make-date): Simplify. + +2004-06-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-syntax-table): Treat `(' and `)' as is. + (rfc2047-encode-region): Treat text within parentheses as special; + show the original text when error has occurred. + + * gnus-group.el (gnus-group-get-new-news-this-group): Pass the + already-computed method to gnus-activate-group. + + * gnus-start.el (gnus-make-hashtable-from-newsrc-alist): Make the + same select-methods identical Lisp objects. + + * gnus-srvr.el (gnus-server-set-info): Don't make a new Lisp + object when modifying the info. + +2004-06-16 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-srvr.el (gnus-server-set-info): Remove the server from + gnus-opened-servers since it has never been opened with the new + configuration yet. + +2004-06-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnheader.el (nnheader-nov-read-message-id): Pass the optional + arg to nnheader-generate-fake-message-id. + +2004-06-14 Teodor Zlatanov <tzz@lifelogs.com> + + * nnheader.el (nnheader-generate-fake-message-id): Accept a + number and build a fake message ID localized to a group and + article number (so it's repeatable from that point on). + (nnheader-fake-message-id-p): Change regex to accomodate new fake + ID format. + + * gnus-sum.el (gnus-get-newsgroup-headers): Call + nnheader-generate-fake-message-id with the article number. + +2004-06-12 YAGI Tatsuya <ynyaaa@ybb.ne.jp> (tiny change) + + * gnus-art.el (gnus-article-next-page): Fix the way to find a real + end-of-buffer. + +2004-06-12 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-ignored-supersedes-headers): Add Approved. + +2004-06-11 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-message-header): Remove useless + goto-char. + (rfc2047-encode): Fold the line before encoding. + +2004-06-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * rfc2047.el (rfc2047-encode-message-header): Disabled header + folding -- not all headers can be folded, and this should be done + by the message composition mode. Probably. I think. + +2004-06-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-util.el (gnus-remove-text-with-property): Make it slightly + fast. + + * gnus-ems.el (gnus-remove-image): Don't use + message-text-with-property; remove only the image found first. + +2004-06-09 Jesper Harder <harder@ifa.au.dk> + + * message.el (message-send-mail-with-sendmail): Use with-current-buffer. + +2004-06-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-text-with-property): Make it fast and accept + optional arguments. + (message-strip-forbidden-properties): Use it. + (message-fix-before-sending): Follow the m-t-w-p change. + + * gnus-ems.el (gnus-remove-image): Follow the m-t-w-p change. + +2004-06-08 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-hide-headers): Don't change the buffer + mistakenly when performing mml-preview even if + gnus-single-article-buffer is nil. + +2004-06-08 Kai Grossjohann <kgrossjo@eu.uu.net> + + * message.el (message-expand-name-databases): New user option. + (message-expand-name): Use it. + +2004-06-07 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-report-articles-resend) + (spam-report-resend-register-routine): Allow ham reporting. + (spam-report-resend-register-ham-routine): Add wrapper. + (spam-registration-functions): Add ham resending functions. + (spam-list-of-processors): Add ham resend processor. + + * gnus.el (ham-resend-to): Add new group parameter. + (spam-process): Add ham resend option. + + * spam-report.el (spam-report-resend): Allow reporting ham. + (spam-report-resend-ham): Add wrapper. + +2004-06-06 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-cite-articles-with-x-no-archive): New + variable. + (message-cite-original): Use it. + +2004-06-04 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-cite-original): Respect X-No-Archive. + +2004-06-04 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-hide-headers): Refer to the values for + gnus-ignored-headers and gnus-visible-headers in the summary + buffer since a user may have set them as group parameters. + +2004-06-03 Teodor Zlatanov <tzz@lifelogs.com> + + * assistant.el (assistant-node-name): Add convenience function. + (assistant-render-text, assistant-render-node): Add error handling, + plus handle multiple next nodes. + (assistant-find-next-node): Comment out for now. + (assistant-find-next-nodes): Add function, returns list of next + nodes. + +2004-06-02 Reiner Steib <Reiner.Steib@gmx.de> + + * mail-source.el (mail-source-directory): Fix doc-string. + +2004-05-29 Teodor Zlatanov <tzz@lifelogs.com> + + * assistant.el (assistant-render-text, assistant-eval): Add :set + widget type, which is different because it takes and returns a + list. Much hilarity ensues. + +2004-05-28 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-button-alist): Fixed regexp for manual links. + + * gnus-group.el (gnus-group-get-new-news-this-group): Added + doc-string. + + * gnus-start.el (gnus-activate-group): Added doc-string. + +2004-05-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-encode.el (mm-safer-encoding): Consider 7bit is safe. + +2004-05-27 Teodor Zlatanov <tzz@lifelogs.com> + + * assistant.el (assistant-render-text): Try to add a :set + widget, more to come. + + * spam.el (spam-group-spam-contents-p): Handle empty groupname + strings. + (spam-report-articles-resend) + (spam-register-routine): Do registration iff any articles warrant + it. + (spam-summary-prepare-exit): Change log message for nil group + destinations. + +2004-05-27 Daniel Pittman <daniel@rimspace.net> + + * spam.el (spam-report-resend-register-routine): Allow + spam-report-resend-to to be a group parameter or a global value. + +2004-05-26 Simon Josefsson <jas@extundo.com> + + * starttls.el: Merge with my GNUTLS based starttls.el. + (starttls-gnutls-program, starttls-use-gnutls) + (starttls-extra-arguments, starttls-process-connection-type) + (starttls-connect, starttls-failure, starttls-success): New + variables. + (starttls-program, starttls-extra-args): Doc fix. + (starttls-negotiate-gnutls, starttls-open-stream-gnutls): New + functions. + (starttls-negotiate, starttls-open-stream): Check + `starttls-use-gnutls' and pass on to corresponding *-gnutls + function if it is set. + +2004-05-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-region): Encode encoded words in + structured fields. + +2004-05-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-resend): Bind rfc2047-encode-encoded-words. + +2004-05-26 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-mark-new-messages-in-spam-group-as-spam): Add + variable. + (spam-mark-junk-as-spam-routine): Use it. Allow to disable + assigning the spam-mark to new messages. + +2004-05-26 Adam Sj,Ax(Bgren <asjo@koldfront.dk> (tiny change) + + (spam-ham-copy-or-move-routine): Don't declare `todo' twice. + +2004-05-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encodable-p): Don't move point. + (rfc2047-decode): Treat the ascii coding-system as raw-text by + default. + +2004-05-25 Anand Mitra <mitramc@yahoo.com> (tiny change) + + * gnus-sum.el (gnus-summary-delete-article): invoke hook with + correct data. + +2004-05-24 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-list-of-processors): Use nil for nonexistent processors. + (spam-group-processor-p): Fix function. + (spam-group-processor-multiple-p) + (spam-group-spam-processor-report-gmane-p) + (spam-group-spam-processor-report-resend-p) + (spam-group-spam-processor-bogofilter-p) + (spam-group-spam-processor-blacklist-p) + (spam-group-spam-processor-ifile-p) + (spam-group-ham-processor-ifile-p) + (spam-group-spam-processor-spamoracle-p) + (spam-group-spam-processor-crm114-p) + (spam-group-ham-processor-bogofilter-p) + (spam-group-spam-processor-stat-p) + (spam-group-ham-processor-stat-p) + (spam-group-ham-processor-whitelist-p) + (spam-group-ham-processor-BBDB-p) + (spam-group-ham-processor-spamoracle-p) + (spam-group-ham-processor-copy-p): Remove functions with some + prejudice against unneeded code. + (spam-report-articles-resend) + (spam-report-resend-register-routine): Allow the group/topic + spam-resend-to value to override spam-report-resend-to. + (spam-summary-prepare-exit): Invoke spam-group-processor-p + properly now. + + * gnus.el (spam-resend-to): Add group/topic parameter. + (spam-process): Move the OBSOLETE processors to the end of the + choices. + +2004-05-24 Daniel Pittman <daniel@rimspace.net> + + * spam-report.el (spam-report-resend-to, spam-report-resend): Start + with resend-to set to nil, and then ask the user if necessary. + (spam-report-resend): spam-report-resend takes a list of articles, not + separate article numbers. + +2004-05-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-decode.el (mm-text-html-renderer): Make sure w3m exists in + addition to emacs-w3m. + +2004-05-23 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * assistant.el (assistant-authinfo-data): New function. + (assistant-eval): Eval for entire assistant. + + * netrc.el (netrc-services-file): New variable. + (netrc-parse-services): New function. + (netrc-find-service-name): New function. + (netrc-find-service-number): New function. + (netrc-port-equal): New function. + (netrc-machine): Use it. + + * nnimap.el (nnimap-open-connection): Use netrc. + + * gnus-util.el (gnus-netrc-get): Remove aliases. + + * gnus-sum.el (gnus-auto-center-summary): Change default to 2. + + * assistant.el (wid-edit): Fix compilation. + + * gnus-util.el (gnus-set-file-modes): Just ignore errors. + +2004-05-23 Paul Stodghill <stodghil@cs.cornell.edu> + + * gnus-util.el (gnus-set-file-modes): New function. (small + patch). + +2004-05-23 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-topic.el (gnus-topic-jump-to-topic): Goto missing topic. + + * assistant.el (assistant-render-node): Fix up rendering and + read-only text. + (assistant-render-node): Reset. + (assistant-make-read-only): Not sticky. + +2004-05-20 Danny Siu <dsiu@adobe.com> + + * gnus-sum.el (gnus-summary-recenter): Summery buffer was not auto + centered even when gnus-auto-center-summary is t + +2004-05-22 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * dns.el (dns-get-txt-answer): New function. + (dns-read-txt): Ditto. + (query-dns): Use it. + +2004-05-21 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-get-unread-articles): Don't invalidate + active for foreign groups even if the group level is higher than + the specified value. + +2004-05-21 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-jump-to-group): Don't prompt for + non-active groups. + + * gnus-art.el (gnus-picon-databases): Add /usr/share/picons. + +2004-05-20 Magnus Henoch <mange@freemail.hu> + + * dns.el (dns-read-type): Add support for SVR. (small patch) + +2004-05-20 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-use-crm114, spam-crm114, spam-crm114-program) + (spam-crm114-header, spam-crm114-spam-switch) + (spam-crm114-spam-strong-switch, spam-crm114-ham-strong-switch) + (spam-crm114-positive-spam-header) + (spam-crm114-database-directory, spam-list-of-processors) + (spam-group-spam-processor-crm114-p) + (spam-group-ham-processor-crm114-p, spam-extra-header-to-number) + (spam-generic-score, spam-list-of-checks) + (spam-list-of-statistical-checks, spam-registration-functions) + (spam-check-crm114-headers, spam-crm114-score) + (spam-check-crm114, spam-crm114-register-with-crm114) + (spam-crm114-register-spam-routine) + (spam-crm114-unregister-spam-routine) + (spam-crm114-register-ham-routine) + (spam-crm114-unregister-ham-routine): Add CRM114 support. From + asjo@koldfront.dk (Adam Sj,Ax(Bgren). + + * gnus.el: Add spam-use-crm114. + + * spam.el (spam-list-of-processors, spam-registration-functions): + Add spam-use-resend. + (spam-group-spam-processor-report-resend-p): Add utility wrapper. + (spam-report-articles-gmane): Add doc fix. + (spam-report-articles-resend, + spam-report-resend-register-routine): Add wrappers around + spam-report-resend-to. + + * spam-report.el (spam-report-resend-to, spam-report-resend): + Add support for resending spam. + (spam-report-gmane): Fix line length >80. + + * gnus.el (spam-process): Add spam-use-resend. + +2004-05-20 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * spam.el (spam-mark-spam-as-expired-and-move-routine): Return the + number of processed spam messages. + (spam-ham-copy-or-move-routine): Return the number of processed + ham messages. + (spam-summary-prepare-exit): Use the above values to decide + whether status messages shouled be displayed. + +2004-05-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encode-function-alist): Renamed from + `rfc2047-encoding-function-alist' in order to avoid conflicting + with the old version. + (rfc2047-encode-region): Concatenate words containing non-ASCII + characters in structured fields; don't encode space-delimited + ASCII words even in unstructured fields; don't break words at + char-category boundaries. + (rfc2047-encode-1): New function. + (rfc2047-encode): Use it; encode text so that it occupies the + maximum width within 76-column; work correctly on Q encoding for + iso-2022-* charsets. + (rfc2047-fold-region): Use existing whitespace for LWSP; make it + sure not to break a line just after the header name. + (rfc2047-b-encode-region): Removed. + (rfc2047-b-encode-string): New function. + (rfc2047-q-encode-region): Removed. + (rfc2047-q-encode-string): New function. + + * mm-util.el (mm-replace-in-string): New function. + +2004-05-20 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-inews-make-draft-meta-information): Really + get it right. + (gnus-inews-make-draft): Really. + +2004-05-19 Ben Menasha <bmenasha@benmenasha.net> + + * nnmh.el (nnmh-request-list-1): Don't check the link count + before descending. (small patch) + 2004-05-19 Lars Magne Ingebrigtsen <larsi@gnus.org> - * pgg-pgp.el (pgg-pgp-verify-region): Clean up. + * gnus-msg.el (gnus-inews-make-draft-meta-information): Fix quote + stuff. + + * gnus-start.el (gnus-subscribe-hierarchical-interactive): Match + on real group name. + + * gnus-art.el (gnus-signature-limit): Doc fix. + + * gnus-msg.el (gnus-inews-make-draft): Quote list. + +2004-05-19 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-draft.el (gnus-draft-send): Bind + rfc2047-encode-encoded-words. + + * rfc2047.el (rfc2047-encode-region): Encode =? strings. + (rfc2047-encodable-p): Say that =? needs encoding. + (rfc2047-encode-encoded-words): New variable. + + * gnus-group.el (gnus-group-select-group): Doc fix. + + * gnus-draft.el (gnus-draft-setup): Mark all replied as replied. + + * gnus-group.el (gnus-group-mode): Set show-trailing-whitespace + to nil. + + * gnus-cache.el (gnus-cache-possibly-enter-article): Use it. + + * nnheader.el (nnheader-get-lines-and-char): New function. + +2004-05-19 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-msg.el (gnus-summary-followup-with-original): Document + yanking of region when active. + +2004-05-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-get-unread-articles): Do nothing for foreign + groups if the group level is higher than the specified value. + +2004-05-18 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-group.el (gnus-group-jump-to-group-prompt): Allow an alist. + (gnus-group-jump-to-group): Added prefix argument using + `gnus-group-jump-to-group-prompt'. Query before jumping to + non-active group. + + * compface.el (uncompface): Be verbose when changing + `uncompface-use-external'. + + * gnus-art.el (gnus-button-handle-man, gnus-button-alist): Try to + handle manual section. + +2004-05-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-button-alist): Revert previous change. + +2004-05-18 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-idna-to-ascii-rhs-1): Fix typo. + +2004-05-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-inews-do-gcc): Don't use read-only-p to see + whether backend can accept message. + + * message.el (message-idna-to-ascii-rhs-1): Don't use equalp. + +2004-05-18 Kai Grossjohann <kgrossjo@eu.uu.net> + + * nntp.el (nntp-request-set-mark, nntp-request-update-info): + Avoid creating directory when nntp-marks-is-evil is true. + Reported by Reiner Steib. + +2004-05-18 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-picon.el (gnus-picon-style): New variable. + (gnus-picon-insert-glyph): Added optional `nostring' argument. + (gnus-picon-transform-address): Support `gnus-picon-style'. From + Jesper Harder <harder@ifa.au.dk>. + +2004-05-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-fill-field): Return point. + (message-generate-headers): Go to end of field. + + * gnus-start.el (gnus-get-unread-articles-in-group): Don't do + stuff for non-living groups. + +2004-05-18 Jesper Harder <harder@ifa.au.dk> + + * gnus-art.el (gnus-article-followup-with-original) + (gnus-article-reply-with-original): gnus-mark-active-p -> + gnus-region-active-p. + +2004-05-17 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Fix messages, so they show + only when there is spam or ham to be processed. + +2004-05-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mail-source.el (mail-source-delete-crash-box): Refactor. + (mail-source-fetch): Use it. + (mail-source-fetch-file): Ditto. + (mail-source-fetch-directory): Run postscript in loop. + (mail-source-fetch-pop): Delete. + (mail-source-fetch-maildir): Ditto. + (mail-source-fetch-imap): Ditto. + + * imap.el (imap-authenticators): Comment out sasl. + + * message.el (message-skip-to-next-address): New function. + (message-fill-header-address): Refactor. + (message-fill-address): Use it. + (message-delete-address): Use it. + (message-fill-header-general): Refactor. + (message-fill-field-address): Rename. + (message-narrow-to-field): Find the start of the header. + (message-header-format-alist): Don't pre-fill. + (message-fill-header): Removed. + (message-insert-header): New function. + (message-shorten-references): Use it. + + * rfc2047.el (rfc2047-field-value): Strip props. + + * mail-parse.el (mail-header-make-address): New alias. + + * ietf-drums.el (ietf-drums-make-address): New function. + + * imap.el: Add compiler directives. + + * gnus-score.el (gnus-score-edit-done): run-hook->run-hooks. + + * gnus-art.el (article-decode-idna-rhs): Don't use + message-idna-inside-rhs-p. + +2004-05-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-idna-inside-rhs-p): Removed. + (message-idna-to-ascii-rhs-1): Use proper address parsing. + + * gnus-art.el (gnus-emphasis-alist): Removed strikethru; too many + false positives. + +2004-05-16 Kim Minh Kaplan <kmkaplan-AwwS6Bc0PDVoiYX5Tdu9fQ@public.gmane.org> + + * imap.el (imap-sasl-make-mechanisms): Use sasl. + +2004-05-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nneething.el (nneething-file-name): Don't create spurions + files. + + * gnus-msg.el (gnus-inews-do-gcc): Ignore read-only groups. + (gnus-inews-do-gcc): Remove sleep. + + * gnus-art.el (gnus-mime-delete-part): Error message when no MIME + part under point. + + * gnus-agent.el (gnus-agent-synchronize-flags): Default to nil. + (gnus-agent-regenerate-group): Using nil messages aren't valid. + +2004-05-15 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Fixed (length). + +2004-05-14 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Fix to produce "marking spam + as expired without moving it" message when there are spam + messages left. + +2004-05-14 Nelson Ferreira <nelson.ferreira@verizon.net> (tiny change) + + * gnus-dup.el (gnus-dup-unsuppress-article): don't assume the mail + header is not nil. + +2004-05-14 Kai Grossjohann <kgrossjo@eu.uu.net> + + * nntp.el (nntp-request-set-mark, nntp-request-update-info): Call + nntp-possibly-create-directory, not nntp-possibly-change-group. + (nntp-marks-changed-p): New arg SERVER. + (nntp-request-update-info): Adjust caller. + +2004-05-14 Kai Grossjohann <kai@emptydomain.de> + + * nntp.el (nntp-save-marks): Pass missing arg. + +2004-05-13 Kai Grossjohann <kai.grossjohann@gmx.net> + + * nntp.el: Support marks. + (nntp-marks-is-evil, nntp-marks-file-name, nntp-marks) + (nntp-marks-modtime, nntp-marks-directory): New variables. + (nntp-request-set-mark, nntp-request-update-info) + (nntp-possibly-create-directory, nntp-marks-changed-p) + (nntp-save-marks, nntp-open-marks, nntp-marks-directory): New + functions. + +2004-05-12 Jesper Harder <harder@ifa.au.dk> + + * gnus-score.el (gnus-score-insert-help): Use + gnus-select-lowest-window. + + * gnus-ems.el (gnus-select-lowest-window): Copy definition of + appt-select-lowest-window and rename to gnus-select-lowest-window. + + * gnus.el: do. + +2004-05-12 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * rfc2047.el (rfc2047-encode): Use uppercase letters to specify + encodings of MIME-encoded words, in order to improve + interoperability with several broken MUAs. + +2004-05-07 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * mm-view.el (mm-inline-text-html-render-with-w3): Check META + tags, only when charsets are not specified in headers. + (mm-inline-text-html-render-with-w3m): Ditto. + +2004-05-06 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * gnus-art.el (article-strip-banner): Use MIME-encoded from fields + instead of MIME-decoded from fields when checking + `gnus-article-address-banner-alist'. + +2004-05-03 Jesper Harder <harder@ifa.au.dk> + + * nnrss.el (nnrss-check-group, nnrss-read-group-data): Hash on + description rather than subject. + +2004-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-version-number): Bump. + +2004-05-01 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no> + + * gnus.el: No Gnus v0.2 is released. + +2004-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-agent.el (gnus-agent-read-agentview): Inline + gnus-uncompress-range. + +2004-05-01 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * spam.el (spam-bsfilter-path): Use `executable-find' instead of + `exec-installed-p'. + +2004-04-30 TSUCHIYA Masatoshi <tsuchiya@namazu.org> + + * gnus.el (spam-process, spam-autodetect-methods): Add + bsfilter and bsfilter-headers. + + * spam.el (spam-bsfilter): New customize group. + (spam-use-bsfilter, spam-use-bsfilter-headers, spam-bsfilter-path) + (spam-bsfilter-header, spam-bsfilter-probability-header) + (spam-bsfilter-spam-switch, spam-bsfilter-ham-switch) + (spam-bsfilter-spam-strong-switch, spam-bsfilter-ham-strong-switch) + (spam-bsfilter-database-directory): New options. + (spam-install-hooks, spam-list-of-processors, spam-list-of-checks) + (spam-list-of-statistical-checks, spam-registration-functions): + Add `spam-use-bsfilter' and `spam-use-bsfilter-headers'. + (spam-bsfilter-score): New command. + (spam-check-bsfilter-headers, spam-check-bsfilter) + (spam-bsfilter-register-with-bsfilter) + (spam-bsfilter-register-spam-routine) + (spam-bsfilter-unregister-spam-routine) + (spam-bsfilter-register-ham-routine) + (spam-bsfilter-unregister-ham-routine): New functions. + (spam-generic-score): Support bsfilter; Accept an optional argument + to recalcurate spam score even if scoring header has already been + added. + (spam-bogofilter-score, spam-spamassassin-score): Accept an + optional argument to recalcurate spam score even if scoring header + has already been added. + +2004-04-29 Jesper Harder <harder@ifa.au.dk> + + * nnrss.el (nnrss-get-namespace-prefix): Use string= to compare + strings! Reported by David D. Smith <davidsmith@acm.org>. + (nnrss-check-group, nnrss-read-group-data): Hash on Subject if + link is missing. + +2004-04-28 Jesper Harder <harder@ifa.au.dk> + + * html2text.el (html2text-replace-list): Add & and '. + (html2text-get-attr): Rewrite. + + * message.el (message-setup-1): Remove redundant put-text-property + on mail-header-separator. + +2004-04-27 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-cache-whitespace) + (gnus-registry-action, gnus-registry-spool-action) + (gnus-registry-split-fancy-with-parent): Change message levels + from 5 to 3 or 7, as needed. + + * spam.el (spam-summary-prepare-exit) + (spam-mark-junk-as-spam-routine, spam-fetch-field-fast) + (spam-split, spam-find-spam, spam-log-undo-registration) + (spam-check-blackholes, spam-enter-ham-BBDB): Changed message + level from 5 to 6. + +2004-04-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-ems.el: Autoload appt-select-lowest-window (revert + 2004-03-04 change). + +2004-04-25 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el (spam-stat-score-buffer): Simplify mapcar usage. + Use mapc when appropriate. + + * sieve-manage.el (sieve-manage-open): do. + + * nnweb.el (nnweb-insert-html): do. + + * nnvirtual.el (nnvirtual-catchup-group, nnvirtual-partition-sequence) + (nnvirtual-partition-sequence, nnvirtual-create-mapping): do. + + * nnspool.el (nnspool-request-group): do. + + * nnrss.el (nnrss-opml-export, nnrss-find-el, nnrss-order-hrefs): + do. + + * nnml.el (nnml-request-update-info): do. + + * nnmh.el (nnmh-request-group, nnmh-request-list-1, nnmh-active-number) + (nnmh-request-create-group, nnmh-update-gnus-unreads): do. + + * nnimap.el (nnimap-request-close, nnimap-acl-edit) + (nnimap-request-set-mark): do. + + * nnfolder.el (nnfolder-request-update-info): do. + + * mm-view.el (mm-pkcs7-signed-magic, mm-pkcs7-enveloped-magic): + do. + + * mml.el (mml-destroy-buffers, mml-compute-boundary-1): do. + + * gnus-uu.el (gnus-uu-find-articles-matching): do. + + * gnus-topic.el (gnus-topic-check-topology, gnus-topic-remove-group): + do. + + * gnus-sum.el (gnus-summary-fetch-faq, gnus-read-move-group-name): + do. + + * gnus-score.el (gnus-score-load-file, gnus-sort-score-files): do. + + * gnus-nocem.el (gnus-nocem-scan-groups): do. + + * gnus-int.el (gnus-start-news-server): do. + + * gnus-group.el (gnus-group-make-kiboze-group) + (gnus-group-browse-foreign-server): do. + +2004-04-22 Teodor Zlatanov <tzz@lifelogs.com> + + FIXME: Make separate entries for each person. + + From Dan Christensen <jdc@uwo.ca>, asjo@koldfront.dk (Adam + Sj,Ax(Bgren), Wes Hardaker <wes@hardakers.net>, and Michael Shields + <shields@msrl.com>: + + * spam.el (spam-necessary-extra-headers): Get the extra headers we + may need for spam sorting and scoring. + (spam-user-format-function-S): Add user format function suitable for + general use. + (spam-article-sort-by-spam-status): Add sorting function for summary + sorting. + (spam-extra-header-to-number): Add function to get a score from a + header. + (spam-summary-score): Add function to get a numeric score from the + headers. + (spam-generic-score): Fixed function doc, was in wrong place. + (spam-initialize): Take symbols when it's run, and install the + extra headers that spam-necessary-extra-headers thinks we need. + +2004-04-21 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Add logic and message fix. + Reported by bojohan+news@dd.chalmers.se (Johan Bockg,Ae(Brd). + +2004-04-17 Jesper Harder <harder@ifa.au.dk> + + * gnus-sum.el (gnus-set-global-variables) + (gnus-build-all-threads, gnus-get-newsgroup-headers) + (gnus-article-get-xrefs, gnus-summary-best-group) + (gnus-summary-next-article, gnus-summary-enter-digest-group) + (gnus-summary-set-bookmark, gnus-offer-save-summaries) + (gnus-summary-update-info, gnus-kill-or-deaden-summary): Use + with-current-buffer. + +2004-04-16 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Simplify logic. + (spam-fetch-article-header): Read the article header if it's not + available. + (spam-list-articles): Simplify logic. + (spam-filelist-register-routine): Fix bug with unregister-list. + + * gnus-registry.el: Fix comments at beginning. + +2004-04-16 Jesper Harder <harder@ifa.au.dk> + + * message.el (message-cater-to-broken-inn): Remove. + (message-shorten-references): Make sure the total folded length of + References is shorter than 998 characters to cater to a bug in INN + 2.3. Also, don't pretend that references aren't folded -- this + hasn't worked for a while. + +2004-04-15 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-agent.el (gnus-agentize): + gnus-agent-send-mail-real-function no longer set to current value + of message-send-mail-function but rather a lambda that calls + message-send-mail-function. The change makes the agent real-time + responsive to user changes to message-send-mail-function. + +2004-04-15 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * legacy-gnus-agent.el + (gnus-agent-convert-to-compressed-agentview): Fixed typos with + help from Florian Weimer <fw@deneb.enyo.de> + +2004-04-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnmail.el (nnmail-cache-insert): Revert last change. + +2004-04-14 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnmail.el (nnmail-cache-insert): Always check whether + nnmail-cache-ignore-groups matches a group name. + +2004-04-13 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-fetch-field-fast, spam-generate-fake-headers) + (spam-find-spam, spam-log-processing-to-registry) + (spam-log-registered-p, spam-log-unregistration-needed-p) + (spam-log-undo-registration): Use gnus-message instead of + gnus-error, none of these errors are fatal. + + * gnus-registry.el (gnus-registry-clean-empty-function) + (gnus-registry-clean-empty): Remove only empty entries without + extra data. + +2004-04-12 Teodor Zlatanov <tzz@lifelogs.com> + + * spam-stat.el (spam-stat-buffer-change-to-spam) + (spam-stat-buffer-change-to-non-spam): Change (error) to + (gnus-message 8) invocation. + +2004-04-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * nntp.el (nntp-via-netcat-command): New variable. + (nntp-via-netcat-switches): New variable. + (nntp-open-via-rlogin-and-netcat): New function. + (nntp-open-connection-function): Doc fix. + (nntp-telnet-command): Doc fix. + (nntp-end-of-line): Doc fix. + (nntp-via-rlogin-command): Doc fix. + (nntp-via-user-name): Doc fix. + (nntp-via-address): Doc fix. + +2004-04-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * mml2015.el (mml2015-use): Avoid the "Recursive load suspected" + error in Emacs 21.1. + +2004-04-08 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-start.el (gnus-get-unread-articles): Fix last commit. + +2004-04-07 Kevin Greiner <kgreiner@xpediantsolutions.com> + * gnus-agent.el (gnus-agent-total-fetched-hashtb): New variable. + (gnus-agent-with-refreshed-group): New macro. + (gnus-agent-rename-group): New function. + (gnus-agent-delete-group): New function. + (gnus-agent-save-group-info): Use gnus-command-method when + `method' parameter is nil. Don't write nil entries into the + active file. + (gnus-agent-get-group-info): New function. + (gnus-agent-fetch-articles): Use + gnus-agent-update-files-total-fetched-for to increment disk space + used. + (gnus-agent-fetch-headers, gnus-agent-save-alist): Use + gnus-agent-update-view-total-fetched-for to increment disk space + used. + (gnus-agent-get-local): Added optional parameters to avoid calling + gnus-group-real-name and gnus-find-method-for-group. + (gnus-agent-set-local): Delete stored entry if either min, or max, + are nil. + (gnus-agent-fetch-session): Reworded error/quit messages. On + quit, use gnus-agent-regenerate-group to record existance of any + articles fetched to disk before the quit occurred. + (gnus-agent-expire-group-1): Use gnus-agent-with-refreshed-group, + gnus-agent-update-view-total-fetched-for, and + gnus-agent-update-files-total-fetched-for to decrement disk space + used. + (gnus-agent-retrieve-headers): Use + gnus-agent-update-view-total-fetched-for to increment disk space + used. + (gnus-agent-regenerate-group): Replace gnus-group-update-group + with gnus-agent-update-files-total-fetched-for to decrement disk + space and fresh group buffer. + (gnus-agent-inhibit-update-total-fetched-for): New variable. + (gnus-agent-need-update-total-fetched-for): New variable. + (gnus-agent-update-files-total-fetched-for): New function. + (gnus-agent-update-view-total-fetched-for): New function. + (gnus-agent-total-fetched-for): New function. + + * gnus-cache.el (gnus-cache-save-buffers): Use + gnus-cache-update-overview-total-fetched-for to change disk space + used by this group. + (gnus-cache-possibly-enter-article): Use + gnus-cache-update-file-total-fetched-for to increment disk space + used by this group. + (gnus-cache-possibly-remove-article): Use + gnus-cache-update-file-total-fetched-for to decrement disk space + used by this group. + (gnus-cache-generate-nov-databases): Purge total fetched cache. + (gnus-cache-rename-group): New function. + (gnus-cache-delete-group): New function. + (gnus-cache-inhibit-update-total-fetched-for): New variable. + (gnus-cache-need-update-total-fetched-for): New variable. + (gnus-cache-with-refreshed-group): New macro. + (gnus-cache-update-file-total-fetched-for): New function. + (gnus-cache-update-overview-total-fetched-for): New function. + (gnus-cache-rename-group-total-fetched-for): New function. + (gnus-cache-delete-group-total-fetched-for): New function. + (gnus-cache-total-fetched-for): New function. + + * gnus-group.el: Require gnus-sum and autoload functions to + resolve warnings when gnus-group.el compiled alone. + (gnus-group-line-format): Documented new %F + (size of Fetched data) group line format; identifies disk space + used by agent and cache. + (gnus-group-line-format-alist): Defined new F format. + (gnus-total-fetched-for): New function. + (gnus-group-delete-group): No longer update + gnus-cache-active-altered as gnus-request-delete-group now keeps + the cache in sync. + (gnus-group-list-active): Let the agent store a server's active + list if currently plugged. + + * gnus-int.el (gnus-request-delete-group): Use + gnus-cache-delete-group and gnus-agent-delete-group to keep the + local disk in sync with the server. + (gnus-request-rename-group): Use + gnus-cache-rename-group and gnus-agent-rename-group to keep the + local disk in sync with the server. + + * gnus-start.el (gnus-get-unread-articles): Cosmetic + simplification to logic. + + * gnus-util.el (gnus-rename-file): New function. + +2004-04-07 Christian Neukirchen <chneukirchen@yahoo.de> (tiny change) + + * mm-util.el (mm-image-load-path): Handle nil in load-path. + +2004-04-07 Jesper Harder <harder@ifa.au.dk> + + * rfc2047.el (rfc2047-encoded-word-regexp): Remove unnecessary + '+'. Reported by Stefan Wiens <s.wi@gmx.net>. + +2004-04-06 Jesper Harder <harder@ifa.au.dk> + + * gnus-cache.el (gnus-cache-save-buffers): Check if buffer is + alive. Reported by Laurent Martelli <laurent@aopsys.com>. + +2004-04-03 Jesper Harder <harder@ifa.au.dk> + + * gnus.el (gnus-getenv-nntpserver): Strip whitespace. + +2004-04-02 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-set-difference): Add function to replace + gnus-set-difference in spam.el. + (spam-summary-prepare-exit): Use spam-set-difference. + +2004-03-29 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-registry.el (gnus-registry-cache-file): Update to use + gnus-dribble-directory OR gnus-home-directory OR ~. + (gnus-registry-split-fancy-with-parent): Fix doc. + +2004-03-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-exchange-point-and-mark): Use + message-mark-active-p. Suggested by Jesper Harder + <harder@ifa.au.dk>. + +2004-03-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-exchange-point-and-mark): Don't activate + region if it was inactive. Suggested by Hiroshi Fujishima + <pooh@nature.tsukuba.ac.jp>. + +2004-03-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-display-face): Display Faces in the same + order as X-Faces. + +2004-03-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * nndoc.el (nndoc-forward-type-p): Recognize envelope From_. + +2004-03-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-recompute-hierarchical-structure): Remove. + (gnus-mime-multipart-functions): Revert 2004-03-19 change. + (gnus-article-mime-hierarchy): Remove. + (gnus-article-mime-hierarchy-next): Remove. + (gnus-article-mode): Revert 2004-03-19 change. + (gnus-article-setup-buffer): Revert 2004-03-19 change. + (gnus-insert-mime-button): Revert 2004-03-19 change. + (gnus-mime-accumulate-hierarchy): Remove. + (gnus-mime-enter-multipart): Remove. + (gnus-mime-leave-multipart): Remove, + (gnus-mime-display-part): Revert 2004-03-19 change. + (gnus-mime-display-alternative): Revert 2004-03-19 change. + + * mml.el (mml-preview): Revert 2004-03-19 change. + +2004-03-18 Helmut Waitzmann <Helmut.Waitzmann@web.de> (tiny change) + + * gnus-sum.el (gnus-newsgroup-variables): Doc fix. + +2004-03-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-decode.el (mm-save-part): Bind enable-multibyte-characters to + t while entering a file name using the mm-with-multibyte macro. + Suggested by Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>. + + * mm-util.el (mm-with-multibyte): New macro. + +2004-03-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-recompute-hierarchical-structure): New + user option. + (gnus-mime-multipart-functions): Doc and customization fix. + (gnus-article-mime-hierarchy): New variable. + (gnus-article-mime-hierarchy-next): New variable. + (gnus-article-mode): Make gnus-article-mime-hierarchy buffer-local. + (gnus-article-setup-buffer): Set gnus-article-mime-hierarchy and + gnus-article-mime-hierarchy-next to nil. + (gnus-insert-mime-button): Show hierarchy numbers. + (gnus-mime-accumulate-hierarchy): New function. + (gnus-mime-enter-multipart): New function. + (gnus-mime-leave-multipart): New function. + (gnus-mime-display-part): Recompute hierarchical MIME structure. + (gnus-mime-display-alternative): Show hierarchy numbers. + + * mml.el (mml-preview): Set gnus-article-mime-hierarchy and + gnus-article-mime-hierarchy-next to nil. + +2004-03-19 Steve Youngs <sryoungs@bigpond.net.au> + + * dns.el: Don't require gnus-xmas. + +2004-03-17 Jesper Harder <harder@ifa.au.dk> + + * mml.el (mml-generate-mime-1): Don't use format=flowed with + inline PGP. + (mml-menu): Disable mml-quote-region if mark is inactive. + +2004-03-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-regenerate-group): Activate the group + when the group's active is not available. + +2004-03-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-agent.el (gnus-agent-read-agentview): Add a missing arg to + error. + +2004-03-12 Reiner Steib <Reiner.Steib@gmx.de> + + * imap.el (imap-store-password): New variable. + (imap-interactive-login): Use it. + Suggested by Mark Plaksin <happy@mcplaksin.org>. + +2004-03-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-read-summary-keys): Restore new + window-start and hscroll to summary window. + +2004-03-12 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-start.el (gnus-convert-old-newsrc): Only write the + conversion message to newsrc-dribble when an actual conversion is + performed. -2004-05-19 Michael Schierl <schierlm-usenet@gmx.de> (tiny change) +2004-03-10 Malcolm Purvis <malcolmpurvis@optushome.com.au> (tiny change) - * pgg-pgp.el (pgg-pgp-verify-region): Default when signature - isn't a string. + * spam-stat.el (spam-stat-coding-system): Use mm-coding-system-p. + +2004-03-10 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-decode.el (mm-complicated-handles): New function reviving + former definition of mm-multiple-handles. + + * gnus-art.el (gnus-mime-save-part-and-strip): Use it. + (gnus-mime-delete-part): Use it. + +2004-03-09 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-agent.el (gnus-agent-read-local): Bind + nnheader-file-coding-system to gnus-agent-file-coding-system to + avoid the implicit assumption that they will always be equal. + (gnus-agent-save-local): Bind buffer-file-coding-system, not + coding-system-for-write, as the with-temp-file macro first prints + to a buffer then saves the buffer. + +2004-03-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-edit-part): New function. + (gnus-mime-save-part-and-strip): Use it; do query instead of + signaling an error; don't use mm-multiple-handles. + (gnus-mime-delete-part): Ditto. + +2004-03-08 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-agent.el (gnus-agent-read-agentview): Removed support for + old file versions. + (gnus-group-prepare-hook): Removed function that converted list + form of gnus-agent-expire-days to group properties. + + * gnus-int.el: Autoload gnus-agent-regenerate-group. + (gnus-request-accept-article): Re-indented. + + * gnus-start.el (gnus-convert-old-newsrc): Registered new + converters to handle old agent file formats. Added logic for a + "backup before upgrading warning". + (gnus-convert-mark-converter-prompt): Developers can mark + functions as needing (default), or not needing, + gnus-convert-old-newsrc's "backup before upgrading warning". + (gnus-convert-converter-needs-prompt): Tests whether the user + should be protected from potentially irreversable changes by the + function. + + * legacy-gnus-agent.el (): New. Provides converters that are only + loaded when gnus-convert-old-newsrc needs to call them. + +2004-03-08 Katsumi Yamaoka <yamaoka@jpl.org> + + * mail-source.el (mail-source-touch-pop): Doc fix. + + * message.el (message-smtpmail-send-it): Doc fix. 2004-03-05 Jesper Harder <harder@ifa.au.dk> * sha1-el.el (sha1-maximum-internal-length): Doc fix. + * nnmail.el (nnmail-split-fancy): do. + + * gnus-kill.el (gnus-kill, gnus-execute): do. + +2004-03-05 Per Abrahamsen <abraham@dina.kvl.dk> + + * gnus-sum.el (gnus-widget-reversible-match) + (gnus-widget-reversible-to-internal) + (gnus-widget-reversible-to-external): New functions. + (gnus-widget-reversible): New widget. + (gnus-article-sort-functions, gnus-thread-sort-functions): Use it. + +2004-03-05 Kai Grossjohann <kgrossjo@eu.uu.net> + + * gnus-sum.el (gnus-thread-sort-functions) + (gnus-article-sort-functions): Document `(not F)' items. + +2004-03-04 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-use-gmane-xref): Add new backend. + (spam-gmane-xref-spam-group): Add variable to control the name of the + Gmane spam group. + (spam-blackhole-servers, spam-blackhole-good-server-regex) + (spam-regex-headers-spam, spam-regex-headers-ham) + (spam-regex-body-spam, spam-regex-body-ham): Clarify docs. + (spam-list-of-checks): Add spam-use-gmane-xref to list of + backends and checks. + (spam-check-gmane-xref): Add function for spam-use-gmane-xref. + + * gnus.el (spam-autodetect-methods): Add spam-use-gmane-xref as + an autodetect method. + +2004-03-04 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-int.el (gnus-request-accept-article): Inform the agent that + articles are being added to a group. + (gnus-request-replace-article): Inform the agent that articles + need to be uncached as the cached contents are no longer valid. + 2004-03-04 Katsumi Yamaoka <yamaoka@jpl.org> + * binhex.el: Don't autoload executable-find. + * canlock.el: Don't autoload mail-fetch-field. + * gnus-ems.el: Don't autoload appt-select-lowest-window. + + * gnus-msg.el: Don't autoload news-reply-mode, news-setup, + rmail-dont-reply-to and rmail-output. + + * gnus-score.el: Don't autoload ffap-string-at-point. + + * gnus-setup.el: Don't autoload sc-cite-original. + + * imap.el: Don't autoload base64-decode-string, + base64-encode-string and md5. + + * message.el: Autoload rmail-dont-reply-to, rmail-msg-is-pruned + and rmail-msg-restore-non-pruned-header. + + * mm-decode.el: Don't autoload executable-find. + + * mm-url.el: Don't autoload executable-find. + + * mm-view.el: Don't autoload diff-mode. + + * nndb.el: Don't autoload news-reply-mode, news-setup, + cancel-timer and telnet. + + * password.el: Don't autoload run-at-time for Emacs. + + * sha1-el.el: Don't autoload executable-find. + + * sieve-mode.el: Don't autoload c-mode. + + * uudecode.el: Don't autoload executable-find. + +2004-03-04 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-agent.el (gnus-agent-file-header-cache): Removed. + (gnus-agent-possibly-alter-active): Avoid null in numeric + comparison. + (gnus-agent-set-local): Refuse to save null in local object table. + (gnus-agent-regenerate-group): The REREAD parameter can now be a + list of articles that will be marked as unread. + +2004-03-04 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encoded-word-regexp): Mismatched paren. + +2004-03-04 Jesper Harder <harder@ifa.au.dk> + + * rfc2047.el (rfc2047-encoded-word-regexp): Support RFC 2231 + language tags. + +2004-03-03 Per Abrahamsen <abraham@dina.kvl.dk> + + * gnus-agent.el (gnus-agent-read-local, gnus-agent-save-local): + Don't bind "obarray". + + * gnus-sum.el (gnus-thread-sort-functions): Added + `gnus-thread-sort-by-most-recent-number' and + `gnus-thread-sort-by-most-recent-date'. + Reported by Kai Grossjohann <kai@emptydomain.de>. + +2004-03-03 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-cus.el (gnus-agent-customize-category): Mismatched paren. + +2004-03-02 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-cus.el (gnus-agent-customize-category): Removed + ignore-errors macro reference that required cl to be loaded at + run-time. + + * gnus-range.el (gnus-sorted-range-intersection): Now accepts + single-interval range of the form (min . max). Previously the + range had to look like ((min . max)). Likewise, return + (min . max) rather than ((min . max)). + (gnus-range-map): Use gnus-range-normalize to accept + single-interval range. + + * gnus-sum.el (gnus-summary-highlight-line): Articles stored in + the cache, but not the agent, now appear with their usual face. + +2004-03-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-wash-html-with-w3m): Don't make the + w3m-safe-url-regexp variable buffer-local. + + * mm-view.el (mm-inline-text-html-render-with-w3m): Ditto. + +2004-02-27 Simon Josefsson <jas@extundo.com> + + * gnus-sum.el (gnus-move-group-prefix-function): Add, default to + gnus-group-real-prefix. + (gnus-summary-move-article): Use it, instead of + gnus-group-real-prefix. + +2004-02-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-wash-html-with-w3m): Make the + w3m-safe-url-regexp variable buffer-local and set it as the value + of mm-w3m-safe-url-regexp. + + * mm-view.el (mm-inline-text-html-render-with-w3m): Ditto. + + * gnus-msg.el (gnus-setup-message): Ignore an article copy while + parsing gnus-posting-styles when the message is not for replying. + + * nnrss.el (nnrss-opml-export): Use + mm-set-buffer-file-coding-system instead of + set-buffer-file-coding-system. + +2004-02-27 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el: Pedantic docstring and whitespace fixes (courtesy + of checkdoc.el). + * nnrss.el: do. + * gnus-mlspl.el: do. + * gnus-ml.el: do. + * gnus-srvr.el: do. + + * nnrss.el (nnrss-opml-export): Turn on sgml-mode. + +2004-02-27 Kevin Ryde <user42@zip.com.au> (tiny change) + + * gnus.el (gnus-group, gnus-summary, gnus-summary-sort): + Corrections to custom-manual links. + + * gnus-art.el (gnus-article): Ditto. + + * mm-decode.el (mime-display, mime-security): Ditto. + +2004-02-26 Jesper Harder <harder@ifa.au.dk> + + * flow-fill.el: Typo. + +2004-02-26 Andrew Cohen <cohen@andy.bu.edu> + + * spam-wash.el: New file. + +2004-02-26 Mark A. Hershberger <mah@everybody.org> + + * nnrss.el (nnrss-opml-import, nnrss-opml-export): New functions. + +2004-02-26 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-summary-prepare-exit): Fix gnus-set-difference: needs + to be run with new-articles as LIST1, not LIST2. + (spam-registration-functions): Add spam-use-ham-copy as a nil + registration backend. + +2004-02-26 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el (spam-stat-washing-hook): New option. + (spam-stat-buffer-words): Use it. + (spam-stat-process-directory, spam-stat-test-directory): Use + insert-file-contents-literally. + (spam-stat-coding-system): New variable. + (spam-stat-load, spam-stat-save): Use it. + +2004-02-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * spam-report.el (spam-report-plug-agent): Quote + spam-report-url-to-file and spam-report-url-ping-plain. + +2004-02-25 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-button-alist, gnus-header-button-alist): Allow + / in mailto URLs. + +2004-02-24 Reiner Steib <Reiner.Steib@gmx.de> + + * spam-report.el (spam-report-process-queue): Fix interactive use. + (spam-report-url-ping-temp-agent-function, spam-report-plug-agent) + (spam-report-unplug-agent): Doc fixes. + (spam-report-url-ping-mm-url, spam-report-url-to-file) + (spam-report-agentize, spam-report-deagentize): Autoload + +2004-02-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-setup-fill-variables): Add mml tags to + paragraph-start and paragraph-separate. Suggested by Andrew Korty + <ajk@iu.edu>. + (message-mode): Don't modify paragraph-separate there. + +2004-02-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * compface.el (uncompface-use-external): Default to undecided. + (uncompface-use-external-threshold): New variable. + (uncompface-float-time): New macro. + (uncompface): Determine whether to use the external decoder if + uncompface-use-external is undecided. + +2004-02-15 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mm-view.el (mm-inline-image-emacs): Don't insert blank lines + after images. + + * gnus-art.el (gnus-mime-display-single): Remove dead code. + +2004-02-14 Jesper Harder <harder@ifa.au.dk> + + * nnrss.el (nnrss-request-article, nnrss-find-el): Cleanup. + + * html2text.el (html2text-get-attr, html2text-fix-paragraph): do + + * gnus-sum.el (gnus-summary-limit-to-age) + (gnus-summary-limit-children): do. + + * gnus-int.el (gnus-request-scan): do. + + * gnus-group.el (gnus-group-suspend): do. + + * gnus-cus.el (gnus-agent-cat-prepare-category-field): do. + + * gnus-cite.el (gnus-cite-parse-attributions): do. + + * gnus-agent.el (gnus-summary-set-agent-mark) + (gnus-agent-regenerate-group): do. + + * deuglify.el (gnus-article-outlook-unwrap-lines): do. + + * binhex.el (binhex-decode-region-internal): do. + +2004-02-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-fun.el (gnus-face-properties-alist): New user option. + (gnus-display-x-face-in-from): Use it. + + * gnus-art.el (article-display-face): Ditto. + + * compface.el (uncompface-use-external): Default to nil. + +2004-02-12 Jesper Harder <harder@ifa.au.dk> + + * nntp.el (nntp-erase-buffer): New function. + (nntp-retrieve-data, nntp-send-command) + (nntp-send-buffer, nntp-retrieve-groups, nntp-handle-authinfo) + (nntp-possibly-change-group): Use it. + + * nnnil.el (nnnil-retrieve-headers, nnnil-request-list): Use + with-current-buffer. + +2004-02-12 TAKAI Kousuke <tak@kmc.gr.jp> + + * compface.el: Merge the ELisp-based uncompface program. + (compface): New customization group. + (uncompface-use-external): New user option. + (uncompface): Call uncompface-internal if uncompface-use-external + is nil. + (uncompface-internal): New function. Note that there are also + some other functions and variables added for this function. + +2004-02-10 Jesper Harder <harder@ifa.au.dk> + + * nnrss.el (nnrss-read-group-data): Initialize nnrss-group-hashtb + if necessary. + +2004-02-09 Teodor Zlatanov <tzz@lifelogs.com> + + * spam-report.el (spam-report-unplug-agent) + (spam-report-plug-agent, spam-report-deagentize) + (spam-report-agentize, spam-report-url-ping-temp-agent-function): + Add support for the Agent in spam-report: when unplugged, report to a + file; when plugged, submit all the requests. + + * spam.el (spam-register-routine): Fix message about + registration. + +2004-02-09 Jesper Harder <harder@ifa.au.dk> + + * rfc2047.el (rfc2047-qp-or-base64): New function to reduce + dependencies. + (rfc2047-encode): Use it. + + * gnus-art.el (gnus-button-marker-list): Move before first + reference. + + * imap.el (imap-parse-flag-list, imap-parse-body-extension) + (imap-parse-body): Fix format string mismatch. + + * gnus-score.el (gnus-summary-increase-score): do. + + * nnrss.el (nnrss-close): New function. + +2004-02-08 Jesper Harder <harder@ifa.au.dk> + + * nnrss.el (nnrss-make-filename): New function. + (nnrss-request-delete-group, nnrss-read-server-data) + (nnrss-save-server-data, nnrss-read-group-data) + (nnrss-save-group-data): Use it. + (nnrss-save-server-data, nnrss-save-group-data): Use gnus-prin1. + (nnrss-read-server-data, nnrss-read-group-data): Use load. + (nnrss-group-hashtb): Make it a hash table rather than an obarray. + +2004-02-07 Jesper Harder <harder@ifa.au.dk> + + * mml.el (mml-compute-boundary-1): Don't uncompress files. + +2004-02-06 Jesper Harder <harder@ifa.au.dk> + + * mml.el (mml-mode, mml-x-dnd-attach-file): Attach drop and drag + files. + + * message.el (message-generate-headers-first): Don't quote nil + and t in docstrings. + + * imap.el (imap-id): do. + + * gnus-agent.el (gnus-agent-consider-all-articles) + (gnus-agent-queue-mail): do. + +2004-02-05 Reiner Steib <Reiner.Steib@gmx.de> + + * spam-report.el (spam-report-process-queue): New function. + Process requests from `spam-report-requests-file'. + (spam-report-process-queue): Doc fix. + +2004-02-05 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-register-routine) + (spam-log-processing-to-registry, spam-log-registered-p) + (spam-log-unregistration-needed-p, spam-log-undo-registration): + Change "check" to "spam-check" for semi-clarity. + +2004-02-05 Jesper Harder <harder@ifa.au.dk> + + * pop3.el: Require nnheader. + + * mml-smime.el: Require cl. Autoload message-fetch-field. + + * mml-sec.el (mml-signencrypt-style): Don't depend on Gnus. + + * gnus-picon.el: Require cl. + + * gnus-fun.el: Require gnus-ems and gnus-util. + + * gnus.el (gnus-method-to-server): Move defsubst before first use. + + * gnus-diary.el (gnus-diary-header-schedule): caddr -> car (cddr + + * gnus-art.el (gnus-article-edit-mode): Define before first + reference. + +2004-02-04 Jesper Harder <harder@ifa.au.dk> + + * gnus-uu.el (gnus-uu-check-correct-stripped-uucode): Simplify. + (gnus-uu-post-encoded): Use point-at-bol. + + * gnus-topic.el (gnus-group-active-topic-p): do. + + * gnus-start.el (gnus-newsrc-to-gnus-format): do. + + * gnus-group.el (gnus-group-kill-region): do. + + * gnus-art.el (article-date-ut): do. + + * message.el (message-fetch-field): Remove redundant + case-fold-search binding. + (message-narrow-to-field): Simplify. + +2004-02-03 Reiner Steib <Reiner.Steib@gmx.de> + + * spam.el (spam-directory): Derive from `gnus-directory'. + + * spam-report.el (spam-report-url-to-file) + (spam-report-requests-file): New function and variable for offline + reporting. + (spam-report-url-ping-function): Add `spam-report-url-to-file' + and user defined function. + (spam-report-url-ping-mm-url): Remove doubled slash. + +2004-02-03 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-list-of-processors): Fix spamassassin variable names. + +2004-02-03 Jesper Harder <harder@ifa.au.dk> + + * spam.el (spam-check-spamoracle, spam-spamoracle-learn): Fix + format string mismatch. + + * sieve.el (sieve-deactivate-all): do. + + * nnfolder.el (nnfolder-request-set-mark, nnfolder-save-marks): do. + + * nnlistserv.el (nnlistserv-kk-wash-article): do. + + * nnml.el (nnml-request-set-mark, nnml-save-marks): do. + + * mm-bodies.el (mm-7bit-chars): Don't include \r. + +2004-02-02 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-list-of-checks): Add spam-use-BBDB-eclusive to + the list of checks. + +2004-01-31 Jesper Harder <harder@ifa.au.dk> + + * rfc2047.el (rfc2047-pad-base64): Deal with more cases of invalid + padding. + +2004-01-27 Ralf Angeli <angeli@iwi.uni-sb.de> + + * mm-view.el (mm-fill-flowed): New variable. + (mm-inline-text): Use it. + +2004-01-27 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-spamassassin-register-ham-routine) + (spam-spamassassin-register-spam-routine): Fix function names. + +2004-01-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus.el (gnus-tmp-grouplens): Remove. + (gnus-summary-line-format): Remove grouplens. + + * gnus-group.el (gnus-group-line-format): Ditto. + + * gnus-spec.el (gnus-format-specs): Ditto. + (gnus-update-format-specifications): Flush the group format spec + cache if there's the grouplens stuff. + (gnus-parse-simple-format): Replace %l with the empty string. + +2004-01-27 Jerry James <james@xemacs.org> (tiny change) + + * gnus-spec.el (gnus-parse-simple-format): Fix setq value + omission. + +2004-01-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-msg.el (gnus-summary-resend-message-edit): Call mime-to-mml. + Suggested by Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>. + +2004-01-25 Paul Jarc <prj@po.cwru.edu> + + * nnmaildir.el (nnmaildir--num-file, nnmaildir--mkfile, + nnmaildir--emlink-p, nnmaildir--eexist-p, nnmaildir--new-number): + New macros and functions. + * nnmaildir.el (nnmaildir--group-maxnum, nnmaildir--update-nov): + Handle > NLINK_MAX messages. + * nnmaildir.el (nnmaildir-request-set-mark): Use + nnmaildir--emlink-p and nnmaildir--eexist-p. + +2004-01-25 Alex Schroeder <alex@gnu.org> + + * spam-stat.el (spam-stat-process-directory-age): New option. + (spam-stat-process-directory): Use it. + +2004-01-24 Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp> (tiny change) + + * spam-stat.el (spam-stat-reduce-size): Set spam-stat-dirty. + (spam-stat-save): Accept prefix argument. + +2004-01-23 Paul Jarc <prj@po.cwru.edu> + + * nnmaildir.el (nnmaildir-request-set-mark): Handle the "too many + links" error. + +2004-01-23 Jesper Harder <harder@ifa.au.dk> + + * gnus.el (gnus-tmp-grouplens): Define for the sake of backward + compatibility with old .newsrc.eld files. + + * gnus-sum.el (gnus-summary-line-format-alist): Remove grouplens. + + * gnus-start.el (gnus-1): do. + + * gnus-group.el (gnus-group-line-format-alist): do. + + * gnus.el (gnus-use-grouplens, gnus-visual): do. + + * gnus-gl.el: Remove. + +2004-01-23 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-sum.el (gnus-adjust-marks): Now correctly handles a list of + marks consisting of a single range {for example, (3 . 5)} rather + than a list of a single range { ((3 . 5)) }. + +2004-01-23 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el (spam-stat-store-gnus-article-buffer): Use + with-current-buffer. + (spam-stat-store-current-buffer): Use insert-buffer-substring to + avoid consing a string. + + * mm-util.el (mm-charset-synonym-alist): Add ks_c_5601-1987. + Remove obsolete entries for big5 and gb2312. + +2004-01-22 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-sum.el (gnus-adjust-marks): Avoid splicing null INTO the + uncompressed list. + +2004-01-22 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el (spam-stat-strip-xref): New function. + (spam-stat-process-directory): Use it. + + * gnus-util.el (gnus-fetch-field): Don't bind case-fold-search + here -- it's done in message-fetch-field. + +2004-01-21 Kevin Greiner <kgreiner@xpediantsolutions.com> + + * gnus-agent.el (gnus-agent-queue-mail, + gnus-agent-prompt-send-queue): New variables. + (gnus-agent-send-mail): Use gnus-agent-queue-mail. + * gnus-draft.el (gnus-group-send-queue): Pass the group name + "nndraft:queue" along to gnus-draft-send. Use + gnus-agent-prompt-send-queue. + (gnus-draft-send): Rebind gnus-agent-queue-mail to nil when group + is "nndraft:queue". Suggested by Gaute Strokkenes + <gs234@srcf.ucam.org> + + * gnus-agent.el (agent-disable-undownloaded-faces): Removed + (agent-enable-undownloaded-faces): Added + (gnus-agent-cat-groups): Use eval-and-compile, not + eval-when-compile, to define gnus-agent-set-cat-groups as the setf + method of gnus-agent-cat-groups even when the buffer has been + evaled. + (gnus-agent-save-active,gnus-agent-save-active-1): Merged to + delete gnus-agent-save-active-1. + (gnus-agent-save-groups): Deleted. Identical to + gnus-agent-save-active. + (gnus-agent-write-active): No longer adjust agent's copy of active + file as agent's adjustments are now stored in their own + file. Removed optional parameter. + (gnus-agent-possibly-alter-active): Ignore groups of unagentized + servers. Add use of min/max range limits from server's local + file. + (gnus-agent-save-alist): Removed unused optional argument. + (gnus-agent-load-local,gnus-agent-read-and-cache-local), + (gnus-agent-read-local,gnus-agent-save-local,gnus-agent-get-local), + (gnus-agent-set-local): A per-server file that keeps min/max range + limits for articles known to the agent. Provides a fast mechanism + for altering many active ranges. + (gnus-agent-expire-group,gnus-agent-expire): No longer save the + active file (local makes it unnecessary). + (gnus-agent-regenerate-group): Fixed XEmacs compatibility. + + * gnus-cus.el (agent-disable-undownloaded-faces): Removed + (agent-enable-undownloaded-faces): Added + + * gnus-draft.el (gnus-draft-send): Bind gnus-agent-queue-mail to + disable it when sending to "nndraft:queue". + (gnus-group-send-queue): Add safety check to avoid sending queue + when unplugged. + + * gnus-group.el (gnus-group-catchup): Use new + gnus-sequence-of-unread-articles, not + gnus-list-of-unread-articles, to avoid exhausting memory with huge + numbers of articles. Use gnus-range-map to avoid having to + uncompress the unread list. + (gnus-group-archive-directory, + gnus-group-recent-archive-directory): Fixed invalid ange-ftp + reference. + + * gnus-range.el (gnus-range-map): Iterate over list or sequence. + (gnus-sorted-range-intersection): Intersection of two ranges + without requiring that they first be uncompressed. + + * gnus-start.el (gnus-activate-group): Unless blocked by the + caller, possibly expand the active range to include both cached + and agentized articles. + (gnus-convert-old-newsrc): Rewrote in anticipation of having + multiple version-dependent converters. + (gnus-groups-to-gnus-format): Replaced gnus-agent-save-groups with + gnus-agent-save-active. + (gnus-save-newsrc-file): Save dirty agent range limits. + + * gnus-sum.el (gnus-select-newgroup): Replaced inline code with + gnus-agent-possibly-alter-active. + (gnus-adjust-marked-articles): Faster handling of simple lists + +2004-01-21 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el (spam-stat-test-directory): New optional argument + displays a list of files detected. Suggested by Andrew Cohen + <cohen@andy.bu.edu>. + (spam-stat-buffer-words-with-scores): Don't narrow and change + syntax table here. Reported by Andrew Cohen <cohen@andy.bu.edu>. + +2004-01-20 Hubert Chan <hubert@uhoreg.ca>: + + * spam.el (spam-use-spamassassin, spam-use-spamassassin-headers) + (spam-install-hooks, spam-spamassassin, spam-spamassassin-path) + (spam-spamassassin-arguments) + (spam-spamassassin-spam-flag-header) + (spam-spamassassin-positive-spam-flag-header) + (spam-spamassassin-spam-status-header, spam-sa-learn-path) + (spam-sa-learn-rebuild, spam-sa-learn-spam-switch) + (spam-sa-learn-ham-switch, spam-sa-learn-unregister-switch) + (spam-list-of-processors, spam-list-of-checks) + (spam-list-of-statistical-checks, spam-registration-functions) + (spam-check-spamassassin-headers, spam-check-spamassassin) + (spam-spamassassin-score) + (spam-spamassassin-register-with-sa-learn) + (spam-spamassassin-register-spam-routine) + (spam-spamassassin-register-ham-routine) + (spam-assassin-register-spam-routine) + (spam-assassin-register-ham-routine): add SpamAssassin support + (spam-bogofilter-score): fix to show article before scoring + +2004-01-20 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (gnus-summary-mode-map): Make spam-generic-score the + default scoring function. + (spam-generic-score): Call spam-spamassassin-score if + spam-use-spamassassin or spam-use-spamassassin-headers is on; + spam-bogofilter-score otherwise. + + * gnus.el (spam-process, spam-autodetect-methods): Add + spamassassin and spamassassin-headers. + +2004-01-20 Nevin Kapur <nkapur@cs.caltech.edu> + + * gnus-registry.el (gnus-registry-split-fancy-with-parent): + Suppress unnecessary messages. + +2004-01-20 Jesper Harder <harder@ifa.au.dk> + + * spam-stat.el (spam-stat-to-hash-table): Use :size keyword in + make-hash-table. + 2004-01-19 Katsumi Yamaoka <yamaoka@jpl.org> * canlock.el (base64-encode-string): Don't autoload it. +2004-01-16 Katsumi Yamaoka <yamaoka@jpl.org> + + * run-at-time.el: Remove useless (require 'itimer), + eval-and-compile and (featurep 'xemacs). + +2004-01-16 Jesper Harder <harder@ifa.au.dk> + + * gnus-msg.el (gnus-post-news): Use blank Newsgroups line if + GROUP is a virtual group. + +2004-01-16 Steve Youngs <sryoungs@bigpond.net.au> + + * gnus.el: Autoload `message-y-or-n-p'. + +2004-01-15 Jesper Harder <harder@ifa.au.dk> + + * pgg-parse.el: Remove unnecessary (require 'custom). + + * pgg-def.el: do. + + * nnmail.el: do. + + * gnus-undo.el: do. + + * gnus-picon.el: do. + + * gnus-util.el: do. + +2004-01-15 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-sum.el (gnus-pick-line-number): Add autoload. + +2004-01-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-decode.el (mm-multiple-handles): Recognize a string as a mime + handle, as well as a list. + + * mm-view.el (mm-w3m-cid-retrieve-1): Call itself recursively. + Suggested by ARISAWA Akihiro <ari@mbf.sphere.ne.jp>. + (mm-w3m-cid-retrieve): Simplify. + +2004-01-14 Vasily Korytov <deskpot@myrealbox.com> + + * message.el (message-kill-to-signature): Allow prefix arg to + specify number of lines to keep before signature. + +2004-01-14 Kai Grossjohann <kai@emptydomain.de> + + (message-kill-to-signature): Change docstring. + 2004-01-14 Katsumi Yamaoka <yamaoka@jpl.org> * canlock.el: Always require sha1-el. (canlock-sha1): Bind sha1-maximum-internal-length to nil. + * message.el: Autoload sha1 only when compiling. + 2004-01-13 Katsumi Yamaoka <yamaoka@jpl.org> * message.el (message-canlock-generate): Require sha1-el. +2004-01-13 Jesper Harder <harder@ifa.au.dk> + + * message.el (message-expand-name): Silence the byte compiler. + +2004-01-13 Simon Josefsson <jas@extundo.com> + + * gnus-score.el (gnus-score-edit-all-score): Fix prototype. + Invoke gnus-score-mode. Reported by + bojohan+news@dd.chalmers.se (Johan Bockg,Ae(Brd). + + * gnus-range.el (gnus-compress-sequence): Doc fix. Suggested by + Jim Blandy <jimb@redhat.com> (tiny change). + +2004-01-12 Jesper Harder <harder@ifa.au.dk> + + * gnus-srvr.el (gnus-browse-foreign-server): Reduce consing. + +2004-01-12 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-get-article-as-string): Update to use + gnus-request-article-this-buffer, much simpler. + (spam-get-article-as-buffer): Remove. + +2004-01-12 Kai Grossjohann <kai.grossjohann@mci.com> + + * message.el (message-expand-name): Use EUDC if the user uses + that. + +2004-01-12 Jesper Harder <harder@ifa.au.dk> + + * rfc2047.el (rfc2047-parse-and-decode, rfc2047-decode): Use a + character for the encoding to avoid consing a string. + + * rfc2047.el (rfc2047-decode-string): Don't cons a string + unnecessarily. + + * mm-util.el (mm-replace-chars-in-string): Remove. + + * rfc2047.el (rfc2047-decode): Use mm-subst-char-in-string instead + of mm-replace-chars-in-string. + +2004-01-11 Jesper Harder <harder@ifa.au.dk> + + * gnus.sum.el (gnus-remove-odd-characters): Don't cons two new + strings. + + * mm-util.el (mm-subst-char-in-string): Support inplace. + + * gnus-sum.el (gnus-summary-remove-list-identifiers): Don't cons + a new string in every iteration. Use shy groups. + +2004-01-10 Jesper Harder <harder@ifa.au.dk> + + * gnus-start.el (gnus-subscribe-newsgroup, gnus-start-draft-setup) + (gnus-group-change-level, gnus-kill-newsgroup) + (gnus-check-bogus-newsgroups, gnus-get-unread-articles-in-group) + (gnus-get-unread-articles, gnus-make-articles-unread) + (gnus-make-ascending-articles-unread): Use accessor + macros (gnus-group-entry, gnus-group-unread, gnus-info-marks etc.) + to get group information for improved readability. + + * gnus-srvr.el (gnus-browse-unsubscribe-group): do. + + * gnus-soup.el (gnus-soup-group-brew): do. + + * gnus-msg.el (gnus-put-message): do. + + * gnus-move.el (gnus-group-move-group-to-server): do. + + * gnus-kill.el (gnus-batch-score): do. + + * gnus-group.el (gnus-group-prepare-flat, gnus-group-delete-group) + (gnus-group-update-group-line, gnus-group-insert-group-line-info) + (gnus-group-update-group, gnus-group-read-group) + (gnus-group-make-group, gnus-group-make-help-group) + (gnus-group-make-archive-group, gnus-group-make-directory-group) + (gnus-group-make-empty-virtual, gnus-group-sort-selected-flat) + (gnus-group-sort-by-unread, gnus-group-catchup) + (gnus-group-unsubscribe-group, gnus-group-kill-group) + (gnus-group-yank-group, gnus-group-set-info) + (gnus-group-list-groups): do. + + * gnus.el (gnus-generate-new-group-name): do. + + * gnus-delay.el (gnus-delay-send-queue): do. + + * nnvirtual.el (nnvirtual-catchup-group): do. + + * nnkiboze.el (nnkiboze-generate-group, nnkiboze-generate-group): + do. + + * gnus-topic.el (gnus-topic-find-groups, gnus-topic-clean-alist) + (gnus-group-prepare-topics, gnus-topic-check-topology): do. + + * gnus-sum.el (gnus-update-read-articles, gnus-select-newsgroup) + (gnus-mark-xrefs-as-read, gnus-compute-read-articles) + (gnus-summary-walk-group-buffer, gnus-summary-move-article) + (gnus-group-make-articles-read): do. + +2004-01-09 Jesper Harder <harder@ifa.au.dk> + + * gnus-art.el (article-decode-mime-words, article-babel) + (gnus-article-highlight-signature, gnus-article-add-buttons) + (gnus-signature-toggle): Use gnus-with-article-buffer. + + * gnus-art.el (gnus-article-highlight-headers) + (gnus-article-add-buttons-to-head): Use gnus-with-article-headers. + + * gnus-art.el (gnus-mm-display-part, gnus-article-wash-status) + (gnus-article-set-globals, gnus-request-article-this-buffer) + (gnus-button-message-id, gnus-article-maybe-hide-headers) + (gnus-mime-view-part-externally, gnus-mime-view-part-internally) + (gnus-mime-display-alternative): Use with-current-buffer. + +2004-01-09 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-generate-fake-headers): Rewrite to be simpler, + also under 80 char limit, and call gnus-error if needed. + (spam-fetch-article-header): Fix - it was a + buffer-local variable (gnus-newsgroup-data). + (spam-find-spam): Use spam-generate-fake-headers, forget about + spam-insert-fake-headers. + (spam-insert-fake-headers): Remove. + +2004-01-09 Jesper Harder <harder@ifa.au.dk> + + * deuglify.el (gnus-article-outlook-unwrap-lines) + (gnus-outlook-rearrange-article) + (gnus-outlook-repair-attribution-outlook) + (gnus-outlook-repair-attribution-block) + (gnus-outlook-repair-attribution-other): Remove redundant + save-excursion. + +2004-01-09 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-fetch-field-fast, spam-fetch-field-from-fast) + (spam-fetch-field-subject-fast) + (spam-fetch-field-message-id-fast, spam-generate-fake-headers) + (spam-fetch-article-header): Add functions to deal with Gnus + internals for fast retrieval of article header data. + (spam-initialize): Put spam-find-spam in the gnus-summary-prepared-hook. + +2004-01-09 Jesper Harder <harder@ifa.au.dk> + + * pop3.el (pop3-md5): Remove. + (pop3-apop): Replace pop3-md5 with md5. + + * mm-bodies.el: base64 is always built-in. + + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use + with-current-buffer. + 2004-01-08 Katsumi Yamaoka <yamaoka@jpl.org> * canlock.el (canlock-insert-header): Remove excessive grouping in regexp. + * gnus-sum.el (gnus-summary-read-document): Ditto. + + * gnus-uu.el (gnus-uu-part-number): Ditto. + + * html2text.el (html2text-remove-tags): Ditto. + (html2text-format-tags): Ditto. + (html2text-format-single-elements): Ditto. + + * mml.el (mml-parse-1): Ditto. + +2004-01-08 Jesper Harder <harder@ifa.au.dk> + + * gnus-sum.el (gnus-summary-update-mark): Revert previous change. + + * gnus-group.el (gnus-group-mark-group): Fix for multibyte marks. + + * gnus-sum.el (gnus-summary-update-mark): Fix for multibyte marks. + + * gnus-util.el (gnus-replace-in-string): Remove Emacs 20 code. + +2003-11-15 Simon Josefsson <jas@extundo.com> + + * pgg-gpg.el (pgg-gpg-lookup-all-secret-keys) + (pgg-gpg-lookup-key): Use regexp match instead of + split-string (split-string is different between emacs 21.2 and + 22.1). Reported by ultrasoul@ultrasoul.com (David D. Smith). + +2004-01-08 Jesper Harder <harder@ifa.au.dk> + + * gnus-art.el (gnus-mime-view-all-parts) + (gnus-article-part-wrapper, gnus-article-view-part): Use + with-current-buffer. + +2004-01-07 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-disable-spam-split-during-ham-respool) + (spam-spamoracle-database, spam-cache-lookups) + (spam-split-last-successful-check, spam-clear-cache, spam-xor) + (spam-group-ham-mark-p, spam-group-spam-mark-p) + (spam-group-ham-marks, spam-group-spam-marks) + (spam-group-spam-contents-p, spam-group-ham-contents-p) + (spam-list-of-processors, spam-list-of-statistical-checks): Fix doc, + also add spam-use-blackholes to the statistical checks. + (spam-fetch-field-fast): Add interface to fetching fields, may + become a macro. + (spam-fetch-field-from-fast, spam-fetch-field-subject-fast) + (spam-fetch-field-message-id-fast): Use spam-fetch-field-fast. + (spam-insert-fake-headers): Fake an article when needed. + (spam-find-spam): Fake article when possible. + (spam-check-blackholes, spam-check-BBDB, spam-from-listed-p) + (spam-check-bogofilter-headers): Use message-fetch-field instead + of nnmail-fetch-field. + +2004-01-07 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-score.el (gnus-score-find-trace): Add `k' (kill-buffer). + +2004-01-07 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el (spam-split): Do not require spam-use-CHECK to be + enabled if that check is passed to spam-split explicitly; also + fix so 'spam doesn't get converted to spam-split-group when + spam-split-symbolic-return is t. + (spam-find-spam): Find registrations of the article and use those + instead of re-running spam-split to find the spam/ham + classification of the article. + (spam-log-processing-to-registry, spam-log-registered-p) + (spam-log-unregistration-needed-p, spam-log-undo-registration): + Use gnus-error instead of gnus-message. + (spam-log-registration-type): Add function to determine the + classification of a message based on registry entries; will + return nil if both 'spam and 'ham are found. + (spam-check-BBDB): Expand all the BBDB macros here so we can have + a reasonably fast local cache without the loading errors. + (spam-cache-lookups): Set to t by default. + (spam-find-spam): Don't try to guess spam-cache-lookups. + (spam-enter-whitelist, spam-enter-blacklist): Clear the + spam-caches entry. + (spam-filelist-build-cache, spam-filelist-check-cache): Fix + caching of whitelist/blacklist entries. + (spam-check-whitelist, spam-check-blacklist): Invoke + spam-from-listed-p with a type, not a cache variable. + (spam-from-listed-p): Wrap around spam-filelist-check-cache. + +2004-01-07 Jesper Harder <harder@ifa.au.dk> + + * message.el (message-cite-prefix-regexp): Use with-syntax-table. + + * nnmail.el (nnmail-split-fancy): do. + + * mml.el (mml-parse): do. + + * gnus-score.el (gnus-enter-score-words-into-hashtb) + (gnus-score-adaptive): do. + 2004-01-07 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-art.el (gnus-treat-emphasize): Ignore Emacs version number. + (gnus-mime-button-map): Don't set keymap parent. + (gnus-button-ctan-directory-regexp): Use shy grouping. + (gnus-prev-page-map): Don't set keymap parent. + (gnus-prev-page-map): Remove duplicated one. + (gnus-next-page-map): Don't set keymap parent. + (gnus-mime-security-button-map): Ditto. + + * nnheader.el (nnheader-directory-files-is-safe): Ignore Emacs + version number. + * sha1-el.el (sha1-string-external): Use with-temp-buffer. 2004-01-07 Katsumi Yamaoka <yamaoka@jpl.org> @@ -4782,275 +10806,346 @@ (sha1-string): Ditto. (sha1): Ditto. -2003-11-15 Simon Josefsson <jas@extundo.com> +2004-01-07 Lars Magne Ingebrigtsen <larsi@gnus.org> - * pgg-gpg.el (pgg-gpg-lookup-all-secret-keys) - (pgg-gpg-lookup-key): Use regexp match instead of - split-string (split-string is different between emacs 21.2 and - 22.1). Reported by ultrasoul@ultrasoul.com (David D. Smith). + * spam.el (spam-report-articles-gmane): New command. -2004-07-28 Simon Josefsson <jas@extundo.com> +2004-01-07 Katsumi Yamaoka <yamaoka@jpl.org> - * pgg-pgp5.el (pgg-pgp5-encrypt-region): Accept sign - parameter (but don't use it, for now). + * gnus.el: Don't make unnecessary *Group* buffer when loading. -2004-02-03 Jesper Harder <harder@ifa.au.dk> + * run-at-time.el (run-at-time-saved): Remove. + (run-at-time): Doc fix. - * sieve.el (sieve-deactivate-all): Fix format string mismatch. +2004-01-07 Jesper Harder <harder@ifa.au.dk> -2004-08-30 Andreas Schwab <schwab@suse.de> + * gnus-sum.el (gnus-summary-limit-to-replied): New command. + (gnus-summary-limit-map): Add it. + (gnus-summary-make-menu-bar): do. - * rfc2231.el (rfc2231-parse-string): Restore whitespace syntax for - ?* and ?\;. +2004-01-06 Teodor Zlatanov <tzz@lifelogs.com> - * ietf-drums.el (ietf-drums-syntax-table): Set syntax of ?* ?\; - and ?\' to symbol instead of whitespace. + * spam.el (spam-cache-lookups, spam-caches, spam-clear-cache): + Make attempt at some caching support (done for BBDB only now). + (spam-find-spam): Set spam-cache-lookups if there are more than 2 + addresses to be checked. + (spam-clear-cache-BBDB): Add function, to be invoked by + bbdb-change-hook, and triggering spam-clear-cache of 'spam-use-BBDB. + (spam-check-BBDB): Check and use the caches, if + spam-cache-lookups is on, remove superfluous (provide). -2004-08-31 Jesper Harder <harder@ifa.au.dk> +2004-01-06 Reiner Steib <Reiner.Steib@gmx.de> - * message.el (message-idna-to-ascii-rhs-1): Don't choke on - invalid addresses. + * gnus-art.el (gnus-treat-ansi-sequences): Changed default. -2004-08-31 Reiner Steib <Reiner.Steib@gmx.de> +2004-01-07 Steve Youngs <sryoungs@bigpond.net.au> - * message.el (message-idna-to-ascii-rhs-1): Fix typo. + * run-at-time.el (run-at-time-saved): Move to after the definition + of `run-at-time'. -2004-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> +2004-01-06 Katsumi Yamaoka <yamaoka@jpl.org> - * message.el (message-idna-to-ascii-rhs-1): Don't use equalp. + * gnus-art.el (gnus-article-wash-html-with-w3m): Don't use + mm-w3m-local-map-property. -2004-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> + * mm-view.el (mm-w3m-mode-map): Remove. + (mm-w3m-local-map-property): Remove. + (mm-inline-text-html-render-with-w3m): Don't use + mm-w3m-local-map-property. - * gnus-art.el (article-decode-idna-rhs): Don't use - message-idna-inside-rhs-p. +2004-01-06 Lars Magne Ingebrigtsen <larsi@gnus.org> -2004-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> + * run-at-time.el: New file. - * message.el (message-idna-inside-rhs-p): Remove. - (message-idna-to-ascii-rhs-1): Use proper address parsing. + * gnus.el ((fboundp 'gnus-set-text-properties)): Remove definition + of gnus-set-text-properties. -2004-08-31 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-uu.el (gnus-uu-save-article): Ditto. - * gnus-agent.el (gnus-agent-restore-gcc): Use ^ and regexp-quote. + * gnus-salt.el (gnus-carpal-setup-buffer): Ditto. -2004-08-30 Helmut Waitzmann <Helmut.Waitzmann@web.de> (tiny change) + * gnus-cite.el (gnus-cite-parse): Ditto. - * gnus-sum.el (gnus-newsgroup-variables): Doc fix. + * gnus-art.el (gnus-button-push): Use set-text-properties instead + of gnus-. -2004-08-26 YAGI Tatsuya <ynyaaa@ybb.ne.jp> (tiny change) + * gnus.el: Changed calls to nnheader-run-at-time and + password-run-at-time throughout to use run-at-time directly. - * gnus-art.el (gnus-article-next-page): Fix the way to find a real - end-of-buffer. + * password.el: Removed definition of run-at-time. -2004-08-26 Stefan Wiens <s.wi@gmx.net> (tiny change) +2004-01-05 Karl Pfl,Ad(Bsterer <sigurd@12move.de> (tiny change) - * gnus-sum.el (gnus-read-header): Don't remove a header for the - parent article of a sparse article in the thread hashtb. + * mml.el (mml-minibuffer-read-disposition): Show attachment type + in prompt. -2004-08-26 David Hedbor <dhedbor@real.com> (tiny change) +2004-01-06 Steve Youngs <sryoungs@bigpond.net.au> - * nnmail.el (nnmail-split-lowercase-expanded): New user option. - (nnmail-expand-newtext): Lowercase expanded entries if - nnmail-split-lowercase-expanded is non-nil. + * gnus-ems.el (gnus-mode-line-modified): Don't conditionalise on + XEmacs version. - * gnus-agent.el (gnus-agent-regenerate-group): Activate the group - when the group's active is not available. + * dns.el (dns-make-network-process): Use `open-network-stream' + instead of `gnus-xmas-open-network-stream'. - * gnus-art.el (article-hide-headers): Refer to the values for - gnus-ignored-headers and gnus-visible-headers in the summary - buffer since a user may have set them as group parameters. - (gnus-article-read-summary-keys): Restore new window-start and - hscroll to summary window. - (gnus-prev-page-map): Remove duplicated one. + * .cvsignore: Add auto-autoloads.el, custom-load.el. - * gnus-cite.el (gnus-cite-ignore-quoted-from): New user option. - (gnus-cite-parse): Ignore quoted envelope From_. Suggested by - Karl Chen <quarl@nospam.quarl.org> and Reiner Steib - <Reiner.Steib@gmx.de>. +2004-01-06 Jesper Harder <harder@ifa.au.dk> - * gnus-cus.el (gnus-agent-cat-prepare-category-field): - Replace pp-to-string with gnus-pp-to-string. + * gnus-art.el (gnus-mime-display-alternative) + (gnus-insert-mime-button, gnus-insert-mime-security-button) + (gnus-insert-prev-page-button, gnus-insert-next-page-button): + Don't use gnus-local-map-property. - * gnus-eform.el (gnus-edit-form): Replace pp with gnus-pp. + * gnus-util.el (gnus-local-map-property): Remove. - * gnus-group.el (gnus-group-make-kiboze-group): Replace pp with - gnus-pp. + * mm-view.el (mm-view-pkcs7-decrypt): Replace + gnus-completing-read-maybe-default with completing-read. - * gnus-msg.el (gnus-setup-message): Ignore an article copy while - parsing gnus-posting-styles when the message is not for replying. - (gnus-summary-resend-message-edit): Call mime-to-mml. - Suggested by Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>. - (gnus-debug): Replace pp with gnus-pp. + * gnus-util.el (gnus-completing-read): do. + (gnus-completing-read-maybe-default): Remove. - * gnus-score.el (gnus-score-save): Replace pp with gnus-pp. +2004-01-06 Steve Youngs <sryoungs@bigpond.net.au> - * gnus-spec.el (gnus-update-format): Replace pp-to-string with - gnus-pp-to-string. + * password.el: Only autoload `run-at-time' if not XEmacs. + Only autoload the itimer functions if XEmacs. - * gnus-util.el (gnus-bind-print-variables): New macro. - (gnus-prin1): Use it. - (gnus-prin1-to-string): Use it. - (gnus-pp): New function. - (gnus-pp-to-string): New function. +2004-01-06 Jesper Harder <harder@ifa.au.dk> - * gnus.el: Don't make unnecessary *Group* buffer when loading. + * gnus-art.el (gnus-read-string): Remove. + (gnus-summary-pipe-to-muttprint): Replace gnus-read-string with + read-string. - * mail-source.el (mail-source-touch-pop): Doc fix. +2004-01-05 Teodor Zlatanov <tzz@lifelogs.com> - * message.el (message-mode): Don't modify paragraph-separate there. - (message-setup-fill-variables): Add mml tags to paragraph-start - and paragraph-separate. Suggested by Andrew Korty <ajk@iu.edu>. - (message-smtpmail-send-it): Doc fix. - (message-exchange-point-and-mark): Don't activate region if it was - inactive. Suggested by Hiroshi Fujishima - <pooh@nature.tsukuba.ac.jp> and Jesper Harder <harder@ifa.au.dk>. + * netrc.el: Autoload password-read. + (netrc): Add configuration group. + (netrc-encoding-method, netrc-openssl-path): Add + variables for encoding and decoding of files with symmetric + ciphers. + (netrc-encode): Add assistant function to encode a file with + netrc-encoding-method. + (netrc-parse): Add interactive parameter, added optional + decoding if netrc-encoding-method is non-nil but otherwise + behavior is standard. + (netrc-encrypting-method, netrc-encrypt, netrc-parse): + Do s/encode/encrypt/ everywhere. - * mm-decode.el (mm-save-part): Bind enable-multibyte-characters to - t while entering a file name using the mm-with-multibyte macro. - Suggested by Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>. + * spam.el: Remove executable-find autoload. - * mm-encode.el (mm-content-transfer-encoding-defaults): - Use qp-or-base64 for the application/* types. - (mm-safer-encoding): Consider 7bit is safe. +2004-01-05 Jesper Harder <harder@ifa.au.dk> - * mm-util.el (mm-with-multibyte-buffer): New macro. - (mm-with-multibyte): New macro. + * gnus-registry.el: Remove Emacs 20 hash table compatibility code. - * mm-view.el (mm-inline-render-with-function): Use multibyte - buffer; decode html source by charset. + * gnus-uu.el (gnus-uu-post-encoded): bury-buffer is always fbound. - * nndoc.el (nndoc-type-alist): Improve regexp for article-begin, - add generate-head-function and generate-article-function to the - rfc822-forward entry. - (nndoc-forward-type-p): Recognize envelope From_. - (nndoc-rfc822-forward-generate-article): New function. - (nndoc-rfc822-forward-generate-head): New function. +2004-01-05 Reiner Steib <Reiner.Steib@gmx.de> - * score-mode.el (gnus-score-pretty-print): Replace pp with gnus-pp. + * gnus-art.el (gnus-treat-ansi-sequences, + article-treat-ansi-sequences): New variable and function. + Suggested by Dan Jacobson <jidanni@jidanni.org>. - * webmail.el (webmail-debug): Replace pp with gnus-pp. + * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): + Use it. - * gnus-art.el (gnus-article-wash-html-with-w3m): - Bind w3m-safe-url-regexp as the value for mm-w3m-safe-url-regexp; - use w3m-minor-mode-map instead of mm-w3m-local-map-property. - (gnus-mime-save-part-and-strip): Use mm-complicated-handles - instead of mm-multiple-handles. - (gnus-mime-delete-part): Ditto. +2004-01-05 Jesper Harder <harder@ifa.au.dk> - * mm-decode.el (mm-multiple-handles): Recognize a string as a mime - handle, as well as a list. - (mm-complicated-handles): Former definition of mm-multiple-handles. + * mm-util.el (mm-quote-arg): Remove. - * mm-view.el (mm-w3m-mode-map): Remove. - (mm-w3m-local-map-property): Remove. - (mm-w3m-cid-retrieve-1): Call itself recursively. Suggested by - ARISAWA Akihiro <ari@mbf.sphere.ne.jp>. - (mm-w3m-cid-retrieve): Simplify. - (mm-inline-text-html-render-with-w3m): Decode html source by - charset; check META tags only when charsets are not specified in - headers; specify charset to w3m-region; use w3m-minor-mode-map - instead of mm-w3m-local-map-property. + * mm-decode.el (mm-mailcap-command): Replace mm-quote-arg with + shell-quote-argument. -2004-08-30 Juanma Barranquero <lektu@terra.es> + * gnus-uu.el (gnus-uu-command): do. - * ietf-drums.el (ietf-drums-remove-whitespace): Fix character constant. + * gnus-sum.el (gnus-summary-insert-pseudos): do. -2004-08-30 Andreas Schwab <schwab@suse.de> + * ietf-drums.el (ietf-drums-token-to-list): Replace mm-make-char + with make-char. - * nnlistserv.el (nnlistserv-kk-wash-article): Fix paren nesting. + * mm-util.el (mm-make-char): Remove. - * gnus-score.el (gnus-summary-increase-score): Fix format string. + * mml.el (mml-mode): Replace gnus-add-minor-mode with + add-minor-mode. -2004-08-30 Stefan Monnier <monnier@iro.umontreal.ca> + * gnus-undo.el (gnus-undo-mode): do. - * nnimap.el (nnimap-demule): Avoid string-as-multibyte. + * gnus-topic.el (gnus-topic-mode): do. -2004-08-30 Kim F. Storm <storm@cua.dk> + * gnus-sum.el (gnus-dead-summary-mode): do. - * nntp.el (nntp-authinfo-file): Add :group 'nntp. + * gnus-start.el (gnus-slave-mode): do. - * nnimap.el (nnimap-authinfo-file, nnimap-prune-cache): - Add :group 'nnimap. + * gnus-salt.el (gnus-binary-mode, gnus-pick-mode): do. -2004-08-23 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-ml.el (gnus-mailing-list-mode): do. - * mm-decode.el (mime-display, mime-security): Fix custom-manual - entries. + * gnus-gl.el (gnus-grouplens-mode): do. - * gnus-art.el (gnus-article): Ditto. + * gnus-draft.el (gnus-draft-mode): do. -2004-08-23 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-dired.el (gnus-dired-mode): do. - * gnus-art.el (article-hide-list-identifiers): - Bind inhibit-read-only as t. + * gnus-ems.el (gnus-add-minor-mode): Remove. -2004-08-22 Reiner Steib <Reiner.Steib@gmx.de> + * gnus-spec.el (gnus-correct-length, gnus-correct-substring): + Replace gnus-char-width with char-width. - * gnus-mlspl.el (gnus-group-split-update): Fix docstring. + * gnus-ems.el (gnus-char-width): Remove. -2004-08-22 Stefan Monnier <monnier@iro.umontreal.ca> + * gnus-spec.el (gnus-correct-length, gnus-correct-substring): + Replace gnus-char-width with char-width. - * gnus-art.el: Use inhibit-read-only instead of buffer-read-only. - (gnus-narrow-to-page): Don't assume point-min == 1. - (gnus-article-edit-mode): Derive from message-mode. + * gnus-ems.el (gnus-char-width): Remove. - * gnus-score.el (gnus-score-find-bnews): Simplify and don't assume - point-min == 1. + * spam-stat.el (with-syntax-table): Remove with-syntax-table + definition. + Remove Emacs 20 hash table compatibility code. - * imap.el (imap-parse-address-list, imap-parse-body-ext): - Disable incorrect use of `assert'. + * rfc2047.el (with-syntax-table): Remove with-syntax-table Emacs + 20 compatibility code. - * message.el (message-mode): Set comment-start-skip. + * spam.el (spam-point-at-eol): Replace with point-at-eol. -2004-08-22 Sam Steingold <sds@gnu.org> + * smime.el (smime-point-at-eol): Replace with point-at-eol. - * pop3.el (pop3-leave-mail-on-server): New user variable. - (pop3-movemail): Delete mail only when it is nil. + * rfc2047.el (rfc2047-point-at-bol, rfc2047-point-at-eol): Replace + with point-at-{eol,bol}. -2004-08-17 Reiner Steib <Reiner.Steib@gmx.de> + * netrc.el (netrc-point-at-eol): Replace with point-at-eol. - * netrc.el, tls.el: Removed; use files from ../net instead. + * imap.el (imap-point-at-eol): Replace with point-at-eol. -2004-08-16 Reiner Steib <Reiner.Steib@gmx.de> + * flow-fill.el (fill-flowed-point-at-bol, + fill-flowed-point-at-eol): Replace with point-at-{eol,bol}. - * gnus-mule.el, smiley-ems.el: Removed obsolete files. + * gnus-util.el (gnus-point-at-bol, gnus-point-at-eol): Remove. + Replace with point-at-{eol,bol} throughout all files. - * mailcap.el (mailcap-mime-data): Mark as risky. +2004-01-05 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus.el (gnus-group, gnus-summary, gnus-summary-sort): - Fix custom-manual entries. + * ntlm.el (ntlm-string-as-unibyte): New macro. + (ntlm-build-auth-response): Use it. - * time-date.el: Removed. Merged into ../calendar/time-date.el. + Remove Emacs 20 stuff: + * gnus-msg.el (gnus-summary-news-other-window): Use remove instead + of delq and copy-sequence. + * gnus-art.el (popup-menu): Remove the compiler macro. + * nnmail.el (nnmail-split-fancy): Don't support customizing with + Emacs 20. -2004-08-02 Reiner Steib <Reiner.Steib@gmx.de> +2004-01-05 Simon Josefsson <jas@extundo.com> - * blink.pbm, blink.xpm, braindamaged.xpm, cry.xpm, dead.xpm, - evil.xpm, forced.xpm, frown.xpm, grin.xpm, indifferent.xpm, - reverse-smile.xpm, sad.pbm, sad.xpm, smile.xpm, time-date.el, - wry.xpm: Added new files from the v5_10 branch of Gnus. + * ntlm.el: Fix namespace. Change smb-passwd-hash into + ntlm-smb-passwd-hash, smb-owf-encrypt into ntlm-smb-owf-encrypt, + smb-passwd-hash into ntlm-smb-passwd-hash, smbdes-e-p16 into + ntlm-smb-des-e-p16, smbdes-e-p24 into ntlm-smb-des-e-p24, smbhash + into ntlm-smb-hash, smb-sp8 into ntlm-smb-sp8, smb-str-to-key into + ntlm-smb-str-to-key, smb-dohash into ntlm-smb-dohash, smb-perm1 + into ntlm-smb-perm1, smb-perm2 into ntlm-smb-perm2, smb-perm3 into + ntlm-smb-perm3, smb-perm4 into ntlm-smb-perm4, smb-perm5 into + ntlm-smb-perm5, smb-perm6 into ntlm-smb-perm6, smb-sc into + ntlm-smb-sc, smb-sbox into ntlm-smb-sbox, string-permute into + ntlm-string-permute, string-lshift into ntlm-string-lshift, + string-xor into ntlm-string-xor. Suggested by + Jesper Harder <harder@myrealbox.com>. -2004-07-22 Andreas Schwab <schwab@suse.de> + * ntlm.el: Don't include poem. - Import Gnus 5.10 from the v5_10 branch of the Gnus repository. + * md4.el (print-int32, print-string-hexa): Remove. Suggested by + Jesper Harder <harder@myrealbox.com>. -2004-05-23 Katsumi Yamaoka <yamaoka@jpl.org> + * sasl-ntlm.el, ntlm.el, md4.el: New files. - * mm-decode.el (mm-text-html-renderer): Make sure w3m exists in - addition to emacs-w3m. + * hmac-md5.el (md5-binary): Fix byte compile warning. (This + probably breaks emacs with DL patch, but do we care? Is anyone + still using the DL stuff?) -2004-05-19 Reiner Steib <Reiner.Steib@gmx.de> + * sieve-manage.el: Use the password package. + (sieve-manage-read-passwd): Remove. + (sieve-manage-interactive-login): Use password. Re-add + condition-case around loop. + + * pgg.el (pgg-passphrase-cache, pgg-run-at-time): Remove. + (pgg-add-passphrase-cache, pgg-remove-passphrase-cache): Use + the password package. + +2003-02-19 Simon Josefsson <jas@extundo.com> + + * sieve-manage.el (sieve-sasl-auth): Quote optional initial SASL + token. + +2002-08-07 Simon Josefsson <jas@extundo.com> + + * sieve-manage.el (require): Use SASL, not RFC2104/MD5. + (sieve-manage-authenticators): + (sieve-manage-authenticator-alist): Add some SASL mechs. + (sieve-sasl-auth): New function. + (sieve-manage-cram-md5-auth): + (sieve-manage-plain-auth): Rewrite using SASL library. + (sieve-manage-digest-md5-p, sieve-manage-digest-md5-auth) + (sieve-manage-scram-md5-p, sieve-manage-scram-md5-auth) + (sieve-manage-ntlm-p, sieve-manage-ntlm-auth) + (sieve-manage-login-p, sieve-manage-login-auth): Add wrappers. + +2004-01-05 Simon Josefsson <jas@extundo.com> + + * sasl.el, sasl-cram.el, sasl-digest.el, hmac-md5.el, hmac-def.el: + New files. + +2004-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-no-groups-message): Update. + + * gnus-sum.el (gnus-summary-insert-new-articles): Remove . + +2003-11-09 Simon Josefsson <jas@extundo.com> + + * imap.el: Support for ID IMAP extension (RFC 2971). + (imap-local-variables): Add imap-id. + (imap-id): New variable. + (imap-id): New function. + (imap-parse-response): Parse untagged ID response. + * nnimap.el (nnimap-id): New variable. + (nnimap-open-connection): Use it. + +2003-12-28 Simon Josefsson <jas@extundo.com> + + * gnus-score.el (gnus-score-edit-all-score): New. + * gnus-group.el (gnus-group-score-map): Bind it to W e. + +2004-01-04 Simon Josefsson <jas@extundo.com> + + * password.el: Add. + +2004-01-04 Mario Lang <lang@zid.tugraz.at> + + * dns.el: Add support for AAAA records (see RFC 3596) + + * Fix typo PRT -> PTR + + * Parse MX, PTR and SOA replies (see RFC 1035) + +2004-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-logo-color-style): Changed colors to `no'. + + * Moved to Changelog.2. + +2004-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-version-number): Bump version. + +2004-01-04 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no> + + * gnus.el: No Gnus v0.1 is released. - * gnus-msg.el (gnus-summary-followup-with-original): - Document yanking of region when active. +2004-01-04 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no> -2004-04-13 Kevin Greiner <kgreiner@xpediantsolutions.com> + * gnus.el: No Gnus v0.0 is released. - * gnus-agent.el: Merged 7.3 through 7.7 updates into branch. - Revision 7.2 changes excluded to maintain compatibility with all - targeted emacs versions. +2004-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org> - * gnus-cus.el: Merged revisions 7.2 through 7.5 into branch to support - gnus-agent.el update and incorporate bug fixes. + * gnus.el (gnus-version-number): Bump. + (gnus-version): No. See ChangeLog.2 for earlier changes. diff --git a/lisp/gnus/assistant.el b/lisp/gnus/assistant.el new file mode 100644 index 00000000000..25ff1732f8f --- /dev/null +++ b/lisp/gnus/assistant.el @@ -0,0 +1,487 @@ +;;; assistant.el --- guiding users through Emacs setup +;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: util + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(require 'widget) +(require 'wid-edit) + +(autoload 'gnus-error "gnus-util") +(autoload 'netrc-get "netrc") +(autoload 'netrc-machine "netrc") +(autoload 'netrc-parse "netrc") + +(defvar assistant-readers + '(("variable" assistant-variable-reader) + ("validate" assistant-sexp-reader) + ("result" assistant-list-reader) + ("next" assistant-list-reader) + ("text" assistant-text-reader))) + +(defface assistant-field '((t (:bold t))) + "Face used for editable fields." + :group 'gnus-article-emphasis) +;; backward-compatibility alias +(put 'assistant-field-face 'face-alias 'assistant-field) + +;;; Internal variables + +(defvar assistant-data nil) +(defvar assistant-current-node nil) +(defvar assistant-previous-nodes nil) +(defvar assistant-widgets nil) + +(defun assistant-parse-buffer () + (let (results command value) + (goto-char (point-min)) + (while (search-forward "@" nil t) + (if (not (looking-at "[^ \t\n]+")) + (error "Dangling @") + (setq command (downcase (match-string 0))) + (goto-char (match-end 0))) + (setq value + (if (looking-at "[ \t]*\n") + (let (start) + (forward-line 1) + (setq start (point)) + (unless (re-search-forward (concat "^@end " command) nil t) + (error "No @end %s found" command)) + (beginning-of-line) + (prog1 + (buffer-substring start (point)) + (forward-line 1))) + (skip-chars-forward " \t") + (prog1 + (buffer-substring (point) (point-at-eol)) + (forward-line 1)))) + (push (list command (assistant-reader command value)) + results)) + (assistant-segment (nreverse results)))) + +(defun assistant-text-reader (text) + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (let ((start (point)) + (sections nil)) + (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t) + (push (buffer-substring start (match-beginning 0)) + sections) + (push (list (match-string 1) (match-string 2)) + sections) + (setq start (point))) + (push (buffer-substring start (point-max)) + sections) + (nreverse sections)))) + +;; Segment the raw assistant data into a list of nodes. +(defun assistant-segment (list) + (let ((ast nil) + (node nil) + (title (pop list))) + (dolist (elem list) + (when (and (equal (car elem) "node") + node) + (push (list "save" nil) node) + (push (nreverse node) ast) + (setq node nil)) + (push elem node)) + (when node + (push (list "save" nil) node) + (push (nreverse node) ast)) + (cons title (nreverse ast)))) + +(defun assistant-reader (command value) + (let ((formatter (cadr (assoc command assistant-readers)))) + (if (not formatter) + value + (funcall formatter value)))) + +(defun assistant-list-reader (value) + (car (read-from-string (concat "(" value ")")))) + +(defun assistant-variable-reader (value) + (let ((section (car (read-from-string (concat "(" value ")"))))) + (append section (list 'default)))) + +(defun assistant-sexp-reader (value) + (if (zerop (length value)) + nil + (car (read-from-string value)))) + +(defun assistant-buffer-name (title) + (format "*Assistant %s*" title)) + +(defun assistant-get (ast command) + (cadr (assoc command ast))) + +(defun assistant-set (ast command value) + (let ((elem (assoc command ast))) + (when elem + (setcar (cdr elem) value)))) + +(defun assistant-get-list (ast command) + (let ((result nil)) + (dolist (elem ast) + (when (equal (car elem) command) + (push elem result))) + (nreverse result))) + +;;;###autoload +(defun assistant (file) + "Assist setting up Emacs based on FILE." + (interactive "fAssistant file name: ") + (let ((ast + (with-temp-buffer + (insert-file-contents file) + (assistant-parse-buffer)))) + (pop-to-buffer (assistant-buffer-name (assistant-get ast "title"))) + (assistant-render ast))) + +(defun assistant-render (ast) + (let ((first-node (assistant-get (nth 1 ast) "node"))) + (set (make-local-variable 'assistant-data) ast) + (set (make-local-variable 'assistant-current-node) nil) + (set (make-local-variable 'assistant-previous-nodes) nil) + (assistant-render-node first-node))) + +(defun assistant-find-node (node-name) + (let ((ast (cdr assistant-data))) + (while (and ast + (not (string= node-name (assistant-get (car ast) "node")))) + (pop ast)) + (car ast))) + +(defun assistant-node-name (node) + (assistant-get node "node")) + +(defun assistant-previous-node-text (node) + (format "<< Go back to %s" node)) + +(defun assistant-next-node-text (node) + (if (and node + (not (eq node 'finish))) + (format "Proceed to %s >>" node) + "Finish")) + +(defun assistant-set-defaults (node &optional forcep) + (dolist (variable (assistant-get-list node "variable")) + (setq variable (cadr variable)) + (when (or (eq (nth 3 variable) 'default) + forcep) + (setcar (nthcdr 3 variable) + (assistant-eval (nth 2 variable)))))) + +(defun assistant-get-variable (node variable &optional type raw) + (let ((variables (assistant-get-list node "variable")) + (result nil) + elem) + (while (and (setq elem (pop variables)) + (not result)) + (setq elem (cadr elem)) + (when (eq (intern variable) (car elem)) + (if type + (setq result (nth 1 elem)) + (setq result (if raw (nth 3 elem) + (format "%s" (nth 3 elem))))))) + result)) + +(defun assistant-set-variable (node variable value) + (let ((variables (assistant-get-list node "variable")) + elem) + (while (setq elem (pop variables)) + (setq elem (cadr elem)) + (when (eq (intern variable) (car elem)) + (setcar (nthcdr 3 elem) value))))) + +(defun assistant-render-text (text node) + (unless (and text node) + (gnus-error + 5 + "The assistant was asked to render invalid text or node data")) + (dolist (elem text) + (if (stringp elem) + ;; Ordinary text + (insert elem) + ;; A variable to be inserted as a widget. + (let* ((start (point)) + (variable (cadr elem)) + (type (assistant-get-variable node variable 'type))) + (cond + ((eq (car-safe type) :radio) + (push + (apply + #'widget-create + 'radio-button-choice + :assistant-variable variable + :assistant-node node + :value (assistant-get-variable node variable) + :notify (lambda (widget &rest ignore) + (assistant-set-variable + (widget-get widget :assistant-node) + (widget-get widget :assistant-variable) + (widget-value widget)) + (assistant-render-node + (assistant-get + (widget-get widget :assistant-node) + "node"))) + (cadr type)) + assistant-widgets)) + ((eq (car-safe type) :set) + (push + (apply + #'widget-create + 'set + :assistant-variable variable + :assistant-node node + :value (assistant-get-variable node variable nil t) + :notify (lambda (widget &rest ignore) + (assistant-set-variable + (widget-get widget :assistant-node) + (widget-get widget :assistant-variable) + (widget-value widget)) + (assistant-render-node + (assistant-get + (widget-get widget :assistant-node) + "node"))) + (cadr type)) + assistant-widgets)) + (t + (push + (widget-create + 'editable-field + :value-face 'assistant-field + :assistant-variable variable + (assistant-get-variable node variable)) + assistant-widgets) + ;; The editable-field widget apparently inserts a newline; + ;; remove it. + (delete-char -1) + (add-text-properties start (point) + (list + 'bold t + 'face 'assistant-field + 'not-read-only t)))))))) + +(defun assistant-render-node (node-name) + (let ((node (assistant-find-node node-name)) + (inhibit-read-only t) + (previous assistant-current-node) + (buffer-read-only nil)) + (unless node + (gnus-error 5 "The node for %s could not be found" node-name)) + (set (make-local-variable 'assistant-widgets) nil) + (assistant-set-defaults node) + (if (equal (assistant-get node "type") "interstitial") + (assistant-render-node (nth 0 (assistant-find-next-nodes node-name))) + (setq assistant-current-node node-name) + (when previous + (push previous assistant-previous-nodes)) + (erase-buffer) + (insert (cadar assistant-data) "\n\n") + (insert node-name "\n\n") + (assistant-render-text (assistant-get node "text") node) + (insert "\n\n") + (when assistant-previous-nodes + (assistant-node-button 'previous (car assistant-previous-nodes))) + (widget-create + 'push-button + :assistant-node node-name + :notify (lambda (widget &rest ignore) + (let* ((node (widget-get widget :assistant-node))) + (assistant-set-defaults (assistant-find-node node) 'force) + (assistant-render-node node))) + "Reset") + (insert "\n") + (dolist (nnode (assistant-find-next-nodes)) + (assistant-node-button 'next nnode) + (insert "\n")) + + (goto-char (point-min)) + (assistant-make-read-only)))) + +(defun assistant-make-read-only () + (let ((start (point-min)) + end) + (while (setq end (text-property-any start (point-max) 'not-read-only t)) + (put-text-property start end 'read-only t) + (put-text-property start end 'rear-nonsticky t) + (while (get-text-property end 'not-read-only) + (incf end)) + (setq start end)) + (put-text-property start (point-max) 'read-only t))) + +(defun assistant-node-button (type node) + (let ((text (if (eq type 'next) + (assistant-next-node-text node) + (assistant-previous-node-text node)))) + (widget-create + 'push-button + :assistant-node node + :assistant-type type + :notify (lambda (widget &rest ignore) + (let* ((node (widget-get widget :assistant-node)) + (type (widget-get widget :assistant-type))) + (if (eq type 'previous) + (progn + (setq assistant-current-node nil) + (pop assistant-previous-nodes)) + (assistant-get-widget-values) + (assistant-validate)) + (if (null node) + (assistant-finish) + (assistant-render-node node)))) + text) + (use-local-map widget-keymap))) + +(defun assistant-validate-types (node) + (dolist (variable (assistant-get-list node "variable")) + (setq variable (cadr variable)) + (let ((type (nth 1 variable)) + (value (nth 3 variable))) + (when + (cond + ((eq type :number) + (string-match "[^0-9]" value)) + (t + nil)) + (error "%s is not of type %s: %s" + (car variable) type value))))) + +(defun assistant-get-widget-values () + (let ((node (assistant-find-node assistant-current-node))) + (dolist (widget assistant-widgets) + (assistant-set-variable + node (widget-get widget :assistant-variable) + (widget-value widget))))) + +(defun assistant-validate () + (let* ((node (assistant-find-node assistant-current-node)) + (validation (assistant-get node "validate")) + result) + (assistant-validate-types node) + (when validation + (when (setq result (assistant-eval validation)) + (unless (y-or-n-p (format "Error: %s. Continue? " result)) + (error "%s" result)))) + (assistant-set node "save" t))) + +;; (defun assistant-find-next-node (&optional node) +;; (let* ((node (assistant-find-node (or node assistant-current-node))) +;; (node-name (assistant-node-name node)) +;; (nexts (assistant-get-list node "next")) +;; next elem applicable) + +;; (while (setq elem (pop nexts)) +;; (when (assistant-eval (car (cadr elem))) +;; (setq applicable (cons elem applicable)))) + +;; ;; return the first thing we can +;; (cadr (cadr (pop applicable))))) + +(defun assistant-find-next-nodes (&optional node) + (let* ((node (assistant-find-node (or node assistant-current-node))) + (nexts (assistant-get-list node "next")) + next elem applicable return) + + (while (setq elem (pop nexts)) + (when (assistant-eval (car (cadr elem))) + (setq applicable (cons elem applicable)))) + + ;; return the first thing we can + + (while (setq elem (pop applicable)) + (push (cadr (cadr elem)) return)) + + return)) + +(defun assistant-get-all-variables () + (let ((variables nil)) + (dolist (node (cdr assistant-data)) + (setq variables + (append (assistant-get-list node "variable") + variables))) + variables)) + +(defun assistant-eval (form) + (let ((bindings nil)) + (dolist (variable (assistant-get-all-variables)) + (setq variable (cadr variable)) + (push (list (car variable) + (if (eq (nth 3 variable) 'default) + nil + (if (listp (nth 3 variable)) + `(list ,@(nth 3 variable)) + (nth 3 variable)))) + bindings)) + (eval + `(let ,bindings + ,form)))) + +(defun assistant-finish () + (let ((results nil) + result) + (dolist (node (cdr assistant-data)) + (when (assistant-get node "save") + (setq result (assistant-get node "result")) + (push (list (car result) + (assistant-eval (cadr result))) + results))) + (message "Results: %s" + (nreverse results)))) + +;;; Validation functions. + +(defun assistant-validate-connect-to-server (server port) + (let* ((error nil) + (stream + (condition-case err + (open-network-stream "nntpd" nil server port) + (error (setq error err))))) + (if (and (processp stream) + (memq (process-status stream) '(open run))) + (progn + (delete-process stream) + nil) + error))) + +(defun assistant-authinfo-data (server port type) + (when (file-exists-p "~/.authinfo") + (netrc-get (netrc-machine (netrc-parse "~/.authinfo") + server port) + (if (eq type 'user) + "login" + "password")))) + +(defun assistant-password-required-p () + nil) + +(provide 'assistant) + +;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b +;;; assistant.el ends here diff --git a/lisp/gnus/binhex.el b/lisp/gnus/binhex.el index 69866a9eacc..88f0e20f17c 100644 --- a/lisp/gnus/binhex.el +++ b/lisp/gnus/binhex.el @@ -27,8 +27,6 @@ ;;; Code: -(autoload 'executable-find "executable") - (eval-when-compile (require 'cl)) (eval-and-compile @@ -246,14 +244,13 @@ If HEADER-ONLY is non-nil only decode header and return filename." (setq file-name-length (char-after (point-min)) data-fork-start (+ (point-min) file-name-length 22)))) - (if (and (null header) - (with-current-buffer work-buffer - (>= (buffer-size) data-fork-start))) - (progn - (binhex-verify-crc work-buffer - (point-min) data-fork-start) - (setq header (binhex-header work-buffer)) - (if header-only (setq tmp nil counter 0)))) + (when (and (null header) + (with-current-buffer work-buffer + (>= (buffer-size) data-fork-start))) + (binhex-verify-crc work-buffer + (point-min) data-fork-start) + (setq header (binhex-header work-buffer)) + (when header-only (setq tmp nil counter 0))) (setq tmp (and tmp (not (eq inputpos end))))) (cond ((= counter 3) diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index b1fdc9a2f0e..4019db2390e 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -315,71 +315,77 @@ You can control what lines will be unwrapped by frobbing indicating the minimum and maximum length of an unwrapped citation line. If NODISPLAY is non-nil, don't redisplay the article buffer." (interactive "P") - (save-excursion - (let ((case-fold-search nil) - (inhibit-read-only t) - (cite-marks gnus-outlook-deuglify-cite-marks) - (no-wrap gnus-outlook-deuglify-no-wrap-chars) - (stop-chars gnus-outlook-deuglify-unwrap-stop-chars)) - (gnus-with-article-buffer - (article-goto-body) - (while (re-search-forward - (concat - "^\\([ \t" cite-marks "]*\\)" - "\\([" cite-marks "].*[^\n " stop-chars "]\\)[ \t]?\n" - "\\1\\([^\n " cite-marks no-wrap "]+.*\\)$") + (let ((case-fold-search nil) + (inhibit-read-only t) + (cite-marks gnus-outlook-deuglify-cite-marks) + (no-wrap gnus-outlook-deuglify-no-wrap-chars) + (stop-chars gnus-outlook-deuglify-unwrap-stop-chars)) + (gnus-with-article-buffer + (article-goto-body) + (while (re-search-forward + (concat + "^\\([ \t" cite-marks "]*\\)" + "\\([" cite-marks "].*[^\n " stop-chars "]\\)[ \t]?\n" + "\\1\\([^\n " cite-marks no-wrap "]+.*\\)$") nil t) - (let ((len12 (- (match-end 2) (match-beginning 1))) + (let ((len12 (- (match-end 2) (match-beginning 1))) (len3 (- (match-end 3) (match-beginning 3)))) - (if (and (> len12 gnus-outlook-deuglify-unwrap-min) + (when (and (> len12 gnus-outlook-deuglify-unwrap-min) (< (+ len12 len3) gnus-outlook-deuglify-unwrap-max)) - (progn - (replace-match "\\1\\2 \\3") - (goto-char (match-beginning 0))))))))) + (replace-match "\\1\\2 \\3") + (goto-char (match-beginning 0))))))) (unless nodisplay (gnus-outlook-display-article-buffer))) (defun gnus-outlook-rearrange-article (attr-start) "Put the text from ATTR-START to the end of buffer at the top of the article buffer." - (save-excursion - (let ((inhibit-read-only t) - (cite-marks gnus-outlook-deuglify-cite-marks)) - (gnus-with-article-buffer - (article-goto-body) - ;; article does not start with attribution - (unless (= (point) attr-start) - (gnus-kill-all-overlays) - (let ((cur (point)) - ;; before signature or end of buffer - (to (if (gnus-article-search-signature) - (point) - (point-max)))) - ;; handle the case where the full quote is below the - ;; signature - (if (< to attr-start) - (setq to (point-max))) - (transpose-regions cur attr-start attr-start to))))))) + ;; FIXME: 1. (*) text/plain ( ) text/html + (let ((inhibit-read-only t) + (cite-marks gnus-outlook-deuglify-cite-marks)) + (gnus-with-article-buffer + (article-goto-body) + ;; article does not start with attribution + (unless (= (point) attr-start) + (gnus-kill-all-overlays) + (let ((cur (point)) + ;; before signature or end of buffer + (to (if (gnus-article-search-signature) + (point) + (point-max)))) + ;; handle the case where the full quote is below the + ;; signature + (when (< to attr-start) + (setq to (point-max))) + (save-excursion + (narrow-to-region attr-start to) + (goto-char attr-start) + (forward-line) + (unless (looking-at ">") + (message-indent-citation (point) (point-max) 'yank-only) + (goto-char (point-max)) + (newline) + (setq to (point-max))) + (widen)) + (transpose-regions cur attr-start attr-start to)))))) ;; John Doe <john.doe@some.domain> wrote in message ;; news:a87usw8$dklsssa$2@some.news.server... (defun gnus-outlook-repair-attribution-outlook () "Repair a broken attribution line (Outlook)." - (save-excursion - (let ((case-fold-search nil) - (inhibit-read-only t) - (cite-marks gnus-outlook-deuglify-cite-marks)) - (gnus-with-article-buffer - (article-goto-body) - (if (re-search-forward + (let ((case-fold-search nil) + (inhibit-read-only t) + (cite-marks gnus-outlook-deuglify-cite-marks)) + (gnus-with-article-buffer + (article-goto-body) + (when (re-search-forward (concat "^\\([^" cite-marks "].+\\)" "\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\)" "\\(.*\n?[^\n" cite-marks "].*\\)?" "\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$") nil t) - (progn - (gnus-kill-all-overlays) - (replace-match "\\1\\2\\4") - (match-beginning 0))))))) + (gnus-kill-all-overlays) + (replace-match "\\1\\2\\4") + (match-beginning 0))))) ;; ----- Original Message ----- @@ -390,42 +396,38 @@ NODISPLAY is non-nil, don't redisplay the article buffer." (defun gnus-outlook-repair-attribution-block () "Repair a big broken attribution block." - (save-excursion - (let ((case-fold-search nil) - (inhibit-read-only t) - (cite-marks gnus-outlook-deuglify-cite-marks)) - (gnus-with-article-buffer - (article-goto-body) - (if (re-search-forward - (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" + (let ((case-fold-search nil) + (inhibit-read-only t) + (cite-marks gnus-outlook-deuglify-cite-marks)) + (gnus-with-article-buffer + (article-goto-body) + (when (re-search-forward + (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" "[^\n:]+:[ \t]*\\([^\n]+\\)\n" "\\([^\n:]+:[ \t]*[^\n]+\n\\)+") nil t) - (progn - (gnus-kill-all-overlays) - (replace-match "\\1 wrote:\n") - (match-beginning 0))))))) + (gnus-kill-all-overlays) + (replace-match "\\1 wrote:\n") + (match-beginning 0))))) ;; On Wed, 16 Jan 2002 23:23:30 +0100, John Doe <john.doe@some.domain> wrote: (defun gnus-outlook-repair-attribution-other () "Repair a broken attribution line (other user agents than Outlook)." - (save-excursion - (let ((case-fold-search nil) - (inhibit-read-only t) - (cite-marks gnus-outlook-deuglify-cite-marks)) - (gnus-with-article-buffer - (article-goto-body) - (if (re-search-forward + (let ((case-fold-search nil) + (inhibit-read-only t) + (cite-marks gnus-outlook-deuglify-cite-marks)) + (gnus-with-article-buffer + (article-goto-body) + (when (re-search-forward (concat "^\\("gnus-outlook-deuglify-attrib-cut-regexp"\\)?" "\\([^" cite-marks "].+\\)\n\\([^\n" cite-marks "].*\\)?" "\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\).*" "\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$") nil t) - (progn - (gnus-kill-all-overlays) - (replace-match "\\4 \\5\\6\\7") - (match-beginning 0))))))) + (gnus-kill-all-overlays) + (replace-match "\\4 \\5\\6\\7") + (match-beginning 0))))) ;;;###autoload (defun gnus-article-outlook-repair-attribution (&optional nodisplay) diff --git a/lisp/gnus/dns.el b/lisp/gnus/dns.el index fdbe9258686..7910261125a 100644 --- a/lisp/gnus/dns.el +++ b/lisp/gnus/dns.el @@ -51,11 +51,13 @@ If nil, /etc/resolv.conf will be consulted.") (MR 9) (NULL 10) (WKS 11) - (PRT 12) + (PTR 12) (HINFO 13) (MINFO 14) (MX 15) (TXT 16) + (AAAA 28) ; RFC3596 + (SRV 33) ; RFC2782 (AXFR 252) (MAILB 253) (MAILA 254) @@ -252,6 +254,12 @@ If TCP-P, the first two bytes of the package with be the length field." (push (list slot qs) spec))) (nreverse spec)))) +(defun dns-read-int32 () + ;; Full 32 bit Integers can't be handled by Emacs. If we use + ;; floats, it works. + (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) + (dns-read-bytes 3)))) + (defun dns-read-type (string type) (let ((buffer (current-buffer)) (point (point))) @@ -265,9 +273,27 @@ If TCP-P, the first two bytes of the package with be the length field." (dotimes (i 4) (push (dns-read-bytes 1) bytes)) (mapconcat 'number-to-string (nreverse bytes) "."))) - ((eq type 'NS) - (dns-read-string-name string buffer)) - ((eq type 'CNAME) + ((eq type 'AAAA) + (let (hextets) + (dotimes (i 8) + (push (dns-read-bytes 2) hextets)) + (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":"))) + ((eq type 'SOA) + (list (list 'mname (dns-read-name buffer)) + (list 'rname (dns-read-name buffer)) + (list 'serial (dns-read-int32)) + (list 'refresh (dns-read-int32)) + (list 'retry (dns-read-int32)) + (list 'expire (dns-read-int32)) + (list 'minimum (dns-read-int32)))) + ((eq type 'SRV) + (list (list 'priority (dns-read-bytes 2)) + (list 'weight (dns-read-bytes 2)) + (list 'port (dns-read-bytes 2)) + (list 'target (dns-read-name buffer)))) + ((eq type 'MX) + (cons (dns-read-bytes 2) (dns-read-name buffer))) + ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR)) (dns-read-string-name string buffer)) (t string))) (goto-char point)))) @@ -281,17 +307,32 @@ If TCP-P, the first two bytes of the package with be the length field." (push (match-string 1) dns-servers)) (setq dns-servers (nreverse dns-servers))))) -;;; Interface functions. -(eval-when-compile - (when (featurep 'xemacs) - (require 'gnus-xmas))) +(defun dns-read-txt (string) + (if (> (length string) 1) + (substring string 1) + string)) + +(defun dns-get-txt-answer (answers) + (let ((result "") + (do-next nil)) + (dolist (answer answers) + (dolist (elem answer) + (when (consp elem) + (cond + ((eq (car elem) 'type) + (setq do-next (eq (cadr elem) 'TXT))) + ((eq (car elem) 'data) + (when do-next + (setq result (concat result (dns-read-txt (cadr elem)))))))))) + result)) +;;; Interface functions. (defmacro dns-make-network-process (server) (if (featurep 'xemacs) `(let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) - (gnus-xmas-open-network-stream "dns" (current-buffer) - ,server "domain" 'udp)) + (open-network-stream "dns" (current-buffer) + ,server "domain" 'udp)) `(let ((server ,server) (coding-system-for-read 'binary) (coding-system-for-write 'binary)) @@ -308,13 +349,32 @@ If TCP-P, the first two bytes of the package with be the length field." ;; connection to the DNS server. (open-network-stream "dns" (current-buffer) server "domain"))))) -(defun query-dns (name &optional type fullp) +(defvar dns-cache (make-vector 4096 0)) + +(defun query-dns-cached (name &optional type fullp reversep) + (let* ((key (format "%s:%s:%s:%s" name type fullp reversep)) + (sym (intern-soft key dns-cache))) + (if (and sym + (boundp sym)) + (symbol-value sym) + (let ((result (query-dns name type fullp reversep))) + (set (intern key dns-cache) result) + result)))) + +(defun query-dns (name &optional type fullp reversep) "Query a DNS server for NAME of TYPE. -If FULLP, return the entire record returned." +If FULLP, return the entire record returned. +If REVERSEP, look up an IP address." (setq type (or type 'A)) (unless dns-servers (dns-parse-resolv-conf)) + (when reversep + (setq name (concat + (mapconcat 'identity (nreverse (split-string name "\\.")) ".") + ".in-addr.arpa") + type 'PTR)) + (if (not dns-servers) (message "No DNS server configuration found") (mm-with-unibyte-buffer @@ -339,6 +399,7 @@ If FULLP, return the entire record returned." tcp-p)) (while (and (zerop (buffer-size)) (> times 0)) + (sit-for (/ step 1000.0)) (accept-process-output process 0 step) (decf times step)) (ignore-errors @@ -347,13 +408,17 @@ If FULLP, return the entire record returned." (>= (buffer-size) 2)) (goto-char (point-min)) (delete-region (point) (+ (point) 2))) - (when (>= (buffer-size) 2) + (when (and (>= (buffer-size) 2) + ;; We had a time-out. + (> times 0)) (let ((result (dns-read (buffer-string)))) (if fullp result (let ((answer (car (dns-get 'answers result)))) (when (eq type (dns-get 'type answer)) - (dns-get 'data answer))))))))))) + (if (eq type 'TXT) + (dns-get-txt-answer (dns-get 'answers result)) + (dns-get 'data answer)))))))))))) (provide 'dns) diff --git a/lisp/gnus/ecomplete.el b/lisp/gnus/ecomplete.el new file mode 100644 index 00000000000..1c333fd2e03 --- /dev/null +++ b/lisp/gnus/ecomplete.el @@ -0,0 +1,152 @@ +;;; ecomplete.el --- electric completion of addresses and the like +;; Copyright (C) 2006 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: mail + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup ecomplete nil + "Electric completion of email addresses and the like." + :group 'mail) + +(defcustom ecomplete-database-file "~/.ecompleterc" + "*The name of the file to store the ecomplete data." + :group 'ecomplete + :type 'file) + +(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit + "Coding system used for writing the ecomplete database file." + :type '(symbol :tag "Coding system") + :group 'ecomplete) + +;;; Internal variables. + +(defvar ecomplete-database nil) + +;;;###autoload +(defun ecomplete-setup () + (when (file-exists-p ecomplete-database-file) + (with-temp-buffer + (let ((coding-system-for-read ecomplete-database-file-coding-system)) + (insert-file-contents ecomplete-database-file) + (setq ecomplete-database (read (current-buffer))))))) + +(defun ecomplete-add-item (type key text) + (let ((elems (assq type ecomplete-database)) + (now (string-to-number + (format "%.0f" (time-to-seconds (current-time))))) + entry) + (unless elems + (push (setq elems (list type)) ecomplete-database)) + (if (setq entry (assoc key (cdr elems))) + (setcdr entry (list (1+ (cadr entry)) now text)) + (nconc elems (list (list key 1 now text)))))) + +(defun ecomplete-get-item (type key) + (assoc key (cdr (assq type ecomplete-database)))) + +(defun ecomplete-save () + (with-temp-buffer + (let ((coding-system-for-write ecomplete-database-file-coding-system)) + (insert "(") + (loop for (type . elems) in ecomplete-database + do + (insert (format "(%s\n" type)) + (dolist (entry elems) + (prin1 entry (current-buffer)) + (insert "\n")) + (insert ")\n")) + (insert ")") + (write-region (point-min) (point-max) + ecomplete-database-file nil 'silent)))) + +(defun ecomplete-get-matches (type match) + (let* ((elems (cdr (assq type ecomplete-database))) + (match (regexp-quote match)) + (candidates + (sort + (loop for (key count time text) in elems + when (string-match match text) + collect (list count time text)) + (lambda (l1 l2) + (> (car l1) (car l2)))))) + (when (> (length candidates) 10) + (setcdr (nthcdr 10 candidates) nil)) + (unless (zerop (length candidates)) + (with-temp-buffer + (dolist (candidate candidates) + (insert (caddr candidate) "\n")) + (goto-char (point-min)) + (put-text-property (point) (1+ (point)) 'ecomplete t) + (while (re-search-forward match nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'face 'isearch)) + (buffer-string))))) + +(defun ecomplete-display-matches (type word &optional choose) + (let* ((matches (ecomplete-get-matches type word)) + (line 0) + (max-lines (when matches (- (length (split-string matches "\n")) 2))) + (message-log-max nil) + command highlight) + (if (not matches) + (progn + (message "No ecomplete matches") + nil) + (if (not choose) + (progn + (message matches) + nil) + (setq highlight (ecomplete-highlight-match-line matches line)) + (while (not (memq (setq command (read-event highlight)) '(? return))) + (cond + ((eq command ?\M-n) + (setq line (min (1+ line) max-lines))) + ((eq command ?\M-p) + (setq line (max (1- line) 0)))) + (setq highlight (ecomplete-highlight-match-line matches line))) + (when (eq command 'return) + (nth line (split-string matches "\n"))))))) + +(defun ecomplete-highlight-match-line (matches line) + (with-temp-buffer + (insert matches) + (goto-char (point-min)) + (forward-line line) + (save-restriction + (narrow-to-region (point) (point-at-eol)) + (while (not (eobp)) + ;; Put the 'region face on any charactes on this line that + ;; aren't already highlighted. + (unless (get-text-property (point) 'face) + (put-text-property (point) (1+ (point)) 'face 'highlight)) + (forward-char 1))) + (buffer-string))) + +(provide 'ecomplete) + +;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72 +;;; ecomplete.el ends here diff --git a/lisp/gnus/encrypt.el b/lisp/gnus/encrypt.el new file mode 100644 index 00000000000..1fb54a280eb --- /dev/null +++ b/lisp/gnus/encrypt.el @@ -0,0 +1,296 @@ +;;; encrypt.el --- file encryption routines +;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov <tzz@lifelogs.com> +;; Created: 2003/01/24 +;; Keywords: files + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; This module addresses data encryption. Page breaks are used for +;;; grouping declarations and documentation relating to each +;;; particular aspect. + +;;; Use in Gnus like this: +;;; (setq +;;; nnimap-authinfo-file "~/.authinfo.enc" +;;; nntp-authinfo-file "~/.authinfo.enc" +;;; smtpmail-auth-credentials "~/.authinfo.enc" +;;; ;; using the AES256 cipher, feel free to use your own favorite +;;; encrypt-file-alist (quote (("~/.authinfo.enc" (gpg "AES256")))) +;;; password-cache-expiry 600) + +;;; Then write ~/.authinfo.enc: + +;;; 1) open the old authinfo +;;; C-x C-f ~/.authinfo + +;;; 2) write the new authinfo.enc +;;; M-x encrypt-write-file-contents RET ~/.authinfo.enc + +;;; 3) verify the new authinfo is correct (this will show the contents in the minibuffer) +;;; M-: (encrypt-get-file-contents "~/.authinfo.enc") + + +;;; Code: + +;; autoload password +(eval-and-compile + (autoload 'password-read "password")) + +(defgroup encrypt '((password-cache custom-variable) + (password-cache-expiry custom-variable)) + "File encryption configuration." + :group 'applications) + +(defcustom encrypt-file-alist nil + "List of file names or regexes matched with encryptions. +Format example: + '((\"beta\" + (gpg \"AES\")) + (\"/home/tzz/alpha\" + (encrypt-xor \"Semi-Secret\")))" + + :type '(repeat + (list :tag "Encryption entry" + (radio :tag "What to encrypt" + (file :tag "Filename") + (regexp :tag "Regular expression match")) + (radio :tag "How to encrypt it" + (list + :tag "GPG Encryption" + (const :tag "GPG Program" gpg) + (radio :tag "Choose a cipher" + (const :tag "3DES Encryption" "3DES") + (const :tag "CAST5 Encryption" "CAST5") + (const :tag "Blowfish Encryption" "BLOWFISH") + (const :tag "AES Encryption" "AES") + (const :tag "AES192 Encryption" "AES192") + (const :tag "AES256 Encryption" "AES256") + (const :tag "Twofish Encryption" "TWOFISH") + (string :tag "Cipher Name"))) + (list + :tag "Built-in simple XOR" + (const :tag "XOR Encryption" encrypt-xor) + (string :tag "XOR Cipher Value (seed value)"))))) + :group 'encrypt) + +;; TODO: now, load gencrypt.el and if successful, modify the +;; custom-type of encrypt-file-alist to add the gencrypt.el options + +;; (plist-get (symbol-plist 'encrypt-file-alist) 'custom-type) +;; then use plist-put + +(defcustom encrypt-gpg-path (executable-find "gpg") + "Path to the GPG program." + :type '(radio + (file :tag "Location of the GPG executable") + (const :tag "GPG is not installed" nil)) + :group 'encrypt) + +(defvar encrypt-temp-prefix "encrypt" + "Prefix for temporary filenames") + +;;;###autoload +(defun encrypt-find-model (filename) + "Given a filename, find a encrypt-file-alist entry" + (dolist (entry encrypt-file-alist) + (let ((match (nth 0 entry)) + (model (nth 1 entry))) + (when (or (eq match filename) + (string-match match filename)) + (return model))))) + +;;;###autoload +(defun encrypt-insert-file-contents (file &optional model) + "Decrypt FILE into the current buffer." + (interactive "fFile to insert: ") + (let* ((model (or model (encrypt-find-model file))) + (method (nth 0 model)) + (cipher (nth 1 model)) + (password-key (format "encrypt-password-%s-%s %s" + (symbol-name method) cipher file)) + (passphrase + (password-read-and-add + (format "%s password for cipher %s (file %s)? " + file (symbol-name method) cipher) + password-key)) + (buffer-file-coding-system 'binary) + (coding-system-for-read 'binary) + outdata) + + ;; note we only insert-file-contents if the method is known to be valid + (cond + ((eq method 'gpg) + (insert-file-contents file) + (setq outdata (encrypt-gpg-decode-buffer passphrase cipher))) + ((eq method 'encrypt-xor) + (insert-file-contents file) + (setq outdata (encrypt-xor-decode-buffer passphrase cipher)))) + + (if outdata + (progn + (message "%s was decrypted with %s (cipher %s)" + file (symbol-name method) cipher) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert outdata)) + ;; the decryption failed, alas + (password-cache-remove password-key) + (gnus-error 5 "%s was NOT decrypted with %s (cipher %s)" + file (symbol-name method) cipher)))) + +(defun encrypt-get-file-contents (file &optional model) + "Decrypt FILE and return the contents." + (interactive "fFile to decrypt: ") + (with-temp-buffer + (encrypt-insert-file-contents file model) + (buffer-string))) + +(defun encrypt-put-file-contents (file data &optional model) + "Encrypt the DATA to FILE, then continue normally." + (with-temp-buffer + (insert data) + (encrypt-write-file-contents file model))) + +(defun encrypt-write-file-contents (file &optional model) + "Encrypt the current buffer to FILE, then continue normally." + (interactive "sFile to write: ") + (setq model (or model (encrypt-find-model file))) + (if model + (let* ((method (nth 0 model)) + (cipher (nth 1 model)) + (password-key (format "encrypt-password-%s-%s %s" + (symbol-name method) cipher file)) + (passphrase + (password-read + (format "%s password for cipher %s? " + (symbol-name method) cipher) + password-key)) + outdata) + + (cond + ((eq method 'gpg) + (setq outdata (encrypt-gpg-encode-buffer passphrase cipher))) + ((eq method 'encrypt-xor) + (setq outdata (encrypt-xor-encode-buffer passphrase cipher)))) + + (if outdata + (progn + (message "%s was encrypted with %s (cipher %s)" + file (symbol-name method) cipher) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert outdata) + ;; do not confirm overwrites + (write-file file nil)) + ;; the decryption failed, alas + (password-cache-remove password-key) + (gnus-error 5 "%s was NOT encrypted with %s (cipher %s)" + file (symbol-name method) cipher))) + (gnus-error 1 "%s has no associated encryption model! See encrypt-file-alist." file))) + +(defun encrypt-xor-encode-buffer (passphrase cipher) + (encrypt-xor-process-buffer passphrase cipher t)) + +(defun encrypt-xor-decode-buffer (passphrase cipher) + (encrypt-xor-process-buffer passphrase cipher nil)) + +(defun encrypt-xor-process-buffer (passphrase + cipher + &optional encode) + "Given PASSPHRASE, xor-encode or decode the contents of the current buffer." + (let* ((bs (buffer-substring-no-properties (point-min) (point-max))) + ;; passphrase-sum is a simple additive checksum of the + ;; passphrase and the cipher + (passphrase-sum + (when (stringp passphrase) + (apply '+ (append cipher passphrase nil)))) + new-list) + + (with-temp-buffer + (if encode + (progn + (dolist (x (append bs nil)) + (setq new-list (cons (logxor x passphrase-sum) new-list))) + + (dolist (x new-list) + (insert (format "%d " x)))) + (progn + (setq new-list (reverse (split-string bs))) + (dolist (x new-list) + (setq x (string-to-number x)) + (insert (format "%c" (logxor x passphrase-sum)))))) + (buffer-substring-no-properties (point-min) (point-max))))) + +(defun encrypt-gpg-encode-buffer (passphrase cipher) + (encrypt-gpg-process-buffer passphrase cipher t)) + +(defun encrypt-gpg-decode-buffer (passphrase cipher) + (encrypt-gpg-process-buffer passphrase cipher nil)) + +(defun encrypt-gpg-process-buffer (passphrase + cipher + &optional encode) + "With PASSPHRASE, use GPG to encode or decode the current buffer." + (let* ((program encrypt-gpg-path) + (input (buffer-substring-no-properties (point-min) (point-max))) + (temp-maker (if (fboundp 'make-temp-file) + 'make-temp-file + 'make-temp-name)) + (temp-file (funcall temp-maker encrypt-temp-prefix)) + (default-enable-multibyte-characters nil) + (args `("--cipher-algo" ,cipher + "--status-fd" "2" + "--logger-fd" "2" + "--passphrase-fd" "0" + "--no-tty")) + exit-status exit-data) + + (when encode + (setq args + (append args + '("--symmetric" + "--armor")))) + + (if program + (with-temp-buffer + (when passphrase + (insert passphrase "\n")) + (insert input) + (setq exit-status + (apply #'call-process-region (point-min) (point-max) program + t `(t ,temp-file) nil args)) + (if (equal exit-status 0) + (setq exit-data + (buffer-substring-no-properties (point-min) (point-max))) + (with-temp-buffer + (when (file-exists-p temp-file) + (insert-file-contents temp-file)) + (gnus-error 5 (format "%s exited abnormally: '%s' [%s]" + program exit-status (buffer-string))))) + (delete-file temp-file)) + (gnus-error 5 "GPG is not installed.")) + exit-data)) + +(provide 'encrypt) +;;; encrypt.el ends here + +;; arch-tag: d907e4f1-71b5-42b1-a180-fc7b84ff0648 diff --git a/lisp/gnus/flow-fill.el b/lisp/gnus/flow-fill.el index 5c2cd65b503..1644ed0f8f2 100644 --- a/lisp/gnus/flow-fill.el +++ b/lisp/gnus/flow-fill.el @@ -75,17 +75,6 @@ RFC 2646 suggests 66 characters for readability." (sexp) (integer))) -(eval-and-compile - (defalias 'fill-flowed-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - - (defalias 'fill-flowed-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) - ;;;###autoload (defun fill-flowed-encode (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -109,7 +98,7 @@ RFC 2646 suggests 66 characters for readability." t))) ;;;###autoload -(defun fill-flowed (&optional buffer) +(defun fill-flowed (&optional buffer delete-space) (save-excursion (set-buffer (or (current-buffer) buffer)) (goto-char (point-min)) @@ -119,6 +108,8 @@ RFC 2646 suggests 66 characters for readability." (forward-line 1)) (goto-char (point-min)) (while (re-search-forward " $" nil t) + (when delete-space + (delete-char -1)) (when (save-excursion (beginning-of-line) (looking-at "^\\(>*\\)\\( ?\\)")) @@ -153,8 +144,8 @@ RFC 2646 suggests 66 characters for readability." (fill-column (eval fill-flowed-display-column)) filladapt-mode adaptive-fill-mode) - (fill-region (fill-flowed-point-at-bol) - (min (1+ (fill-flowed-point-at-eol)) + (fill-region (point-at-bol) + (min (1+ (point-at-eol)) (point-max)) 'left 'nosqueeze)) (error diff --git a/lisp/gnus/format-spec.el b/lisp/gnus/format-spec.el index 137603e42c9..951f9aecb81 100644 --- a/lisp/gnus/format-spec.el +++ b/lisp/gnus/format-spec.el @@ -49,7 +49,7 @@ the text that it generates." (spec (string-to-char (match-string 2))) (val (cdr (assq spec specification)))) (unless val - (error "Invalid format character: %s" spec)) + (error "Invalid format character: `%%%c'" spec)) ;; Pad result to desired length. (let ((text (format (concat "%" num "s") val))) ;; Insert first, to preserve text properties. diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 71a0662f35a..1d9f30c273c 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -50,6 +50,19 @@ jabbering all the time." :group 'gmm) ;;;###autoload +(defun gmm-regexp-concat (regexp) + "Potentially concat a list of regexps into a single one. +The concatenation is done with logical ORs." + (cond ((null regexp) + nil) + ((stringp regexp) + regexp) + ((listp regexp) + (mapconcat (lambda (elt) (concat "\\(" elt "\\)")) + regexp + "\\|")))) + +;;;###autoload (defun gmm-message (level &rest args) "If LEVEL is lower than `gmm-verbose' print ARGS using `message'. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 21b442aebbb..0271186273a 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -115,7 +115,7 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'function) -(defcustom gnus-agent-synchronize-flags t +(defcustom gnus-agent-synchronize-flags nil "Indicate if flags are synchronized when you plug in. If this is `ask' the hook will query the user." ;; If the default switches to something else than nil, then the function @@ -251,11 +251,24 @@ NOTES: (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) +(defvar gnus-agent-total-fetched-hashtb nil) +(defvar gnus-agent-inhibit-update-total-fetched-for nil) +(defvar gnus-agent-need-update-total-fetched-for nil) ;; Dynamic variables (defvar gnus-headers) (defvar gnus-score) +;; Added to support XEmacs +(eval-and-compile + (unless (fboundp 'directory-files-and-attributes) + (defun directory-files-and-attributes (directory + &optional full match nosort) + (let (result) + (dolist (file (directory-files directory full match nosort)) + (push (cons file (file-attributes file)) result)) + (nreverse result))))) + ;;; ;;; Setup ;;; @@ -290,6 +303,17 @@ NOTES: ;;; Utility functions ;;; +(defmacro gnus-agent-with-refreshed-group (group &rest body) + "Performs the body then updates the group's line in the group +buffer. Automatically blocks multiple updates due to recursion." +`(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) + (when (and gnus-agent-need-update-total-fetched-for + (not gnus-agent-inhibit-update-total-fetched-for)) + (save-excursion + (set-buffer gnus-group-buffer) + (setq gnus-agent-need-update-total-fetched-for nil) + (gnus-group-update-group ,group t))))) + (defun gnus-agent-read-file (file) "Load FILE and do a `read' there." (with-temp-buffer @@ -345,8 +369,8 @@ manipulated as follows: (let* ((--category--temp-- (make-symbol "--category--")) (--value--temp-- (make-symbol "--value--"))) (list (list --category--temp--) ; temporary-variables - (list category) ; value-forms - (list --value--temp--) ; store-variables + (list category) ; value-forms + (list --value--temp--) ; store-variables (let* ((category --category--temp--) ; store-form (value --value--temp--)) (list (quote gnus-agent-cat-set-property) @@ -435,6 +459,16 @@ manipulated as follows: (defsubst gnus-agent-cat-make (name &optional default-agent-predicate) (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) +(defun gnus-agent-read-group () + "Read a group name in the minibuffer, with completion." + (let ((def (or (gnus-group-group-name) gnus-newsgroup-name))) + (when def + (setq def (gnus-group-decoded-name def))) + (gnus-group-completing-read (if def + (concat "Group Name (" def "): ") + "Group Name: ") + nil nil t nil nil def))) + ;;; Fetching setup functions. (defun gnus-agent-start-fetch () @@ -892,7 +926,8 @@ supported." (new-command-method (gnus-find-method-for-group new-group)) (new-path (directory-file-name (let (gnus-command-method new-command-method) - (gnus-agent-group-pathname new-group))))) + (gnus-agent-group-pathname new-group)))) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-rename-file old-path new-path t) (let* ((old-real-group (gnus-group-real-name old-group)) @@ -920,7 +955,8 @@ supported." (let* ((command-method (gnus-find-method-for-group group)) (path (directory-file-name (let (gnus-command-method command-method) - (gnus-agent-group-pathname group))))) + (gnus-agent-group-pathname group)))) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-delete-directory path) (let* ((real-group (gnus-group-real-name group))) @@ -1285,7 +1321,8 @@ This can be added to `gnus-select-article-hook' or (gnus-active-to-gnus-format nil new) (gnus-agent-write-active file new) (erase-buffer) - (nnheader-insert-file-contents file)))) + (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))))) (defun gnus-agent-write-active (file new) (gnus-make-directory (file-name-directory file)) @@ -1398,6 +1435,18 @@ downloaded into the agent." oactive-min (read (current-buffer))) ;; min (cons oactive-min oactive-max)))))))) +(defvar gnus-agent-decoded-group-names nil + "Alist of non-ASCII group names and decoded ones.") + +(defun gnus-agent-decoded-group-name (group) + "Return a decoded group name of GROUP." + (or (cdr (assoc group gnus-agent-decoded-group-names)) + (if (string-match "[^\000-\177]" group) + (let ((decoded (gnus-group-decoded-name group))) + (push (cons group decoded) gnus-agent-decoded-group-names) + decoded) + group))) + (defun gnus-agent-group-path (group) "Translate GROUP into a file name." @@ -1409,26 +1458,25 @@ downloaded into the agent." (nnheader-translate-file-chars (nnheader-replace-duplicate-chars-in-string (nnheader-replace-chars-in-string - (gnus-group-real-name (gnus-group-decoded-name group)) + (gnus-group-real-name (gnus-agent-decoded-group-name group)) ?/ ?_) ?. ?_))) (if (or nnmail-use-long-file-names (file-directory-p (expand-file-name group (gnus-agent-directory)))) group - (mm-encode-coding-string - (nnheader-replace-chars-in-string group ?. ?/) - nnmail-pathname-coding-system))) + (nnheader-replace-chars-in-string group ?. ?/))) (defun gnus-agent-group-pathname (group) "Translate GROUP into a file name." ;; nnagent uses nnmail-group-pathname to read articles while ;; unplugged. The agent must, therefore, use the same directory ;; while plugged. - (let ((gnus-command-method (or gnus-command-method - (gnus-find-method-for-group group)))) - (nnmail-group-pathname (gnus-group-real-name - (gnus-group-decoded-name group)) - (gnus-agent-directory)))) + (nnmail-group-pathname + (gnus-group-real-name (gnus-agent-decoded-group-name group)) + (if gnus-command-method + (gnus-agent-directory) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-directory))))) (defun gnus-agent-get-function (method) (if (gnus-online method) @@ -1532,7 +1580,8 @@ downloaded into the agent." (dir (gnus-agent-group-pathname group)) (date (time-to-days (current-time))) (case-fold-search t) - pos crosses id) + pos crosses id + (file-name-coding-system nnmail-pathname-coding-system)) (setcar selected-sets (nreverse (car selected-sets))) (setq selected-sets (nreverse selected-sets)) @@ -1601,33 +1650,46 @@ downloaded into the agent." (setq pos (cdr pos))))) (gnus-agent-save-alist group (cdr fetched-articles) date) + (gnus-agent-update-files-total-fetched-for group (cdr fetched-articles)) + (gnus-message 7 "")) (cdr fetched-articles)))))) (defun gnus-agent-unfetch-articles (group articles) "Delete ARTICLES that were fetched from GROUP into the agent." (when articles - (gnus-agent-load-alist group) - (let* ((alist (cons nil gnus-agent-article-alist)) - (articles (sort articles #'<)) - (next-possibility alist) - (delete-this (pop articles))) - (while (and (cdr next-possibility) delete-this) - (let ((have-this (caar (cdr next-possibility)))) - (cond ((< delete-this have-this) - (setq delete-this (pop articles))) - ((= delete-this have-this) - (let ((timestamp (cdar (cdr next-possibility)))) - (when timestamp - (let* ((file-name (concat (gnus-agent-group-pathname group) - (number-to-string have-this)))) - (delete-file file-name)))) - - (setcdr next-possibility (cddr next-possibility))) - (t - (setq next-possibility (cdr next-possibility)))))) - (setq gnus-agent-article-alist (cdr alist)) - (gnus-agent-save-alist group)))) + (gnus-agent-with-refreshed-group + group + (gnus-agent-load-alist group) + (let* ((alist (cons nil gnus-agent-article-alist)) + (articles (sort articles #'<)) + (next-possibility alist) + (delete-this (pop articles))) + (while (and (cdr next-possibility) delete-this) + (let ((have-this (caar (cdr next-possibility)))) + (cond + ((< delete-this have-this) + (setq delete-this (pop articles))) + ((= delete-this have-this) + (let ((timestamp (cdar (cdr next-possibility)))) + (when timestamp + (let* ((file-name (concat (gnus-agent-group-pathname group) + (number-to-string have-this))) + (size-file + (float (or (and gnus-agent-total-fetched-hashtb + (nth 7 (file-attributes file-name))) + 0))) + (file-name-coding-system + nnmail-pathname-coding-system)) + (delete-file file-name) + (gnus-agent-update-files-total-fetched-for + group (- size-file))))) + + (setcdr next-possibility (cddr next-possibility))) + (t + (setq next-possibility (cdr next-possibility)))))) + (setq gnus-agent-article-alist (cdr alist)) + (gnus-agent-save-alist group))))) (defun gnus-agent-crosspost (crosses article &optional date) (setq date (or date t)) @@ -1651,8 +1713,9 @@ downloaded into the agent." (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors - (nnheader-insert-file-contents - (gnus-agent-article-name ".overview" group)))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (nnheader-insert-file-contents + (gnus-agent-article-name ".overview" group))))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) (insert-buffer-substring gnus-agent-overview-buffer beg end) @@ -1663,7 +1726,8 @@ downloaded into the agent." (when gnus-newsgroup-name (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) (cnt 0) - name) + name + (file-name-coding-system nnmail-pathname-coding-system)) (while (file-exists-p (setq name (concat root "~" (int-to-string (setq cnt (1+ cnt))) "~")))) @@ -1697,7 +1761,7 @@ and that there are no duplicates." (gnus-message 1 "Overview buffer contains garbage '%s'." (buffer-substring - p (gnus-point-at-eol)))) + p (point-at-eol)))) ((= cur prev-num) (or backed-up (setq backed-up (gnus-agent-backup-overview-buffer))) @@ -1715,25 +1779,71 @@ and that there are no duplicates." (setq prev-num cur))) (forward-line 1))))))) +(defun gnus-agent-flush-server (&optional server-or-method) + "Flush all agent index files for every subscribed group within + the given SERVER-OR-METHOD. When called with nil, the current + value of gnus-command-method identifies the server." + (let* ((gnus-command-method (if server-or-method + (gnus-server-to-method server-or-method) + gnus-command-method)) + (alist gnus-newsrc-alist)) + (while alist + (let ((entry (pop alist))) + (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry)) + (gnus-agent-flush-group (gnus-info-group entry))))))) + +(defun gnus-agent-flush-group (group) + "Flush the agent's index files such that the GROUP no longer +appears to have any local content. The actual content, the +article files, may then be deleted using gnus-agent-expire-group. +If flushing was a mistake, the gnus-agent-regenerate-group method +provides an undo mechanism by reconstructing the index files from +the article files." + (interactive (list (gnus-agent-read-group))) + + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (overview (gnus-agent-article-name ".overview" group)) + (agentview (gnus-agent-article-name ".agentview" group)) + (file-name-coding-system nnmail-pathname-coding-system)) + + (if (file-exists-p overview) + (delete-file overview)) + (if (file-exists-p agentview) + (delete-file agentview)) + + (gnus-agent-update-view-total-fetched-for group nil gnus-command-method) + (gnus-agent-update-view-total-fetched-for group t gnus-command-method) + + ;(gnus-agent-set-local group nil nil) + ;(gnus-agent-save-local t) + (gnus-agent-save-group-info nil group nil))) + (defun gnus-agent-flush-cache () + "Flush the agent's index files such that the group no longer +appears to have any local content. The actual content, the +article files, is then deleted using gnus-agent-expire-group. The +gnus-agent-regenerate-group method provides an undo mechanism by +reconstructing the index files from the article files." + (interactive) (save-excursion - (while gnus-agent-buffer-alist - (set-buffer (cdar gnus-agent-buffer-alist)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) - (gnus-agent-article-name ".overview" - (caar gnus-agent-buffer-alist)) - nil 'silent)) - (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) - (while gnus-agent-group-alist - (with-temp-file (gnus-agent-article-name - ".agentview" (caar gnus-agent-group-alist)) - (princ (cdar gnus-agent-group-alist)) - (insert "\n") - (princ 1 (current-buffer)) - (insert "\n")) - (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (while gnus-agent-buffer-alist + (set-buffer (cdar gnus-agent-buffer-alist)) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) + (gnus-agent-article-name ".overview" + (caar gnus-agent-buffer-alist)) + nil 'silent)) + (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) + (while gnus-agent-group-alist + (with-temp-file (gnus-agent-article-name + ".agentview" (caar gnus-agent-group-alist)) + (princ (cdar gnus-agent-group-alist)) + (insert "\n") + (princ 1 (current-buffer)) + (insert "\n")) + (setq gnus-agent-group-alist (cdr gnus-agent-group-alist)))))) ;;;###autoload (defun gnus-agent-find-parameter (group symbol) @@ -1777,7 +1887,8 @@ article numbers will be returned." (gnus-list-of-unread-articles group))) (gnus-decode-encoded-word-function 'identity) (gnus-decode-encoded-address-function 'identity) - (file (gnus-agent-article-name ".overview" group))) + (file (gnus-agent-article-name ".overview" group)) + (file-name-coding-system nnmail-pathname-coding-system)) (unless fetch-all ;; Add articles with marks to the list of article headers we want to @@ -1857,6 +1968,7 @@ article numbers will be returned." gnus-agent-file-coding-system)) (gnus-agent-check-overview-buffer) (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-update-view-total-fetched-for group t) (gnus-agent-save-alist group articles nil) articles) (ignore-errors @@ -1926,21 +2038,21 @@ doesn't exist, to valid the overview buffer." (gnus-agent-copy-nov-line (pop articles)) (ignore-errors - (while articles - (while (let ((art (read (current-buffer)))) - (cond ((< art (car articles)) - (forward-line 1) - t) - ((= art (car articles)) - (beginning-of-line) - (delete-region - (point) (progn (forward-line 1) (point))) - nil) - (t - (beginning-of-line) - nil)))) + (while articles + (while (let ((art (read (current-buffer)))) + (cond ((< art (car articles)) + (forward-line 1) + t) + ((= art (car articles)) + (beginning-of-line) + (delete-region + (point) (progn (forward-line 1) (point))) + nil) + (t + (beginning-of-line) + nil)))) - (gnus-agent-copy-nov-line (pop articles))))) + (gnus-agent-copy-nov-line (pop articles))))) (goto-char (point-max)) @@ -1957,26 +2069,26 @@ doesn't exist, to valid the overview buffer." (setq last (or last -134217728)) (while (catch 'problems - (let (sort art) - (while (not (eobp)) - (setq art (gnus-agent-read-article-number)) - (cond ((not art) - ;; Bad art num - delete this line - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - ((< art last) - ;; Art num out of order - enable sort - (setq sort t) - (forward-line 1)) + (let (sort art) + (while (not (eobp)) + (setq art (gnus-agent-read-article-number)) + (cond ((not art) + ;; Bad art num - delete this line + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ((< art last) + ;; Art num out of order - enable sort + (setq sort t) + (forward-line 1)) ((= art last) ;; Bad repeat of art number - delete this line (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point)))) - (t - ;; Good art num - (setq last art) - (forward-line 1)))) - (when sort + (t + ;; Good art num + (setq last art) + (forward-line 1)))) + (when sort ;; something is seriously wrong as we simply shouldn't see out-of-order data. ;; First, we'll fix the sort. (sort-numeric-fields 1 (point-min) (point-max)) @@ -1998,7 +2110,8 @@ doesn't exist, to valid the overview buffer." (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." ;; Bind free variable that's used in `gnus-agent-read-agentview'. - (let ((gnus-agent-read-agentview group)) + (let ((gnus-agent-read-agentview group) + (file-name-coding-system nnmail-pathname-coding-system)) (setq gnus-agent-article-alist (gnus-cache-file-contents (gnus-agent-article-name ".agentview" group) @@ -2009,52 +2122,63 @@ doesn't exist, to valid the overview buffer." "Load FILE and do a `read' there." (with-temp-buffer (condition-case nil - (progn - (nnheader-insert-file-contents file) - (goto-char (point-min)) - (let ((alist (read (current-buffer))) - (version (condition-case nil (read (current-buffer)) - (end-of-file 0))) - changed-version) - - (cond - ((= version 0) - (let ((inhibit-quit t) - entry) - (gnus-agent-open-history) - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (while (not (eobp)) - (if (and (looking-at - "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") - (string= (match-string 2) - gnus-agent-read-agentview) - (setq entry (assoc (string-to-number (match-string 3)) alist))) - (setcdr entry (string-to-number (match-string 1)))) - (forward-line 1)) - (gnus-agent-close-history) - (setq changed-version t))) - ((= version 1) - (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) - ((= version 2) - (let (uncomp) - (mapcar - (lambda (comp-list) - (let ((state (car comp-list)) - (sequence (inline - (gnus-uncompress-range - (cdr comp-list))))) - (mapcar (lambda (article-id) - (setq uncomp (cons (cons article-id state) uncomp))) - sequence))) - alist) + (progn + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (let ((alist (read (current-buffer))) + (version (condition-case nil (read (current-buffer)) + (end-of-file 0))) + changed-version) + + (cond + ((= version 0) + (let ((inhibit-quit t) + entry) + (gnus-agent-open-history) + (set-buffer (gnus-agent-history-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (looking-at + "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") + (string= (match-string 2) + gnus-agent-read-agentview) + (setq entry (assoc (string-to-number (match-string 3)) alist))) + (setcdr entry (string-to-number (match-string 1)))) + (forward-line 1)) + (gnus-agent-close-history) + (setq changed-version t))) + ((= version 1) + (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) + ((= version 2) + (let (state sequence uncomp) + (while alist + (setq state (caar alist) + sequence (inline (gnus-uncompress-range (cdar alist))) + alist (cdr alist)) + (while sequence + (push (cons (pop sequence) state) uncomp))) (setq alist (sort uncomp 'car-less-than-car))) (setq changed-version (not (= 2 gnus-agent-article-alist-save-format))))) - (when changed-version - (let ((gnus-agent-article-alist alist)) - (gnus-agent-save-alist gnus-agent-read-agentview))) - alist)) - (file-error nil)))) + (when changed-version + (let ((gnus-agent-article-alist alist)) + (gnus-agent-save-alist gnus-agent-read-agentview))) + alist)) + ((end-of-file file-error) + ;; The agentview file is missing. + (condition-case nil + ;; If the agent directory exists, attempt to perform a brute-force + ;; reconstruction of its contents. + (let* (alist + (file-name-coding-system nnmail-pathname-coding-system) + (file-attributes (directory-files-and-attributes + (gnus-agent-article-name "" + gnus-agent-read-agentview) nil "^[0-9]+$" t))) + (while file-attributes + (let ((fa (pop file-attributes))) + (unless (nth 1 fa) + (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist)))) + alist) + (file-error nil)))))) (defun gnus-agent-save-alist (group &optional articles state) "Save the article-state alist for GROUP." @@ -2085,27 +2209,27 @@ doesn't exist, to valid the overview buffer." (cond ((eq gnus-agent-article-alist-save-format 1) (princ gnus-agent-article-alist (current-buffer))) ((eq gnus-agent-article-alist-save-format 2) - (let ((compressed nil)) - (mapcar (lambda (pair) - (let* ((article-id (car pair)) - (day-of-download (cdr pair)) - (comp-list (assq day-of-download compressed))) - (if comp-list - (setcdr comp-list - (cons article-id (cdr comp-list))) - (setq compressed - (cons (list day-of-download article-id) - compressed))) - nil)) gnus-agent-article-alist) - (mapcar (lambda (comp-list) - (setcdr comp-list - (gnus-compress-sequence - (nreverse (cdr comp-list))))) - compressed) + (let ((alist gnus-agent-article-alist) + article-id day-of-download comp-list compressed) + (while alist + (setq article-id (caar alist) + day-of-download (cdar alist) + comp-list (assq day-of-download compressed) + alist (cdr alist)) + (if comp-list + (setcdr comp-list (cons article-id (cdr comp-list))) + (push (list day-of-download article-id) compressed))) + (setq alist compressed) + (while alist + (setq comp-list (pop alist)) + (setcdr comp-list + (gnus-compress-sequence (nreverse (cdr comp-list))))) (princ compressed (current-buffer))))) (insert "\n") (princ gnus-agent-article-alist-save-format (current-buffer)) - (insert "\n")))) + (insert "\n")) + + (gnus-agent-update-view-total-fetched-for group nil))) (defvar gnus-agent-article-local nil) (defvar gnus-agent-file-loading-local nil) @@ -2183,10 +2307,10 @@ modified) original contents, they are first saved to their own file." (dest (gnus-agent-lib-file "local"))) (gnus-make-directory (gnus-agent-lib-file "")) - (let ((buffer-file-coding-system gnus-agent-file-coding-system)) + (let ((coding-system-for-write gnus-agent-file-coding-system) + (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file dest (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) - (file-name-coding-system nnmail-pathname-coding-system) print-level print-length item article (standard-output (current-buffer))) (mapatoms (lambda (symbol) @@ -2197,11 +2321,11 @@ modified) original contents, they are first saved to their own file." (t (let ((range (symbol-value symbol))) (when range - (prin1 symbol) - (princ " ") - (princ (car range)) - (princ " ") - (princ (cdr range)) + (prin1 symbol) + (princ " ") + (princ (car range)) + (princ " ") + (princ (cdr range)) (princ "\n")))))) my-obarray)))))))) @@ -2462,8 +2586,8 @@ modified) original contents, they are first saved to their own file." (when gnus-agent-mark-unread-after-downloaded (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) - (gnus-summary-mark-article - article gnus-unread-mark)) + (gnus-summary-mark-article + article gnus-unread-mark)) (when (gnus-summary-goto-subject article nil t) (gnus-summary-update-download-mark article))) (dolist (article unfetched-articles) @@ -2654,7 +2778,7 @@ The following commands are available: (gnus-category-position-point))) (defun gnus-category-name () - (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) + (or (intern (get-text-property (point-at-bol) 'gnus-category)) (error "No category on the current line"))) (defun gnus-category-read () @@ -2975,22 +3099,12 @@ The articles on which the expiration process runs are selected as follows: if ARTICLES is t, all articles. if ARTICLES is a list, just those articles. FORCE is equivalent to setting the expiration predicates to true." - (interactive - (list (let ((def (or (gnus-group-group-name) - gnus-newsgroup-name))) - (let ((select (read-string (if def - (concat "Group Name (" - def "): ") - "Group Name: ")))) - (if (and (equal "" select) - def) - def - select))))) + (interactive (list (gnus-agent-read-group))) (if (not group) (gnus-agent-expire articles group force) (let ( ;; Bind gnus-agent-expire-stats to enable tracking of - ;; expiration statistics of this single group + ;; expiration statistics of this single group (gnus-agent-expire-stats (list 0 0 0.0))) (if (or (not (eq articles t)) (yes-or-no-p @@ -3020,337 +3134,375 @@ FORCE is equivalent to setting the expiration predicates to true." ;; gnus-command-method, initialized overview buffer, and to have ;; provided a non-nil active - (let ((dir (gnus-agent-group-pathname group))) - (when (boundp 'gnus-agent-expire-current-dirs) - (set 'gnus-agent-expire-current-dirs - (cons dir - (symbol-value 'gnus-agent-expire-current-dirs)))) - - (if (and (not force) - (eq 'DISABLE (gnus-agent-find-parameter group - 'agent-enable-expiration))) - (gnus-message 5 "Expiry skipping over %s" group) - (gnus-message 5 "Expiring articles in %s" group) - (gnus-agent-load-alist group) - (let* ((bytes-freed 0) - (files-deleted 0) - (nov-entries-deleted 0) - (info (gnus-get-info group)) - (alist gnus-agent-article-alist) - (day (- (time-to-days (current-time)) - (gnus-agent-find-parameter group 'agent-days-until-old))) - (specials (if (and alist - (not force)) - ;; This could be a bit of a problem. I need to - ;; keep the last article to avoid refetching - ;; headers when using nntp in the backend. At - ;; the same time, if someone uses a backend - ;; that supports article moving then I may have - ;; to remove the last article to complete the - ;; move. Right now, I'm going to assume that - ;; FORCE overrides specials. - (list (caar (last alist))))) - (unreads ;; Articles that are excluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are marked read by global decree - nil) - ((eq articles t) - ;; All articles are marked read by function - ;; parameter - nil) - ((not articles) - ;; Unread articles are marked protected from - ;; expiration Don't call - ;; gnus-list-of-unread-articles as it returns - ;; articles that have not been fetched into the - ;; agent. - (ignore-errors - (gnus-agent-unread-articles group))) - (t - ;; All articles EXCEPT those named by the caller - ;; are protected from expiration - (gnus-sorted-difference - (gnus-uncompress-range - (cons (caar alist) - (caar (last alist)))) - (sort articles '<))))) - (marked ;; More articles that are excluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are unmarked by global decree - nil) - ((eq articles t) - ;; All articles are unmarked by function - ;; parameter - nil) - (articles - ;; All articles may as well be unmarked as the - ;; unreads list already names the articles we are - ;; going to keep - nil) - (t - ;; Ticked and/or dormant articles are excluded - ;; from expiration - (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info)))))))) - (nov-file (concat dir ".overview")) - (cnt 0) - (completed -1) - dlist - type) - - ;; The normal article alist contains elements that look like - ;; (article# . fetch_date) I need to combine other - ;; information with this list. For example, a flag indicating - ;; that a particular article MUST BE KEPT. To do this, I'm - ;; going to transform the elements to look like (article# - ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse - ;; the process to generate the expired article alist. - - ;; Convert the alist elements to (article# fetch_date nil - ;; nil). - (setq dlist (mapcar (lambda (e) - (list (car e) (cdr e) nil nil)) alist)) - - ;; Convert the keep lists to elements that look like (article# - ;; nil keep_flag nil) then append it to the expanded dlist - ;; These statements are sorted by ascending precidence of the - ;; keep_flag. - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'unread nil)) - unreads))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'marked nil)) - marked))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'special nil)) - specials))) - - (set-buffer overview) - (erase-buffer) - (buffer-disable-undo) - (when (file-exists-p nov-file) - (gnus-message 7 "gnus-agent-expire: Loading overview...") - (nnheader-insert-file-contents nov-file) - (goto-char (point-min)) - - (let (p) - (while (< (setq p (point)) (point-max)) - (condition-case nil - ;; If I successfully read an integer (the plus zero - ;; ensures a numeric type), prepend a marker entry - ;; to the list - (push (list (+ 0 (read (current-buffer))) nil nil - (set-marker (make-marker) p)) - dlist) - (error - (gnus-message 1 "gnus-agent-expire: read error \ + (let ((dir (gnus-agent-group-pathname group)) + (file-name-coding-system nnmail-pathname-coding-system) + (decoded (gnus-agent-decoded-group-name group))) + (gnus-agent-with-refreshed-group + group + (when (boundp 'gnus-agent-expire-current-dirs) + (set 'gnus-agent-expire-current-dirs + (cons dir + (symbol-value 'gnus-agent-expire-current-dirs)))) + + (if (and (not force) + (eq 'DISABLE (gnus-agent-find-parameter group + 'agent-enable-expiration))) + (gnus-message 5 "Expiry skipping over %s" decoded) + (gnus-message 5 "Expiring articles in %s" decoded) + (gnus-agent-load-alist group) + (let* ((bytes-freed 0) + (size-files-deleted 0.0) + (files-deleted 0) + (nov-entries-deleted 0) + (info (gnus-get-info group)) + (alist gnus-agent-article-alist) + (day (- (time-to-days (current-time)) + (gnus-agent-find-parameter group 'agent-days-until-old))) + (specials (if (and alist + (not force)) + ;; This could be a bit of a problem. I need to + ;; keep the last article to avoid refetching + ;; headers when using nntp in the backend. At + ;; the same time, if someone uses a backend + ;; that supports article moving then I may have + ;; to remove the last article to complete the + ;; move. Right now, I'm going to assume that + ;; FORCE overrides specials. + (list (caar (last alist))))) + (unreads ;; Articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are marked read by global decree + nil) + ((eq articles t) + ;; All articles are marked read by function + ;; parameter + nil) + ((not articles) + ;; Unread articles are marked protected from + ;; expiration Don't call + ;; gnus-list-of-unread-articles as it returns + ;; articles that have not been fetched into the + ;; agent. + (ignore-errors + (gnus-agent-unread-articles group))) + (t + ;; All articles EXCEPT those named by the caller + ;; are protected from expiration + (gnus-sorted-difference + (gnus-uncompress-range + (cons (caar alist) + (caar (last alist)))) + (sort articles '<))))) + (marked ;; More articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function + ;; parameter + nil) + (articles + ;; All articles may as well be unmarked as the + ;; unreads list already names the articles we are + ;; going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded + ;; from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))))) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains elements that look like + ;; (article# . fetch_date) I need to combine other + ;; information with this list. For example, a flag indicating + ;; that a particular article MUST BE KEPT. To do this, I'm + ;; going to transform the elements to look like (article# + ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse + ;; the process to generate the expired article alist. + + ;; Convert the alist elements to (article# fetch_date nil + ;; nil). + (setq dlist (mapcar (lambda (e) + (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements that look like (article# + ;; nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precidence of the + ;; keep_flag. + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'unread nil)) + unreads))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'marked nil)) + marked))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'special nil)) + specials))) + + (set-buffer overview) + (erase-buffer) + (buffer-disable-undo) + (when (file-exists-p nov-file) + (gnus-message 7 "gnus-agent-expire: Loading overview...") + (nnheader-insert-file-contents nov-file) + (goto-char (point-min)) + + (let (p) + (while (< (setq p (point)) (point-max)) + (condition-case nil + ;; If I successfully read an integer (the plus zero + ;; ensures a numeric type), append the position + ;; to the list + (push (list (+ 0 (read (current-buffer))) nil nil + p) + dlist) + (error + (gnus-message 1 "gnus-agent-expire: read error \ occurred when reading expression at %s in %s. Skipping to next \ line." (point) nov-file))) - ;; Whether I succeeded, or failed, it doesn't matter. - ;; Move to the next line then try again. - (forward-line 1))) - - (gnus-message - 7 "gnus-agent-expire: Loading overview... Done")) - (set-buffer-modified-p nil) - - ;; At this point, all of the information is in dlist. The - ;; only problem is that much of it is spread across multiple - ;; entries. Sort then MERGE!! - (gnus-message 7 "gnus-agent-expire: Sorting entries... ") - ;; If two entries have the same article-number then sort by - ;; ascending keep_flag. - (let ((special 0) - (marked 1) - (unread 2)) - (setq dlist - (sort dlist - (lambda (a b) - (cond ((< (nth 0 a) (nth 0 b)) - t) - ((> (nth 0 a) (nth 0 b)) - nil) - (t - (let ((a (or (symbol-value (nth 2 a)) - 3)) - (b (or (symbol-value (nth 2 b)) - 3))) - (<= a b)))))))) - (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") - (gnus-message 7 "gnus-agent-expire: Merging entries... ") - (let ((dlist dlist)) - (while (cdr dlist) ; I'm not at the end-of-list - (if (eq (caar dlist) (caadr dlist)) - (let ((first (cdr (car dlist))) - (secnd (cdr (cadr dlist)))) - (setcar first (or (car first) - (car secnd))) ; fetch_date - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) - (car secnd))) ; Keep_flag - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) - (car secnd))) ; NOV_entry_marker - - (setcdr dlist (cddr dlist))) - (setq dlist (cdr dlist))))) - (gnus-message 7 "gnus-agent-expire: Merging entries... Done") - - (let* ((len (float (length dlist))) - (alist (list nil)) - (tail-alist alist)) - (while dlist - (let ((new-completed (truncate (* 100.0 - (/ (setq cnt (1+ cnt)) - len)))) - message-log-max) - (when (> new-completed completed) - (setq completed new-completed) - (gnus-message 7 "%3d%% completed..." completed))) - (let* ((entry (car dlist)) - (article-number (nth 0 entry)) - (fetch-date (nth 1 entry)) - (keep (nth 2 entry)) - (marker (nth 3 entry))) - - (cond - ;; Kept articles are unread, marked, or special. - (keep - (gnus-agent-message 10 - "gnus-agent-expire: %s:%d: Kept %s article%s." - group article-number keep (if fetch-date " and file" "")) - (when fetch-date - (unless (file-exists-p - (concat dir (number-to-string - article-number))) - (setf (nth 1 entry) nil) - (gnus-agent-message 3 "gnus-agent-expire cleared \ + ;; Whether I succeeded, or failed, it doesn't matter. + ;; Move to the next line then try again. + (forward-line 1))) + + (gnus-message + 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information is in dlist. The + ;; only problem is that much of it is spread across multiple + ;; entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + ;; If two entries have the same article-number then sort by + ;; ascending keep_flag. + (let ((special 0) + (marked 1) + (unread 2)) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) + 3)) + (b (or (symbol-value (nth 2 b)) + 3))) + (<= a b)))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) + (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; NOV_entry_position + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + + ;; Check the order of the entry positions. They should be in + ;; ascending order. If they aren't, the positions must be + ;; converted to markers. + (when (catch 'sort-results + (let ((dlist dlist) + (prev-pos -1) + pos) + (while dlist + (if (setq pos (nth 3 (pop dlist))) + (if (< pos prev-pos) + (throw 'sort-results 'unsorted) + (setq prev-pos pos)))))) + (gnus-message 7 "gnus-agent-expire: Unsorted overview; inserting markers to compensate.") + (mapc (lambda (entry) + (let ((pos (nth 3 entry))) + (if pos + (setf (nth 3 entry) + (set-marker (make-marker) + pos))))) + dlist)) + + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist) + (position-offset 0) + ) + + (while dlist + (let ((new-completed (truncate (* 100.0 + (/ (setq cnt (1+ cnt)) + len)))) + message-log-max) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 7 "%3d%% completed..." completed))) + (let* ((entry (car dlist)) + (article-number (nth 0 entry)) + (fetch-date (nth 1 entry)) + (keep (nth 2 entry)) + (marker (nth 3 entry))) + + (cond + ;; Kept articles are unread, marked, or special. + (keep + (gnus-agent-message 10 + "gnus-agent-expire: %s:%d: Kept %s article%s." + decoded article-number keep (if fetch-date " and file" "")) + (when fetch-date + (unless (file-exists-p + (concat dir (number-to-string + article-number))) + (setf (nth 1 entry) nil) + (gnus-agent-message 3 "gnus-agent-expire cleared \ download flag on %s:%d as the cached article file is missing." - group (caar dlist))) - (unless marker - (gnus-message 1 "gnus-agent-expire detected a \ + decoded (caar dlist))) + (unless marker + (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) - (gnus-agent-append-to-list - tail-alist - (cons article-number fetch-date))) - - ;; The following articles are READ, UNMARKED, and - ;; ORDINARY. See if they can be EXPIRED!!! - ((setq type - (cond - ((not (integerp fetch-date)) + (gnus-agent-append-to-list + tail-alist + (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and + ;; ORDINARY. See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) 'read) ;; never fetched article (may expire - ;; right now) - ((not (file-exists-p - (concat dir (number-to-string - article-number)))) - (setf (nth 1 entry) nil) - 'externally-expired) ;; Can't find the cached - ;; article. Handle case - ;; as though this article - ;; was never fetched. - - ;; We now have the arrival day, so we see - ;; whether it's old enough to be expired. - ((< fetch-date day) - 'expired) - (force - 'forced))) - - ;; I found some reason to expire this entry. - - (let ((actions nil)) - (when (memq type '(forced expired)) - (ignore-errors ; Just being paranoid. - (let* ((file-name (nnheader-concat dir (number-to-string - article-number))) - (size (float (nth 7 (file-attributes file-name))))) - (incf bytes-freed size) - (incf files-deleted) - (delete-file file-name)) - (push "expired cached article" actions)) - (setf (nth 1 entry) nil) - ) - - (when marker - (push "NOV entry removed" actions) - (goto-char marker) - - (incf nov-entries-deleted) - - (let ((from (gnus-point-at-bol)) - (to (progn (forward-line 1) (point)))) - (incf bytes-freed (- to from)) - (delete-region from to))) - - ;; If considering all articles is set, I can only - ;; expire article IDs that are no longer in the - ;; active range (That is, articles that preceed the - ;; first article in the new alist). - (if (and gnus-agent-consider-all-articles - (>= article-number (car active))) - ;; I have to keep this ID in the alist - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date)) - (push (format "Removed %s article number from \ + ;; right now) + ((not (file-exists-p + (concat dir (number-to-string + article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached + ;; article. Handle case + ;; as though this article + ;; was never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date day) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (let* ((file-name (nnheader-concat dir (number-to-string + article-number))) + (size (float (nth 7 (file-attributes file-name))))) + (incf bytes-freed size) + (incf size-files-deleted size) + (incf files-deleted) + (delete-file file-name)) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" actions) + + (goto-char (if (markerp marker) + marker + (- marker position-offset))) + + (incf nov-entries-deleted) + + (let* ((from (point-at-bol)) + (to (progn (forward-line 1) (point))) + (freed (- to from))) + (incf bytes-freed freed) + (incf position-offset freed) + (delete-region from to))) + + ;; If considering all articles is set, I can only + ;; expire article IDs that are no longer in the + ;; active range (That is, articles that preceed the + ;; first article in the new alist). + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from \ article alist" type) actions)) - (when actions - (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" - group article-number - (mapconcat 'identity actions ", "))))) - (t - (gnus-agent-message - 10 "gnus-agent-expire: %s:%d: Article kept as \ -expiration tests failed." group article-number) - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date))) - ) - - ;; Clean up markers as I want to recycle this buffer - ;; over several groups. - (when marker - (set-marker marker nil)) - - (setq dlist (cdr dlist)))) - - (setq alist (cdr alist)) - - (let ((inhibit-quit t)) - (unless (equal alist gnus-agent-article-alist) - (setq gnus-agent-article-alist alist) - (gnus-agent-save-alist group)) - - (when (buffer-modified-p) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (gnus-make-directory dir) - (write-region (point-min) (point-max) nov-file nil - 'silent) - ;; clear the modified flag as that I'm not confused by - ;; its status on the next pass through this routine. - (set-buffer-modified-p nil))) - - (when (eq articles t) - (gnus-summary-update-info)))) - - (when (boundp 'gnus-agent-expire-stats) - (let ((stats (symbol-value 'gnus-agent-expire-stats))) - (incf (nth 2 stats) bytes-freed) - (incf (nth 1 stats) files-deleted) - (incf (nth 0 stats) nov-entries-deleted))) - )))) + (when actions + (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" + decoded article-number + (mapconcat 'identity actions ", "))))) + (t + (gnus-agent-message + 10 "gnus-agent-expire: %s:%d: Article kept as \ +expiration tests failed." decoded article-number) + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date))) + ) + + ;; Remove markers as I intend to reuse this buffer again. + (when (and marker + (markerp marker)) + (set-marker marker nil)) + + (setq dlist (cdr dlist)))) + + (setq alist (cdr alist)) + + (let ((inhibit-quit t)) + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) + (gnus-agent-save-alist group)) + + (when (buffer-modified-p) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-make-directory dir) + (write-region (point-min) (point-max) nov-file nil + 'silent) + ;; clear the modified flag as that I'm not confused by + ;; its status on the next pass through this routine. + (set-buffer-modified-p nil) + (gnus-agent-update-view-total-fetched-for group t))) + + (when (eq articles t) + (gnus-summary-update-info)))) + + (when (boundp 'gnus-agent-expire-stats) + (let ((stats (symbol-value 'gnus-agent-expire-stats))) + (incf (nth 2 stats) bytes-freed) + (incf (nth 1 stats) files-deleted) + (incf (nth 0 stats) nov-entries-deleted))) + + (gnus-agent-update-files-total-fetched-for group (- size-files-deleted))))))) (defun gnus-agent-expire (&optional articles group force) "Expire all old articles. @@ -3428,7 +3580,8 @@ articles in every agentized group? ")) ;; compiler will not complain about free references. (gnus-agent-expire-current-dirs (symbol-value 'gnus-agent-expire-current-dirs)) - dir) + dir + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-sethash gnus-agent-directory t keep) (while gnus-agent-expire-current-dirs @@ -3485,6 +3638,7 @@ articles in every agentized group? ")) (let ((dir (pop to-remove))) (if (gnus-y-or-n-p (format "Delete %s? " dir)) (let* (delete-recursive + files f (delete-recursive (function (lambda (f-or-d) @@ -3493,12 +3647,13 @@ articles in every agentized group? ")) (condition-case nil (delete-directory f-or-d) (file-error - (mapcar (lambda (f) - (or (member f '("." "..")) - (funcall delete-recursive - (nnheader-concat - f-or-d f)))) - (directory-files f-or-d)) + (setq files (directory-files f-or-d)) + (while files + (setq f (pop files)) + (or (member f '("." "..")) + (funcall delete-recursive + (nnheader-concat + f-or-d f)))) (delete-directory f-or-d))) (delete-file f-or-d))))))) (funcall delete-recursive dir)))))))))) @@ -3582,7 +3737,8 @@ has been fetched." (let ((gnus-decode-encoded-word-function 'identity) (gnus-decode-encoded-address-function 'identity) (file (gnus-agent-article-name ".overview" group)) - cached-articles uncached-articles) + cached-articles uncached-articles + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) @@ -3685,6 +3841,8 @@ has been fetched." (gnus-agent-check-overview-buffer) (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-update-view-total-fetched-for group t) + ;; Update the group's article alist to include the newly ;; fetched articles. (gnus-agent-load-alist group) @@ -3715,7 +3873,8 @@ has been fetched." (numberp article)) (let* ((gnus-command-method (gnus-find-method-for-group group)) (file (gnus-agent-article-name (number-to-string article) group)) - (buffer-read-only nil)) + (buffer-read-only nil) + (file-name-coding-system nnmail-pathname-coding-system)) (when (and (file-exists-p file) (> (nth 7 (file-attributes file)) 0)) (erase-buffer) @@ -3732,16 +3891,7 @@ In addition, their NOV entries in .overview will be refreshed using the articles' current headers. If REREAD is not nil, downloaded articles are marked as unread." (interactive - (list (let ((def (or (gnus-group-group-name) - gnus-newsgroup-name))) - (let ((select (read-string (if def - (concat "Group Name (" - def "): ") - "Group Name: ")))) - (if (and (equal "" select) - def) - def - select))) + (list (gnus-agent-read-group) (catch 'mark (while (let (c (cursor-in-echo-area t) @@ -3759,199 +3909,200 @@ If REREAD is not nil, downloaded articles are marked as unread." (sit-for 1) t))))) (when group - (gnus-message 5 "Regenerating in %s" group) - (let* ((gnus-command-method (or gnus-command-method - (gnus-find-method-for-group group))) - (file (gnus-agent-article-name ".overview" group)) - (dir (file-name-directory file)) - point - (downloaded (if (file-exists-p dir) + (gnus-message 5 "Regenerating in %s" group) + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (file (gnus-agent-article-name ".overview" group)) + (dir (file-name-directory file)) + point + (file-name-coding-system nnmail-pathname-coding-system) + (downloaded (if (file-exists-p dir) (sort (delq nil (mapcar (lambda (name) (and (not (file-directory-p (nnheader-concat dir name))) (string-to-number name))) (directory-files dir nil "^[0-9]+$" t))) - '>) - (progn (gnus-make-directory dir) nil))) - dl nov-arts - alist header - regenerated) - - (mm-with-unibyte-buffer - (if (file-exists-p file) - (let ((nnheader-file-coding-system - gnus-agent-file-coding-system)) - (nnheader-insert-file-contents file))) - (set-buffer-modified-p nil) - - ;; Load the article IDs found in the overview file. As a - ;; side-effect, validate the file contents. - (let ((load t)) - (while load - (setq load nil) - (goto-char (point-min)) - (while (< (point) (point-max)) - (cond ((and (looking-at "[0-9]+\t") - (<= (- (match-end 0) (match-beginning 0)) 9)) - (push (read (current-buffer)) nov-arts) - (forward-line 1) - (let ((l1 (car nov-arts)) - (l2 (cadr nov-arts))) - (cond ((and (listp reread) (memq l1 reread)) - (gnus-delete-line) - (setq nov-arts (cdr nov-arts)) - (gnus-message 4 "gnus-agent-regenerate-group: NOV\ + '>) + (progn (gnus-make-directory dir) nil))) + dl nov-arts + alist header + regenerated) + + (mm-with-unibyte-buffer + (if (file-exists-p file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))) + (set-buffer-modified-p nil) + + ;; Load the article IDs found in the overview file. As a + ;; side-effect, validate the file contents. + (let ((load t)) + (while load + (setq load nil) + (goto-char (point-min)) + (while (< (point) (point-max)) + (cond ((and (looking-at "[0-9]+\t") + (<= (- (match-end 0) (match-beginning 0)) 9)) + (push (read (current-buffer)) nov-arts) + (forward-line 1) + (let ((l1 (car nov-arts)) + (l2 (cadr nov-arts))) + (cond ((and (listp reread) (memq l1 reread)) + (gnus-delete-line) + (setq nov-arts (cdr nov-arts)) + (gnus-message 4 "gnus-agent-regenerate-group: NOV\ entry of article %s deleted." l1)) - ((not l2) - nil) - ((< l1 l2) - (gnus-message 3 "gnus-agent-regenerate-group: NOV\ + ((not l2) + nil) + ((< l1 l2) + (gnus-message 3 "gnus-agent-regenerate-group: NOV\ entries are NOT in ascending order.") - ;; Don't sort now as I haven't verified - ;; that every line begins with a number - (setq load t)) - ((= l1 l2) - (forward-line -1) - (gnus-message 4 "gnus-agent-regenerate-group: NOV\ - entries contained duplicate of article %s. Duplicate deleted." l1) - (gnus-delete-line) - (setq nov-arts (cdr nov-arts)))))) - (t - (gnus-message 1 "gnus-agent-regenerate-group: NOV\ + ;; Don't sort now as I haven't verified + ;; that every line begins with a number + (setq load t)) + ((= l1 l2) + (forward-line -1) + (gnus-message 4 "gnus-agent-regenerate-group: NOV\ + entries contained duplicate of article %s. Duplicate deleted." l1) + (gnus-delete-line) + (setq nov-arts (cdr nov-arts)))))) + (t + (gnus-message 1 "gnus-agent-regenerate-group: NOV\ entries contained line that did not begin with an article number. Deleted\ line.") - (gnus-delete-line)))) - (when load - (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ + (gnus-delete-line)))) + (when load + (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ entries into ascending order.") - (sort-numeric-fields 1 (point-min) (point-max)) - (setq nov-arts nil)))) - (gnus-agent-check-overview-buffer) - - ;; Construct a new article alist whose nodes match every header - ;; in the .overview file. As a side-effect, missing headers are - ;; reconstructed from the downloaded article file. - (while (or downloaded nov-arts) - (cond ((and downloaded - (or (not nov-arts) - (> (car downloaded) (car nov-arts)))) - ;; This entry is missing from the overview file - (gnus-message 3 "Regenerating NOV %s %d..." group - (car downloaded)) - (let ((file (concat dir (number-to-string (car downloaded))))) - (mm-with-unibyte-buffer - (nnheader-insert-file-contents file) - (nnheader-remove-body) - (setq header (nnheader-parse-naked-head))) - (mail-header-set-number header (car downloaded)) - (if nov-arts - (let ((key (concat "^" (int-to-string (car nov-arts)) - "\t"))) - (or (re-search-backward key nil t) - (re-search-forward key)) - (forward-line 1)) - (goto-char (point-min))) - (nnheader-insert-nov header)) - (setq nov-arts (cons (car downloaded) nov-arts))) - ((eq (car downloaded) (car nov-arts)) - ;; This entry in the overview has been downloaded - (push (cons (car downloaded) - (time-to-days - (nth 5 (file-attributes - (concat dir (number-to-string - (car downloaded))))))) alist) - (setq downloaded (cdr downloaded)) - (setq nov-arts (cdr nov-arts))) - (t - ;; This entry in the overview has not been downloaded - (push (cons (car nov-arts) nil) alist) - (setq nov-arts (cdr nov-arts))))) - - ;; When gnus-agent-consider-all-articles is set, - ;; gnus-agent-regenerate-group should NOT remove article IDs from - ;; the alist. Those IDs serve as markers to indicate that an - ;; attempt has been made to fetch that article's header. - - ;; When gnus-agent-consider-all-articles is NOT set, - ;; gnus-agent-regenerate-group can remove the article ID of every - ;; article (with the exception of the last ID in the list - it's - ;; special) that no longer appears in the overview. In this - ;; situtation, the last article ID in the list implies that it, - ;; and every article ID preceeding it, have been fetched from the - ;; server. - - (if gnus-agent-consider-all-articles - ;; Restore all article IDs that were not found in the overview file. - (let* ((n (cons nil alist)) - (merged n) - (o (gnus-agent-load-alist group))) - (while o - (let ((nID (caadr n)) - (oID (caar o))) - (cond ((not nID) - (setq n (setcdr n (list (list oID)))) - (setq o (cdr o))) - ((< oID nID) - (setcdr n (cons (list oID) (cdr n))) - (setq o (cdr o))) - ((= oID nID) - (setq o (cdr o)) - (setq n (cdr n))) - (t - (setq n (cdr n)))))) - (setq alist (cdr merged))) - ;; Restore the last article ID if it is not already in the new alist - (let ((n (last alist)) - (o (last (gnus-agent-load-alist group)))) - (cond ((not o) - nil) - ((not n) - (push (cons (caar o) nil) alist)) - ((< (caar n) (caar o)) - (setcdr n (list (car o))))))) - - (let ((inhibit-quit t)) - (if (setq regenerated (buffer-modified-p)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent))) - - (setq regenerated (or regenerated - (and reread gnus-agent-article-alist) - (not (equal alist gnus-agent-article-alist)))) - - (setq gnus-agent-article-alist alist) - - (when regenerated - (gnus-agent-save-alist group) - - ;; I have to alter the group's active range NOW as - ;; gnus-make-ascending-articles-unread will use it to - ;; recalculate the number of unread articles in the group - - (let ((group (gnus-group-real-name group)) - (group-active (or (gnus-active group) - (gnus-activate-group group)))) - (gnus-agent-possibly-alter-active group group-active))))) - - (when (and reread gnus-agent-article-alist) + (sort-numeric-fields 1 (point-min) (point-max)) + (setq nov-arts nil)))) + (gnus-agent-check-overview-buffer) + + ;; Construct a new article alist whose nodes match every header + ;; in the .overview file. As a side-effect, missing headers are + ;; reconstructed from the downloaded article file. + (while (or downloaded nov-arts) + (cond ((and downloaded + (or (not nov-arts) + (> (car downloaded) (car nov-arts)))) + ;; This entry is missing from the overview file + (gnus-message 3 "Regenerating NOV %s %d..." group + (car downloaded)) + (let ((file (concat dir (number-to-string (car downloaded))))) + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (nnheader-remove-body) + (setq header (nnheader-parse-naked-head))) + (mail-header-set-number header (car downloaded)) + (if nov-arts + (let ((key (concat "^" (int-to-string (car nov-arts)) + "\t"))) + (or (re-search-backward key nil t) + (re-search-forward key)) + (forward-line 1)) + (goto-char (point-min))) + (nnheader-insert-nov header)) + (setq nov-arts (cons (car downloaded) nov-arts))) + ((eq (car downloaded) (car nov-arts)) + ;; This entry in the overview has been downloaded + (push (cons (car downloaded) + (time-to-days + (nth 5 (file-attributes + (concat dir (number-to-string + (car downloaded))))))) alist) + (setq downloaded (cdr downloaded)) + (setq nov-arts (cdr nov-arts))) + (t + ;; This entry in the overview has not been downloaded + (push (cons (car nov-arts) nil) alist) + (setq nov-arts (cdr nov-arts))))) + + ;; When gnus-agent-consider-all-articles is set, + ;; gnus-agent-regenerate-group should NOT remove article IDs from + ;; the alist. Those IDs serve as markers to indicate that an + ;; attempt has been made to fetch that article's header. + + ;; When gnus-agent-consider-all-articles is NOT set, + ;; gnus-agent-regenerate-group can remove the article ID of every + ;; article (with the exception of the last ID in the list - it's + ;; special) that no longer appears in the overview. In this + ;; situtation, the last article ID in the list implies that it, + ;; and every article ID preceeding it, have been fetched from the + ;; server. + + (if gnus-agent-consider-all-articles + ;; Restore all article IDs that were not found in the overview file. + (let* ((n (cons nil alist)) + (merged n) + (o (gnus-agent-load-alist group))) + (while o + (let ((nID (caadr n)) + (oID (caar o))) + (cond ((not nID) + (setq n (setcdr n (list (list oID)))) + (setq o (cdr o))) + ((< oID nID) + (setcdr n (cons (list oID) (cdr n))) + (setq o (cdr o))) + ((= oID nID) + (setq o (cdr o)) + (setq n (cdr n))) + (t + (setq n (cdr n)))))) + (setq alist (cdr merged))) + ;; Restore the last article ID if it is not already in the new alist + (let ((n (last alist)) + (o (last (gnus-agent-load-alist group)))) + (cond ((not o) + nil) + ((not n) + (push (cons (caar o) nil) alist)) + ((< (caar n) (caar o)) + (setcdr n (list (car o))))))) + + (let ((inhibit-quit t)) + (if (setq regenerated (buffer-modified-p)) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) file nil 'silent))) + + (setq regenerated (or regenerated + (and reread gnus-agent-article-alist) + (not (equal alist gnus-agent-article-alist)))) + + (setq gnus-agent-article-alist alist) + + (when regenerated + (gnus-agent-save-alist group) + + ;; I have to alter the group's active range NOW as + ;; gnus-make-ascending-articles-unread will use it to + ;; recalculate the number of unread articles in the group + + (let ((group (gnus-group-real-name group)) + (group-active (or (gnus-active group) + (gnus-activate-group group)))) + (gnus-agent-possibly-alter-active group group-active))))) + + (when (and reread gnus-agent-article-alist) (gnus-agent-synchronize-group-flags - group + group (list (list - (if (listp reread) - reread - (delq nil (mapcar (function (lambda (c) - (cond ((eq reread t) - (car c)) - ((cdr c) - (car c))))) + (if (listp reread) + reread + (delq nil (mapcar (function (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c))))) gnus-agent-article-alist))) 'del '(read))) gnus-command-method) - (when (gnus-buffer-live-p gnus-group-buffer) - (gnus-group-update-group group t))) + (when regenerated + (gnus-agent-update-files-total-fetched-for group nil))) - (gnus-message 5 "") - regenerated))) + (gnus-message 5 "") + regenerated))) ;;;###autoload (defun gnus-agent-regenerate (&optional clean reread) @@ -3996,6 +4147,84 @@ If CLEAN, obsolete (ignore)." (defun gnus-agent-group-covered-p (group) (gnus-agent-method-p (gnus-group-method group))) +(defun gnus-agent-update-files-total-fetched-for + (group delta &optional method path) + "Update, or set, the total disk space used by the articles that the +agent has fetched." + (when gnus-agent-total-fetched-hashtb + (gnus-agent-with-refreshed-group + group + ;; if null, gnus-agent-group-pathname will calc method. + (let* ((gnus-command-method method) + (path (or path (gnus-agent-group-pathname group))) + (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) + (gnus-sethash path (make-list 3 0) + gnus-agent-total-fetched-hashtb))) + (file-name-coding-system nnmail-pathname-coding-system)) + (when (listp delta) + (if delta + (let ((sum 0.0) + file) + (while (setq file (pop delta)) + (incf sum (float (or (nth 7 (file-attributes + (nnheader-concat + path + (if (numberp file) + (number-to-string file) + file)))) 0)))) + (setq delta sum)) + (let ((sum (- (nth 2 entry))) + (info (directory-files-and-attributes path nil "^-?[0-9]+$" t)) + file) + (while (setq file (pop info)) + (incf sum (float (or (nth 8 file) 0)))) + (setq delta sum)))) + + (setq gnus-agent-need-update-total-fetched-for t) + (incf (nth 2 entry) delta))))) + +(defun gnus-agent-update-view-total-fetched-for + (group agent-over &optional method path) + "Update, or set, the total disk space used by the .agentview and +.overview files. These files are calculated separately as they can be +modified." + (when gnus-agent-total-fetched-hashtb + (gnus-agent-with-refreshed-group + group + ;; if null, gnus-agent-group-pathname will calc method. + (let* ((gnus-command-method method) + (path (or path (gnus-agent-group-pathname group))) + (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) + (gnus-sethash path (make-list 3 0) + gnus-agent-total-fetched-hashtb))) + (file-name-coding-system nnmail-pathname-coding-system) + (size (or (nth 7 (file-attributes + (nnheader-concat + path (if agent-over + ".overview" + ".agentview")))) + 0))) + (setq gnus-agent-need-update-total-fetched-for t) + (setf (nth (if agent-over 1 0) entry) size))))) + +(defun gnus-agent-total-fetched-for (group &optional method no-inhibit) + "Get the total disk space used by the specified GROUP." + (unless (equal group "dummy.group") + (unless gnus-agent-total-fetched-hashtb + (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024))) + + ;; if null, gnus-agent-group-pathname will calc method. + (let* ((gnus-command-method method) + (path (gnus-agent-group-pathname group)) + (entry (gnus-gethash path gnus-agent-total-fetched-hashtb))) + (if entry + (apply '+ entry) + (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit))) + (+ + (gnus-agent-update-view-total-fetched-for group nil method path) + (gnus-agent-update-view-total-fetched-for group t method path) + (gnus-agent-update-files-total-fetched-for group nil method path))))))) + (provide 'gnus-agent) ;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index a02a7d153bb..0c98babcad5 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -33,7 +33,10 @@ (defvar w3m-minor-mode-map)) (require 'gnus) -(require 'gnus-sum) +;; Avoid the "Recursive load suspected" error in Emacs 21.1. +(eval-and-compile + (let ((recursive-load-depth-limit 100)) + (require 'gnus-sum))) (require 'gnus-spec) (require 'gnus-int) (require 'gnus-win) @@ -49,6 +52,8 @@ (autoload 'gnus-button-mailto "gnus-msg") (autoload 'gnus-button-reply "gnus-msg" nil t) (autoload 'parse-time-string "parse-time" nil nil) +(autoload 'ansi-color-apply-on-region "ansi-color") +(autoload 'mm-url-insert-file-contents-external "mm-url") (autoload 'mm-extern-cache-contents "mm-extern") (defgroup gnus-article nil @@ -153,7 +158,10 @@ "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway" "X-Local-Origin" "X-Local-Destination" "X-UserInfo1" "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications" - "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer")) + "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer" + "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane" + "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At" + "Envelope-Sender" "Envelope-Recipients")) "*All headers that start with 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." @@ -238,7 +246,9 @@ 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." +regexp. If it matches, the text in question is not a signature. + +This can also be a list of the above values." :type '(choice (const nil) (integer :value 200) (number :value 4.0) @@ -412,7 +422,7 @@ is the face used for highlighting." (widget-group-value-create widget)) regexp (integer :format "Match group: %v") - (integer :format "Emphasize group: %v") + (integer :format "Emphasize group: %v") face) (group :tag "Simple" :value (("_" . "_") nil default) @@ -480,14 +490,14 @@ Example: (_/*word*/_)." "Face used for displaying highlighted words." :group 'gnus-article-emphasis) -(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" +(defcustom gnus-article-time-format "%a, %d %b %Y %T %Z" "Format for display of Date headers in article bodies. See `format-time-string' for the possible values. The variable can also be function, which should return a complete Date header. The function is called with one argument, the time, which can be fed to `format-time-string'." - :type '(choice string symbol) + :type '(choice string function) :link '(custom-manual "(gnus)Article Date") :group 'gnus-article-washing) @@ -645,17 +655,18 @@ you could set this variable to something like: '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) -This variable is an alist where the where the key is the match and the -value is a list of possible files to save in if the match is non-nil. +This variable is an alist where the key is the match and the +value is a list of possible files to save in if the match is +non-nil. If the match is a string, it is used as a regexp match on the article. If the match is a symbol, that symbol will be funcalled from the buffer of the article to be saved with the newsgroup as the -parameter. If it is a list, it will be evalled in the same buffer. +parameter. If it is a list, it will be evaled in the same buffer. -If this form or function returns a string, this string will be used as -a possible file name; and if it returns a non-nil list, that list will -be used as possible file names." +If this form or function returns a string, this string will be used as a +possible file name; and if it returns a non-nil list, that list will be +used as possible file names." :group 'gnus-article-saving :type '(repeat (choice (list :value (fun) function) (cons :value ("" "") regexp (repeat string)) @@ -701,10 +712,22 @@ The following additional specs are available: :type 'hook :group 'gnus-article-various) +(defcustom gnus-copy-article-ignored-headers nil + "List of headers to be removed when copying an article. +Each element is a regular expression." + :version "23.0" ;; No Gnus + :type '(repeat regexp) + :group 'gnus-article-various) + (make-obsolete-variable 'gnus-article-hide-pgp-hook "This variable is obsolete in Gnus 5.10.") -(defcustom gnus-article-button-face 'bold +(defface gnus-button + '((t (:weight bold))) + "Face used for highlighting a button in the article buffer." + :group 'gnus-article-buttons) + +(defcustom gnus-article-button-face 'gnus-button "Face used for highlighting buttons in the article buffer. An article button is a piece of text that you can activate by pressing @@ -739,7 +762,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." (defface gnus-header-from '((((class color) (background dark)) - (:foreground "spring green")) + (:foreground "PaleGreen1")) (((class color) (background light)) (:foreground "red3")) @@ -754,7 +777,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." (defface gnus-header-subject '((((class color) (background dark)) - (:foreground "SeaGreen3")) + (:foreground "SeaGreen1")) (((class color) (background light)) (:foreground "red4")) @@ -786,7 +809,7 @@ articles." (defface gnus-header-name '((((class color) (background dark)) - (:foreground "SeaGreen")) + (:foreground "SpringGreen2")) (((class color) (background light)) (:foreground "maroon")) @@ -801,7 +824,7 @@ articles." (defface gnus-header-content '((((class color) (background dark)) - (:foreground "forest green" :italic t)) + (:foreground "SpringGreen1" :italic t)) (((class color) (background light)) (:foreground "indianred4" :italic t)) @@ -838,6 +861,31 @@ be displayed by the first non-nil matching CONTENT face." (item :tag "skip" nil) (face :value default))))) +(defcustom gnus-face-properties-alist (if (featurep 'xemacs) + '((xface . (:face gnus-x-face))) + '((pbm . (:face gnus-x-face)) + (png . nil))) + "Alist of image types and properties applied to Face and X-Face images. +Here are examples: + +;; Specify the altitude of Face images in the From header. +\(setq gnus-face-properties-alist + '((pbm . (:face gnus-x-face :ascent 80)) + (png . (:ascent 80)))) + +;; Show Face images as pressed buttons. +\(setq gnus-face-properties-alist + '((pbm . (:face gnus-x-face :relief -2)) + (png . (:relief -2)))) + +See the manual for the valid properties for various image types. +Currently, `pbm' is used for X-Face images and `png' is used for Face +images in Emacs. Only the `:face' property is effective on the `xface' +image type in XEmacs if it is built with the libcompface library." + :version "23.0" ;; No Gnus + :group 'gnus-article-headers + :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist))) + (defcustom gnus-article-decode-hook '(article-decode-charset article-decode-encoded-words article-decode-group-name article-decode-idna-rhs) @@ -954,7 +1002,7 @@ on parts -- for instance, adding Vcard info to a database." "An alist of MIME types to functions to display them." :version "21.1" :group 'gnus-article-mime - :type 'alist) + :type '(repeat (cons :format "%v" (string :tag "MIME type") function))) (defcustom gnus-article-date-lapsed-new-header nil "Whether the X-Sent and Date headers can coexist. @@ -985,6 +1033,7 @@ used." (defcustom gnus-mime-action-alist '(("save to file" . gnus-mime-save-part) ("save and strip" . gnus-mime-save-part-and-strip) + ("replace with file" . gnus-mime-replace-part) ("delete part" . gnus-mime-delete-part) ("display as text" . gnus-mime-inline-part) ("view the part" . gnus-mime-view-part) @@ -999,6 +1048,19 @@ used." :type '(repeat (cons (string :tag "name") (function)))) +(defcustom gnus-auto-select-part 1 + "Advance to next MIME part when deleting or stripping parts. + +When 0, point will be placed on the same part as before. When +positive (negative), move point forward (backwards) this many +parts. When nil, redisplay article." + :version "23.0" ;; No Gnus + :group 'gnus-article-mime + :type '(choice (const nil :tag "Redisplay article.") + (const 1 :tag "Next part.") + (const 0 :tag "Current part.") + integer)) + ;;; ;;; The treatment variables ;;; @@ -1010,6 +1072,7 @@ used." '(choice (const :tag "Off" nil) (const :tag "On" t) (const :tag "Header" head) + (const :tag "First" first) (const :tag "Last" last) (integer :tag "Less") (repeat :tag "Groups" regexp) @@ -1019,7 +1082,8 @@ used." '(choice (const :tag "Off" nil) (const :tag "Header" head))) -(defvar gnus-article-treat-types '("text/plain") +(defvar gnus-article-treat-types '("text/plain" "text/x-verbatim" + "text/x-patch") "Parts to treat.") (defvar gnus-inhibit-treatment nil @@ -1027,8 +1091,8 @@ used." (defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard")) "Highlight the signature. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles'." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1036,8 +1100,8 @@ See Info node `(gnus)Customizing Articles'." (defcustom gnus-treat-buttonize 100000 "Add buttons. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles'." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1045,21 +1109,17 @@ See Info node `(gnus)Customizing Articles'." (defcustom gnus-treat-buttonize-head 'head "Add buttons to the head. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (put 'gnus-treat-buttonize-head 'highlight t) -(defcustom gnus-treat-emphasize - (and (or window-system - (featurep 'xemacs) - (>= (string-to-number emacs-version) 21)) - 50000) +(defcustom gnus-treat-emphasize 50000 "Emphasize text. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1067,8 +1127,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-strip-cr nil "Remove carriage returns. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1076,8 +1136,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-unsplit-urls nil "Remove newlines from within URLs. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1085,8 +1145,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-leading-whitespace nil "Remove leading whitespace in headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1094,56 +1154,56 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-hide-headers 'head "Hide headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-hide-boring-headers nil "Hide boring headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-hide-signature nil "Hide the signature. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-fill-article nil "Fill the article. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-hide-citation nil "Hide cited text. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-hide-citation-maybe nil "Hide cited text. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-strip-list-identifiers 'head "Strip list identifiers from `gnus-list-identifiers`. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1154,8 +1214,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-strip-pem nil "Strip PEM signatures. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1163,16 +1223,16 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-strip-banner t "Strip banners from articles. The banner to be stripped is specified in the `banner' group parameter. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-highlight-headers 'head "Highlight the headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) @@ -1180,8 +1240,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-highlight-citation t "Highlight cited text. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1189,24 +1249,24 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-date-ut nil "Display the Date in UT (GMT). -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-local nil "Display the Date in the local timezone. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-english nil "Display the Date in a format that can be read aloud in English. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1214,24 +1274,24 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-date-lapsed nil "Display the Date header in a way that says how much time has elapsed. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-original nil "Display the date in the original timezone. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-iso8601 nil "Display the date in the ISO8601 format. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1240,16 +1300,16 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-date-user-defined nil "Display the date in a user-defined format. The format is defined by the `gnus-article-time-format' variable. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-strip-headers-in-body t "Strip the X-No-Archive header line from the beginning of the body. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1257,8 +1317,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-strip-trailing-blank-lines nil "Strip trailing blank lines. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'. When set to t, it also strips trailing blanks in all MIME parts. Consider to use `last' instead." @@ -1268,8 +1328,8 @@ Consider to use `last' instead." (defcustom gnus-treat-strip-leading-blank-lines nil "Strip leading blank lines. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'. When set to t, it also strips trailing blanks in all MIME parts." :group 'gnus-article-treat @@ -1278,25 +1338,37 @@ When set to t, it also strips trailing blanks in all MIME parts." (defcustom gnus-treat-strip-multiple-blank-lines nil "Strip multiple blank lines. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-unfold-headers 'head "Unfold folded header lines. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) +(defcustom gnus-article-unfold-long-headers nil + "If non-nil, allow unfolding headers even if the header is long. +If it is a regexp, only long headers matching this regexp are unfolded. +If it is t, all long headers are unfolded. + +This variable has no effect if `gnus-treat-unfold-headers' is nil." + :version "23.0" ;; No Gnus + :group 'gnus-article-treat + :type '(choice (const nil) + (const :tag "all" t) + (regexp))) + (defcustom gnus-treat-fold-headers nil "Fold headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1304,8 +1376,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-fold-newsgroups 'head "Fold the Newsgroups and Followup-To headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1313,13 +1385,21 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-overstrike t "Treat overstrike highlighting. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) +(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t) + "Treat ANSI SGR control sequences. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + (make-obsolete-variable 'gnus-treat-display-xface 'gnus-treat-display-x-face) @@ -1364,9 +1444,9 @@ See Info node `(gnus)Customizing Articles' and Info node (gnus-image-type-available-p 'png) 'head) "Display Face headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)X-Face' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)X-Face' for details." :group 'gnus-article-treat :version "22.1" :link '(custom-manual "(gnus)Customizing Articles") @@ -1376,9 +1456,9 @@ See Info node `(gnus)Customizing Articles' and Info node (defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm) "Display smileys. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)Smileys' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Smileys' for details." :group 'gnus-article-treat :version "21.1" :link '(custom-manual "(gnus)Customizing Articles") @@ -1391,9 +1471,9 @@ See Info node `(gnus)Customizing Articles' and Info node (gnus-picons-installed-p)) 'head nil) "Display picons in the From header. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)Picons' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Picons' for details." :version "22.1" :group 'gnus-article-treat :group 'gnus-picon @@ -1407,9 +1487,9 @@ See Info node `(gnus)Customizing Articles' and Info node (gnus-picons-installed-p)) 'head nil) "Display picons in To and Cc headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)Picons' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Picons' for details." :version "22.1" :group 'gnus-article-treat :group 'gnus-picon @@ -1423,9 +1503,9 @@ See Info node `(gnus)Customizing Articles' and Info node (gnus-picons-installed-p)) 'head nil) "Display picons in the Newsgroups and Followup-To headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)Picons' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Picons' for details." :version "22.1" :group 'gnus-article-treat :group 'gnus-picon @@ -1438,7 +1518,9 @@ See Info node `(gnus)Customizing Articles' and Info node (if (or gnus-treat-newsgroups-picon gnus-treat-mail-picon gnus-treat-from-picon) - 'head nil) + ;; If there's much decoration, the user might prefer a boundery. + 'head + nil) "Draw a boundary at the end of the headers. Valid values are nil and `head'. See Info node `(gnus)Customizing Articles' for details." @@ -1449,8 +1531,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-capitalize-sentences nil "Capitalize sentence-starting words. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1458,8 +1540,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-wash-html nil "Format as HTML. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1467,16 +1549,16 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-fill-long-lines nil "Fill long lines. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-play-sounds nil "Play sounds. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1484,8 +1566,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-translate nil "Translate articles from one language to another. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") @@ -1494,8 +1576,8 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-x-pgp-sig nil "Verify X-PGP-Sig. To automatically treat X-PGP-Sig, set it to head. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :version "22.1" :group 'gnus-article-treat :group 'mime-security @@ -1581,9 +1663,10 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-strip-multiple-blank-lines gnus-article-strip-multiple-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) + (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences) (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) - (gnus-treat-fold-headers gnus-article-treat-fold-headers) (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) + (gnus-treat-fold-headers gnus-article-treat-fold-headers) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) (gnus-treat-display-smileys gnus-treat-smiley) (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) @@ -1814,12 +1897,9 @@ always hide." (save-excursion (save-restriction (let ((inhibit-read-only t) - (list gnus-boring-article-headers) - (inhibit-point-motion-hooks t) - elem) + (inhibit-point-motion-hooks t)) (article-narrow-to-head) - (while list - (setq elem (pop list)) + (dolist (elem gnus-boring-article-headers) (goto-char (point-min)) (cond ;; Hide empty headers. @@ -1827,7 +1907,7 @@ always hide." (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) (forward-line -1) (gnus-article-hide-text-type - (gnus-point-at-bol) + (point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1957,7 +2037,7 @@ always hide." (goto-char (point-min)) (when (re-search-forward (concat "^" header ":") nil t) (gnus-article-hide-text-type - (gnus-point-at-bol) + (point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1978,7 +2058,7 @@ always hide." (article-narrow-to-head) (while (not (eobp)) (cond - ((< (setq column (- (gnus-point-at-eol) (point))) + ((< (setq column (- (point-at-eol) (point))) gnus-article-normalized-header-length) (end-of-line) (insert (make-string @@ -1989,7 +2069,7 @@ always hide." (progn (forward-char gnus-article-normalized-header-length) (point)) - (gnus-point-at-eol) + (point-at-eol) 'invisible t)) (t ;; Do nothing. @@ -2031,9 +2111,8 @@ characters to translate to." MAP is an alist where the elements are on the form (\"from\" \"to\")." (save-excursion (when (article-goto-body) - (let ((inhibit-read-only t) - elem) - (while (setq elem (pop map)) + (let ((inhibit-read-only t)) + (dolist (elem map) (save-excursion (while (search-forward (car elem) nil t) (replace-match (cadr elem))))))))) @@ -2064,6 +2143,14 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (put-text-property (point) (1+ (point)) 'face 'underline))))))))) +(defun article-treat-ansi-sequences () + "Translate ANSI SGR control sequences into overlays or extents." + (interactive) + (save-excursion + (when (article-goto-body) + (let ((inhibit-read-only t)) + (ansi-color-apply-on-region (point) (point-max)))))) + (defun gnus-article-treat-unfold-headers () "Unfold folded message headers. Only the headers that fit into the current window width will be @@ -2074,16 +2161,21 @@ unfolded." (while (not (eobp)) (save-restriction (mail-header-narrow-to-field) - (let ((header (buffer-string))) + (let* ((header (buffer-string)) + (unfoldable + (or (equal gnus-article-unfold-long-headers t) + (and (stringp gnus-article-unfold-long-headers) + (string-match gnus-article-unfold-long-headers header))))) (with-temp-buffer (insert header) (goto-char (point-min)) (while (re-search-forward "\n[\t ]" nil t) (replace-match " " t t))) - (setq length (- (point-max) (point-min) 1))) - (when (< length (window-width)) - (while (re-search-forward "\n[\t ]" nil t) - (replace-match " " t t))) + (setq length (- (point-max) (point-min) 1)) + (when (or unfoldable + (< length (window-width))) + (while (re-search-forward "\n[\t ]" nil t) + (replace-match " " t t)))) (goto-char (point-max))))))) (defun gnus-article-treat-fold-headers () @@ -2130,6 +2222,39 @@ unfolded." (mail-header-fold-field) (goto-char (point-max)))))) +(defcustom gnus-article-truncate-lines default-truncate-lines + "Value of `truncate-lines' in Gnus Article buffer. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." + :version "23.0" ;; No Gnus + :group 'gnus-article + ;; :link '(custom-manual "(gnus)Customizing Articles") + :type 'boolean) + +(defun gnus-article-toggle-truncate-lines (&optional arg) + "Toggle whether to fold or truncate long lines in article the buffer. +If ARG is non-nil and not a number, toggle +`gnus-article-truncate-lines' too. If ARG is a number, truncate +long lines iff arg is positive." + (interactive "P") + (cond + ((and (numberp arg) (> arg 0)) + (setq gnus-article-truncate-lines t)) + ((numberp arg) + (setq gnus-article-truncate-lines nil)) + (arg + (setq gnus-article-truncate-lines + (not gnus-article-truncate-lines)))) + (gnus-with-article-buffer + (cond + ((and (numberp arg) (> arg 0)) + (setq truncate-lines nil)) + ((numberp arg) + (setq truncate-lines t))) + ;; In versions of Emacs 22 (CVS) before 2006-05-26, + ;; `toggle-truncate-lines' needs an argument. + (toggle-truncate-lines))) + (defun gnus-article-treat-body-boundary () "Place a boundary line at the end of the headers." (interactive) @@ -2160,7 +2285,7 @@ unfolded." (end-of-line) (when (>= (current-column) (min fill-column width)) (narrow-to-region (min (1+ (point)) (point-max)) - (gnus-point-at-bol)) + (point-at-bol)) (let ((goback (point-marker))) (fill-paragraph nil) (goto-char (marker-position goback))) @@ -2202,11 +2327,14 @@ unfolded." (while (and (not (bobp)) (looking-at "^[ \t]*$") (not (gnus-annotation-in-region-p - (point) (gnus-point-at-eol)))) + (point) (point-at-eol)))) (forward-line -1)) (forward-line 1) (point)))))) +(eval-when-compile + (defvar gnus-face-properties-alist)) + (defun article-display-face () "Display any Face headers in the header." (interactive) @@ -2239,7 +2367,9 @@ unfolded." (insert "[no `from' set]\n")) (while faces (when (setq png (gnus-convert-face-to-png (pop faces))) - (setq image (gnus-create-image png 'png t)) + (setq image + (apply 'gnus-create-image png 'png t + (cdr (assq 'png gnus-face-properties-alist)))) (goto-char from) (gnus-add-wash-type 'face) (gnus-add-image 'face image) @@ -2311,14 +2441,12 @@ unfolded." (defun article-decode-mime-words () "Decode all MIME-encoded words in the article." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) + (gnus-with-article-buffer (let ((inhibit-point-motion-hooks t) - (inhibit-read-only t) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (mail-decode-encoded-word-region (point-min) (point-max))))) (defun article-decode-charset (&optional prompt) @@ -2395,44 +2523,31 @@ If PROMPT (the prefix), prompt for a coding system to use." (goto-char (setq end start))))) (defun article-decode-group-name () - "Decode group names in `Newsgroups:'." + "Decode group names in Newsgroups, Followup-To and Xref headers." (let ((inhibit-point-motion-hooks t) (inhibit-read-only t) - (method (gnus-find-method-for-group gnus-newsgroup-name))) + (method (gnus-find-method-for-group gnus-newsgroup-name)) + regexp) (when (and (or gnus-group-name-charset-method-alist gnus-group-name-charset-group-alist) (gnus-buffer-live-p gnus-original-article-buffer)) (save-restriction (article-narrow-to-head) - (with-current-buffer gnus-original-article-buffer - (goto-char (point-min))) - (while (re-search-forward - "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) - (replace-match (save-match-data - (gnus-decode-newsgroups - ;; XXX how to use data in article buffer? - (with-current-buffer gnus-original-article-buffer - (re-search-forward - "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" - nil t) - (match-string 1)) - gnus-newsgroup-name method)) - t t nil 1)) - (goto-char (point-min)) - (with-current-buffer gnus-original-article-buffer - (goto-char (point-min))) - (while (re-search-forward - "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) - (replace-match (save-match-data - (gnus-decode-newsgroups - ;; XXX how to use data in article buffer? - (with-current-buffer gnus-original-article-buffer - (re-search-forward - "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" - nil t) - (match-string 1)) - gnus-newsgroup-name method)) - t t nil 1)))))) + (dolist (header '("Newsgroups" "Followup-To" "Xref")) + (with-current-buffer gnus-original-article-buffer + (goto-char (point-min))) + (setq regexp (concat "^" header + ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n")) + (while (re-search-forward regexp nil t) + (replace-match (save-match-data + (gnus-decode-newsgroups + ;; XXX how to use data in article buffer? + (with-current-buffer gnus-original-article-buffer + (re-search-forward regexp nil t) + (match-string 1)) + gnus-newsgroup-name method)) + t t nil 1)) + (goto-char (point-min))))))) (autoload 'idna-to-unicode "idna") @@ -2628,6 +2743,104 @@ charset defined in `gnus-summary-show-article-charset-alist' is used." "-I" (symbol-name charset) "-O" (symbol-name charset)))) (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html"))) +(defvar gnus-article-browse-html-temp-list nil + "List of temporary files created by `gnus-article-browse-html-parts'. +Internal variable.") + +(defcustom gnus-article-browse-delete-temp 'ask + "What to do with temporary files from `gnus-article-browse-html-parts'. +If nil, don't delete temporary files. If it is t, delete them on +exit from the summary buffer. If it is the symbol `file', query +on each file, if it is `ask' ask once when exiting from the +summary buffer." + :group 'gnus-article + :version "23.0" ;; No Gnus + :type '(choice (const :tag "Don't delete" nil) + (const :tag "Don't ask" t) + (const :tag "Ask" ask) + (const :tag "Ask for each file" file))) + +;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list. + +(defun gnus-article-browse-delete-temp-files (&optional how) + "Delete temp-files created by `gnus-article-browse-html-parts'." + (when (and gnus-article-browse-html-temp-list + (or how + (setq how gnus-article-browse-delete-temp))) + (when (and (eq how 'ask) + (y-or-n-p (format + "Delete all %s temporary HTML file(s)? " + (length gnus-article-browse-html-temp-list))) + (setq how t))) + (dolist (file gnus-article-browse-html-temp-list) + (when (and (file-exists-p file) + (or (eq how t) + ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'): + (gnus-y-or-n-p + (format "Delete temporary HTML file `%s'? " file)))) + (delete-file file))) + ;; Also remove file from the list when not deleted or if file doesn't + ;; exist anymore. + (setq gnus-article-browse-html-temp-list nil)) + gnus-article-browse-html-temp-list) + +(defun gnus-article-browse-html-parts (list) + "View all \"text/html\" parts from LIST. +Recurse into multiparts." + ;; Internal function used by `gnus-article-browse-html-article'. + (let ((showed)) + ;; Find and show the html-parts. + (dolist (handle list) + ;; If HTML, show it: + (when (listp handle) + (cond ((and (bufferp (car handle)) + (string-match "text/html" (car (mm-handle-type handle)))) + (let ((tmp-file (mm-make-temp-file + ;; Do we need to care for 8.3 filenames? + "mm-" nil ".html"))) + (mm-save-part-to-file handle tmp-file) + (add-to-list 'gnus-article-browse-html-temp-list tmp-file) + (add-hook 'gnus-summary-prepare-exit-hook + 'gnus-article-browse-delete-temp-files) + (add-hook 'gnus-exit-gnus-hook + (lambda () + (gnus-article-browse-delete-temp-files t))) + ;; FIXME: Warn if there's an <img> tag? + (browse-url-of-file tmp-file) + (setq showed t))) + ;; If multipart, recurse + ((and (stringp (car handle)) + (string-match "^multipart/" (car handle)) + (setq showed + (or showed + (gnus-article-browse-html-parts handle)))))))) + showed)) + +;; FIXME: Documentation in texi/gnus.texi missing. +(defun gnus-article-browse-html-article () + "View \"text/html\" parts of the current article with a WWW browser. + +Warning: Spammers use links to images in HTML articles to verify +whether you have read the message. As +`gnus-article-browse-html-article' passes the unmodified HTML +content to the browser without eliminating these \"web bugs\" you +should only use it for mails from trusted senders." + ;; Cf. `mm-w3m-safe-url-regexp' + (interactive) + (save-window-excursion + ;; Open raw article and select the buffer + (gnus-summary-show-article t) + (gnus-summary-select-article-buffer) + (let ((parts (mm-dissect-buffer t t))) + ;; If singlepart, enforce a list. + (when (and (bufferp (car parts)) + (stringp (car (mm-handle-type parts)))) + (setq parts (list parts))) + ;; Process the list + (unless (gnus-article-browse-html-parts parts) + (gnus-error 3 "Mail doesn't contain a \"text/html\" part!")) + (gnus-summary-show-article)))) + (defun article-hide-list-identifiers () "Remove list identifies from the Subject header. The `gnus-list-identifiers' variable specifies what to do." @@ -2732,11 +2945,9 @@ always hide." "Translate article using an online translation service." (interactive) (require 'babel) - (save-excursion - (set-buffer gnus-article-buffer) + (gnus-with-article-buffer (when (article-goto-body) - (let* ((inhibit-read-only t) - (start (point)) + (let* ((start (point)) (end (point-max)) (orig (buffer-substring start end)) (trans (babel-as-string orig))) @@ -3007,22 +3218,20 @@ should replace the \"Date:\" one, or should be added below it." (point-max))) (goto-char (point-min)) (when (re-search-forward tdate-regexp nil t) - (setq bface (get-text-property (gnus-point-at-bol) 'face) - eface (get-text-property (1- (gnus-point-at-eol)) 'face))) + (setq bface (get-text-property (point-at-bol) 'face) + eface (get-text-property (1- (point-at-eol)) 'face))) (goto-char (point-min)) (setq pos nil) ;; Delete any old Date headers. (while (re-search-forward date-regexp nil t) (if pos - (delete-region (gnus-point-at-bol) - (progn - (gnus-article-forward-header) - (point))) - (delete-region (gnus-point-at-bol) - (progn - (gnus-article-forward-header) - (forward-char -1) - (point))) + (delete-region (point-at-bol) (progn + (gnus-article-forward-header) + (point))) + (delete-region (point-at-bol) (progn + (gnus-article-forward-header) + (forward-char -1) + (point))) (setq pos (point)))) (when (and (not pos) (re-search-forward tdate-regexp nil t)) @@ -3052,22 +3261,21 @@ should replace the \"Date:\" one, or should be added below it." (cond ;; Convert to the local timezone. ((eq type 'local) - (let ((tz (car (current-time-zone time)))) - (format "Date: %s %s%02d%02d" (current-time-string time) - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60)))) + (concat "Date: " (message-make-date time))) ;; Convert to Universal Time. ((eq type 'ut) (concat "Date: " - (current-time-string - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - " UT")) + (substring + (message-make-date + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + 0 -5) + "UT")) ;; Get the original date from the article. ((eq type 'original) (concat "Date: " (if (string-match "\n+$" date) @@ -3208,7 +3416,7 @@ is to run." (setq n 1)) (gnus-stop-date-timer) (setq article-lapsed-timer - (nnheader-run-at-time 1 n 'article-update-date-lapsed))) + (run-at-time 1 n 'article-update-date-lapsed))) (defun gnus-stop-date-timer () "Stop the X-Sent timer." @@ -3237,7 +3445,7 @@ This format is defined by the `gnus-article-time-format' variable." (not (bolp))) (match-end 0)))) (date (when (and start - (re-search-forward "[\t ]*\n\\([^\t ]\\|\\'\\)" + (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)" nil t)) (buffer-substring-no-properties start (match-beginning 0))))) @@ -3588,17 +3796,9 @@ The directory to save in defaults to `gnus-article-save-directory'." (shell-command-on-region (point-min) (point-max) command nil))) (setq gnus-last-shell-command command)) -(defmacro gnus-read-string (prompt &optional initial-contents history - default-value) - "Like `read-string' but allow for older XEmacsen that don't have the 5th arg." - (if (and (featurep 'xemacs) - (< emacs-minor-version 2)) - `(read-string ,prompt ,initial-contents ,history) - `(read-string ,prompt ,initial-contents ,history ,default-value))) - (defun gnus-summary-pipe-to-muttprint (&optional command) "Pipe this article to muttprint." - (setq command (gnus-read-string + (setq command (read-string "Print using command: " gnus-summary-muttprint-program nil gnus-summary-muttprint-program)) (gnus-summary-save-in-pipe command)) @@ -3721,8 +3921,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (message-narrow-to-head) (goto-char (point-max)) (forward-line -1) - (setq bface (get-text-property (gnus-point-at-bol) 'face) - eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (setq bface (get-text-property (point-at-bol) 'face) + eface (get-text-property (1- (point-at-eol)) 'face)) (message-remove-header "X-Gnus-PGP-Verify") (if (re-search-forward "^X-PGP-Sig:" nil t) (forward-line) @@ -3750,7 +3950,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (canlock-verify gnus-original-article-buffer))) (eval-and-compile - (mapcar + (mapc (lambda (func) (let (afunc gfunc) (if (consp func) @@ -3773,6 +3973,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-verify-cancel-lock article-hide-boring-headers article-treat-overstrike + article-treat-ansi-sequences article-fill-long-lines article-capitalize-sentences article-remove-cr @@ -3810,7 +4011,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-emphasize article-treat-dumbquotes article-normalize-headers -;; (article-show-all . gnus-article-show-all-headers) + ;;(article-show-all . gnus-article-show-all-headers) ))) ;;; @@ -3873,6 +4074,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] + ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t] ["Remove carriage return" gnus-article-remove-cr t] ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] @@ -3929,20 +4131,18 @@ commands: ;; face. (set (make-local-variable 'nobreak-char-display) nil) (setq cursor-in-non-selected-windows nil) + (setq truncate-lines gnus-article-truncate-lines) (gnus-set-default-directory) (buffer-disable-undo) - (setq buffer-read-only t) + (setq buffer-read-only t + show-trailing-whitespace nil) (set-syntax-table gnus-article-mode-syntax-table) (mm-enable-multibyte) (gnus-run-mode-hooks 'gnus-article-mode-hook)) -;; Internal variables. Are `gnus-button-regexp' and `gnus-button-last' used -;; at all? -(defvar gnus-button-regexp nil) (defvar gnus-button-marker-list nil - "Regexp matching any of the regexps from `gnus-button-alist'.") -(defvar gnus-button-last nil - "The value of `gnus-button-alist' when `gnus-button-regexp' was build.") + "Regexp matching any of the regexps from `gnus-button-alist'. +Internal variable.") (defun gnus-article-setup-buffer () "Initialize the article buffer." @@ -3955,10 +4155,9 @@ commands: (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) (setq gnus-article-mime-handle-alist nil) - ;; This might be a variable local to the summary buffer. - (unless gnus-single-article-buffer - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + ;; This might be a variable local to the summary buffer. + (unless gnus-single-article-buffer (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) (gnus-set-global-variables))) @@ -3999,23 +4198,27 @@ commands: (set-buffer (gnus-get-buffer-create name)) (gnus-article-mode) (make-local-variable 'gnus-summary-buffer) + (setq gnus-summary-buffer + (gnus-summary-buffer-name gnus-newsgroup-name)) (gnus-summary-set-local-parameters gnus-newsgroup-name) (current-buffer))))) ;; Set article window start at LINE, where LINE is the number of lines ;; from the head of the article. (defun gnus-article-set-window-start (&optional line) - (set-window-start - (gnus-get-buffer-window gnus-article-buffer t) - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (if (not line) - (point-min) - (gnus-message 6 "Moved to bookmark") - (search-forward "\n\n" nil t) - (forward-line line) - (point))))) + (let ((article-window (gnus-get-buffer-window gnus-article-buffer t))) + (when article-window + (set-window-start + article-window + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (if (not line) + (point-min) + (gnus-message 6 "Moved to bookmark") + (search-forward "\n\n" nil t) + (forward-line line) + (point))))))) (defun gnus-article-prepare (article &optional all-headers header) "Prepare ARTICLE in article mode buffer. @@ -4147,6 +4350,90 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-run-hooks 'gnus-article-prepare-hook))) ;;; +;;; Gnus Sticky Article Mode +;;; + +(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle" + "Mode for sticky articles." + ;; Release bindings that won't work. + (substitute-key-definition 'gnus-article-read-summary-keys 'undefined + gnus-sticky-article-mode-map) + (substitute-key-definition 'gnus-article-refer-article 'undefined + gnus-sticky-article-mode-map) + (dolist (k '("e" "h" "s" "F" "R")) + (define-key gnus-sticky-article-mode-map k nil)) + (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer) + (define-key gnus-sticky-article-mode-map "q" 'bury-buffer) + (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly) + (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key)) + +(defun gnus-sticky-article (arg) + "Make the current article sticky. +If a prefix ARG is given, ask for a name for this sticky article buffer." + (interactive "P") + (gnus-summary-show-thread) + (gnus-summary-select-article nil nil 'pseudo) + (let (new-art-buf-name) + (gnus-eval-in-buffer-window gnus-article-buffer + (setq new-art-buf-name + (concat + "*Sticky Article: " + (if arg + (read-from-minibuffer "Sticky article buffer name: ") + (gnus-with-article-headers + (gnus-article-goto-header "subject") + (setq new-art-buf-name + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))) + (goto-char (point-min)) + (gnus-article-goto-header "from") + (setq new-art-buf-name + (concat + new-art-buf-name ", " + (buffer-substring-no-properties + (line-beginning-position) (line-end-position)))) + (goto-char (point-min)) + (gnus-article-goto-header "date") + (setq new-art-buf-name + (concat + new-art-buf-name ", " + (buffer-substring-no-properties + (line-beginning-position) (line-end-position)))))) + "*")) + (if (and (gnus-buffer-live-p new-art-buf-name) + (with-current-buffer new-art-buf-name + (eq major-mode 'gnus-sticky-article-mode))) + (switch-to-buffer new-art-buf-name) + (setq new-art-buf-name (rename-buffer new-art-buf-name t))) + (gnus-sticky-article-mode)) + (setq gnus-article-buffer new-art-buf-name)) + (gnus-summary-recenter) + (gnus-summary-position-point)) + +(defun gnus-kill-sticky-article-buffer (&optional buffer) + "Kill the given sticky article BUFFER. +If none is given, assume the current buffer and kill it if it has +`gnus-sticky-article-mode'." + (interactive) + (unless buffer + (setq buffer (current-buffer))) + (with-current-buffer buffer + (when (eq major-mode 'gnus-sticky-article-mode) + (gnus-kill-buffer buffer)))) + +(defun gnus-kill-sticky-article-buffers (arg) + "Kill all sticky article buffers. +If a prefix ARG is given, ask for confirmation." + (interactive "P") + (dolist (buf (gnus-buffers)) + (with-current-buffer buf + (when (eq major-mode 'gnus-sticky-article-mode) + (if (not arg) + (gnus-kill-buffer buf) + (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? ")) + (gnus-kill-buffer buf))))))) + +;;; ;;; Gnus MIME viewing functions ;;; @@ -4181,10 +4468,11 @@ General format specifiers can also be used. See Info node (gnus-mime-view-part-as-charset "C" "View As charset...") (gnus-mime-save-part "o" "Save...") (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") + (gnus-mime-replace-part "r" "Replace part") (gnus-mime-delete-part "d" "Delete part") (gnus-mime-copy-part "c" "View As Text, In Other Buffer") (gnus-mime-inline-part "i" "View As Text, In This Buffer") - (gnus-mime-view-part-internally "E" "View Internally") + (gnus-mime-view-part-internally "E" "View Internally") ;; Why `E'? (gnus-mime-view-part-externally "e" "View Externally") (gnus-mime-print-part "p" "Print") (gnus-mime-pipe-part "|" "Pipe To Command...") @@ -4199,9 +4487,6 @@ General format specifiers can also be used. See Info node (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-article-push-button) (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) @@ -4212,25 +4497,9 @@ General format specifiers can also be used. See Info node gnus-mime-button-menu gnus-mime-button-map "MIME button menu." `("MIME Part" ,@(mapcar (lambda (c) - (vector (caddr c) (car c) :enable t)) + (vector (caddr c) (car c) :active t)) gnus-mime-button-commands))) -(eval-when-compile - (define-compiler-macro popup-menu (&whole form - menu &optional position prefix) - (if (and (fboundp 'popup-menu) - (not (memq 'popup-menu (assoc "lmenu" load-history)))) - form - ;; Gnus is probably running under Emacs 20. - `(let* ((menu (cdr ,menu)) - (response (x-popup-menu - t (list (car menu) - (cons "" (mapcar (lambda (c) - (cons (caddr c) (car c))) - (cdr menu))))))) - (if response - (call-interactively (nth 3 (assq response menu)))))))) - (defun gnus-mime-button-menu (event prefix) "Construct a context-sensitive menu of MIME commands." (interactive "e\nP") @@ -4244,8 +4513,7 @@ General format specifiers can also be used. See Info node (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." (interactive) - (save-current-buffer - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((handles (or handles gnus-article-mime-handles)) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets @@ -4259,8 +4527,102 @@ General format specifiers can also be used. See Info node (delete-region (point) (point-max)) (mm-display-parts handles)))))) -(defun gnus-mime-save-part-and-strip () - "Save the MIME part under point then replace it with an external body." +(defun gnus-article-jump-to-part (n) + "Jump to MIME part N." + (interactive "P") + (pop-to-buffer gnus-article-buffer) + ;; FIXME: why is it necessary? + (sit-for 0) + (let ((parts (length gnus-article-mime-handle-alist))) + (or n (setq n + (string-to-number + (read-string ;; Emacs 21 doesn't have `read-number'. + (format "Jump to part (2..%s): " parts))))) + (unless (and (integerp n) (<= n parts) (>= n 1)) + (setq n + (progn + (gnus-message 7 "Invalid part `%s', using %s instead." + n parts) + parts))) + (gnus-message 9 "Jumping to part %s." n) + (cond ((>= gnus-auto-select-part 1) + (while (and (<= n parts) + (not (gnus-article-goto-part n))) + (setq n (1+ n)))) + ((< gnus-auto-select-part 0) + (while (and (>= n 1) + (not (gnus-article-goto-part n))) + (setq n (1- n)))) + (t + (gnus-article-goto-part n))))) + +(eval-when-compile + (defsubst gnus-article-edit-part (handles &optional current-id) + "Edit an article in order to delete a mime part. +This function is exclusively used by `gnus-mime-save-part-and-strip' +and `gnus-mime-delete-part', and not provided at run-time normally." + (gnus-article-edit-article + `(lambda () + (buffer-disable-undo) + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (insert-buffer-substring gnus-original-article-buffer) + (mime-to-mml ',handles) + (setq gnus-article-mime-handles nil) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight)) + t) + (gnus-article-edit-done) + (gnus-summary-expand-window) + (gnus-summary-show-article) + (when (and current-id (integerp gnus-auto-select-part)) + (gnus-article-jump-to-part + (if (text-property-any (point-min) (point-max) + 'gnus-part (+ current-id gnus-auto-select-part)) + (+ current-id gnus-auto-select-part) + (with-current-buffer gnus-article-buffer + (length gnus-article-mime-handle-alist))))))) + +(defun gnus-mime-replace-part (file) + "Replace MIME part under point with an external body." + ;; Useful if file has already been saved to disk + (interactive + (list + (mm-with-multibyte + (read-file-name "Replace MIME part with file: " + (or mm-default-directory default-directory) + nil nil)))) + (gnus-mime-save-part-and-strip file)) + +(defun gnus-mime-save-part-and-strip (&optional file) + "Save the MIME part under point then replace it with an external body. +If FILE is given, use it for the external part." (interactive) (gnus-article-check-buffer) (when (gnus-group-read-only-p) @@ -4268,66 +4630,36 @@ General format specifiers can also be used. See Info node (when (mm-complicated-handles gnus-article-mime-handles) (error "\ The current article has a complicated MIME structure, giving up...")) - (when (gnus-yes-or-no-p "\ -Deleting parts may malfunction or destroy the article; continue? ") - (let* ((data (get-text-property (point) 'gnus-data)) - file param - (handles gnus-article-mime-handles)) - (setq file (and data (mm-save-part data))) - (when file - (with-current-buffer (mm-handle-buffer data) - (erase-buffer) - (insert "Content-Type: " (mm-handle-media-type data)) - (mml-insert-parameter-string (cdr (mm-handle-type data)) - '(charset)) - ;; Add a filename for the sake of saving the part again. - (mml-insert-parameter - (mail-header-encode-parameter "name" (file-name-nondirectory file))) - (insert "\n") - (insert "Content-ID: " (message-make-message-id) "\n") - (insert "Content-Transfer-Encoding: binary\n") - (insert "\n")) - (setcdr data - (cdr (mm-make-handle nil - `("message/external-body" - (access-type . "LOCAL-FILE") - (name . ,file))))) - (set-buffer gnus-summary-buffer) - (gnus-article-edit-article - `(lambda () - (erase-buffer) - (let ((mail-parse-charset (or gnus-article-charset - ',gnus-newsgroup-charset)) - (mail-parse-ignored-charsets - (or gnus-article-ignored-charsets - ',gnus-newsgroup-ignored-charsets)) - (mbl mml-buffer-list)) - (setq mml-buffer-list nil) - (insert-buffer-substring gnus-original-article-buffer) - (mime-to-mml ',handles) - (setq gnus-article-mime-handles nil) - (let ((mbl1 mml-buffer-list)) - (setq mml-buffer-list mbl) - (set (make-local-variable 'mml-buffer-list) mbl1)) - (gnus-make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) - `(lambda (no-highlight) - (let ((mail-parse-charset (or gnus-article-charset - ',gnus-newsgroup-charset)) - (message-options message-options) - (message-options-set-recipient) - (mail-parse-ignored-charsets - (or gnus-article-ignored-charsets - ',gnus-newsgroup-ignored-charsets))) - (mml-to-mime) - (mml-destroy-buffers) - (remove-hook 'kill-buffer-hook - 'mml-destroy-buffers t) - (kill-local-variable 'mml-buffer-list)) - (gnus-summary-edit-article-done - ,(or (mail-header-references gnus-current-headers) "") - ,(gnus-group-read-only-p) - ,gnus-summary-buffer no-highlight))))))) + (let* ((data (get-text-property (point) 'gnus-data)) + (id (get-text-property (point) 'gnus-part)) + param + (handles gnus-article-mime-handles)) + (unless file + (setq file + (and data (mm-save-part data "Delete MIME part and save to: ")))) + (when file + (with-current-buffer (mm-handle-buffer data) + (erase-buffer) + (insert "Content-Type: " (mm-handle-media-type data)) + (mml-insert-parameter-string (cdr (mm-handle-type data)) + '(charset)) + ;; Add a filename for the sake of saving the part again. + (mml-insert-parameter + (mail-header-encode-parameter "name" (file-name-nondirectory file))) + (insert "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: binary\n") + (insert "\n")) + (setcdr data + (cdr (mm-make-handle nil + `("message/external-body" + (access-type . "LOCAL-FILE") + (name . ,file))))) + ;; (set-buffer gnus-summary-buffer) + (gnus-article-edit-part handles id)))) + +;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all +;; parts...>') but with stripping would be nice. (defun gnus-mime-delete-part () "Delete the MIME part under point. @@ -4339,9 +4671,11 @@ Replace it with some information about the removed part." (when (mm-complicated-handles gnus-article-mime-handles) (error "\ The current article has a complicated MIME structure, giving up...")) - (when (gnus-yes-or-no-p "\ -Deleting parts may malfunction or destroy the article; continue? ") + (when (or gnus-expert-user + (gnus-yes-or-no-p "\ +Deleting parts may malfunction or destroy the article; continue? ")) (let* ((data (get-text-property (point) 'gnus-data)) + (id (get-text-property (point) 'gnus-part)) (handles gnus-article-mime-handles) (none "(none)") (description @@ -4371,48 +4705,8 @@ Deleting parts may malfunction or destroy the article; continue? ") nil `("text/plain") nil nil (list "attachment") (format "Deleted attachment (%s bytes)" bsize)))))) - (set-buffer gnus-summary-buffer) - ;; FIXME: maybe some of the following code (borrowed from - ;; `gnus-mime-save-part-and-strip') isn't necessary? - (gnus-article-edit-article - `(lambda () - (erase-buffer) - (let ((mail-parse-charset (or gnus-article-charset - ',gnus-newsgroup-charset)) - (mail-parse-ignored-charsets - (or gnus-article-ignored-charsets - ',gnus-newsgroup-ignored-charsets)) - (mbl mml-buffer-list)) - (setq mml-buffer-list nil) - (insert-buffer-substring gnus-original-article-buffer) - (mime-to-mml ',handles) - (setq gnus-article-mime-handles nil) - (let ((mbl1 mml-buffer-list)) - (setq mml-buffer-list mbl) - (set (make-local-variable 'mml-buffer-list) mbl1)) - (gnus-make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) - `(lambda (no-highlight) - (let ((mail-parse-charset (or gnus-article-charset - ',gnus-newsgroup-charset)) - (message-options message-options) - (message-options-set-recipient) - (mail-parse-ignored-charsets - (or gnus-article-ignored-charsets - ',gnus-newsgroup-ignored-charsets))) - (mml-to-mime) - (mml-destroy-buffers) - (remove-hook 'kill-buffer-hook - 'mml-destroy-buffers t) - (kill-local-variable 'mml-buffer-list)) - (gnus-summary-edit-article-done - ,(or (mail-header-references gnus-current-headers) "") - ,(gnus-group-read-only-p) - ,gnus-summary-buffer no-highlight)))) - ;; Not in `gnus-mime-save-part-and-strip': - (gnus-article-edit-done) - (gnus-summary-expand-window) - (gnus-summary-show-article))) + ;; (set-buffer gnus-summary-buffer) + (gnus-article-edit-part handles id)))) (defun gnus-mime-save-part () "Save the MIME part under point." @@ -4450,7 +4744,11 @@ Deleting parts may malfunction or destroy the article; continue? ") ;; Content-Disposition: attachment; filename=... (cdr (assq 'filename (cdr (mm-handle-disposition handle)))))) (def-type (and name (mm-default-file-encoding name)))) - (and def-type (cons def-type 0)))) + (or (and def-type (cons def-type 0)) + (and handle + (equal (mm-handle-media-supertype handle) "text") + '("text/plain" . 0)) + '("application/octet-stream" . 0)))) (defun gnus-mime-view-part-as-type (&optional mime-type pred) "Choose a MIME media type, and view the part as such. @@ -4484,62 +4782,67 @@ available media-types." (mm-handle-id handle))) (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles handle)) + (when (mm-handle-displayed-p handle) + (mm-remove-part handle)) (gnus-mm-display-part handle)))) -(eval-when-compile - (require 'jka-compr)) - -;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days -;; emacs can do that itself. -;; -(defun gnus-mime-jka-compr-maybe-uncompress () - "Uncompress the current buffer if `auto-compression-mode' is enabled. -The uncompress method used is derived from `buffer-file-name'." - (when (and (fboundp 'jka-compr-installed-p) - (jka-compr-installed-p)) - (let ((info (jka-compr-get-compression-info buffer-file-name))) - (when info - (let ((basename (file-name-nondirectory buffer-file-name)) - (args (jka-compr-info-uncompress-args info)) - (prog (jka-compr-info-uncompress-program info)) - (message (jka-compr-info-uncompress-message info)) - (err-file (jka-compr-make-temp-name))) - (if message - (message "%s %s..." message basename)) - (unwind-protect - (unless (memq (apply 'call-process-region - (point-min) (point-max) - prog - t (list t err-file) nil - args) - jka-compr-acceptable-retval-list) - (jka-compr-error prog args basename message err-file)) - (jka-compr-delete-temp-file err-file))))))) - -(defun gnus-mime-copy-part (&optional handle) +(defun gnus-mime-copy-part (&optional handle arg) "Put the MIME part under point into a new buffer. If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 are decompressed." - (interactive) + (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (contents (and handle (mm-get-part handle))) - (base (and handle - (file-name-nondirectory - (or - (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename) - "*decoded*")))) - (buffer (and base (generate-new-buffer base)))) - (when contents - (switch-to-buffer buffer) - (insert contents) + (unless handle + (setq handle (get-text-property (point) 'gnus-data))) + (when handle + (let ((filename (or (mail-content-type-get (mm-handle-type handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename))) + contents dont-decode charset coding-system) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (setq contents (or (condition-case nil + (mm-decompress-buffer filename nil 'sig) + (error + (setq dont-decode t) + nil)) + (buffer-string)))) + (setq filename (cond (filename (file-name-nondirectory filename)) + (dont-decode "*raw data*") + (t "*decoded*"))) + (cond + (dont-decode) + ((not arg) + (unless (setq charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + (unless (setq coding-system (mm-with-unibyte-buffer + (insert contents) + (mm-find-buffer-file-coding-system))) + (setq charset gnus-newsgroup-charset)))) + ((numberp arg) + (setq charset (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: "))))) + (switch-to-buffer (generate-new-buffer filename)) + (if (or coding-system + (and charset + (setq coding-system (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii)))) + (progn + (mm-enable-multibyte) + (insert (mm-decode-coding-string contents coding-system)) + (setq buffer-file-coding-system + (if (boundp 'last-coding-system-used) + (symbol-value 'last-coding-system-used) + coding-system))) + (mm-disable-multibyte) + (insert contents) + (setq buffer-file-coding-system mm-binary-coding-system)) ;; We do it this way to make `normal-mode' set the appropriate mode. (unwind-protect (progn - (setq buffer-file-name (expand-file-name base)) - (gnus-mime-jka-compr-maybe-uncompress) + (setq buffer-file-name (expand-file-name filename)) (normal-mode)) (setq buffer-file-name nil)) (goto-char (point-min))))) @@ -4570,22 +4873,37 @@ are decompressed." (ps-despool filename))))) (defun gnus-mime-inline-part (&optional handle arg) - "Insert the MIME part under point into the current buffer." + "Insert the MIME part under point into the current buffer. +Compressed files like .gz and .bz2 are decompressed." (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - contents charset - (b (point)) - (inhibit-read-only t)) - (when handle + (unless handle + (setq handle (get-text-property (point) 'gnus-data))) + (when handle + (let ((b (point)) + (inhibit-read-only t) + contents charset coding-system) (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) - (setq contents (mm-get-part handle)) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (setq contents + (or (mm-decompress-buffer + (or (mail-content-type-get (mm-handle-type handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename)) + nil t) + (buffer-string)))) (cond ((not arg) - (setq charset (or (mail-content-type-get - (mm-handle-type handle) 'charset) - gnus-newsgroup-charset))) + (unless (setq charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + (unless (setq coding-system + (mm-with-unibyte-buffer + (insert contents) + (mm-find-buffer-file-coding-system))) + (setq charset gnus-newsgroup-charset)))) ((numberp arg) (if (mm-handle-undisplayer handle) (mm-remove-part handle)) @@ -4599,11 +4917,12 @@ are decompressed." (forward-line 2) (mm-insert-inline handle - (if (and charset - (setq charset (mm-charset-to-coding-system - charset)) - (not (eq charset 'ascii))) - (mm-decode-coding-string contents charset) + (if (or coding-system + (and charset + (setq coding-system + (mm-charset-to-coding-system charset)) + (not (eq coding-system 'ascii)))) + (mm-decode-coding-string contents coding-system) (mm-string-to-multibyte contents))) (goto-char b))))) @@ -4632,12 +4951,15 @@ specified charset." (gnus-newsgroup-ignored-charsets 'gnus-all) gnus-newsgroup-charset form preferred parts) (when handle - (if (mm-handle-undisplayer handle) - (mm-remove-part handle)) - (when fun - (setq gnus-newsgroup-charset - (or (cdr (assq arg gnus-summary-show-article-charset-alist)) - (mm-read-coding-system "Charset: "))) + (when (prog1 + (and fun + (setq gnus-newsgroup-charset + (or (cdr (assq + arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: ")))) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle))) (gnus-mime-strip-charset-parameters handle) (when (and (consp (setq form (cdr-safe fun))) (setq form (ignore-errors @@ -4710,64 +5032,152 @@ If no internal viewer is available, use an external viewer." (if action-pair (funcall (cdr action-pair))))) -(defun gnus-article-part-wrapper (n function) - (let ((window (get-buffer-window gnus-article-buffer 'visible)) - frame) - (when window - ;; It is necessary to select the article window so that - ;; `gnus-article-goto-part' may really move the point. - (setq frame (selected-frame)) - (gnus-select-frame-set-input-focus (window-frame window)) - (unwind-protect - (save-window-excursion - (select-window window) - (when (> n (length gnus-article-mime-handle-alist)) - (error "No such part")) - (gnus-article-goto-part n) - (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) - (funcall function handle))) - (gnus-select-frame-set-input-focus frame))))) +(defun gnus-article-part-wrapper (n function &optional no-handle interactive) + "Call FUNCTION on MIME part N. +Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument. +If INTERACTIVE, call FUNCTION interactivly." + (let (window frame) + ;; Check whether the article is displayed. + (unless (and (gnus-buffer-live-p gnus-article-buffer) + (setq window (get-buffer-window gnus-article-buffer t)) + (frame-visible-p (setq frame (window-frame window)))) + (error "No article is displayed")) + (with-current-buffer gnus-article-buffer + ;; Check whether the article displays the right contents. + (unless (with-current-buffer gnus-summary-buffer + (eq gnus-current-article (gnus-summary-article-number))) + (error "You should select the right article first")) + (if n + (setq n (prefix-numeric-value n)) + (let ((pt (point))) + (setq n (or (get-text-property pt 'gnus-part) + (and (not (bobp)) + (get-text-property (1- pt) 'gnus-part)) + (get-text-property (prog2 + (forward-line 1) + (point) + (goto-char pt)) + 'gnus-part) + (get-text-property + (or (and (setq pt (previous-single-property-change + pt 'gnus-part)) + (1- pt)) + (next-single-property-change (point) 'gnus-part) + (point)) + 'gnus-part) + 1)))) + ;; Check whether the specified part exists. + (when (> n (length gnus-article-mime-handle-alist)) + (error "No such part"))) + (unless + (progn + ;; To select the window is needed so that the cursor + ;; might be visible on the MIME button. + (select-window (prog1 + window + (setq window (selected-window)) + ;; Article may be displayed in the other frame. + (gnus-select-frame-set-input-focus + (prog1 + frame + (setq frame (selected-frame)))))) + (when (gnus-article-goto-part n) + ;; We point the cursor and the arrow at the MIME button + ;; when the `function' prompt the user for something. + (let ((cursor-in-non-selected-windows t) + (overlay-arrow-string "=>") + (overlay-arrow-position (point-marker))) + (unwind-protect + (cond + ((and no-handle interactive) + (call-interactively function)) + (no-handle + (funcall function)) + (interactive + (call-interactively + function + (cdr (assq n gnus-article-mime-handle-alist)))) + (t + (funcall function + (cdr (assq n gnus-article-mime-handle-alist))))) + (set-marker overlay-arrow-position nil) + (unless gnus-auto-select-part + (gnus-select-frame-set-input-focus frame) + (select-window window)))) + t)) + (if gnus-inhibit-mime-unbuttonizing + ;; This is the default though the program shouldn't reach here. + (error "No such part") + ;; The part which doesn't have the MIME button is selected. + ;; So, we display all the buttons and redo it. + (let ((gnus-inhibit-mime-unbuttonizing t)) + (gnus-summary-show-article) + (gnus-article-part-wrapper n function no-handle)))))) (defun gnus-article-pipe-part (n) "Pipe MIME part N, which is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'mm-pipe-part)) (defun gnus-article-save-part (n) "Save MIME part N, which is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'mm-save-part)) (defun gnus-article-interactively-view-part (n) "View MIME part N interactively, which is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'mm-interactively-view-part)) (defun gnus-article-copy-part (n) "Copy MIME part N, which is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'gnus-mime-copy-part)) (defun gnus-article-view-part-as-charset (n) "View MIME part N using a specified charset. N is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) (defun gnus-article-view-part-externally (n) "View MIME part N externally, which is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'gnus-mime-view-part-externally)) (defun gnus-article-inline-part (n) "Inline MIME part N, which is the numerical prefix." - (interactive "p") + (interactive "P") (gnus-article-part-wrapper n 'gnus-mime-inline-part)) +(defun gnus-article-save-part-and-strip (n) + "Save MIME part N and replace it with an external body. +N is the numerical prefix." + (interactive "P") + (gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t)) + +(defun gnus-article-replace-part (n) + "Replace MIME part N with an external body. +N is the numerical prefix." + (interactive "P") + (gnus-article-part-wrapper n 'gnus-mime-replace-part t t)) + +(defun gnus-article-delete-part (n) + "Delete MIME part N and add some information about the removed part. +N is the numerical prefix." + (interactive "P") + (gnus-article-part-wrapper n 'gnus-mime-delete-part t)) + +(defun gnus-article-view-part-as-type (n) + "Choose a MIME media type, and view part N as such. +N is the numerical prefix." + (interactive "P") + (gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t)) + (defun gnus-article-mime-match-handle-first (condition) (if condition - (let ((alist gnus-article-mime-handle-alist) ihandle n) - (while (setq ihandle (pop alist)) + (let (n) + (dolist (ihandle gnus-article-mime-handle-alist) (if (and (cond ((functionp condition) (funcall condition (cdr ihandle))) @@ -4787,8 +5197,7 @@ N is the numerical prefix." (defun gnus-article-view-part (&optional n) "View MIME part N, which is the numerical prefix." (interactive "P") - (save-current-buffer - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (or (numberp n) (setq n (gnus-article-mime-match-handle-first gnus-article-mime-match-handle-function))) (when (> n (length gnus-article-mime-handle-alist)) @@ -4816,8 +5225,7 @@ N is the numerical prefix." (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (if (gnus-buffer-live-p gnus-summary-buffer) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer gnus-newsgroup-ignored-charsets) nil))) (save-excursion @@ -4885,15 +5293,18 @@ N is the numerical prefix." (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist - `(,@(gnus-local-map-property gnus-mime-button-map) - gnus-callback gnus-mm-display-part - gnus-part ,gnus-tmp-id - article-type annotation - gnus-data ,handle)) + `(keymap ,gnus-mime-button-map + gnus-callback gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) (setq e (if (bolp) ;; Exclude a newline. (1- (point)) (point))) + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button 'link b e :mime-handle handle @@ -5121,8 +5532,9 @@ If displaying \"text/html\" is discouraged \(see (gnus-article-insert-newline) (mm-insert-inline handle - (let ((charset (mail-content-type-get (mm-handle-type handle) - 'charset))) + (let ((charset (or (mail-content-type-get (mm-handle-type handle) + 'charset) + (and (equal type "text/calendar") 'utf-8)))) (cond ((not charset) (mm-string-as-multibyte (mm-get-part handle))) ((eq charset 'gnus-decoded) @@ -5135,10 +5547,21 @@ If displaying \"text/html\" is discouraged \(see (save-excursion (save-restriction (narrow-to-region beg (point)) - (gnus-treat-article - nil id - (gnus-article-mime-total-parts) - (mm-handle-media-type handle))))))))) + (if (eq handle gnus-article-mime-handles) + ;; The format=flowed case. + (gnus-treat-article nil 1 1 (mm-handle-media-type handle)) + ;; Don't count signature parts that are never displayed. + ;; The part number should be re-calculated supposing this + ;; might be a message/rfc822 part. + (let (handles) + (dolist (part gnus-article-mime-handles) + (unless (or (stringp part) + (equal (car (mm-handle-type part)) + "application/pgp-signature")) + (push part handles))) + (gnus-treat-article + nil (length (memq handle handles)) (length handles) + (mm-handle-media-type handle))))))))))) (defun gnus-unbuttonized-mime-type-p (type) "Say whether TYPE is to be unbuttonized." @@ -5195,7 +5618,7 @@ If displaying \"text/html\" is discouraged \(see ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',not-pref ',begend ,id)) - ,@(gnus-local-map-property gnus-mime-button-map) + keymap ,gnus-mime-button-map ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id @@ -5219,7 +5642,7 @@ If displaying \"text/html\" is discouraged \(see ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',handle ',begend ,id)) - ,@(gnus-local-map-property gnus-mime-button-map) + keymap ,gnus-mime-button-map ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id @@ -5234,8 +5657,8 @@ If displaying \"text/html\" is discouraged \(see (gnus-display-mime preferred) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (mm-display-part preferred) ;; Do highlighting. (save-excursion @@ -5285,8 +5708,7 @@ is the string to use when it is inactive.") (defun gnus-article-wash-status () "Return a string which display status of article washing." - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((cite (memq 'cite gnus-article-wash-types)) (headers (memq 'headers gnus-article-wash-types)) (boring (memq 'boring-headers gnus-article-wash-types)) @@ -5335,8 +5757,8 @@ is the string to use when it is inactive.") "Hide unwanted headers if `gnus-have-all-headers' is nil. Provided for backwards compatibility." (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer)) - (not (save-excursion (set-buffer gnus-summary-buffer) - gnus-have-all-headers))) + (not (with-current-buffer gnus-summary-buffer + gnus-have-all-headers))) (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) @@ -5471,10 +5893,16 @@ If end of article, return non-nil. Otherwise return nil. Argument LINES specifies lines to be scrolled up." (interactive "p") (move-to-window-line -1) - (if (save-excursion - (end-of-line) - (and (pos-visible-in-window-p) ;Not continuation line. - (>= (1+ (point)) (point-max)))) ;Allow for trailing newline. + (if (and (not (and gnus-article-over-scroll + (> (count-lines (window-start) (point-max)) + (+ (or lines (1- (window-height))) + (or (and (boundp 'scroll-margin) + (symbol-value 'scroll-margin)) + 0))))) + (save-excursion + (end-of-line) + (and (pos-visible-in-window-p) ;Not continuation line. + (>= (1+ (point)) (point-max))))) ;Allow for trailing newline. ;; Nothing in this page. (if (or (not gnus-page-broken) (save-excursion @@ -5502,9 +5930,7 @@ specifies." (min (max 0 scroll-margin) (max 1 (- (window-height) (if mode-line-format 1 0) - (if (and (boundp 'header-line-format) - (symbol-value 'header-line-format)) - 1 0))))))) + (if header-line-format 1 0))))))) (defun gnus-article-next-page-1 (lines) (when (and (not (featurep 'xemacs)) @@ -5536,7 +5962,14 @@ Argument LINES specifies lines to be scrolled down." (progn (gnus-narrow-to-page -1) ;Go to previous page. (goto-char (point-max)) - (recenter -1)) + (recenter (if gnus-article-over-scroll + (if lines + (max (+ lines (or (and (boundp 'scroll-margin) + (symbol-value 'scroll-margin)) + 0)) + 3) + (- (window-height) 2)) + -1))) (prog1 (condition-case () (let ((scroll-in-place nil)) @@ -5567,9 +6000,9 @@ not have a face in `gnus-article-boring-faces'." "Read article specified by message-id around point." (interactive) (save-excursion - (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t) - (re-search-forward "<?news:<?\\|<" (gnus-point-at-eol) t) - (if (re-search-forward "[^@ ]+@[^ \t>]+" (gnus-point-at-eol) t) + (re-search-backward "[ \t]\\|^" (point-at-bol) t) + (re-search-forward "<?news:<?\\|<" (point-at-eol) t) + (if (re-search-forward "[^@ ]+@[^ \t>]+" (point-at-eol) t) (let ((msg-id (concat "<" (match-string 0) ">"))) (set-buffer gnus-summary-buffer) (gnus-summary-refer-article msg-id)) @@ -5641,64 +6074,94 @@ not have a face in `gnus-article-boring-faces'." (message "") - (if (or (member keys nosaves) - (member keys nosave-but-article) - (member keys nosave-in-article)) - (let (func) - (save-window-excursion - (pop-to-buffer gnus-article-current-summary) - ;; We disable the pick minor mode commands. - (let (gnus-pick-mode) - (setq func (lookup-key (current-local-map) keys)))) - (if (or (not func) - (numberp func)) - (ding) - (unless (member keys nosave-in-article) - (set-buffer gnus-article-current-summary)) - (call-interactively func) - (setq new-sum-point (point))) - (when (member keys nosave-but-article) - (pop-to-buffer gnus-article-buffer))) + (cond + ((eq (aref keys (1- (length keys))) ?\C-h) + (with-current-buffer gnus-article-current-summary + (describe-bindings (substring keys 0 -1)))) + ((or (member keys nosaves) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-article-current-summary) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (or (not func) + (numberp func)) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-article-current-summary)) + (call-interactively func) + (setq new-sum-point (point))) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer)))) + (t ;; These commands should restore window configuration. (let ((obuf (current-buffer)) (owin (current-window-configuration)) - (opoint (point)) - win func in-buffer selected new-sum-start new-sum-hscroll) + win func in-buffer selected new-sum-start new-sum-hscroll err) (cond (not-restore-window - (pop-to-buffer gnus-article-current-summary)) + (pop-to-buffer gnus-article-current-summary) + (setq win (selected-window))) ((setq win (get-buffer-window gnus-article-current-summary)) (select-window win)) (t - (switch-to-buffer gnus-article-current-summary 'norecord))) + (let ((summary-buffer gnus-article-current-summary)) + (gnus-configure-windows 'article) + (unless (setq win (get-buffer-window summary-buffer 'visible)) + (let ((gnus-buffer-configuration + '(article ((vertical 1.0 + (summary 0.25 point) + (article 1.0)))))) + (gnus-configure-windows 'article)) + (setq win (get-buffer-window summary-buffer 'visible))) + (gnus-select-frame-set-input-focus (window-frame win)) + (select-window win)))) (setq in-buffer (current-buffer)) ;; We disable the pick minor mode commands. (if (and (setq func (let (gnus-pick-mode) (lookup-key (current-local-map) keys))) - (functionp func)) + (functionp func) + (condition-case code + (progn + (call-interactively func) + t) + (error + (setq err code) + nil))) (progn - (call-interactively func) (when (eq win (selected-window)) (setq new-sum-point (point) new-sum-start (window-start win) new-sum-hscroll (window-hscroll win))) - (when (eq in-buffer (current-buffer)) + (when (or (eq in-buffer (current-buffer)) + (when (eq obuf (current-buffer)) + (set-buffer in-buffer) + t)) (setq selected (gnus-summary-select-article)) (set-buffer obuf) (unless not-restore-window (set-window-configuration owin)) - (when (eq selected 'old) - (article-goto-body) + (when (and (eq selected 'old) + new-sum-point) (set-window-start (get-buffer-window (current-buffer)) 1) (set-window-point (get-buffer-window (current-buffer)) - (point))) + (if (article-goto-body) + (1- (point)) + (point)))) (when (and (not not-restore-window) - new-sum-point) + new-sum-point + (with-current-buffer (window-buffer win) + (eq major-mode 'gnus-summary-mode))) (set-window-point win new-sum-point) (set-window-start win new-sum-start) (set-window-hscroll win new-sum-hscroll)))) (set-window-configuration owin) - (ding)))))) + (if err + (signal (car err) (cdr err)) + (ding)))))))) (defun gnus-article-describe-key (key) "Display documentation of the function invoked by KEY. KEY is a string." @@ -5868,16 +6331,14 @@ If given a prefix, show the hidden text instead." gnus-summary-buffer (get-buffer gnus-summary-buffer) (gnus-buffer-exists-p gnus-summary-buffer) - (eq (cdr (save-excursion - (set-buffer gnus-summary-buffer) + (eq (cdr (with-current-buffer gnus-summary-buffer (assq article gnus-newsgroup-reads))) gnus-canceled-mark)) nil) ;; We first check `gnus-original-article-buffer'. ((and (get-buffer gnus-original-article-buffer) (numberp article) - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (and (equal (car gnus-original-article) group) (eq (cdr gnus-original-article) article)))) (insert-buffer-substring gnus-original-article-buffer) @@ -5995,7 +6456,6 @@ If given a prefix, show the hidden text instead." (defvar gnus-article-edit-done-function nil) (defvar gnus-article-edit-mode-map nil) -(defvar gnus-article-edit-mode nil) ;; Should we be using derived.el for this? (unless gnus-article-edit-mode-map @@ -6095,7 +6555,7 @@ groups." ,(or (mail-header-references gnus-current-headers) "") ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) -(defun gnus-article-edit-article (start-func exit-func) +(defun gnus-article-edit-article (start-func exit-func &optional quiet) "Start editing the contents of the current article buffer." (let ((winconf (current-window-configuration))) (set-buffer gnus-article-buffer) @@ -6108,7 +6568,8 @@ groups." (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) - (gnus-message 6 "C-c C-c to end edits"))) + (unless quiet + (gnus-message 6 "C-c C-c to end edits")))) (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." @@ -6135,7 +6596,7 @@ groups." (car gnus-article-current) (cdr gnus-article-current))) ;; We remove all text props from the article buffer. (kill-all-local-variables) - (gnus-set-text-properties (point-min) (point-max) nil) + (set-text-properties (point-min) (point-max) nil) (gnus-article-mode) (set-window-configuration winconf) (set-buffer buf) @@ -6183,9 +6644,24 @@ groups." ;;; Internal Variables: (defcustom gnus-button-url-regexp - (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") + (concat + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" + "\\(//[-a-z0-9_.]+:[0-9]*\\)?" + (if (string-match "[[:digit:]]" "1") ;; Support POSIX? + (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") + (punct "!?:;.,")) + (concat + "\\(?:" + ;; Match paired parentheses, e.g. in Wikipedia URLs: + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "\\|" + "[" chars punct "]+" "[" chars "]" + "\\)")) + (concat ;; XEmacs 21.4 doesn't support POSIX. + "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+" + "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)")) + "\\)") "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) @@ -6314,6 +6790,7 @@ must return `mid', `mail', `invalid' or `ask'." (-20.0 . "\\.fsf@") ;; Gnus (-20.0 . "^slrn") (-20.0 . "^Pine") + (-20.0 . "^alpine\\.") (-20.0 . "_-_") ;; Subject change in thread ;; (-20.0 . "\\.ln@") ;; leafnode @@ -6437,9 +6914,14 @@ address, `ask' if unsure and `invalid' if the string is invalid." (gnus-url-mailto url-mailto)) (t (gnus-message 3 "Invalid string."))))) -(defun gnus-button-handle-custom (url) - "Follow a Custom URL." - (customize-apropos (gnus-url-unhex-string url))) +(defun gnus-button-handle-custom (fun arg) + "Call function FUN on argument ARG. +Both FUN and ARG are supposed to be strings. ARG will be passed +as a symbol to FUN." + (funcall (intern fun) + (if (string-match "^customize-apropos" fun) + arg + (intern arg)))) (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)") @@ -6583,6 +7065,8 @@ positives are possible." 0 (>= gnus-button-message-level 0) gnus-button-message-id 2) ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) + ("\\b\\(mid\\|message-id\\):? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" + 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 (>= gnus-button-message-level 0) gnus-url-mailto 2) ;; RFC 2368 (The mailto URL scheme) @@ -6619,10 +7103,8 @@ positives are possible." ;; Info links like `C-h i d m CC Mode RET' 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) ;; This is custom - ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" - 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2) - ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 - (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1) + ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 + (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2) ;; Emacs help commands ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" ;; regexp doesn't match arguments containing ` '. @@ -6640,7 +7122,7 @@ positives are possible." 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) ("`\\([a-z][-a-z0-9]+\\.el\\)'" 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) - ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" + ("`\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)'" 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) @@ -6657,13 +7139,10 @@ positives are possible." ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... - ("<URL: *\\([^<>]*\\)>" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; RFC 2396 (2.4.3., delims) ... - ("\"URL: *\\([^\"]*\\)\"" + ("<URL: *\\([^\n<>]*\\)>" 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; RFC 2396 (2.4.3., delims) ... - ("\"URL: *\\([^\"]*\\)\"" + ("\"URL: *\\([^\n\"]*\\)\"" 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; Raw URLs. (gnus-button-url-regexp @@ -6680,6 +7159,13 @@ positives are possible." ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W" 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) + ;; Recognizing patches to .el files. This is somewhat obscure, + ;; but considering the percentage of Gnus users who hack Emacs + ;; Lisp files... + ("^--- \\([^ .]+\\.el\\).*\n.*\n@@ -?\\([0-9]+\\)" 1 + (>= gnus-button-message-level 4) gnus-button-patch 1 2) + ("^\\*\\*\\* \\([^ .]+\\.el\\).*\n.*\n\\*+\n\\*\\*\\* \\([0-9]+\\)" 1 + (>= gnus-button-message-level 4) gnus-button-patch 1 2) ;; MID or mail: To avoid too many false positives we don't try to catch ;; all kind of allowed MIDs or mail addresses. Domain part must contain ;; at least one dot. TLD must contain two or three chars or be a know TLD @@ -6708,6 +7194,7 @@ variable it the real callback function." (repeat :tag "Par" :inline t (integer :tag "Regexp group"))))) +(put 'gnus-button-alist 'risky-local-variable t) (defcustom gnus-header-button-alist '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" @@ -6722,6 +7209,8 @@ variable it the real callback function." 0 (>= gnus-button-browse-level 0) browse-url 0) ("^[^:]+:" gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^OpenPGP:.*url=" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0) ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" @@ -6745,6 +7234,7 @@ HEADER is a regexp to match a header. For a fuller explanation, see (repeat :tag "Par" :inline t (integer :tag "Regexp group"))))) +(put 'gnus-header-button-alist 'risky-local-variable t) ;;; Commands: @@ -6797,55 +7287,46 @@ do the highlighting. See the documentation for those functions." (defun gnus-article-highlight-headers () "Highlight article headers as specified by `gnus-header-face-alist'." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((alist gnus-header-face-alist) - (inhibit-read-only t) - (case-fold-search t) - (inhibit-point-motion-hooks t) - entry regexp header-face field-face from hpoints fpoints) - (article-narrow-to-head) - (while (setq entry (pop alist)) - (goto-char (point-min)) - (setq regexp (concat "^\\(" - (if (string-equal "" (nth 0 entry)) - "[^\t ]" - (nth 0 entry)) - "\\)") - header-face (nth 1 entry) - field-face (nth 2 entry)) - (while (and (re-search-forward regexp nil t) - (not (eobp))) - (beginning-of-line) - (setq from (point)) - (unless (search-forward ":" nil t) - (forward-char 1)) - (when (and header-face - (not (memq (point) hpoints))) - (push (point) hpoints) - (gnus-put-text-property from (point) 'face header-face)) - (when (and field-face - (not (memq (setq from (point)) fpoints))) - (push from fpoints) - (if (re-search-forward "^[^ \t]" nil t) - (forward-char -2) - (goto-char (point-max))) - (gnus-put-text-property from (point) 'face field-face)))))))) + (gnus-with-article-headers + (let (regexp header-face field-face from hpoints fpoints) + (dolist (entry gnus-header-face-alist) + (goto-char (point-min)) + (setq regexp (concat "^\\(" + (if (string-equal "" (nth 0 entry)) + "[^\t ]" + (nth 0 entry)) + "\\)") + header-face (nth 1 entry) + field-face (nth 2 entry)) + (while (and (re-search-forward regexp nil t) + (not (eobp))) + (beginning-of-line) + (setq from (point)) + (unless (search-forward ":" nil t) + (forward-char 1)) + (when (and header-face + (not (memq (point) hpoints))) + (push (point) hpoints) + (gnus-put-text-property from (point) 'face header-face)) + (when (and field-face + (not (memq (setq from (point)) fpoints))) + (push from fpoints) + (if (re-search-forward "^[^ \t]" nil t) + (forward-char -2) + (goto-char (point-max))) + (gnus-put-text-property from (point) 'face field-face))))))) (defun gnus-article-highlight-signature () "Highlight the signature in an article. It does this by highlighting everything after `gnus-signature-separator' using the face `gnus-signature'." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t)) + (gnus-with-article-buffer + (let ((inhibit-point-motion-hooks t)) (save-restriction (when (and gnus-signature-face (gnus-article-narrow-to-signature)) - (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) + (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t) 'face gnus-signature-face) (widen) (gnus-article-search-signature) @@ -6863,10 +7344,8 @@ It does this by highlighting everything after \"External references\" are things like Message-IDs and URLs, as specified by `gnus-button-alist'." (interactive (list 'force)) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t) + (gnus-with-article-buffer + (let ((inhibit-point-motion-hooks t) (case-fold-search t) (alist gnus-button-alist) beg entry regexp) @@ -6889,65 +7368,116 @@ specified by `gnus-button-alist'." (setq regexp (eval (car entry))) (goto-char beg) (while (re-search-forward regexp nil t) - (let* ((start (and entry (match-beginning (nth 1 entry)))) - (end (and entry (match-end (nth 1 entry)))) - (from (match-beginning 0))) + (let ((start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (from (match-beginning 0))) (when (and (or (eq t (nth 2 entry)) (eval (nth 2 entry))) (not (gnus-button-in-region-p start end 'gnus-callback))) ;; That optional form returned non-nil, so we add the ;; button. - (gnus-article-add-button - start end 'gnus-button-push - (car (push (set-marker (make-marker) from) - gnus-button-marker-list)))))))))) + (setq from (set-marker (make-marker) from)) + (push from gnus-button-marker-list) + (unless (and (eq (car entry) 'gnus-button-url-regexp) + (gnus-article-extend-url-button from start end)) + (gnus-article-add-button start end + 'gnus-button-push from))))))))) + +(defun gnus-article-extend-url-button (beg start end) + "Extend url button if url is folded into two or more lines. +Return non-nil if button is extended. BEG is a marker that points to +the beginning position of a text containing url. START and END are +the endpoints of a url button before it is extended. The concatenated +url is put as the `gnus-button-url' overlay property on the button." + (let ((opoint (point)) + (points (list start end)) + url delim regexp) + (prog1 + (when (and (progn + (goto-char end) + (not (looking-at "[\t ]*[\">]"))) + (progn + (goto-char start) + (string-match + "\\(?:\"\\|\\(<\\)\\)[\t ]*\\(?:url[\t ]*:[\t ]*\\)?\\'" + (buffer-substring (point-at-bol) start))) + (progn + (setq url (list (buffer-substring start end)) + delim (if (match-beginning 1) ">" "\"")) + (beginning-of-line) + (setq regexp (concat + (when (and (looking-at + message-cite-prefix-regexp) + (< (match-end 0) start)) + (regexp-quote (match-string 0))) + "\ +\[\t ]*\\(?:\\([^\t\n \">]+\\)[\t ]*$\\|\\([^\t\n \">]*\\)[\t ]*" + delim "\\)")) + (while (progn + (forward-line 1) + (and (looking-at regexp) + (prog1 + (match-beginning 1) + (push (or (match-string 2) + (match-string 1)) + url) + (push (setq end (or (match-end 2) + (match-end 1))) + points) + (push (or (match-beginning 2) + (match-beginning 1)) + points))))) + (match-beginning 2))) + (let (gnus-article-mouse-face widget-mouse-face) + (while points + (gnus-article-add-button (pop points) (pop points) + 'gnus-button-push beg))) + (let ((overlay (gnus-make-overlay start end))) + (gnus-overlay-put overlay 'evaporate t) + (gnus-overlay-put overlay 'gnus-button-url + (list (mapconcat 'identity (nreverse url) ""))) + (when gnus-article-mouse-face + (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face))) + t) + (goto-char opoint)))) ;; Add buttons to the head of an article. (defun gnus-article-add-buttons-to-head () "Add buttons to the head of the article." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist gnus-header-button-alist) - entry beg end) - (article-narrow-to-head) - (while alist - ;; Each alist entry. - (setq entry (car alist) - alist (cdr alist)) - (goto-char (point-min)) - (while (re-search-forward (car entry) nil t) - ;; Each header matching the entry. - (setq beg (match-beginning 0)) - (setq end (or (and (re-search-forward "^[^ \t]" nil t) - (match-beginning 0)) - (point-max))) - (goto-char beg) - (while (re-search-forward (eval (nth 1 entry)) end t) - ;; Each match within a header. - (let* ((entry (cdr entry)) - (start (match-beginning (nth 1 entry))) - (end (match-end (nth 1 entry))) - (form (nth 2 entry))) - (goto-char (match-end 0)) - (when (eval form) - (gnus-article-add-button - start end (nth 3 entry) - (buffer-substring (match-beginning (nth 4 entry)) - (match-end (nth 4 entry))))))) - (goto-char end))))))) + (gnus-with-article-headers + (let (beg end) + (dolist (entry gnus-header-button-alist) + ;; Each alist entry. + (goto-char (point-min)) + (while (re-search-forward (car entry) nil t) + ;; Each header matching the entry. + (setq beg (match-beginning 0)) + (setq end (or (and (re-search-forward "^[^ \t]" nil t) + (match-beginning 0)) + (point-max))) + (goto-char beg) + (while (re-search-forward (eval (nth 1 entry)) end t) + ;; Each match within a header. + (let* ((entry (cdr entry)) + (start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (form (nth 2 entry))) + (goto-char (match-end 0)) + (when (eval form) + (gnus-article-add-button + start end (nth 3 entry) + (buffer-substring (match-beginning (nth 4 entry)) + (match-end (nth 4 entry))))))) + (goto-char end)))))) ;;; External functions: (defun gnus-article-add-button (from to fun &optional data) "Create a button between FROM and TO with callback FUN and data DATA." (when gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay from to) + (gnus-overlay-put (gnus-make-overlay from to nil t) 'face gnus-article-button-face)) (gnus-add-text-properties from to @@ -6961,15 +7491,12 @@ specified by `gnus-button-alist'." ;;; Internal functions: (defun gnus-article-set-globals () - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-set-global-variables))) (defun gnus-signature-toggle (end) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((inhibit-read-only t) - (inhibit-point-motion-hooks t)) + (gnus-with-article-buffer + (let ((inhibit-point-motion-hooks t)) (if (text-property-any end (point-max) 'article-type 'signature) (progn (gnus-delete-wash-type 'signature) @@ -7003,12 +7530,14 @@ specified by `gnus-button-alist'." (let* ((entry (gnus-button-entry)) (inhibit-point-motion-hooks t) (fun (nth 3 entry)) - (args (mapcar (lambda (group) - (let ((string (match-string group))) - (gnus-set-text-properties - 0 (length string) nil string) - string)) - (nthcdr 4 entry)))) + (args (or (and (eq (car entry) 'gnus-button-url-regexp) + (get-char-property marker 'gnus-button-url)) + (mapcar (lambda (group) + (let ((string (match-string group))) + (set-text-properties + 0 (length string) nil string) + string)) + (nthcdr 4 entry))))) (cond ((fboundp fun) (apply fun args)) @@ -7066,6 +7595,15 @@ specified by `gnus-button-alist'." (group (gnus-button-fetch-group url))))) +(defun gnus-button-patch (library line) + "Visit an Emacs Lisp library LIBRARY on line LINE." + (interactive) + (let ((file (locate-library (file-name-nondirectory library)))) + (unless file + (error "Couldn't find library %s" library)) + (find-file file) + (goto-line (string-to-number line)))) + (defun gnus-button-handle-man (url) "Fetch a man page." (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) @@ -7115,14 +7653,25 @@ specified by `gnus-button-alist'." (Info-directory) (Info-menu url)) +(defun gnus-button-openpgp (url) + "Retrieve and add an OpenPGP key given URL from an OpenPGP header." + (with-temp-buffer + (mm-url-insert-file-contents-external url) + (pgg-snarf-keys-region (point-min) (point-max)) + (pgg-display-output-buffer nil nil nil))) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-refer-article message-id))) -(defun gnus-button-fetch-group (address) +(defun gnus-button-fetch-group (address &rest ignore) "Fetch GROUP specified by ADDRESS." + (when (string-match "\\`\\(nntp\\|news\\):\\(//\\)?\\(.*\\)\\'" + address) + ;; Allow to use `gnus-button-fetch-group' in `browse-url-browser-function' + ;; for nntp:// and news:// + (setq address (match-string 3 address))) (if (not (string-match "[:/]" address)) ;; This is just a simple group url. (gnus-group-read-ephemeral-group address gnus-select-method) @@ -7198,9 +7747,6 @@ specified by `gnus-button-alist'." (defvar gnus-prev-page-map (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-button-prev-page) (define-key map "\r" 'gnus-button-prev-page) map)) @@ -7215,19 +7761,23 @@ specified by `gnus-button-alist'." map)) (defun gnus-insert-prev-page-button () - (let ((b (point)) + (let ((b (point)) e (inhibit-read-only t)) (gnus-eval-format gnus-prev-page-line-format nil - `(,@(gnus-local-map-property gnus-prev-page-map) - gnus-prev t - gnus-callback gnus-article-button-prev-page - article-type annotation)) + `(keymap ,gnus-prev-page-map + gnus-prev t + gnus-callback gnus-article-button-prev-page + article-type annotation)) + (setq e (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point))) + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button - 'link b (if (bolp) - ;; Exclude a newline. - (1- (point)) - (point)) + 'link b e :action 'gnus-button-prev-page :button-keymap gnus-prev-page-map))) @@ -7248,18 +7798,22 @@ specified by `gnus-button-alist'." (select-window win))) (defun gnus-insert-next-page-button () - (let ((b (point)) + (let ((b (point)) e (inhibit-read-only t)) (gnus-eval-format gnus-next-page-line-format nil - `(,@(gnus-local-map-property gnus-next-page-map) - gnus-next t - gnus-callback gnus-article-button-next-page - article-type annotation)) + `(keymap ,gnus-next-page-map + gnus-next t + gnus-callback gnus-article-button-next-page + article-type annotation)) + (setq e (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point))) + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button - 'link b (if (bolp) - ;; Exclude a newline. - (1- (point)) - (point)) + 'link b e :action 'gnus-button-next-page :button-keymap gnus-next-page-map))) @@ -7302,14 +7856,13 @@ For example: (eq gnus-newsgroup-name (car gnus-decode-header-methods-cache))) (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) - (mapcar (lambda (x) - (if (symbolp x) - (nconc gnus-decode-header-methods-cache (list x)) - (if (and gnus-newsgroup-name - (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-header-methods-cache - (list (cdr x)))))) - gnus-decode-header-methods)) + (dolist (x gnus-decode-header-methods) + (if (symbolp x) + (nconc gnus-decode-header-methods-cache (list x)) + (if (and gnus-newsgroup-name + (string-match (car x) gnus-newsgroup-name)) + (nconc gnus-decode-header-methods-cache + (list (cdr x))))))) (let ((xlist gnus-decode-header-methods-cache)) (pop xlist) (save-restriction @@ -7385,6 +7938,8 @@ For example: t) ((eq val 'head) nil) + ((eq val 'first) + (eq part-number 1)) ((eq val 'last) (eq part-number total-parts)) ((numberp val) @@ -7485,14 +8040,51 @@ For example: (?d gnus-tmp-details ?s) (?D gnus-tmp-pressed-details ?s))) +(defvar gnus-mime-security-button-commands + '((gnus-article-press-button "\r" "Show Detail") + (undefined "v") + (undefined "t") + (undefined "C") + (gnus-mime-security-save-part "o" "Save...") + (undefined "\C-o") + (undefined "r") + (undefined "d") + (undefined "c") + (undefined "i") + (undefined "E") + (undefined "e") + (undefined "p") + (gnus-mime-security-pipe-part "|" "Pipe To Command...") + (undefined "."))) + (defvar gnus-mime-security-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-article-push-button) - (define-key map "\r" 'gnus-article-press-button) + (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu) + (dolist (c gnus-mime-security-button-commands) + (define-key map (cadr c) (car c))) map)) +(easy-menu-define + gnus-mime-security-button-menu gnus-mime-security-button-map + "Security button menu." + `("Security Part" + ,@(delq nil + (mapcar (lambda (c) + (unless (eq (car c) 'undefined) + (vector (caddr c) (car c) :active t))) + gnus-mime-security-button-commands)))) + +(defun gnus-mime-security-button-menu (event prefix) + "Construct a context-sensitive menu of security commands." + (interactive "e\nP") + (save-window-excursion + (let ((pos (event-start event))) + (select-window (posn-window pos)) + (goto-char (posn-point pos)) + (gnus-article-check-buffer) + (popup-menu gnus-mime-security-button-menu nil prefix)))) + (defvar gnus-mime-security-details-buffer nil) (defvar gnus-mime-security-button-pressed nil) @@ -7506,18 +8098,15 @@ For example: point (inhibit-read-only t)) (if region (goto-char (car region))) - (save-restriction - (narrow-to-region (point) (point)) - (with-current-buffer (mm-handle-multipart-original-buffer handle) - (let* ((mm-verify-option 'known) - (mm-decrypt-option 'known) - (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) - (unless (eq nparts (cdr handle)) - (mm-destroy-parts (cdr handle)) - (setcdr handle nparts)))) - (setq point (point)) - (gnus-mime-display-security handle) - (goto-char (point-max))) + (setq point (point)) + (with-current-buffer (mm-handle-multipart-original-buffer handle) + (let* ((mm-verify-option 'known) + (mm-decrypt-option 'known) + (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) + (unless (eq nparts (cdr handle)) + (mm-destroy-parts (cdr handle)) + (setcdr handle nparts)))) + (gnus-mime-display-security handle) (when region (delete-region (point) (cdr region)) (set-marker (car region) nil) @@ -7595,7 +8184,7 @@ For example: (gnus-eval-format gnus-mime-security-button-line-format gnus-mime-security-button-line-format-alist - `(,@(gnus-local-map-property gnus-mime-security-button-map) + `(keymap ,gnus-mime-security-button-map gnus-callback gnus-mime-security-press-button gnus-line-format ,gnus-mime-security-button-line-format gnus-mime-details ,gnus-mime-security-button-pressed @@ -7605,6 +8194,9 @@ For example: ;; Exclude a newline. (1- (point)) (point))) + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay b e nil t) + 'face gnus-article-button-face)) (widget-convert-button 'link b e :mime-handle handle @@ -7617,15 +8209,16 @@ For example: (when (boundp 'help-echo-owns-message) (setq help-echo-owns-message t)) (format - "%S: show detail" - (aref gnus-mouse-2 0)))))) + "%S: show detail; %S: more options" + (aref gnus-mouse-2 0) + (aref gnus-down-mouse-3 0)))))) (defun gnus-mime-display-security (handle) (save-restriction (narrow-to-region (point) (point)) (unless (gnus-unbuttonized-mime-type-p (car handle)) (gnus-insert-mime-security-button handle)) - (gnus-mime-display-mixed (cdr handle)) + (gnus-mime-display-part (cadr handle)) (unless (bolp) (insert "\n")) (unless (gnus-unbuttonized-mime-type-p (car handle)) @@ -7635,7 +8228,36 @@ For example: (mm-set-handle-multipart-parameter handle 'gnus-region (cons (set-marker (make-marker) (point-min)) - (set-marker (make-marker) (point-max)))))) + (set-marker (make-marker) (point-max)))) + (goto-char (point-max)))) + +(defun gnus-mime-security-run-function (function) + "Run FUNCTION with the security part under point." + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-data)) + buffer handle) + (when (and (stringp (car-safe data)) + (setq buffer (mm-handle-multipart-original-buffer data)) + (setq handle (cadr data))) + (if (bufferp (mm-handle-buffer handle)) + (progn + (setq handle (cons buffer (copy-sequence (cdr handle)))) + (mm-handle-set-undisplayer handle nil)) + (setq handle (mm-make-handle + buffer + (mm-handle-multipart-ctl-parameter handle 'protocol) + nil nil nil nil nil nil))) + (funcall function handle)))) + +(defun gnus-mime-security-save-part () + "Save the security part under point." + (interactive) + (gnus-mime-security-run-function 'mm-save-part)) + +(defun gnus-mime-security-pipe-part () + "Pipe the security part under point to a process." + (interactive) + (gnus-mime-security-run-function 'mm-pipe-part)) (gnus-ems-redefine) diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index a06724855c5..65189573da3 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -33,10 +33,6 @@ (require 'gnus-sum) (require 'nntp) -(eval-when-compile - (when (featurep 'xemacs) - (require 'timer-funcs))) - (defgroup gnus-asynchronous nil "Support for asynchronous operations." :group 'gnus) @@ -274,28 +270,29 @@ It should return non-nil if the article is to be prefetched." (nntp-server-buffer (current-buffer)) (nntp-have-messaged nil) (tries 0)) - (condition-case nil - ;; FIXME: we could stop waiting after some - ;; timeout, but this is the wrong place to do it. - ;; rather than checking time-spent-waiting, we - ;; should check time-since-last-output, which - ;; needs to be done in nntp.el. - (while (eq article gnus-async-current-prefetch-article) - (incf tries) - (when (nntp-accept-process-output proc) - (setq tries 0)) - (when (and (not nntp-have-messaged) - (= tries 3)) - (gnus-message 5 "Waiting for async article...") - (setq nntp-have-messaged t))) - (quit - ;; if the user interrupted on a slow/hung connection, - ;; do something friendly. - (when (> tries 3) - (setq gnus-async-current-prefetch-article nil)) - (signal 'quit nil))) - (when nntp-have-messaged - (gnus-message 5 ""))))) + (when proc + (condition-case nil + ;; FIXME: we could stop waiting after some + ;; timeout, but this is the wrong place to do it. + ;; rather than checking time-spent-waiting, we + ;; should check time-since-last-output, which + ;; needs to be done in nntp.el. + (while (eq article gnus-async-current-prefetch-article) + (incf tries) + (when (nntp-accept-process-output proc) + (setq tries 0)) + (when (and (not nntp-have-messaged) + (= tries 3)) + (gnus-message 5 "Waiting for async article...") + (setq nntp-have-messaged t))) + (quit + ;; if the user interrupted on a slow/hung connection, + ;; do something friendly. + (when (> tries 3) + (setq gnus-async-current-prefetch-article nil)) + (signal 'quit nil))) + (when nntp-have-messaged + (gnus-message 5 "")))))) (defun gnus-async-delete-prefetched-entry (entry) "Delete ENTRY from buffer and alist." @@ -311,13 +308,11 @@ It should return non-nil if the article is to be prefetched." "Remove all articles belonging to GROUP from the prefetch buffer." (when (and (gnus-group-asynchronous-p group) (memq 'exit gnus-prefetched-article-deletion-strategy)) - (let ((alist gnus-async-article-alist)) - (save-excursion - (gnus-async-set-buffer) - (while alist - (when (equal group (nth 3 (car alist))) - (gnus-async-delete-prefetched-entry (car alist))) - (pop alist)))))) + (save-excursion + (gnus-async-set-buffer) + (dolist (entry gnus-async-article-alist) + (when (equal group (nth 3 entry)) + (gnus-async-delete-prefetched-entry entry)))))) (defun gnus-async-prefetched-article-entry (group article) "Return the entry for ARTICLE in GROUP if it has been prefetched." diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el new file mode 100644 index 00000000000..1e76e3ac57b --- /dev/null +++ b/lisp/gnus/gnus-bookmark.el @@ -0,0 +1,826 @@ +;;; gnus-bookmark.el --- Bookmarks in Gnus + +;; Copyright (C) 2006 Free Software Foundation, Inc. + +;; Author: Bastien Guerry <bzg AT altern DOT org> +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file implements real bookmarks for Gnus, closely following the way +;; `bookmark.el' handles bookmarks. Most of the code comes from +;; `bookmark.el'. +;; +;; Set a Gnus bookmark: +;; M-x `gnus-bookmark-set' from the summary buffer. +;; +;; Jump to a Gnus bookmark: +;; M-x `gnus-bookmark-jump'. +;; +;; Display a list of bookmarks +;; M-x `gnus-bookmark-bmenu-list'. +;; + +;;; Todo: + +;; - add tags to bookmarks +;; - don't write file each time a bookmark is created +;; - better annotation interactive buffer +;; - edit annotation in gnus-bookmark-bmenu +;; - sort gnus-bookmark-buffer by author/subject/date/group/message-id +;; - auto-bmk-name customizable format +;; - renaming bookmarks in gnus-bookmark-bmenu-list +;; - better (formatted string) display in bmenu-list + +;; - Integrate the `gnus-summary-*-bookmark' functionality +;; - Initialize defcustoms from corresponding `bookmark.el' variables? + +;;; Code: + +(require 'gnus-sum) + +;; FIXME: should avoid using C-c (no?) +;; (define-key gnus-summary-mode-map "\C-crm" 'gnus-bookmark-set) +;; (define-key global-map "\C-crb" 'gnus-bookmark-jump) +;; (define-key global-map "\C-crj" 'gnus-bookmark-jump) +;; (define-key global-map "\C-crl" 'gnus-bookmark-bmenu-list) + +(defgroup gnus-bookmark nil + "Setting, annotation and jumping to Gnus bookmarks." + :group 'gnus) + +(defcustom gnus-bookmark-default-file + (cond + ;; Backward compatibility with previous versions: + ((file-exists-p "~/.gnus.bmk") "~/.gnus.bmk") + (t (nnheader-concat gnus-directory "bookmarks.el"))) + "The default Gnus bookmarks file." + :type 'string + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-file-coding-system + (if (mm-coding-system-p 'iso-2022-7bit) + 'iso-2022-7bit) + "Coding system used for writing Gnus bookmark files." + :type '(symbol :tag "Coding system") + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-sort-flag t + "Non-nil means Gnus bookmarks are sorted by bookmark names. +Otherwise they will be displayed in LIFO order (that is, +most recently set ones come first, oldest ones come last)." + :type 'boolean + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-bmenu-toggle-infos t + "Non-nil means show details when listing Gnus bookmarks. +List of details is defined in `gnus-bookmark-bookmark-inline-details'. +This may result in truncated bookmark names. To disable this, put the +following in your `.emacs' file: + +\(setq gnus-bookmark-bmenu-toggle-infos nil\)" + :type 'boolean + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-bmenu-file-column 30 + "Column at which to display details in a buffer listing Gnus bookmarks. +You can toggle whether details are shown with \\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-toggle-infos]." + :type 'integer + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-use-annotations nil + "If non-nil, ask for an annotation when setting a bookmark." + :type 'boolean + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-bookmark-inline-details '(author) + "Details to be shown with `gnus-bookmark-bmenu-toggle-infos'. +The default value is \(subject\)." + :type '(list :tag "Gnus bookmark details" + (set :inline t + (const :tag "Author" author) + (const :tag "Subject" subject) + (const :tag "Date" date) + (const :tag "Group" group) + (const :tag "Message-id" message-id))) + :group 'gnus-bookmark) + +(defcustom gnus-bookmark-bookmark-details + '(author subject date group annotation) + "Details to be shown with `gnus-bookmark-bmenu-show-details'. +The default value is \(author subject date group annotation\)." + :type '(list :tag "Gnus bookmark details" + (set :inline t + (const :tag "Author" author) + (const :tag "Subject" subject) + (const :tag "Date" date) + (const :tag "Group" group) + (const :tag "Message-id" message-id) + (const :tag "Annotation" annotation))) + :group 'gnus-bookmark) + +(defface gnus-bookmark-menu-heading + '((t (:inherit font-lock-type-face))) + "Face used to highlight the heading in Gnus bookmark menu buffers." + :version "23.0" ;; No Gnus + :group 'gnus-bookmark) + +(defconst gnus-bookmark-end-of-version-stamp-marker + "-*- End Of Bookmark File Format Version Stamp -*-\n" + "This string marks the end of the version stamp in a Gnus bookmark file.") + +(defconst gnus-bookmark-file-format-version 0 + "The current version of the format used by bookmark files. +You should never need to change this.") + +(defvar gnus-bookmark-after-jump-hook nil + "Hook run after `gnus-bookmark-jump' jumps to a Gnus bookmark.") + +(defvar gnus-bookmark-alist () + "Association list of Gnus bookmarks and their records. +The format of the alist is + + \(BMK1 BMK2 ...\) + +where each BMK is of the form + +\(NAME + \(group . GROUP\) + \(message-id . MESSAGE-ID\) + \(author . AUTHOR\) + \(date . DATE\) + \(subject . SUBJECT\) + \(annotation . ANNOTATION\)\) + +So the cdr of each bookmark is an alist too.") + +(defmacro gnus-bookmark-mouse-available-p () + "Return non-nil if a mouse is available." + (if (featurep 'xemacs) + '(and (eq (device-class) 'color) (device-on-window-system-p)) + '(and (display-color-p) (display-mouse-p)))) + +(defun gnus-bookmark-remove-properties (string) + "Remove all text properties from STRING." + (set-text-properties 0 (length string) nil string) + string) + +;;;###autoload +(defun gnus-bookmark-set () + "Set a bookmark for this article." + (interactive) + (gnus-bookmark-maybe-load-default-file) + (if (or (not (eq major-mode 'gnus-summary-mode)) + (not gnus-article-current)) + (error "Please select an article in the Gnus summary buffer") + (let* ((group (car gnus-article-current)) + (article (cdr gnus-article-current)) + (header (gnus-summary-article-header article)) + (author (mail-header-from header)) + (message-id (mail-header-id header)) + (date (mail-header-date header)) + (subject (gnus-summary-subject-string)) + (bmk-name (gnus-bookmark-set-bookmark-name group author subject)) + ;; Maybe ask for annotation + (annotation + (if gnus-bookmark-use-annotations + (read-from-minibuffer + (format "Annotation for %s: " bmk-name)) ""))) + ;; Set the bookmark list + (setq gnus-bookmark-alist + (cons + (list (gnus-bookmark-remove-properties bmk-name) + (gnus-bookmark-make-cell + group message-id author date subject annotation)) + gnus-bookmark-alist)))) + (gnus-bookmark-bmenu-surreptitiously-rebuild-list) + (gnus-bookmark-write-file)) + +(defun gnus-bookmark-make-cell + (group message-id author date subject annotation) + "Return the record part of a new bookmark, given GROUP MESSAGE-ID AUTHOR DATE SUBJECT and ANNOTATION." + (let ((the-record + `((group . ,(gnus-bookmark-remove-properties group)) + (message-id . ,(gnus-bookmark-remove-properties message-id)) + (author . ,(gnus-bookmark-remove-properties author)) + (date . ,(gnus-bookmark-remove-properties date)) + (subject . ,(gnus-bookmark-remove-properties subject)) + (annotation . ,(gnus-bookmark-remove-properties annotation))))) + the-record)) + +(defun gnus-bookmark-set-bookmark-name (group author subject) + "Set bookmark name from GROUP AUTHOR and SUBJECT." + (let* ((subject (split-string subject)) + (default-name-0 ;; Should be merged with -1? + (concat (car (nreverse (delete "" (split-string group "[\\.:]")))) + "-" (car (split-string author)) + "-" (car subject) "-" (cadr subject))) + (default-name-1 + ;; Strip "[]" chars from the bookmark name: + (gnus-replace-in-string default-name-0 "[]_[]" "")) + (name (read-from-minibuffer + (format "Set bookmark (%s): " default-name-1) + nil nil nil nil + default-name-1))) + (if (string-equal name "") + default-name-1 + name))) + +(defun gnus-bookmark-write-file () + "Write currently defined Gnus bookmarks into `gnus-bookmark-default-file'." + (interactive) + (save-excursion + (save-window-excursion + ;; Avoir warnings? + ;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file) + (set-buffer (get-buffer-create " *Gnus bookmarks*")) + (erase-buffer) + (gnus-bookmark-insert-file-format-version-stamp) + (pp gnus-bookmark-alist (current-buffer)) + (condition-case nil + (let ((coding-system-for-write gnus-bookmark-file-coding-system)) + (write-region (point-min) (point-max) + gnus-bookmark-default-file)) + (file-error (message "Can't write %s" + gnus-bookmark-default-file))) + (kill-buffer (current-buffer)) + (message + "Saving Gnus bookmarks to file %s...done" + gnus-bookmark-default-file)))) + +(defun gnus-bookmark-insert-file-format-version-stamp () + "Insert text indicating current version of Gnus bookmark file format." + (insert + (format ";;;; Gnus Bookmark Format Version %d %s;;;;\n" + gnus-bookmark-file-format-version + (if gnus-bookmark-file-coding-system + (concat "-*- coding: " + (symbol-name gnus-bookmark-file-coding-system) + "; -*- ") + ""))) + (insert ";;; This format is meant to be slightly human-readable;\n" + ";;; nevertheless, you probably don't want to edit it.\n" + ";;; " + gnus-bookmark-end-of-version-stamp-marker)) + +;;;###autoload +(defun gnus-bookmark-jump (&optional bmk-name) + "Jump to a Gnus bookmark (BMK-NAME)." + (interactive) + (gnus-bookmark-maybe-load-default-file) + (let* ((bookmark (or bmk-name + (completing-read "Jump to bookmarked article: " + gnus-bookmark-alist))) + (bmk-cell (cadr (assoc bookmark gnus-bookmark-alist))) + (group (cdr (assoc 'group bmk-cell))) + (message-id (cdr (assoc 'message-id bmk-cell)))) + (when group + (unless (get-buffer gnus-group-buffer) + (gnus-no-server)) + (gnus-activate-group group) + (gnus-group-quick-select-group 0 group)) + (if message-id + (or (gnus-summary-goto-article message-id nil 'force) + (if (fboundp 'gnus-summary-insert-cached-articles) + (progn + (gnus-summary-insert-cached-articles) + (gnus-summary-goto-article message-id nil 'force)) + (message "Message could not be found.")))))) + +(defvar gnus-bookmark-already-loaded nil) + +(defun gnus-bookmark-alist-from-buffer () + "Return a `gnus-bookmark-alist' from the current buffer. +The buffer must of course contain Gnus bookmark format information. +Does not care from where in the buffer it is called, and does not +affect point." + (save-excursion + (goto-char (point-min)) + (if (search-forward + gnus-bookmark-end-of-version-stamp-marker nil t) + (read (current-buffer)) + ;; Else no hope of getting information here. + (error "Not Gnus bookmark format")))) + +(defun gnus-bookmark-load (file) + "Load Gnus bookmarks from FILE (which must be in bookmark format)." + (interactive + (list (read-file-name + (format "Load Gnus bookmarks from: (%s) " + gnus-bookmark-default-file) + "~/" gnus-bookmark-default-file 'confirm))) + (setq file (expand-file-name file)) + (if (file-readable-p file) + (save-excursion + (save-window-excursion + (set-buffer (let ((enable-local-variables nil)) + (find-file-noselect file))) + (goto-char (point-min)) + (let ((blist (gnus-bookmark-alist-from-buffer))) + (if (listp blist) + (progn (setq gnus-bookmark-already-loaded t) + (setq gnus-bookmark-alist blist)) + (error "Not Gnus bookmark format"))))))) + +(defun gnus-bookmark-maybe-load-default-file () + "Maybe load Gnus bookmarks in `gnus-bookmark-alist'." + (and (not gnus-bookmark-already-loaded) + (null gnus-bookmark-alist) + (file-readable-p (expand-file-name gnus-bookmark-default-file)) + (gnus-bookmark-load gnus-bookmark-default-file))) + +(defun gnus-bookmark-maybe-sort-alist () + "Return the gnus-bookmark-alist for display. +If the gnus-bookmark-sort-flag is non-nil, then return a sorted +copy of the alist." + (when gnus-bookmark-sort-flag + (setq gnus-bookmark-alist + (sort (copy-alist gnus-bookmark-alist) + (function + (lambda (x y) (string-lessp (car x) (car y)))))))) + +;;;###autoload +(defun gnus-bookmark-bmenu-list () + "Display a list of existing Gnus bookmarks. +The list is displayed in a buffer named `*Gnus Bookmark List*'. +The leftmost column displays a D if the bookmark is flagged for +deletion, or > if it is flagged for displaying." + (interactive) + (gnus-bookmark-maybe-load-default-file) + (if (interactive-p) + (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) + (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) + (let ((inhibit-read-only t) + alist name start end) + (erase-buffer) + (insert "% Gnus Bookmark\n- --------\n") + (add-text-properties (point-min) (point) + '(font-lock-face gnus-bookmark-menu-heading)) + ;; sort before displaying + (gnus-bookmark-maybe-sort-alist) + ;; Display gnus bookmarks + (setq alist gnus-bookmark-alist) + (while alist + (setq name (gnus-bookmark-name-from-full-record (pop alist))) + ;; if a Gnus bookmark has an annotation, prepend a "*" + ;; in the list of bookmarks. + (insert (if (member (gnus-bookmark-get-annotation name) (list nil "")) + " " + " *")) + (if (gnus-bookmark-mouse-available-p) + (add-text-properties + (prog1 + (point) + (insert name)) + (let ((end (point))) + (prog2 + (re-search-backward "[^ \t]") + (1+ (point)) + (goto-char end) + (insert "\n"))) + `(mouse-face highlight follow-link t + help-echo ,(format "%s: go to this article" + (aref gnus-mouse-2 0)))) + (insert name "\n"))) + (goto-char (point-min)) + (forward-line 2) + (gnus-bookmark-bmenu-mode) + (if gnus-bookmark-bmenu-toggle-infos + (gnus-bookmark-bmenu-toggle-infos t)))) + +(defun gnus-bookmark-bmenu-surreptitiously-rebuild-list () + "Rebuild the Bookmark List if it exists. +Don't affect the buffer ring order." + (if (get-buffer "*Gnus Bookmark List*") + (save-excursion + (save-window-excursion + (gnus-bookmark-bmenu-list))))) + +(defun gnus-bookmark-get-annotation (bookmark) + "Return the annotation of Gnus BOOKMARK, or nil if none." + (cdr (assq 'annotation (gnus-bookmark-get-bookmark-record bookmark)))) + +(defun gnus-bookmark-get-bookmark (bookmark) + "Return the full entry for Gnus BOOKMARK in `gnus-bookmark-alist'. +If BOOKMARK is not a string, return nil." + (when (stringp bookmark) + (assoc bookmark gnus-bookmark-alist))) + +(defun gnus-bookmark-get-bookmark-record (bookmark) + "Return the guts of the entry for Gnus BOOKMARK in `gnus-bookmark-alist'. +That is, all information but the name." + (car (cdr (gnus-bookmark-get-bookmark bookmark)))) + +(defun gnus-bookmark-name-from-full-record (full-record) + "Return name of FULL-RECORD \(an alist element instead of a string\)." + (car full-record)) + +(defvar gnus-bookmark-bmenu-bookmark-column nil) +(defvar gnus-bookmark-bmenu-hidden-bookmarks ()) +(defvar gnus-bookmark-bmenu-mode-map nil) + +(if gnus-bookmark-bmenu-mode-map + nil + (setq gnus-bookmark-bmenu-mode-map (make-keymap)) + (suppress-keymap gnus-bookmark-bmenu-mode-map t) + (define-key gnus-bookmark-bmenu-mode-map "q" (if (fboundp 'quit-window) + 'quit-window + 'bury-buffer)) + (define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select) + (define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select) + (define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete) + (define-key gnus-bookmark-bmenu-mode-map "k" 'gnus-bookmark-bmenu-delete) + (define-key gnus-bookmark-bmenu-mode-map "\C-d" 'gnus-bookmark-bmenu-delete-backwards) + (define-key gnus-bookmark-bmenu-mode-map "x" 'gnus-bookmark-bmenu-execute-deletions) + (define-key gnus-bookmark-bmenu-mode-map " " 'next-line) + (define-key gnus-bookmark-bmenu-mode-map "n" 'next-line) + (define-key gnus-bookmark-bmenu-mode-map "p" 'previous-line) + (define-key gnus-bookmark-bmenu-mode-map "\177" 'gnus-bookmark-bmenu-backup-unmark) + (define-key gnus-bookmark-bmenu-mode-map "?" 'describe-mode) + (define-key gnus-bookmark-bmenu-mode-map "u" 'gnus-bookmark-bmenu-unmark) + (define-key gnus-bookmark-bmenu-mode-map "m" 'gnus-bookmark-bmenu-mark) + (define-key gnus-bookmark-bmenu-mode-map "l" 'gnus-bookmark-bmenu-load) + (define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save) + (define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos) + (define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details) + (define-key gnus-bookmark-bmenu-mode-map gnus-mouse-2 + 'gnus-bookmark-bmenu-select-by-mouse)) + +;; Bookmark Buffer Menu mode is suitable only for specially formatted +;; data. +(put 'gnus-bookmark-bmenu-mode 'mode-class 'special) + +;; Been to lazy to use gnus-bookmark-save... +(defalias 'gnus-bookmark-bmenu-save 'gnus-bookmark-write-file) + +(defun gnus-bookmark-bmenu-mode () + "Major mode for editing a list of Gnus bookmarks. +Each line describes one of the bookmarks in Gnus. +Letters do not insert themselves; instead, they are commands. +Gnus bookmarks names preceded by a \"*\" have annotations. +\\<gnus-bookmark-bmenu-mode-map> +\\[gnus-bookmark-bmenu-mark] -- mark bookmark to be displayed. +\\[gnus-bookmark-bmenu-select] -- select bookmark of line point is on. + Also show bookmarks marked using m in other windows. +\\[gnus-bookmark-bmenu-toggle-infos] -- toggle displaying of details (they may obscure long bookmark names). +\\[gnus-bookmark-bmenu-locate] -- display (in minibuffer) location of this bookmark. +\\[gnus-bookmark-bmenu-rename] -- rename this bookmark \(prompts for new name\). +\\[gnus-bookmark-bmenu-delete] -- mark this bookmark to be deleted, and move down. +\\[gnus-bookmark-bmenu-delete-backwards] -- mark this bookmark to be deleted, and move up. +\\[gnus-bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[gnus-bookmark-bmenu-delete]'. +\\[gnus-bookmark-bmenu-load] -- load in a file of bookmarks (prompts for file.) +\\[gnus-bookmark-bmenu-save] -- load in a file of bookmarks (prompts for file.) +\\[gnus-bookmark-bmenu-unmark] -- remove all kinds of marks from current line. + With prefix argument, also move up one line. +\\[gnus-bookmark-bmenu-backup-unmark] -- back up a line and remove marks. +\\[gnus-bookmark-bmenu-show-details] -- show the annotation, if it exists, for the current bookmark + in another buffer. +\\[gnus-bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer. +\\[gnus-bookmark-bmenu-edit-annotation] -- edit the annotation for the current bookmark." + (kill-all-local-variables) + (use-local-map gnus-bookmark-bmenu-mode-map) + (setq truncate-lines t) + (setq buffer-read-only t) + (setq major-mode 'gnus-bookmark-bmenu-mode) + (setq mode-name "Bookmark Menu") + (gnus-run-mode-hooks 'gnus-bookmark-bmenu-mode-hook)) + +;; avoid compilation warnings +(defvar gnus-bookmark-bmenu-toggle-infos nil) + +(defun gnus-bookmark-bmenu-toggle-infos (&optional show) + "Toggle whether details are shown in the Gnus bookmark list. +Optional argument SHOW means show them unconditionally." + (interactive) + (cond + (show + (setq gnus-bookmark-bmenu-toggle-infos nil) + (gnus-bookmark-bmenu-show-infos) + (setq gnus-bookmark-bmenu-toggle-infos t)) + (gnus-bookmark-bmenu-toggle-infos + (gnus-bookmark-bmenu-hide-infos) + (setq gnus-bookmark-bmenu-toggle-infos nil)) + (t + (gnus-bookmark-bmenu-show-infos) + (setq gnus-bookmark-bmenu-toggle-infos t)))) + +(defun gnus-bookmark-bmenu-show-infos (&optional force) + "Show infos in bmenu, maybe FORCE display of infos." + (if (and (not force) gnus-bookmark-bmenu-toggle-infos) + nil ;already shown, so do nothing + (save-excursion + (save-window-excursion + (goto-char (point-min)) + (forward-line 2) + (setq gnus-bookmark-bmenu-hidden-bookmarks ()) + (let ((inhibit-read-only t)) + (while (< (point) (point-max)) + (let ((bmrk (gnus-bookmark-bmenu-bookmark))) + (setq gnus-bookmark-bmenu-hidden-bookmarks + (cons bmrk gnus-bookmark-bmenu-hidden-bookmarks)) + (let ((start (save-excursion (end-of-line) (point)))) + (move-to-column gnus-bookmark-bmenu-file-column t) + ;; Strip off `mouse-face' from the white spaces region. + (if (gnus-bookmark-mouse-available-p) + (remove-text-properties start (point) + '(mouse-face nil help-echo nil)))) + (delete-region (point) (progn (end-of-line) (point))) + (insert " ") + ;; Pass the NO-HISTORY arg: + (gnus-bookmark-insert-details bmrk) + (forward-line 1)))))))) + +(defun gnus-bookmark-insert-details (bmk-name) + "Insert the details of the article associated with BMK-NAME." + (let ((start (point))) + (prog1 + (insert (gnus-bookmark-get-details + bmk-name + gnus-bookmark-bookmark-inline-details)) + (if (gnus-bookmark-mouse-available-p) + (add-text-properties + start + (save-excursion (re-search-backward + "[^ \t]") + (1+ (point))) + `(mouse-face highlight + follow-link t + help-echo ,(format "%s: go to this article" + (aref gnus-mouse-2 0)))))))) + +(defun gnus-bookmark-kill-line (&optional newline-too) + "Kill from point to end of line. +If optional arg NEWLINE-TOO is non-nil, delete the newline too. +Does not affect the kill ring." + (let ((eol (save-excursion (end-of-line) (point)))) + (delete-region (point) eol) + (if (and newline-too (looking-at "\n")) + (delete-char 1)))) + +(defun gnus-bookmark-get-details (bmk-name details-list) + "Get details for a Gnus BMK-NAME depending on DETAILS-LIST." + (let ((details (cadr (assoc bmk-name gnus-bookmark-alist)))) + (mapconcat + (lambda (info) + (cdr (assoc info details))) + details-list " | "))) + +(defun gnus-bookmark-bmenu-hide-infos (&optional force) + "Hide infos in bmenu, maybe FORCE." + (if (and (not force) gnus-bookmark-bmenu-toggle-infos) + ;; nothing to hide if above is nil + (save-excursion + (save-window-excursion + (goto-char (point-min)) + (forward-line 2) + (setq gnus-bookmark-bmenu-hidden-bookmarks + (nreverse gnus-bookmark-bmenu-hidden-bookmarks)) + (save-excursion + (goto-char (point-min)) + (search-forward "Gnus Bookmark") + (backward-word 2) + (setq gnus-bookmark-bmenu-bookmark-column (current-column))) + (save-excursion + (let ((inhibit-read-only t)) + (while gnus-bookmark-bmenu-hidden-bookmarks + (move-to-column gnus-bookmark-bmenu-bookmark-column t) + (gnus-bookmark-kill-line) + (let ((start (point))) + (insert (car gnus-bookmark-bmenu-hidden-bookmarks)) + (if (gnus-bookmark-mouse-available-p) + (add-text-properties + start + (save-excursion (re-search-backward + "[^ \t]") + (1+ (point))) + `(mouse-face highlight + follow-link t + help-echo + ,(format "%s: go to this bookmark in other window" + (aref gnus-mouse-2 0)))))) + (setq gnus-bookmark-bmenu-hidden-bookmarks + (cdr gnus-bookmark-bmenu-hidden-bookmarks)) + (forward-line 1)))))))) + +(defun gnus-bookmark-bmenu-check-position () + "Return non-nil if on a line with a bookmark. +The actual value returned is gnus-bookmark-alist. Else +reposition and try again, else return nil." + (cond ((< (count-lines (point-min) (point)) 2) + (goto-char (point-min)) + (forward-line 2) + gnus-bookmark-alist) + ((and (bolp) (eobp)) + (beginning-of-line 0) + gnus-bookmark-alist) + (t + gnus-bookmark-alist))) + +(defun gnus-bookmark-bmenu-bookmark () + "Return a string which is bookmark of this line." + (if (gnus-bookmark-bmenu-check-position) + (save-excursion + (save-window-excursion + (goto-char (point-min)) + (search-forward "Gnus Bookmark") + (backward-word 2) + (setq gnus-bookmark-bmenu-bookmark-column (current-column))))) + (if gnus-bookmark-bmenu-toggle-infos + (gnus-bookmark-bmenu-hide-infos)) + (save-excursion + (save-window-excursion + (beginning-of-line) + (forward-char gnus-bookmark-bmenu-bookmark-column) + (prog1 + (buffer-substring-no-properties (point) + (progn + (end-of-line) + (point))) + ;; well, this is certainly crystal-clear: + (if gnus-bookmark-bmenu-toggle-infos + (gnus-bookmark-bmenu-toggle-infos t)))))) + +(defun gnus-bookmark-show-details (bookmark) + "Display the annotation for BOOKMARK in a buffer." + (let ((record (gnus-bookmark-get-bookmark-record bookmark)) + (old-buf (current-buffer)) + (details gnus-bookmark-bookmark-details) + detail) + (save-excursion + (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) + (erase-buffer) + (while details + (setq detail (pop details)) + (unless (equal (cdr (assoc detail record)) "") + (insert (symbol-name detail) ": " (cdr (assoc detail record)) "\n"))) + (goto-char (point-min)) + (pop-to-buffer old-buf)))) + +(defun gnus-bookmark-bmenu-show-details () + "Show the annotation for the current bookmark in another window." + (interactive) + (let ((bookmark (gnus-bookmark-bmenu-bookmark))) + (if (gnus-bookmark-bmenu-check-position) + (gnus-bookmark-show-details bookmark)))) + +(defun gnus-bookmark-bmenu-mark () + "Mark bookmark on this line to be displayed by \\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-select]." + (interactive) + (beginning-of-line) + (if (gnus-bookmark-bmenu-check-position) + (let ((inhibit-read-only t)) + (delete-char 1) + (insert ?>) + (forward-line 1) + (gnus-bookmark-bmenu-check-position)))) + +(defun gnus-bookmark-bmenu-unmark (&optional backup) + "Cancel all requested operations on bookmark on this line and move down. +Optional BACKUP means move up." + (interactive "P") + (beginning-of-line) + (if (gnus-bookmark-bmenu-check-position) + (progn + (let ((inhibit-read-only t)) + (delete-char 1) + ;; any flags to reset according to circumstances? How about a + ;; flag indicating whether this bookmark is being visited? + ;; well, we don't have this now, so maybe later. + (insert " ")) + (forward-line (if backup -1 1)) + (gnus-bookmark-bmenu-check-position)))) + +(defun gnus-bookmark-bmenu-backup-unmark () + "Move up and cancel all requested operations on bookmark on line above." + (interactive) + (forward-line -1) + (if (gnus-bookmark-bmenu-check-position) + (progn + (gnus-bookmark-bmenu-unmark) + (forward-line -1) + (gnus-bookmark-bmenu-check-position)))) + +(defun gnus-bookmark-bmenu-delete () + "Mark Gnus bookmark on this line to be deleted. +To carry out the deletions that you've marked, use +\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-execute-deletions]." + (interactive) + (beginning-of-line) + (if (gnus-bookmark-bmenu-check-position) + (let ((inhibit-read-only t)) + (delete-char 1) + (insert ?D) + (forward-line 1) + (gnus-bookmark-bmenu-check-position)))) + +(defun gnus-bookmark-bmenu-delete-backwards () + "Mark bookmark on this line to be deleted, then move up one line. +To carry out the deletions that you've marked, use +\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-execute-deletions]." + (interactive) + (gnus-bookmark-bmenu-delete) + (forward-line -2) + (if (gnus-bookmark-bmenu-check-position) + (forward-line 1)) + (gnus-bookmark-bmenu-check-position)) + +(defun gnus-bookmark-bmenu-select () + "Select this line's bookmark; also display bookmarks marked with `>'. +You can mark bookmarks with the +\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-mark] +command." + (interactive) + (if (gnus-bookmark-bmenu-check-position) + (let ((bmrk (gnus-bookmark-bmenu-bookmark)) + (menu (current-buffer))) + (goto-char (point-min)) + (delete-other-windows) + (gnus-bookmark-jump bmrk) + (bury-buffer menu)))) + +(defun gnus-bookmark-bmenu-select-by-mouse (event) + (interactive "e") + (mouse-set-point event) + (gnus-bookmark-bmenu-select)) + +(defun gnus-bookmark-bmenu-load () + "Load the Gnus bookmark file and rebuild the bookmark menu-buffer." + (interactive) + (if (gnus-bookmark-bmenu-check-position) + (save-excursion + (save-window-excursion + ;; This will call `gnus-bookmark-bmenu-list' + (call-interactively 'gnus-bookmark-load))))) + +(defun gnus-bookmark-bmenu-execute-deletions () + "Delete Gnus bookmarks marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] commands." + (interactive) + (message "Deleting Gnus bookmarks...") + (let ((hide-em gnus-bookmark-bmenu-toggle-infos) + (o-point (point)) + (o-str (save-excursion + (beginning-of-line) + (if (looking-at "^D") + nil + (buffer-substring + (point) + (progn (end-of-line) (point)))))) + (o-col (current-column))) + (if hide-em (gnus-bookmark-bmenu-hide-infos)) + (setq gnus-bookmark-bmenu-toggle-infos nil) + (goto-char (point-min)) + (forward-line 1) + (while (re-search-forward "^D" (point-max) t) + (gnus-bookmark-delete (gnus-bookmark-bmenu-bookmark) t)) ; pass BATCH arg + (gnus-bookmark-bmenu-list) + (setq gnus-bookmark-bmenu-toggle-infos hide-em) + (if gnus-bookmark-bmenu-toggle-infos + (gnus-bookmark-bmenu-toggle-infos t)) + (if o-str + (progn + (goto-char (point-min)) + (search-forward o-str) + (beginning-of-line) + (forward-char o-col)) + (goto-char o-point)) + (beginning-of-line) + (gnus-bookmark-write-file) + (message "Deleting bookmarks...done"))) + +(defun gnus-bookmark-delete (bookmark &optional batch) + "Delete BOOKMARK from the bookmark list. +Removes only the first instance of a bookmark with that name. If +there are one or more other bookmarks with the same name, they will +not be deleted. Defaults to the \"current\" bookmark \(that is, the +one most recently used in this file, if any\). +Optional second arg BATCH means don't update the bookmark list buffer, +probably because we were called from there." + (gnus-bookmark-maybe-load-default-file) + (let ((will-go (gnus-bookmark-get-bookmark bookmark))) + (setq gnus-bookmark-alist (delq will-go gnus-bookmark-alist))) + ;; Don't rebuild the list + (if batch + nil + (gnus-bookmark-bmenu-surreptitiously-rebuild-list))) + +(provide 'gnus-bookmark) + +;; arch-tag: 779df694-366f-46e8-84b2-1d0340e6f525 +;;; gnus-bookmark.el ends here diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 581a8db3227..fecb0685858 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -30,11 +30,8 @@ (eval-when-compile (require 'cl)) (require 'gnus) -(require 'gnus-int) -(require 'gnus-range) -(require 'gnus-start) (eval-when-compile - (if (not (fboundp 'gnus-agent-load-alist)) + (unless (fboundp 'gnus-agent-load-alist) (defun gnus-agent-load-alist (group))) (require 'gnus-sum)) @@ -92,6 +89,7 @@ it's not cached." (defvar gnus-cache-buffer nil) (defvar gnus-cache-active-hashtb nil) (defvar gnus-cache-active-altered nil) +(defvar gnus-cache-total-fetched-hashtb nil) (eval-and-compile (autoload 'nnml-generate-nov-databases-1 "nnml") @@ -133,16 +131,20 @@ it's not cached." (let ((coding-system-for-write gnus-cache-overview-coding-system)) (gnus-write-buffer overview-file)) - ;; Empty overview file, remove it - (when (file-exists-p overview-file) - (delete-file overview-file)) - ;; If possible, remove group's cache subdirectory. - (condition-case nil - ;; FIXME: we can detect the error type and warn the user - ;; of any inconsistencies (articles w/o nov entries?). - ;; for now, just be conservative...delete only if safe -- sj - (delete-directory (file-name-directory overview-file)) - (error nil))))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + ;; Empty overview file, remove it + (when (file-exists-p overview-file) + (delete-file overview-file)) + ;; If possible, remove group's cache subdirectory. + (condition-case nil + ;; FIXME: we can detect the error type and warn the user + ;; of any inconsistencies (articles w/o nov entries?). + ;; for now, just be conservative...delete only if safe -- sj + (delete-directory (file-name-directory overview-file)) + (error)))) + + (gnus-cache-update-overview-total-fetched-for + (car gnus-cache-buffer) overview-file))) ;; Kill the buffer -- it's either unmodified or saved. (gnus-kill-buffer buffer) (setq gnus-cache-buffer nil)))) @@ -152,7 +154,9 @@ it's not cached." (when (and (or force (not (eq gnus-use-cache 'passive))) (numberp article) (> article 0)) ; This might be a dummy article. - (let ((number article) file headers) + (let ((number article) + file headers lines-chars + (file-name-coding-system nnmail-pathname-coding-system)) ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) (let ((result (nnvirtual-find-group-art @@ -180,10 +184,14 @@ it's not cached." (gnus-request-article-this-buffer number group)) (when (> (buffer-size) 0) (let ((coding-system-for-write gnus-cache-coding-system)) - (gnus-write-buffer file)) + (gnus-write-buffer file) + (gnus-cache-update-file-total-fetched-for group file)) + (setq lines-chars (nnheader-get-lines-and-char)) (nnheader-remove-body) (setq headers (nnheader-parse-naked-head)) (mail-header-set-number headers number) + (mail-header-set-lines headers (car lines-chars)) + (mail-header-set-chars headers (cadr lines-chars)) (gnus-cache-change-buffer group) (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-max)) @@ -236,12 +244,10 @@ it's not cached." (defun gnus-cache-possibly-remove-articles-1 () "Possibly remove some of the removable articles." (when (gnus-cache-fully-p gnus-newsgroup-name) - (let ((articles gnus-cache-removable-articles) - (cache-articles gnus-newsgroup-cached) - article) + (let ((cache-articles gnus-newsgroup-cached)) (gnus-cache-change-buffer gnus-newsgroup-name) - (while articles - (when (memq (setq article (pop articles)) cache-articles) + (dolist (article gnus-cache-removable-articles) + (when (memq article cache-articles) ;; The article was in the cache, so we see whether we are ;; supposed to remove it from the cache. (gnus-cache-possibly-remove-article @@ -256,7 +262,8 @@ it's not cached." (defun gnus-cache-request-article (article group) "Retrieve ARTICLE in GROUP from the cache." (let ((file (gnus-cache-file-name group article)) - (buffer-read-only nil)) + (buffer-read-only nil) + (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) (erase-buffer) (gnus-kill-all-overlays) @@ -285,7 +292,8 @@ it's not cached." (gnus-retrieve-headers articles group fetch-old)) (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) - type) + type + (file-name-coding-system nnmail-pathname-coding-system)) ;; We first retrieve all the headers that we don't have in ;; the cache. (let ((gnus-use-cache nil)) @@ -325,9 +333,8 @@ it's not cached." If not given a prefix, use the process marked articles instead. Returns the list of articles entered." (interactive "P") - (let ((articles (gnus-summary-work-articles n)) - article out) - (while (setq article (pop articles)) + (let (out) + (dolist (article (gnus-summary-work-articles n)) (gnus-summary-remove-process-mark article) (if (natnump article) (when (gnus-cache-possibly-enter-article @@ -348,10 +355,8 @@ If not given a prefix, use the process marked articles instead. Returns the list of articles removed." (interactive "P") (gnus-cache-change-buffer gnus-newsgroup-name) - (let ((articles (gnus-summary-work-articles n)) - article out) - (while articles - (setq article (pop articles)) + (let (out) + (dolist (article (gnus-summary-work-articles n)) (gnus-summary-remove-process-mark article) (when (gnus-cache-possibly-remove-article article nil nil nil t) (when gnus-newsgroup-agentized @@ -407,7 +412,8 @@ Returns the list of articles removed." " *gnus-cache-overview*")))) ;; Insert the contents of this group's cache overview. (erase-buffer) - (let ((file (gnus-cache-file-name group ".overview"))) + (let ((file (gnus-cache-file-name group ".overview")) + (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) (nnheader-insert-file-contents file))) ;; We have a fresh (empty/just loaded) buffer, @@ -421,8 +427,43 @@ Returns the list of articles removed." (and unread (memq 'unread class)) (and (not unread) (not ticked) (not dormant) (memq 'read class)))) +(defvar gnus-cache-decoded-group-names nil + "Alist of original group names and decoded group names. +Decoding is done according to `gnus-group-name-charset-method-alist' +or `gnus-group-name-charset-group-alist'.") + +(defvar gnus-cache-unified-group-names nil + "Alist of unified decoded group names and original group names. +A group name is decoded according to +`gnus-group-name-charset-method-alist' or +`gnus-group-name-charset-group-alist' first, and is encoded and +decoded again according to `nnmail-pathname-coding-system', +`file-name-coding-system', or `default-file-name-coding-system'. + +It is used when asking for a original group name from a cache +directory name, in which non-ASCII characters might have been unified +into the ones of a certain charset particularly if the `utf-8' coding +system for example was used.") + +(defun gnus-cache-decoded-group-name (group) + "Return a decoded group name of GROUP." + (or (cdr (assoc group gnus-cache-decoded-group-names)) + (let ((decoded (gnus-group-decoded-name group)) + (coding (or nnmail-pathname-coding-system + (and (boundp 'file-name-coding-system) + file-name-coding-system) + (and (boundp 'default-file-name-coding-system) + default-file-name-coding-system)))) + (push (cons group decoded) gnus-cache-decoded-group-names) + (push (cons (mm-decode-coding-string + (mm-encode-coding-string decoded coding) + coding) + group) + gnus-cache-unified-group-names) + decoded))) + (defun gnus-cache-file-name (group article) - (setq group (gnus-group-decoded-name group)) + (setq group (gnus-cache-decoded-group-name group)) (expand-file-name (if (stringp article) article (int-to-string article)) (file-name-as-directory @@ -455,7 +496,8 @@ Returns the list of articles removed." "Possibly remove ARTICLE from the cache." (let ((group gnus-newsgroup-name) (number article) - file) + file + (file-name-coding-system nnmail-pathname-coding-system)) ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) (let ((result (nnvirtual-find-group-art @@ -468,13 +510,15 @@ Returns the list of articles removed." (gnus-cache-member-of-class gnus-cache-remove-articles ticked dormant unread))) (save-excursion + (gnus-cache-update-file-total-fetched-for group file t) (delete-file file) + (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-min)) (when (or (looking-at (concat (int-to-string number) "\t")) (search-forward (concat "\n" (int-to-string number) "\t") (point-max) t)) - (gnus-delete-line))) + (gnus-delete-line))) (unless (setq gnus-newsgroup-cached (delq article gnus-newsgroup-cached)) (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) @@ -485,7 +529,8 @@ Returns the list of articles removed." (defun gnus-cache-articles-in-group (group) "Return a sorted list of cached articles in GROUP." (let ((dir (file-name-directory (gnus-cache-file-name group 1))) - articles) + articles + (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p dir) (setq articles (sort (mapcar (lambda (name) (string-to-number name)) @@ -508,8 +553,8 @@ Returns the list of articles removed." (save-excursion (set-buffer cache-buf) (erase-buffer) - (let ((coding-system-for-read - gnus-cache-overview-coding-system)) + (let ((coding-system-for-read gnus-cache-overview-coding-system) + (file-name-coding-system nnmail-pathname-coding-system)) (insert-file-contents (or file (gnus-cache-file-name group ".overview")))) (goto-char (point-min)) @@ -525,7 +570,7 @@ Returns the list of articles removed." (set-buffer cache-buf) (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") nil t) - (setq beg (gnus-point-at-bol) + (setq beg (point-at-bol) end (progn (end-of-line) (point))) (setq beg nil)) (set-buffer nntp-server-buffer) @@ -537,24 +582,23 @@ Returns the list of articles removed." (defun gnus-cache-braid-heads (group cached) (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) - (save-excursion - (set-buffer cache-buf) + (with-current-buffer cache-buf (erase-buffer)) (set-buffer nntp-server-buffer) (goto-char (point-min)) - (while cached + (dolist (entry cached) (while (and (not (eobp)) (looking-at "2.. +\\([0-9]+\\) ") (< (progn (goto-char (match-beginning 1)) (read (current-buffer))) - (car cached))) + entry)) (search-forward "\n.\n" nil 'move)) (beginning-of-line) (set-buffer cache-buf) (erase-buffer) - (let ((coding-system-for-read - gnus-cache-coding-system)) - (insert-file-contents (gnus-cache-file-name group (car cached)))) + (let ((coding-system-for-read gnus-cache-coding-system) + (file-name-coding-system nnmail-pathname-coding-system)) + (insert-file-contents (gnus-cache-file-name group entry))) (goto-char (point-min)) (insert "220 ") (princ (car cached) (current-buffer)) @@ -564,8 +608,7 @@ Returns the list of articles removed." (forward-char -1) (insert ".") (set-buffer nntp-server-buffer) - (insert-buffer-substring cache-buf) - (setq cached (cdr cached))) + (insert-buffer-substring cache-buf)) (kill-buffer cache-buf))) ;;;###autoload @@ -661,6 +704,7 @@ If LOW, update the lower bound instead." (interactive) (let* ((top (null directory)) (directory (expand-file-name (or directory gnus-cache-directory))) + (file-name-coding-system nnmail-pathname-coding-system) (files (directory-files directory 'full)) (group (if top @@ -686,16 +730,21 @@ If LOW, update the lower bound instead." (push (pop files) alphs))) ;; If we have nums, then this is probably a valid group. (when (setq nums (sort nums '<)) - (gnus-sethash group (cons (car nums) (gnus-last-element nums)) + ;; Use non-decoded group name. + ;; FIXME: this is kind of a workaround. The active file should + ;; be updated at the time articles are cached. It will make + ;; `gnus-cache-unified-group-names' needless. + (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) + group) + (cons (car nums) (gnus-last-element nums)) gnus-cache-active-hashtb)) ;; Go through all the other files. - (while alphs - (when (and (file-directory-p (car alphs)) + (dolist (file alphs) + (when (and (file-directory-p file) (not (string-match "^\\." - (file-name-nondirectory (car alphs))))) + (file-name-nondirectory file)))) ;; We descend directories. - (gnus-cache-generate-active (car alphs))) - (setq alphs (cdr alphs))) + (gnus-cache-generate-active file))) ;; Write the new active file. (when top (gnus-cache-write-active t) @@ -708,6 +757,9 @@ If LOW, update the lower bound instead." (gnus-cache-close) (let ((nnml-generate-active-function 'identity)) (nnml-generate-nov-databases-1 dir)) + + (setq gnus-cache-total-fetched-hashtb nil) + (gnus-cache-open)) (defun gnus-cache-move-cache (dir) @@ -736,9 +788,12 @@ files would corrupt Gnus when the cache was next enabled. It depends on the caller to determine whether group renaming is supported." (let ((old-dir (gnus-cache-file-name old-group "")) - (new-dir (gnus-cache-file-name new-group ""))) + (new-dir (gnus-cache-file-name new-group "")) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-rename-file old-dir new-dir t)) + (gnus-cache-rename-group-total-fetched-for old-group new-group) + (let ((no-save gnus-cache-active-hashtb)) (unless gnus-cache-active-hashtb (gnus-cache-read-active)) @@ -762,9 +817,12 @@ Always updates the cache, even when disabled, as the old cache files would corrupt gnus when the cache was next enabled. Depends upon the caller to determine whether group deletion is supported." - (let ((dir (gnus-cache-file-name group ""))) + (let ((dir (gnus-cache-file-name group "")) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-delete-directory dir)) + (gnus-cache-delete-group-total-fetched-for group) + (let ((no-save gnus-cache-active-hashtb)) (unless gnus-cache-active-hashtb (gnus-cache-read-active)) @@ -775,6 +833,85 @@ supported." (setq gnus-cache-active-altered group-hash-value) (gnus-cache-write-active group-hash-value))))) +(defvar gnus-cache-inhibit-update-total-fetched-for nil) +(defvar gnus-cache-need-update-total-fetched-for nil) + +(defmacro gnus-cache-with-refreshed-group (group &rest body) + `(prog1 (let ((gnus-cache-inhibit-update-total-fetched-for t)) + ,@body) + (when (and gnus-cache-need-update-total-fetched-for + (not gnus-cache-inhibit-update-total-fetched-for)) + (save-excursion + (set-buffer gnus-group-buffer) + (setq gnus-cache-need-update-total-fetched-for nil) + (gnus-group-update-group ,group t))))) + +(defun gnus-cache-update-file-total-fetched-for (group file &optional subtract) + (when gnus-cache-total-fetched-hashtb + (gnus-cache-with-refreshed-group + group + (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) + (gnus-sethash group (make-vector 2 0) + gnus-cache-total-fetched-hashtb))) + size) + + (if file + (setq size (or (nth 7 (file-attributes file)) 0)) + (let* ((file-name-coding-system nnmail-pathname-coding-system) + (files (directory-files (gnus-cache-file-name group "") + t nil t)) + file attrs) + (setq size 0.0) + (while (setq file (pop files)) + (setq attrs (file-attributes file)) + (unless (nth 0 attrs) + (incf size (float (nth 7 attrs))))))) + + (setq gnus-cache-need-update-total-fetched-for t) + + (incf (nth 1 entry) (if subtract (- size) size)))))) + +(defun gnus-cache-update-overview-total-fetched-for (group file) + (when gnus-cache-total-fetched-hashtb + (gnus-cache-with-refreshed-group + group + (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) + (gnus-sethash group (make-list 2 0) + gnus-cache-total-fetched-hashtb))) + (file-name-coding-system nnmail-pathname-coding-system) + (size (or (nth 7 (file-attributes + (or file + (gnus-cache-file-name group ".overview")))) + 0))) + (setq gnus-cache-need-update-total-fetched-for t) + (setf (nth 0 entry) size))))) + +(defun gnus-cache-rename-group-total-fetched-for (old-group new-group) + "Record of disk space used by OLD-GROUP now associated with NEW-GROUP." + (when gnus-cache-total-fetched-hashtb + (let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb))) + (gnus-sethash new-group entry gnus-cache-total-fetched-hashtb) + (gnus-sethash old-group nil gnus-cache-total-fetched-hashtb)))) + +(defun gnus-cache-delete-group-total-fetched-for (group) + "Delete record of disk space used by GROUP being deleted." + (when gnus-cache-total-fetched-hashtb + (gnus-sethash group nil gnus-cache-total-fetched-hashtb))) + +(defun gnus-cache-total-fetched-for (group &optional no-inhibit) + "Get total disk space used by the cache for the specified GROUP." + (unless (equal group "dummy.group") + (unless gnus-cache-total-fetched-hashtb + (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024))) + + (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb))) + (if entry + (apply '+ entry) + (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) + (+ + (gnus-cache-update-overview-total-fetched-for group nil) + (gnus-cache-update-file-total-fetched-for group nil))))))) + (provide 'gnus-cache) ;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 1611dd235f5..5d1b2b26a8e 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -27,6 +27,9 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus) (require 'gnus-range) @@ -268,7 +271,7 @@ It is merged with the face for the cited text belonging to the attribution." (defface gnus-cite-10 '((((class color) (background dark)) - (:foreground "medium purple")) + (:foreground "plum1")) (((class color) (background light)) (:foreground "medium purple")) @@ -294,14 +297,28 @@ It is merged with the face for the cited text belonging to the attribution." (defcustom gnus-cite-face-list '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6 - gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11) + gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11) "*List of faces used for highlighting citations. When there are citations from multiple articles in the same message, Gnus will try to give each citation from each article its own face. This should make it easier to see who wrote what." :group 'gnus-cite - :type '(repeat face)) + :type '(repeat face) + :set (lambda (symbol value) + (prog1 + (custom-set-default symbol value) + (if (boundp 'gnus-message-max-citation-depth) + (setq gnus-message-max-citation-depth (length value))) + (if (boundp 'gnus-message-citation-keywords) + (setq gnus-message-citation-keywords + `((gnus-message-search-citation-line + ,@(let ((list nil) + (count 1)) + (dolist (face value (nreverse list)) + (push (list count (list 'quote face) 'prepend t) + list) + (setq count (1+ count))))))))))) (defcustom gnus-cite-hide-percentage 50 "Only hide excess citation if above this percentage of the body." @@ -367,7 +384,7 @@ in a boring face, then the pages will be skipped." ;;; Commands: -(defun gnus-article-highlight-citation (&optional force) +(defun gnus-article-highlight-citation (&optional force same-buffer) "Highlight cited text. Each citation in the article will be highlighted with a different face. The faces are taken from `gnus-cite-face-list'. @@ -381,7 +398,8 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." (interactive (list 'force)) (save-excursion - (set-buffer gnus-article-buffer) + (unless same-buffer + (set-buffer gnus-article-buffer)) (gnus-cite-parse-maybe force) (let ((buffer-read-only nil) (alist gnus-cite-prefix-alist) @@ -416,7 +434,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (goto-char (point-min)) (forward-line (1- number)) (when (re-search-forward gnus-cite-attribution-suffix - (gnus-point-at-eol) + (point-at-eol) t) (gnus-article-add-button (match-beginning 1) (match-end 1) 'gnus-cite-toggle prefix)) @@ -770,7 +788,7 @@ See also the documentation for `gnus-article-highlight-citation'." ;; Each line. (setq begin (point) guess-limit (progn (skip-chars-forward "^> \t\r\n") (point)) - end (gnus-point-at-bol 2) + end (point-at-bol 2) start end) (goto-char begin) ;; Ignore standard Supercite attribution prefix. @@ -793,7 +811,7 @@ See also the documentation for `gnus-article-highlight-citation'." ;; Each prefix. (setq end (match-end 0) prefix (buffer-substring begin end)) - (gnus-set-text-properties 0 (length prefix) nil prefix) + (set-text-properties 0 (length prefix) nil prefix) (setq entry (assoc prefix alist)) (if entry (setcdr entry (cons line (cdr entry))) @@ -803,13 +821,24 @@ See also the documentation for `gnus-article-highlight-citation'." (setq line (1+ line))) ;; Horrible special case for some Microsoft mailers. (goto-char (point-min)) - (when (re-search-forward gnus-cite-unsightly-citation-regexp max t) - (setq begin (count-lines (point-min) (point))) - (setq end (count-lines (point-min) max)) - (setq entry nil) - (while (< begin end) - (push begin entry) - (setq begin (1+ begin))) + (setq start t begin nil entry nil) + (while start + ;; Assume this search ends up at the beginning of a line. + (if (re-search-forward gnus-cite-unsightly-citation-regexp max t) + (progn + (when (number-or-marker-p start) + (setq begin (count-lines (point-min) start) + end (count-lines (point-min) (match-beginning 0)))) + (setq start (match-end 0))) + (when (number-or-marker-p start) + (setq begin (count-lines (point-min) start) + end (count-lines (point-min) max))) + (setq start nil)) + (when begin + (while (< begin end) + ;; Need to do 1+ because we're in the bol. + (push (setq begin (1+ begin)) entry)))) + (when entry (push (cons "" entry) alist)) ;; We got all the potential prefixes. Now create ;; `gnus-cite-prefix-alist' containing the oldest prefix for each @@ -875,11 +904,10 @@ See also the documentation for `gnus-article-highlight-citation'." (let ((al (buffer-substring (save-excursion (beginning-of-line 0) (1+ (point))) end))) - (if (not (assoc al al-alist)) - (progn - (push (list wrote in prefix tag) - gnus-cite-loose-attribution-alist) - (push (cons al t) al-alist)))))))) + (when (not (assoc al al-alist)) + (push (list wrote in prefix tag) + gnus-cite-loose-attribution-alist) + (push (cons al t) al-alist))))))) (defun gnus-cite-connect-attributions () ;; Connect attributions to citations @@ -1101,6 +1129,108 @@ See also the documentation for `gnus-article-highlight-citation'." (setq found t))) found))) + +;; Highlighting of different citation levels in message-mode. +;; - message-cite-prefix will be overridden if this is enabled. + +(defvar gnus-message-max-citation-depth + (length gnus-cite-face-list) + "Maximum supported level of citation.") + +(defvar gnus-message-cite-prefix-regexp + (concat "^\\(?:" message-cite-prefix-regexp "\\)")) + +(defun gnus-message-search-citation-line (limit) + "Search for a cited line and set match data accordingly. +Returns nil if there is no such line before LIMIT, t otherwise." + (when (re-search-forward gnus-message-cite-prefix-regexp limit t) + (let ((cdepth (min (length (apply 'concat + (split-string + (match-string-no-properties 0) + "[ \t [:alnum:]]+"))) + gnus-message-max-citation-depth)) + (mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil)) + (start (point-at-bol)) + (end (point-at-eol))) + (setcar mlist start) + (setcar (cdr mlist) end) + (setcar (nthcdr (* cdepth 2) mlist) start) + (setcar (nthcdr (1+ (* cdepth 2)) mlist) end) + (set-match-data mlist)) + t)) + +(defvar gnus-message-citation-keywords + ;; eval-when-compile ;; This breaks in XEmacs + `((gnus-message-search-citation-line + ,@(let ((list nil) + (count 1)) + ;; (require 'gnus-cite) + (dolist (face gnus-cite-face-list (nreverse list)) + (push (list count (list 'quote face) 'prepend t) list) + (setq count (1+ count)))))) ;; + "Keywords for highlighting different levels of message citations.") + +(eval-when-compile + (defvar font-lock-defaults-computed) + (defvar font-lock-keywords) + (defvar font-lock-set-defaults)) + +(eval-and-compile + (unless (featurep 'xemacs) + (autoload 'font-lock-set-defaults "font-lock"))) + +(define-minor-mode gnus-message-citation-mode + "Toggle `gnus-message-citation-mode' in current buffer. +This buffer local minor mode provides additional font-lock support for +nested citations. +With prefix ARG, turn `gnus-message-citation-mode' on if and only if ARG +is positive. +Automatically turn `font-lock-mode' on when `gnus-message-citation-mode' +is turned on." + nil ;; init-value + "" ;; lighter + nil ;; keymap + (when (eq major-mode 'message-mode) + (let ((defaults (car (if (featurep 'xemacs) + (get 'message-mode 'font-lock-defaults) + font-lock-defaults))) + default keywords) + (while defaults + (setq default (if (consp defaults) + (pop defaults) + (prog1 + defaults + (setq defaults nil)))) + (if gnus-message-citation-mode + ;; `gnus-message-citation-keywords' should be the last + ;; elements of the keywords because the others are unlikely + ;; to have the OVERRIDE flags -- XEmacs applies a keyword + ;; having no OVERRIDE flag to matched text even if it has + ;; already other faces, while Emacs doesn't. + (set (make-local-variable default) + (append (default-value default) + gnus-message-citation-keywords)) + (kill-local-variable default)))) + ;; Force `font-lock-set-defaults' to update `font-lock-keywords'. + (if (featurep 'xemacs) + (progn + (require 'font-lock) + (setq font-lock-defaults-computed nil + font-lock-keywords nil)) + (setq font-lock-set-defaults nil)) + (font-lock-set-defaults) + (cond ((symbol-value 'font-lock-mode) + (font-lock-fontify-buffer)) + (gnus-message-citation-mode + (font-lock-mode 1))))) + +(defun turn-on-gnus-message-citation-mode () + "Turn on `gnus-message-citation-mode'." + (gnus-message-citation-mode 1)) +(defun turn-off-gnus-message-citation-mode () + "Turn off `gnus-message-citation-mode'." + (gnus-message-citation-mode -1)) + (gnus-ems-redefine) (provide 'gnus-cite) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 1470f0cbac1..6d37120bd59 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -980,7 +980,7 @@ articles in the thread. (deflt (if (,field defaults) (concat " [" (gnus-trim-whitespace (gnus-pp-to-string (,field defaults))) - "]"))) + "]"))) symb) (if (eq (car type) 'radio) diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index e928dc78c8f..ea38ba0456d 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -152,7 +152,7 @@ DELAY is a string, giving the length of the time. Possible values are: (message-send-hook (copy-sequence message-send-hook)) articles article deadline) - (when (gnus-gethash group gnus-newsrc-hashtb) + (when (gnus-group-entry group) (gnus-activate-group group) (add-hook 'message-send-hook '(lambda () diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 715e77a7099..98d098c51cf 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -35,10 +35,6 @@ (require 'nntp) (require 'nnmail) (require 'gnus-util) -(eval-and-compile - (if (featurep 'xemacs) - (require 'itimer) - (require 'timer))) (autoload 'parse-time-string "parse-time" nil nil) @@ -109,7 +105,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (when gnus-demon-handlers ;; Set up the timer. (setq gnus-demon-timer - (nnheader-run-at-time + (run-at-time gnus-demon-timestep gnus-demon-timestep 'gnus-demon)) ;; Reset control variables. (setq gnus-demon-handler-state diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el index cc3c3815a1c..655d652ba27 100644 --- a/lisp/gnus/gnus-diary.el +++ b/lisp/gnus/gnus-diary.el @@ -251,32 +251,32 @@ Optional prefix (or REVERSE argument) means sort in reverse order." ;; - a nice summary line format ;; - NNDiary specific sorting by schedule functions ;; In general, try not to mess with what the user might have modified. - (let ((posting-style (gnus-group-get-parameter group 'posting-style t))) - ;; Posting style: - (mapcar (lambda (elt) - (let ((header (format "X-Diary-%s" (car elt)))) - (unless (assoc header posting-style) - (setq posting-style (append posting-style - `((,header "*"))))) - )) - nndiary-headers) - (gnus-group-set-parameter group 'posting-style posting-style) - ;; Summary line format: - (unless (gnus-group-get-parameter group 'gnus-summary-line-format t) - (gnus-group-set-parameter group 'gnus-summary-line-format - `(,gnus-diary-summary-line-format))) - ;; Sorting by schedule: - (unless (gnus-group-get-parameter group 'gnus-article-sort-functions) - (gnus-group-set-parameter group 'gnus-article-sort-functions - '((append gnus-article-sort-functions - (list - 'gnus-article-sort-by-schedule))))) - (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions) - (gnus-group-set-parameter group 'gnus-thread-sort-functions - '((append gnus-thread-sort-functions - (list - 'gnus-thread-sort-by-schedule))))) - )) + + ;; Posting style: + (let ((posting-style (gnus-group-get-parameter group 'posting-style t)) + (headers nndiary-headers) + header) + (while headers + (setq header (format "X-Diary-%s" (caar headers)) + headers (cdr headers)) + (unless (assoc header posting-style) + (setq posting-style (append posting-style (list (list header "*")))))) + (gnus-group-set-parameter group 'posting-style posting-style)) + ;; Summary line format: + (unless (gnus-group-get-parameter group 'gnus-summary-line-format t) + (gnus-group-set-parameter group 'gnus-summary-line-format + `(,gnus-diary-summary-line-format))) + ;; Sorting by schedule: + (unless (gnus-group-get-parameter group 'gnus-article-sort-functions) + (gnus-group-set-parameter group 'gnus-article-sort-functions + '((append gnus-article-sort-functions + (list + 'gnus-article-sort-by-schedule))))) + (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions) + (gnus-group-set-parameter group 'gnus-thread-sort-functions + '((append gnus-thread-sort-functions + (list + 'gnus-thread-sort-by-schedule)))))) ;; Called when a group is subscribed. This is needed because groups created ;; because of mail splitting are *not* created with the back end function. @@ -347,7 +347,7 @@ If ARG (or prefix) is non-nil, force prompting for all fields." (when (re-search-forward (concat "^" header ":") nil t) (unless (eq (char-after) ? ) (insert " ")) - (setq value (buffer-substring (point) (gnus-point-at-eol))) + (setq value (buffer-substring (point) (point-at-eol))) (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value) (setq value (match-string 1 value))) (condition-case () diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index 93c89aec3ea..fa9ef21bd1a 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -72,7 +72,7 @@ (if (null arg) (not gnus-dired-mode) (> (prefix-numeric-value arg) 0))) (when gnus-dired-mode - (gnus-add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map) + (add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map) (gnus-run-hooks 'gnus-dired-mode-hook)))) ;;;###autoload diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 287d71844af..344f9c028d6 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -75,7 +75,7 @@ ;; Set up the menu. (when (gnus-visual-p 'draft-menu 'menu) (gnus-draft-make-menu-bar)) - (gnus-add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map) + (add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map) (gnus-run-hooks 'gnus-draft-mode-hook)))) ;;; Commands @@ -105,7 +105,9 @@ (save-restriction (message-narrow-to-headers) (message-remove-header "date"))) - (save-buffer) + (let ((message-draft-headers + (delq 'Date (copy-sequence message-draft-headers)))) + (save-buffer)) (let ((gnus-verbose-backends nil)) (gnus-request-expire-articles (list article) group t)) (push @@ -160,7 +162,7 @@ (concat "^" (regexp-quote gnus-agent-target-move-group-header) ":") nil t) (skip-syntax-forward "-") - (setq move-to (buffer-substring (point) (gnus-point-at-eol))) + (setq move-to (buffer-substring (point) (point-at-eol))) (message-remove-header gnus-agent-target-move-group-header)) (goto-char (point-min)) (when (re-search-forward @@ -238,6 +240,12 @@ (throw 'continue t) (error "Stop!")))))))) +(defcustom gnus-draft-setup-hook nil + "Hook run after setting up a draft buffer." + :group 'gnus-message + :version "23.0" ;; No Gnus + :type 'hook) + ;;; Utility functions ;;;!!!If this is byte-compiled, it fails miserably. @@ -285,7 +293,8 @@ (gnus-add-mark ,(car ga) 'replied ,article) (gnus-request-set-mark ,(car ga) (list (list (list ,article) 'add '(reply))))) - 'send))))))) + 'send)))) + (run-hooks 'gnus-draft-setup-hook)))) (defun gnus-draft-article-sendable-p (article) "Say whether ARTICLE is sendable." diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index 0c2e1af0a94..fa08b443a90 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -85,10 +85,8 @@ seen in the same session." (setq gnus-dup-list nil)) (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) ;; Enter all Message-IDs into the hash table. - (let ((list gnus-dup-list) - (obarray gnus-dup-hashtb)) - (while list - (intern (pop list))))) + (let ((obarray gnus-dup-hashtb)) + (mapc 'intern gnus-dup-list))) (defun gnus-dup-read () "Read the duplicate suppression list." @@ -113,11 +111,10 @@ seen in the same session." (unless gnus-dup-list (gnus-dup-open)) (setq gnus-dup-list-dirty t) ; mark list for saving - (let ((data gnus-newsgroup-data) - datum msgid) + (let (msgid) ;; Enter the Message-IDs of all read articles into the list ;; and hash table. - (while (setq datum (pop data)) + (dolist (datum gnus-newsgroup-data) (when (and (not (gnus-data-pseudo-p datum)) (> (gnus-data-number datum) 0) (not (memq (gnus-data-number datum) gnus-newsgroup-unreads)) @@ -130,6 +127,7 @@ seen in the same session." ;; Chop off excess Message-IDs from the list. (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) (when end + (mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end)) (setcdr end nil)))) (defun gnus-dup-suppress-articles () @@ -137,11 +135,10 @@ seen in the same session." (unless gnus-dup-list (gnus-dup-open)) (gnus-message 6 "Suppressing duplicates...") - (let ((headers gnus-newsgroup-headers) - (auto (and gnus-newsgroup-auto-expire + (let ((auto (and gnus-newsgroup-auto-expire (memq gnus-duplicate-mark gnus-auto-expirable-marks))) - number header) - (while (setq header (pop headers)) + number) + (dolist (header gnus-newsgroup-headers) (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) (gnus-summary-article-unread-p (mail-header-number header))) (setq gnus-newsgroup-unreads @@ -155,7 +152,8 @@ seen in the same session." (defun gnus-dup-unsuppress-article (article) "Stop suppression of ARTICLE." - (let ((id (mail-header-id (gnus-data-header (gnus-data-find article))))) + (let* ((header (gnus-data-header (gnus-data-find article))) + (id (when header (mail-header-id header)))) (when id (setq gnus-dup-list-dirty t) (setq gnus-dup-list (delete id gnus-dup-list)) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 4dc5dde369a..220f9c3ce5c 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -86,13 +86,14 @@ It is a slightly enhanced emacs-lisp-mode. (make-local-variable 'gnus-prev-winconf) (gnus-run-mode-hooks 'gnus-edit-form-mode-hook)) -(defun gnus-edit-form (form documentation exit-func) +(defun gnus-edit-form (form documentation exit-func &optional layout) "Edit FORM in a new buffer. Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning -of the buffer." +of the buffer. +The optional LAYOUT overrides the `edit-form' window layout." (let ((winconf (current-window-configuration))) (set-buffer (gnus-get-buffer-create gnus-edit-form-buffer)) - (gnus-configure-windows 'edit-form) + (gnus-configure-windows (or layout 'edit-form)) (gnus-edit-form-mode) (setq gnus-prev-winconf winconf) (setq gnus-edit-form-done-function exit-func) diff --git a/lisp/gnus/gnus-ems.el b/lisp/gnus/gnus-ems.el index 88190b8085b..f37b1b73416 100644 --- a/lisp/gnus/gnus-ems.el +++ b/lisp/gnus/gnus-ems.el @@ -38,21 +38,17 @@ (defvar gnus-down-mouse-2 [down-mouse-2]) (defvar gnus-widget-button-keymap nil) (defvar gnus-mode-line-modified - (if (or (featurep 'xemacs) - (< emacs-major-version 20)) + (if (featurep 'xemacs) '("--**-" . "-----") '("**" "--"))) (eval-and-compile (autoload 'gnus-xmas-define "gnus-xmas") (autoload 'gnus-xmas-redefine "gnus-xmas") - (autoload 'appt-select-lowest-window "appt") (autoload 'gnus-get-buffer-create "gnus") (autoload 'nnheader-find-etc-directory "nnheader")) (autoload 'smiley-region "smiley") -;; Fixme: shouldn't require message -(autoload 'message-text-with-property "message") (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." @@ -73,12 +69,6 @@ valstr))) (eval-and-compile - (defalias 'gnus-char-width - (if (fboundp 'char-width) - 'char-width - (lambda (ch) 1)))) ;; A simple hack. - -(eval-and-compile (if (featurep 'xemacs) (gnus-xmas-define) (defvar gnus-mouse-face-prop 'mouse-face @@ -149,6 +139,18 @@ gnus-mouse-face-prop gnus-mouse-face) (insert " " gnus-tmp-subject-or-nil "\n"))))) +;; Clone of `appt-select-lowest-window' in appt.el. +(defun gnus-select-lowest-window () +"Select the lowest window on the frame." + (let ((lowest-window (selected-window)) + (bottom-edge (nth 3 (window-edges)))) + (walk-windows (lambda (w) + (let ((next-bottom-edge (nth 3 (window-edges w)))) + (when (< bottom-edge next-bottom-edge) + (setq bottom-edge next-bottom-edge + lowest-window w))))) + (select-window lowest-window))) + (defun gnus-region-active-p () "Say whether the region is active." (and (boundp 'transient-mark-mode) @@ -160,16 +162,6 @@ "Non-nil means the mark and region are currently active in this buffer." mark-active) ; aliased to region-exists-p in XEmacs. -(if (fboundp 'add-minor-mode) - (defalias 'gnus-add-minor-mode 'add-minor-mode) - (defun gnus-add-minor-mode (mode name map &rest rest) - (set (make-local-variable mode) t) - (unless (assq mode minor-mode-alist) - (push `(,mode ,name) minor-mode-alist)) - (unless (assq mode minor-mode-map-alist) - (push (cons mode map) - minor-mode-map-alist)))) - (defun gnus-x-splash () "Show a splash screen using a pixmap in the current buffer." (interactive) @@ -208,7 +200,9 @@ (setq sbars (cons (/ (or (frame-parameter nil 'scroll-bar-width) 14) fcw) - 0)))) + 0))) + (t + (setq sbars '(0 . 0)))) (setq left (- (* (round (/ (1- (/ (+ (window-width) (car sbars) (cdr sbars) (/ (+ (or (car fringes) 0) @@ -289,13 +283,26 @@ glyph)) (defun gnus-remove-image (image &optional category) - (dolist (position (message-text-with-property 'display)) - (when (and (equal (get-text-property position 'display) image) - (equal (get-text-property position 'gnus-image-category) + "Remove the image matching IMAGE and CATEGORY found first." + (let ((start (point-min)) + val end) + (while (and (not end) + (or (setq val (get-text-property start 'display)) + (and (setq start + (next-single-property-change start 'display)) + (setq val (get-text-property start 'display))))) + (setq end (or (next-single-property-change start 'display) + (point-max))) + (if (and (equal val image) + (equal (get-text-property start 'gnus-image-category) category)) - (put-text-property position (1+ position) 'display nil) - (when (get-text-property position 'gnus-image-text-deletable) - (delete-region position (1+ position)))))) + (progn + (put-text-property start end 'display nil) + (when (get-text-property start 'gnus-image-text-deletable) + (delete-region start end))) + (unless (= end (point-max)) + (setq start end + end nil)))))) (provide 'gnus-ems) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 83b5904e80b..162cc7e1984 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -46,21 +46,37 @@ :group 'gnus-fun :type 'string) -(defcustom gnus-convert-image-to-x-face-command "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface" +(defcustom gnus-convert-image-to-x-face-command + "convert -scale 48x48! %s xbm:- | xbm2xface.pl" "Command for converting an image to an X-Face. +The command must take a image filename (use \"%s\") as input. +The output must be the Face header data on stdout in PNG format. + By default it takes a GIF filename and output the X-Face header data on stdout." :version "22.1" :group 'gnus-fun - :type 'string) + :type '(choice (const :tag "giftopnm, netpbm (GIF input only)" + "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface") + (const :tag "convert" + "convert -scale 48x48! %s xbm:- | xbm2xface.pl") + (string))) -(defcustom gnus-convert-image-to-face-command "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng" +(defcustom gnus-convert-image-to-face-command + "convert -scale 48x48! %s -colors %d png:-" "Command for converting an image to a Face. -By default it takes a JPEG filename and output the Face header data -on stdout." + +The command must take an image filename (first format argument +\"%s\") and the number of colors (second format argument: \"%d\") +as input. The output must be the Face header data on stdout in +PNG format." :version "22.1" :group 'gnus-fun - :type 'string) + :type '(choice (const :tag "djpeg, netpbm (JPG input only)" + "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng") + (const :tag "convert" + "convert -scale 48x48! %s -colors %d png:-") + (string))) (defun gnus-shell-command-to-string (command) "Like `shell-command-to-string' except not mingling ERROR." @@ -102,8 +118,11 @@ Output to the current buffer, replace text, and don't mingle error." ;;;###autoload (defun gnus-x-face-from-file (file) - "Insert an X-Face header based on an image file." - (interactive "fImage file name (by default GIF): ") + "Insert an X-Face header based on an image file. + +Depending on `gnus-convert-image-to-x-face-command' it may accept +different input formats." + (interactive "fImage file name: ") (when (file-exists-p file) (gnus-shell-command-to-string (format gnus-convert-image-to-x-face-command @@ -111,8 +130,11 @@ Output to the current buffer, replace text, and don't mingle error." ;;;###autoload (defun gnus-face-from-file (file) - "Return a Face header based on an image file." - (interactive "fImage file name (by default JPEG): ") + "Return a Face header based on an image file. + +Depending on `gnus-convert-image-to-face-command' it may accept +different input formats." + (interactive "fImage file name: ") (when (file-exists-p file) (let ((done nil) (attempt "") @@ -127,7 +149,7 @@ Output to the current buffer, replace text, and don't mingle error." quant)))) (if (> (length attempt) 726) (progn - (setq quant (- quant 2)) + (setq quant (- quant (if (< quant 10) 1 2))) (gnus-message 9 "Length %d; trying quant %d" (length attempt) quant)) (setq done t))) @@ -197,11 +219,11 @@ colors of the displayed X-Faces." 'xface (gnus-put-image (if (gnus-image-type-available-p 'xface) - (gnus-create-image - (concat "X-Face: " data) - 'xface t :face 'gnus-x-face) - (gnus-create-image - pbm 'pbm t :face 'gnus-x-face)) nil 'xface)) + (apply 'gnus-create-image (concat "X-Face: " data) 'xface t + (cdr (assq 'xface gnus-face-properties-alist))) + (apply 'gnus-create-image pbm 'pbm t + (cdr (assq 'pbm gnus-face-properties-alist)))) + nil 'xface)) (gnus-add-wash-type 'xface)))))) (defun gnus-grab-cam-x-face () diff --git a/lisp/gnus/gnus-gl.el b/lisp/gnus/gnus-gl.el deleted file mode 100644 index 98326ee2923..00000000000 --- a/lisp/gnus/gnus-gl.el +++ /dev/null @@ -1,860 +0,0 @@ -;;; gnus-gl.el --- an interface to GroupLens for Gnus - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. - -;; Author: Brad Miller <bmiller@cs.umn.edu> -;; Keywords: news, score - -;; 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 3, 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; GroupLens software and documentation is copyright (c) 1995 by Paul -;; Resnick (Massachusetts Institute of Technology); Brad Miller, John -;; Riedl, Jon Herlocker, and Joseph Konstan (University of Minnesota), -;; and David Maltz (Carnegie-Mellon University). -;; -;; Permission to use, copy, modify, and distribute this documentation -;; for non-commercial and commercial purposes without fee is hereby -;; granted provided that this copyright notice and permission notice -;; appears in all copies and that the names of the individuals and -;; institutions holding this copyright are not used in advertising or -;; publicity pertaining to this software without specific, written -;; prior permission. The copyright holders make no representations -;; about the suitability of this software and documentation for any -;; purpose. It is provided ``as is'' without express or implied -;; warranty. -;; -;; The copyright holders request that they be notified of -;; modifications of this code. Please send electronic mail to -;; grouplens@cs.umn.edu for more information or to announce derived -;; works. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Author: Brad Miller -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; User Documentation: -;; To use GroupLens you must load this file. -;; You must also register a pseudonym with the Better Bit Bureau. -;; http://www.cs.umn.edu/Research/GroupLens -;; -;; ---------------- For your .emacs or .gnus file ---------------- -;; -;; As of version 2.5, grouplens now works as a minor mode of -;; gnus-summary-mode. To get make that work you just need a couple of -;; hooks. -;; (setq gnus-use-grouplens t) -;; (setq grouplens-pseudonym "") -;; (setq grouplens-bbb-host "grouplens.cs.umn.edu") -;; -;; (setq gnus-summary-default-score 0) -;; -;; USING GROUPLENS -;; How do I Rate an article?? -;; Before you type n to go to the next article, hit a number from 1-5 -;; Type r in the summary buffer and you will be prompted. -;; Note that when you're in grouplens-minor-mode 'r' masks the -;; usual reply binding for 'r' -;; -;; What if, Gasp, I find a bug??? -;; Please type M-x gnus-gl-submit-bug-report. This will set up a -;; mail buffer with the state of variables and buffers that will help -;; me debug the problem. A short description up front would help too! -;; -;; How do I display the prediction for an article: -;; If you set the gnus-summary-line-format as shown above, the score -;; (prediction) will be shown automatically. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Programmer Notes -;; 10/9/95 -;; gnus-scores-articles contains the articles -;; When scoring is done, the call tree looks something like: -;; gnus-possibly-score-headers -;; ==> gnus-score-headers -;; ==> gnus-score-load-file -;; ==> get-all-mids (from the eval form) -;; -;; it would be nice to have one that gets called after all the other -;; headers have been scored. -;; we may want a variable gnus-grouplens-scale-factor -;; and gnus-grouplens-offset this would probably be either -3 or 0 -;; to make the scores centered around zero or not. -;; Notes 10/12/95 -;; According to Lars, Norse god of gnus, the simple way to insert a -;; call to an external function is to have a function added to the -;; variable gnus-score-find-files-function This new function -;; gnus-grouplens-score-alist will return a core alist that -;; has (("message-id" ("<message-id-xxxx>" score) ("<message-id-xxxy>" score)) -;; This seems like it would be pretty inefficient, though workable. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; TODO -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 3. Add some more ways to rate messages -;; 4. Better error handling for token timeouts. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; bugs -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'gnus-score) -(require 'gnus) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; User variables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar gnus-summary-grouplens-line-format - "%U\%R\%z%l%I\%(%[%4L: %-23,23n%]%) %s\n" - "*The line format spec in summary GroupLens mode buffers.") - -(defvar grouplens-pseudonym "" - "User's pseudonym. -This pseudonym is obtained during the registration process") - -(defvar grouplens-bbb-host "grouplens.cs.umn.edu" - "Host where the bbbd is running.") - -(defvar grouplens-bbb-port 9000 - "Port where the bbbd is listening.") - -(defvar grouplens-newsgroups - '("comp.groupware" "comp.human-factors" "comp.lang.c++" - "comp.lang.java" "comp.os.linux.admin" "comp.os.linux.advocacy" - "comp.os.linux.announce" "comp.os.linux.answers" - "comp.os.linux.development" "comp.os.linux.development.apps" - "comp.os.linux.development.system" "comp.os.linux.hardware" - "comp.os.linux.help" "comp.os.linux.m68k" "comp.os.linux.misc" - "comp.os.linux.networking" "comp.os.linux.setup" "comp.os.linux.x" - "mn.general" "rec.arts.movies" "rec.arts.movies.current-films" - "rec.food.recipes" "rec.humor") - "*Groups that are part of the GroupLens experiment.") - -(defvar grouplens-prediction-display 'prediction-spot - "valid values are: - prediction-spot -- an * corresponding to the prediction between 1 and 5, - confidence-interval -- a numeric confidence interval - prediction-bar -- |##### | the longer the bar, the better the article, - confidence-bar -- | ----- } the prediction is in the middle of the bar, - confidence-spot -- ) * | the spot gets bigger with more confidence, - prediction-num -- plain-old numeric value, - confidence-plus-minus -- prediction +/i confidence") - -(defvar grouplens-score-offset 0 - "Offset the prediction by this value. -Setting this variable to -2 would have the following effect on -GroupLens scores: - - 1 --> -2 - 2 --> -1 - 3 --> 0 - 4 --> 1 - 5 --> 2 - -The reason is that a user might want to do this is to combine -GroupLens predictions with scores calculated by other score methods.") - -(defvar grouplens-score-scale-factor 1 - "This variable allows the user to magnify the effect of GroupLens scores. -The scale factor is applied after the offset.") - -(defvar gnus-grouplens-override-scoring 'override - "Tell GroupLens to override the normal Gnus scoring mechanism. -GroupLens scores can be combined with gnus scores in one of three ways. -'override -- just use grouplens predictions for grouplens groups -'combine -- combine grouplens scores with gnus scores -'separate -- treat grouplens scores completely separate from gnus") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Program global variables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar grouplens-bbb-token nil - "Current session token number.") - -(defvar grouplens-bbb-process nil - "Process Id of current bbbd network stream process.") - -(defvar grouplens-bbb-buffer nil - "Buffer associated with the BBBD process.") - -(defvar grouplens-rating-alist nil - "Current set of message-id rating pairs.") - -(defvar grouplens-current-hashtable nil - "A hashtable to hold predictions from the BBB.") - -(defvar grouplens-current-group nil) - -;;(defvar bbb-alist nil) - -(defvar bbb-timeout-secs 10 - "Number of seconds to wait for some response from the BBB. -If this times out we give up and assume that something has died..." ) - -(defvar grouplens-previous-article nil - "Message-ID of the last article read.") - -(defvar bbb-read-point) -(defvar bbb-response-point) - -(defun bbb-renew-hash-table () - (setq grouplens-current-hashtable (make-vector 100 0))) - -(bbb-renew-hash-table) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Utility Functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun bbb-connect-to-bbbd (host port) - (unless grouplens-bbb-buffer - (setq grouplens-bbb-buffer - (gnus-get-buffer-create (format " *BBBD trace: %s*" host))) - (save-excursion - (set-buffer grouplens-bbb-buffer) - (make-local-variable 'bbb-read-point) - (make-local-variable 'bbb-response-point) - (setq bbb-read-point (point-min)))) - - ;; if an old process is still running for some reason, kill it - (when grouplens-bbb-process - (ignore-errors - (when (eq 'open (process-status grouplens-bbb-process)) - (set-process-buffer grouplens-bbb-process nil) - (delete-process grouplens-bbb-process)))) - - ;; clear the trace buffer of old output - (save-excursion - (set-buffer grouplens-bbb-buffer) - (erase-buffer)) - - ;; open the connection to the server - (catch 'done - (condition-case error - (setq grouplens-bbb-process - (open-network-stream "BBBD" grouplens-bbb-buffer host port)) - (error (gnus-message 3 "Error: Failed to connect to BBB") - nil)) - (and (null grouplens-bbb-process) - (throw 'done nil)) - (save-excursion - (set-buffer grouplens-bbb-buffer) - (setq bbb-read-point (point-min)) - (or (bbb-read-response grouplens-bbb-process) - (throw 'done nil)))) - - ;; return the process - grouplens-bbb-process) - -(defun bbb-send-command (process command) - (goto-char (point-max)) - (insert command) - (insert "\r\n") - (setq bbb-read-point (point)) - (setq bbb-response-point (point)) - (set-marker (process-mark process) (point)) ; process output also comes here - (process-send-string process command) - (process-send-string process "\r\n") - (process-send-eof process)) - -(defun bbb-read-response (process) - "This function eats the initial response of OK or ERROR from the BBB." - (let ((case-fold-search nil) - match-end) - (goto-char bbb-read-point) - (while (and (not (search-forward "\r\n" nil t)) - (accept-process-output process bbb-timeout-secs)) - (goto-char bbb-read-point)) - (setq match-end (point)) - (goto-char bbb-read-point) - (setq bbb-read-point match-end) - (looking-at "OK"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Login Functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun bbb-login () - "return the token number if login is successful, otherwise return nil." - (interactive) - (setq grouplens-bbb-token nil) - (if (not (equal grouplens-pseudonym "")) - (let ((bbb-process - (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) - (if bbb-process - (save-excursion - (set-buffer (process-buffer bbb-process)) - (bbb-send-command bbb-process - (concat "login " grouplens-pseudonym)) - (if (bbb-read-response bbb-process) - (setq grouplens-bbb-token (bbb-extract-token-number)) - (gnus-message 3 "Error: GroupLens login failed"))))) - (gnus-message 3 "Error: you must set a pseudonym")) - grouplens-bbb-token) - -(defun bbb-extract-token-number () - (let ((token-pos (search-forward "token=" nil t))) - (when (looking-at "[0-9]+") - (buffer-substring token-pos (match-end 0))))) - -(gnus-add-shutdown 'bbb-logout 'gnus) - -(defun bbb-logout () - "logout of bbb session." - (when grouplens-bbb-token - (let ((bbb-process - (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) - (when bbb-process - (save-excursion - (set-buffer (process-buffer bbb-process)) - (bbb-send-command bbb-process (concat "logout " grouplens-bbb-token)) - (bbb-read-response bbb-process)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Get Predictions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun bbb-build-mid-scores-alist (groupname) - "this function can be called as part of the function to return the list of score files to use. -See the gnus variable `gnus-score-find-score-files-function'. - -*Note:* If you want to use grouplens scores along with calculated scores, -you should see the offset and scale variables. At this point, I don't -recommend using both scores and grouplens predictions together." - (setq grouplens-current-group groupname) - (when (member groupname grouplens-newsgroups) - (setq grouplens-previous-article nil) - ;; scores-alist should be a list of lists: - ;; ((("message-id" ("<mid1>" score1 nil s) ("<mid2> score2 nil s)))) - ;;`((("message-id" . ,predict-list))) ; Yes, this is the return value - (list - (list - (list (append (list "message-id") - (bbb-get-predictions (bbb-get-all-mids) groupname))))))) - -(defun bbb-get-predictions (midlist groupname) - "Ask the bbb for predictions, and build up the score alist." - (gnus-message 5 "Fetching Predictions...") - (if grouplens-bbb-token - (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host - grouplens-bbb-port))) - (when bbb-process - (save-excursion - (set-buffer (process-buffer bbb-process)) - (bbb-send-command bbb-process - (bbb-build-predict-command midlist groupname - grouplens-bbb-token)) - (if (bbb-read-response bbb-process) - (bbb-get-prediction-response bbb-process) - (gnus-message 1 "Invalid Token, login and try again") - (ding))))) - (gnus-message 3 "Error: You are not logged in to a BBB") - (ding))) - -(defun bbb-get-all-mids () - (mapcar (function (lambda (x) (mail-header-id x))) gnus-newsgroup-headers)) - -(defun bbb-build-predict-command (mlist grpname token) - (concat "getpredictions " token " " grpname "\r\n" - (mapconcat 'identity mlist "\r\n") "\r\n.\r\n")) - -(defun bbb-get-prediction-response (process) - (let ((case-fold-search nil)) - (goto-char bbb-read-point) - (while (and (not (search-forward ".\r\n" nil t)) - (accept-process-output process bbb-timeout-secs)) - (goto-char bbb-read-point)) - (goto-char (+ bbb-response-point 4));; we ought to be right before OK - (bbb-build-response-alist))) - -;; build-response-alist assumes that the cursor has been positioned at -;; the first line of the list of mid/rating pairs. -(defun bbb-build-response-alist () - (let (resp mid pred) - (while - (cond - ((looking-at "\\(<.*>\\) :nopred=") - ;;(push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp) - (forward-line 1) - t) - ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)") - (setq mid (bbb-get-mid) - pred (bbb-get-pred)) - (push `(,mid ,pred nil s) resp) - (gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh)) - grouplens-current-hashtable) - (forward-line 1) - t) - ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)") - (setq mid (bbb-get-mid) - pred (bbb-get-pred)) - (push `(,mid ,pred nil s) resp) - (gnus-sethash mid (list pred 0 0) grouplens-current-hashtable) - (forward-line 1) - t) - (t nil))) - resp)) - -;; these "get" functions assume that there is an active match lying -;; around. Where the first parenthesized expression is the -;; message-id, and the second is the prediction, the third and fourth -;; are the confidence interval -;; -;; Since gnus assumes that scores are integer values?? we round the -;; prediction. -(defun bbb-get-mid () - (buffer-substring (match-beginning 1) (match-end 1))) - -(defun bbb-get-pred () - (let ((tpred (string-to-number (buffer-substring (match-beginning 2) - (match-end 2))))) - (if (> tpred 0) - (round (* grouplens-score-scale-factor - (+ grouplens-score-offset tpred))) - 1))) - -(defun bbb-get-confl () - (string-to-number (buffer-substring (match-beginning 4) (match-end 4)))) - -(defun bbb-get-confh () - (string-to-number (buffer-substring (match-beginning 4) (match-end 4)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Prediction Display -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst grplens-rating-range 4.0) -(defconst grplens-maxrating 5) -(defconst grplens-minrating 1) -(defconst grplens-predstringsize 12) - -(defvar gnus-tmp-score) -(defun bbb-grouplens-score (header) - (if (eq gnus-grouplens-override-scoring 'separate) - (bbb-grouplens-other-score header) - (let* ((rate-string (make-string 12 ?\ )) - (mid (mail-header-id header)) - (hashent (gnus-gethash mid grouplens-current-hashtable)) - (iscore gnus-tmp-score) - (low (car (cdr hashent))) - (high (car (cdr (cdr hashent))))) - (aset rate-string 0 ?|) - (aset rate-string 11 ?|) - (unless (member grouplens-current-group grouplens-newsgroups) - (unless (equal grouplens-prediction-display 'prediction-num) - (cond ((< iscore 0) - (setq iscore 1)) - ((> iscore 5) - (setq iscore 5)))) - (setq low 0) - (setq high 0)) - (if (and (bbb-valid-score iscore) - (not (null mid))) - (cond - ;; prediction-spot - ((equal grouplens-prediction-display 'prediction-spot) - (setq rate-string (bbb-fmt-prediction-spot rate-string iscore))) - ;; confidence-interval - ((equal grouplens-prediction-display 'confidence-interval) - (setq rate-string (bbb-fmt-confidence-interval iscore low high))) - ;; prediction-bar - ((equal grouplens-prediction-display 'prediction-bar) - (setq rate-string (bbb-fmt-prediction-bar rate-string iscore))) - ;; confidence-bar - ((equal grouplens-prediction-display 'confidence-bar) - (setq rate-string (format "| %4.2f |" iscore))) - ;; confidence-spot - ((equal grouplens-prediction-display 'confidence-spot) - (setq rate-string (format "| %4.2f |" iscore))) - ;; prediction-num - ((equal grouplens-prediction-display 'prediction-num) - (setq rate-string (bbb-fmt-prediction-num iscore))) - ;; confidence-plus-minus - ((equal grouplens-prediction-display 'confidence-plus-minus) - (setq rate-string (bbb-fmt-confidence-plus-minus iscore low high)) - ) - (t (gnus-message 3 "Invalid prediction display type"))) - (aset rate-string 5 ?N) (aset rate-string 6 ?A)) - rate-string))) - -;; Gnus user format function that doesn't depend on -;; bbb-build-mid-scores-alist being used as the score function, but is -;; instead called from gnus-select-group-hook. -- LAB -(defun bbb-grouplens-other-score (header) - (if (not (member grouplens-current-group grouplens-newsgroups)) - ;; Return an empty string - "" - (let* ((rate-string (make-string 12 ?\ )) - (mid (mail-header-id header)) - (hashent (gnus-gethash mid grouplens-current-hashtable)) - (pred (or (nth 0 hashent) 0)) - (low (nth 1 hashent)) - (high (nth 2 hashent))) - ;; Init rate-string - (aset rate-string 0 ?|) - (aset rate-string 11 ?|) - (unless (equal grouplens-prediction-display 'prediction-num) - (cond ((< pred 0) - (setq pred 1)) - ((> pred 5) - (setq pred 5)))) - ;; If no entry in BBB hash mark rate string as NA and return - (cond - ((null hashent) - (aset rate-string 5 ?N) - (aset rate-string 6 ?A) - rate-string) - - ((equal grouplens-prediction-display 'prediction-spot) - (bbb-fmt-prediction-spot rate-string pred)) - - ((equal grouplens-prediction-display 'confidence-interval) - (bbb-fmt-confidence-interval pred low high)) - - ((equal grouplens-prediction-display 'prediction-bar) - (bbb-fmt-prediction-bar rate-string pred)) - - ((equal grouplens-prediction-display 'confidence-bar) - (format "| %4.2f |" pred)) - - ((equal grouplens-prediction-display 'confidence-spot) - (format "| %4.2f |" pred)) - - ((equal grouplens-prediction-display 'prediction-num) - (bbb-fmt-prediction-num pred)) - - ((equal grouplens-prediction-display 'confidence-plus-minus) - (bbb-fmt-confidence-plus-minus pred low high)) - - (t - (gnus-message 3 "Invalid prediction display type") - (aset rate-string 0 ?|) - (aset rate-string 11 ?|) - rate-string))))) - -(defun bbb-valid-score (score) - (or (equal grouplens-prediction-display 'prediction-num) - (and (>= score grplens-minrating) - (<= score grplens-maxrating)))) - -(defun bbb-requires-confidence (format-type) - (or (equal format-type 'confidence-plus-minus) - (equal format-type 'confidence-spot) - (equal format-type 'confidence-interval))) - -(defun bbb-have-confidence (clow chigh) - (not (or (null clow) - (null chigh)))) - -(defun bbb-fmt-prediction-spot (rate-string score) - (aset rate-string - (round (* (/ (- score grplens-minrating) grplens-rating-range) - (+ (- grplens-predstringsize 4) 1.49))) - ?*) - rate-string) - -(defun bbb-fmt-confidence-interval (score low high) - (if (bbb-have-confidence low high) - (format "|%4.2f-%4.2f |" low high) - (bbb-fmt-prediction-num score))) - -(defun bbb-fmt-confidence-plus-minus (score low high) - (if (bbb-have-confidence low high) - (format "|%3.1f+/-%4.2f|" score (/ (- high low) 2.0)) - (bbb-fmt-prediction-num score))) - -(defun bbb-fmt-prediction-bar (rate-string score) - (let* ((i 1) - (step (/ grplens-rating-range (- grplens-predstringsize 4))) - (half-step (/ step 2)) - (loc (- grplens-minrating half-step))) - (while (< i (- grplens-predstringsize 2)) - (if (> score loc) - (aset rate-string i ?#) - (aset rate-string i ?\ )) - (setq i (+ i 1)) - (setq loc (+ loc step))) - ) - rate-string) - -(defun bbb-fmt-prediction-num (score) - (format "| %4.2f |" score)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Put Ratings -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun bbb-put-ratings () - (if (and grouplens-bbb-token - grouplens-rating-alist - (member gnus-newsgroup-name grouplens-newsgroups)) - (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host - grouplens-bbb-port)) - (rate-command (bbb-build-rate-command grouplens-rating-alist))) - (if bbb-process - (save-excursion - (set-buffer (process-buffer bbb-process)) - (gnus-message 5 "Sending Ratings...") - (bbb-send-command bbb-process rate-command) - (if (bbb-read-response bbb-process) - (setq grouplens-rating-alist nil) - (gnus-message 1 - "Token timed out: call bbb-login and quit again") - (ding)) - (gnus-message 5 "Sending Ratings...Done")) - (gnus-message 3 "No BBB connection"))) - (setq grouplens-rating-alist nil))) - -(defun bbb-build-rate-command (rate-alist) - (concat "putratings " grouplens-bbb-token " " grouplens-current-group " \r\n" - (mapconcat (lambda (this) ; form (mid . (score . time)) - (concat (car this) - " :rating=" (cadr this) ".00" - " :time=" (cddr this))) - rate-alist "\r\n") - "\r\n.\r\n")) - -;; Interactive rating functions. -(defun bbb-summary-rate-article (rating &optional midin) - (interactive "nRating: ") - (when (member gnus-newsgroup-name grouplens-newsgroups) - (let ((mid (or midin (bbb-get-current-id)))) - (if (and rating - (>= rating grplens-minrating) - (<= rating grplens-maxrating) - mid) - (let ((oldrating (assoc mid grouplens-rating-alist))) - (if oldrating - (setcdr oldrating (cons rating 0)) - (push `(,mid . (,rating . 0)) grouplens-rating-alist)) - (gnus-summary-mark-article nil (int-to-string rating))) - (gnus-message 3 "Invalid rating"))))) - -(defun grouplens-next-unread-article (rating) - "Select unread article after current one." - (interactive "P") - (when rating - (bbb-summary-rate-article rating)) - (gnus-summary-next-unread-article)) - -(defun grouplens-best-unread-article (rating) - "Select unread article after current one." - (interactive "P") - (when rating - (bbb-summary-rate-article rating)) - (gnus-summary-best-unread-article)) - -(defun grouplens-summary-catchup-and-exit (rating) - "Mark all articles not marked as unread in this newsgroup as read, then exit. -If prefix argument ALL is non-nil, all articles are marked as read." - (interactive "P") - (when rating - (bbb-summary-rate-article rating)) - (if (numberp rating) - (gnus-summary-catchup-and-exit) - (gnus-summary-catchup-and-exit rating))) - -(defun grouplens-score-thread (score) - "Raise the score of the articles in the current thread with SCORE." - (interactive "nRating: ") - (let (e) - (save-excursion - (let ((articles (gnus-summary-articles-in-thread)) - article) - (while (setq article (pop articles)) - (gnus-summary-goto-subject article) - (bbb-summary-rate-article score - (mail-header-id - (gnus-summary-article-header article))))) - (setq e (point))) - (let ((gnus-summary-check-current t)) - (or (zerop (gnus-summary-next-subject 1 t)) - (goto-char e)))) - (gnus-summary-recenter) - (gnus-summary-position-point) - (gnus-set-mode-line 'summary)) - -(defun bbb-exit-group () - (bbb-put-ratings) - (bbb-renew-hash-table)) - -(defun bbb-get-current-id () - (if gnus-current-headers - (mail-header-id gnus-current-headers) - (gnus-message 3 "You must select an article before you rate it"))) - -(defun bbb-grouplens-group-p (group) - "Say whether GROUP is a GroupLens group." - (if (member group grouplens-newsgroups) " (GroupLens Enhanced)" "")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; TIME SPENT READING -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar grouplens-current-starting-time nil) - -(defun grouplens-start-timer () - (setq grouplens-current-starting-time (current-time))) - -(defun grouplens-elapsed-time () - (let ((et (bbb-time-float (current-time)))) - (- et (bbb-time-float grouplens-current-starting-time)))) - -(defun bbb-time-float (timeval) - (+ (* (car timeval) 65536) - (cadr timeval))) - -(defun grouplens-do-time () - (when (member gnus-newsgroup-name grouplens-newsgroups) - (when grouplens-previous-article - (let ((elapsed-time (grouplens-elapsed-time)) - (oldrating (assoc grouplens-previous-article - grouplens-rating-alist))) - (if (not oldrating) - (push `(,grouplens-previous-article . (0 . ,elapsed-time)) - grouplens-rating-alist) - (setcdr oldrating (cons (cadr oldrating) elapsed-time))))) - (grouplens-start-timer) - (setq grouplens-previous-article (bbb-get-current-id)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; BUG REPORTING -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst gnus-gl-version "gnus-gl.el 2.50") -(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu") -(defun gnus-gl-submit-bug-report () - "Submit via mail a bug report on gnus-gl." - (interactive) - (require 'reporter) - (reporter-submit-bug-report gnus-gl-maintainer-address - (concat "gnus-gl.el " gnus-gl-version) - (list 'grouplens-pseudonym - 'grouplens-bbb-host - 'grouplens-bbb-port - 'grouplens-newsgroups - 'grouplens-bbb-token - 'grouplens-bbb-process - 'grouplens-current-group - 'grouplens-previous-article) - nil - 'gnus-gl-get-trace)) - -(defun gnus-gl-get-trace () - "Insert the contents of the BBBD trace buffer." - (when grouplens-bbb-buffer - (insert-buffer-substring grouplens-bbb-buffer))) - -;; -;; GroupLens minor mode -;; - -(defvar gnus-grouplens-mode nil - "Minor mode for providing a GroupLens interface in Gnus summary buffers.") - -(defvar gnus-grouplens-mode-map nil) - -(unless gnus-grouplens-mode-map - (setq gnus-grouplens-mode-map (make-keymap)) - (gnus-define-keys - gnus-grouplens-mode-map - "n" grouplens-next-unread-article - "r" bbb-summary-rate-article - "k" grouplens-score-thread - "c" grouplens-summary-catchup-and-exit - "," grouplens-best-unread-article)) - -(defun gnus-grouplens-make-menu-bar () - (unless (boundp 'gnus-grouplens-menu) - (easy-menu-define - gnus-grouplens-menu gnus-grouplens-mode-map "" - '("GroupLens" - ["Login" bbb-login t] - ["Rate" bbb-summary-rate-article t] - ["Next article" grouplens-next-unread-article t] - ["Best article" grouplens-best-unread-article t] - ["Raise thread" grouplens-score-thread t] - ["Report bugs" gnus-gl-submit-bug-report t])))) - -(defun gnus-grouplens-mode (&optional arg) - "Minor mode for providing a GroupLens interface in Gnus summary buffers." - (interactive "P") - (when (and (eq major-mode 'gnus-summary-mode) - (member gnus-newsgroup-name grouplens-newsgroups)) - (make-local-variable 'gnus-grouplens-mode) - (setq gnus-grouplens-mode - (if (null arg) (not gnus-grouplens-mode) - (> (prefix-numeric-value arg) 0))) - (when gnus-grouplens-mode - (gnus-make-local-hook 'gnus-select-article-hook) - (add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local) - (gnus-make-local-hook 'gnus-exit-group-hook) - (add-hook 'gnus-exit-group-hook 'bbb-exit-group nil 'local) - (make-local-variable 'gnus-score-find-score-files-function) - - (cond - ((eq gnus-grouplens-override-scoring 'combine) - ;; either add bbb-buld-mid-scores-alist to a list - ;; or make a list - (if (listp gnus-score-find-score-files-function) - (setq gnus-score-find-score-files-function - (append 'bbb-build-mid-scores-alist - gnus-score-find-score-files-function)) - (setq gnus-score-find-score-files-function - (list gnus-score-find-score-files-function - 'bbb-build-mid-scores-alist)))) - ;; leave the gnus-score-find-score-files variable alone - ((eq gnus-grouplens-override-scoring 'separate) - (add-hook 'gnus-select-group-hook - (lambda () - (bbb-get-predictions (bbb-get-all-mids) - gnus-newsgroup-name)))) - ;; default is to override - (t - (setq gnus-score-find-score-files-function - 'bbb-build-mid-scores-alist))) - - ;; Change how summary lines look - (make-local-variable 'gnus-summary-line-format) - (make-local-variable 'gnus-summary-line-format-spec) - (setq gnus-summary-line-format gnus-summary-grouplens-line-format) - (setq gnus-summary-line-format-spec nil) - (gnus-update-format-specifications nil 'summary) - (gnus-update-summary-mark-positions) - - ;; Set up the menu. - (when (and menu-bar-mode - (gnus-visual-p 'grouplens-menu 'menu)) - (gnus-grouplens-make-menu-bar)) - (gnus-add-minor-mode - 'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map) - (gnus-run-hooks 'gnus-grouplens-mode-hook)))) - -(provide 'gnus-gl) - -;;; arch-tag: 6f1bab2c-c2a3-4764-9ef6-0714cd5902a4 -;;; gnus-gl.el ends here diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 3c5cd7bedef..942a1cf4947 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -47,7 +47,11 @@ (require 'mm-url) (let ((features (cons 'gnus-group features))) (require 'gnus-sum)) - (defvar gnus-cache-active-hashtb)) + (unless (boundp 'gnus-cache-active-hashtb) + (defvar gnus-cache-active-hashtb nil))) + +(autoload 'gnus-agent-total-fetched-for "gnus-agent") +(autoload 'gnus-cache-total-fetched-for "gnus-cache") (defcustom gnus-group-archive-directory "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" @@ -61,7 +65,7 @@ :group 'gnus-group-foreign :type 'directory) -(defcustom gnus-no-groups-message "No gnus is bad news" +(defcustom gnus-no-groups-message "No Gnus is good news" "*Message displayed by Gnus when no groups are available." :group 'gnus-start :type 'string) @@ -151,7 +155,7 @@ list." (function-item gnus-group-sort-by-rank) (function :tag "other" nil)))) -(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%l %O\n" +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n" "*Format of group lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -179,11 +183,11 @@ with some simple extensions. %O Moderated group (string, \"(m)\" or \"\") %P Topic indentation (string) %m Whether there is new(ish) mail in the group (char, \"%\") -%l Whether there are GroupLens predictions for this group (string) %n Select from where (string) %z A string that look like `<%s:%n>' if a foreign select method is used %d The date the group was last entered. %E Icon as defined by `gnus-group-icon-list'. +%F The disk space used by the articles fetched by both the cache and agent. %u User defined specifier. The next character in the format string should be a letter. Gnus will call the function gnus-user-format-function-X, where X is the letter following %u. The function will be passed a @@ -198,10 +202,10 @@ output may end up looking strange when listing both alive and killed groups. If you use %o or %O, reading the active file will be slower and quite -a bit of extra memory will be used. %D will also worsen performance. -Also note that if you change the format specification to include any -of these specs, you must probably re-start Gnus to see them go into -effect. +a bit of extra memory will be used. %D and %F will also worsen +performance. Also note that if you change the format specification to +include any of these specs, you must probably re-start Gnus to see +them go into effect. General format specifiers can also be used. See Info node `(gnus)Formatting Variables'." @@ -416,6 +420,7 @@ score: The score of the group. ticked: The number of ticked articles." :group 'gnus-group-icons :type '(repeat (cons (sexp :tag "Form") file))) +(put 'gnus-group-icon-list 'risky-local-variable t) (defcustom gnus-group-name-charset-method-alist nil "Alist of method and the charset for group names. @@ -440,13 +445,20 @@ For example: (defcustom gnus-group-jump-to-group-prompt nil "Default prompt for `gnus-group-jump-to-group'. -If non-nil, the value should be a string, e.g. \"nnml:\", -in which case `gnus-group-jump-to-group' offers \"Group: nnml:\" -in the minibuffer prompt." + +If non-nil, the value should be a string or an alist. If it is a string, +e.g. \"nnml:\", in which case `gnus-group-jump-to-group' offers \"Group: +nnml:\" in the minibuffer prompt. + +If it is an alist, it must consist of \(NUMBER . PROMPT\) pairs, for example: +\((1 . \"\") (2 . \"nnfolder+archive:\")). The element with number 0 is +used when no prefix argument is given to `gnus-group-jump-to-group'." :version "22.1" :group 'gnus-group-various :type '(choice (string :tag "Prompt string") - (const :tag "Empty" nil))) + (const :tag "Empty" nil) + (repeat (cons (integer :tag "Argument") + (string :tag "Prompt string"))))) (defvar gnus-group-listing-limit 1000 "*A limit of the number of groups when listing. @@ -512,11 +524,12 @@ simple manner.") (?P gnus-group-indentation ?s) (?E gnus-tmp-group-icon ?s) (?B gnus-tmp-summary-live ?c) - (?l gnus-tmp-grouplens ?s) (?z gnus-tmp-news-method-string ?s) (?m (gnus-group-new-mail gnus-tmp-group) ?c) (?d (gnus-group-timestamp-string gnus-tmp-group) ?s) - (?u gnus-tmp-user-defined ?s))) + (?u gnus-tmp-user-defined ?s) + (?F (gnus-total-fetched-for gnus-tmp-group) ?s) + )) (defvar gnus-group-mode-line-format-alist `((?S gnus-tmp-news-server ?s) @@ -648,6 +661,7 @@ simple manner.") "r" gnus-group-rename-group "R" gnus-group-make-rss-group "c" gnus-group-customize + "z" gnus-group-compact-group "x" gnus-group-nnimap-expunge "\177" gnus-group-delete-group [delete] gnus-group-delete-group) @@ -730,7 +744,8 @@ simple manner.") "?" gnus-group-list-plus) (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) - "f" gnus-score-flush-cache) + "f" gnus-score-flush-cache + "e" gnus-score-edit-all-score) (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) "c" gnus-group-fetch-charter @@ -825,6 +840,8 @@ simple manner.") (gnus-group-group-name)] ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] ["Customize" gnus-group-customize (gnus-group-group-name)] + ["Compact" gnus-group-compact-group + :active (gnus-group-group-name)] ("Edit" ["Parameters" gnus-group-edit-group-parameters :included (not (gnus-topic-mode-p)) @@ -1010,7 +1027,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and (const :tag "Retro look" gnus-group-tool-bar-retro) (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1053,7 +1070,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and See `gmm-tool-bar-from-list' for the format of the list." :type '(repeat gmm-tool-bar-item) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1072,7 +1089,7 @@ See `gmm-tool-bar-from-list' for the format of the list." See `gmm-tool-bar-from-list' for the format of the list." :type '(repeat gmm-tool-bar-item) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1083,7 +1100,7 @@ These items are not displayed in the Gnus group mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1143,7 +1160,8 @@ The following commands are available: (use-local-map gnus-group-mode-map) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t) + (setq buffer-read-only t + show-trailing-whitespace nil) (gnus-set-default-directory) (gnus-update-format-specifications nil 'group 'group-mode) (gnus-update-group-mark-positions) @@ -1202,7 +1220,10 @@ The following commands are available: (defun gnus-group-name-charset (method group) (if (null method) (setq method (gnus-find-method-for-group group))) - (let ((item (assoc method gnus-group-name-charset-method-alist)) + (let ((item (or (assoc method gnus-group-name-charset-method-alist) + (and (consp method) + (assoc (list (car method) (cadr method)) + gnus-group-name-charset-method-alist)))) (alist gnus-group-name-charset-group-alist) result) (if item @@ -1244,7 +1265,7 @@ Also see the `gnus-group-use-permanent-levels' variable." (gnus-group-setup-buffer) (gnus-update-format-specifications nil 'group 'group-mode) (let ((case-fold-search nil) - (props (text-properties-at (gnus-point-at-bol))) + (props (text-properties-at (point-at-bol))) (empty (= (point-min) (point-max))) (group (gnus-group-group-name)) number) @@ -1276,7 +1297,7 @@ Also see the `gnus-group-use-permanent-levels' variable." (point-min) (point-max) 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))) - (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb)))) + (let ((newsrc (cdddr (gnus-group-entry group)))) (while (and newsrc (not (gnus-goto-char (text-property-any @@ -1331,7 +1352,7 @@ if it is a string, only list groups matching REGEXP." group (gnus-info-group info) params (gnus-info-params info) newsrc (cdr newsrc) - unread (car (gnus-gethash group gnus-newsrc-hashtb))) + unread (gnus-group-unread group)) (when not-in-list (setq not-in-list (delete group not-in-list))) (when (gnus-group-prepare-logic @@ -1431,7 +1452,7 @@ if it is a string, only list groups matching REGEXP." "Update the current line in the group buffer." (let* ((buffer-read-only nil) (group (gnus-group-group-name)) - (entry (and group (gnus-gethash group gnus-newsrc-hashtb))) + (entry (and group (gnus-group-entry group))) gnus-group-indentation) (when group (and entry @@ -1448,7 +1469,7 @@ if it is a string, only list groups matching REGEXP." (defun gnus-group-insert-group-line-info (group) "Insert GROUP on the current line." - (let ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (let ((entry (gnus-group-entry group)) (gnus-group-indentation (gnus-group-group-indentation)) active info) (if entry @@ -1575,10 +1596,6 @@ if it is a string, only list groups matching REGEXP." (gnus-tmp-process-marked (if (member gnus-tmp-group gnus-group-marked) gnus-process-mark ? )) - (gnus-tmp-grouplens - (or (and gnus-use-grouplens - (bbb-grouplens-group-p gnus-tmp-group)) - "")) (buffer-read-only nil) beg end header gnus-tmp-header) ; passed as parameter to user-funcs. @@ -1615,7 +1632,7 @@ if it is a string, only list groups matching REGEXP." "Highlight the current line according to `gnus-group-highlight'." (let* ((list gnus-group-highlight) (p (point)) - (end (gnus-point-at-eol)) + (end (point-at-eol)) ;; now find out where the line starts and leave point there. (beg (progn (beginning-of-line) (point))) (group (gnus-group-group-name)) @@ -1666,7 +1683,7 @@ already." (loc (point-min)) found buffer-read-only) ;; Enter the current status into the dribble buffer. - (let ((entry (gnus-gethash group gnus-newsrc-hashtb))) + (let ((entry (gnus-group-entry group))) (when (and entry (not (gnus-ephemeral-group-p group))) (gnus-dribble-enter @@ -1691,7 +1708,7 @@ already." ;; go, and insert it there (or at the end of the buffer). (if gnus-goto-missing-group-function (funcall gnus-goto-missing-group-function group) - (let ((entry (cddr (gnus-gethash group gnus-newsrc-hashtb)))) + (let ((entry (cddr (gnus-group-entry group)))) (while (and entry (car entry) (not (gnus-goto-char @@ -1751,24 +1768,24 @@ already." (defun gnus-group-group-name () "Get the name of the newsgroup on the current line." - (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group))) + (let ((group (get-text-property (point-at-bol) 'gnus-group))) (when group (symbol-name group)))) (defun gnus-group-group-level () "Get the level of the newsgroup on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-level)) + (get-text-property (point-at-bol) 'gnus-level)) (defun gnus-group-group-indentation () "Get the indentation of the newsgroup on the current line." - (or (get-text-property (gnus-point-at-bol) 'gnus-indentation) + (or (get-text-property (point-at-bol) 'gnus-indentation) (and gnus-group-indentation-function (funcall gnus-group-indentation-function)) "")) (defun gnus-group-group-unread () "Get the number of unread articles of the newsgroup on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-unread)) + (get-text-property (point-at-bol) 'gnus-unread)) (defun gnus-group-new-mail (group) (if (nnmail-new-mail-p (gnus-group-real-name group)) @@ -1826,6 +1843,18 @@ If FIRST-TOO, the current line is also eligible as a target." (goto-char (or pos beg)) (and pos t)))) +(defun gnus-total-fetched-for (group) + (let* ((size-in-cache (or (gnus-cache-total-fetched-for group) 0)) + (size-in-agent (or (gnus-agent-total-fetched-for group) 0)) + (size (+ size-in-cache size-in-agent)) + (suffix '("B" "K" "M" "G")) + (scale 1024.0) + (cutoff scale)) + (while (> size cutoff) + (setq size (/ size scale) + suffix (cdr suffix))) + (format "%5.1f%s" size (car suffix)))) + ;;; Gnus group mode commands ;; Group marking. @@ -1847,15 +1876,14 @@ If FIRST-TOO, the current line is also eligible as a target." ;; Go to the mark position. (beginning-of-line) (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) - (subst-char-in-region - (point) (1+ (point)) (char-after) - (if unmark - (progn - (setq gnus-group-marked (delete group gnus-group-marked)) - ? ) + (delete-char 1) + (if unmark + (progn + (setq gnus-group-marked (delete group gnus-group-marked)) + (insert-char ? 1 t)) (setq gnus-group-marked (cons group (delete group gnus-group-marked))) - gnus-process-mark))) + (insert-char gnus-process-mark 1 t))) (unless no-advance (gnus-group-next-group 1)) (decf n)) @@ -1871,10 +1899,8 @@ If FIRST-TOO, the current line is also eligible as a target." (defun gnus-group-unmark-all-groups () "Unmark all groups." (interactive) - (let ((groups gnus-group-marked)) - (save-excursion - (while groups - (gnus-group-remove-mark (pop groups))))) + (save-excursion + (mapc 'gnus-group-remove-mark gnus-group-marked)) (gnus-group-position-point)) (defun gnus-group-mark-region (unmark beg end) @@ -2020,8 +2046,7 @@ group." (unless group (error "No group on current line")) (setq marked (gnus-info-marks - (nth 2 (setq entry (gnus-gethash - group gnus-newsrc-hashtb))))) + (nth 2 (setq entry (gnus-group-entry group))))) ;; This group might be a dead group. In that case we have to get ;; the number of unread articles from `gnus-active-hashtb'. (setq number @@ -2051,11 +2076,11 @@ articles in the group." (forward-line -1)) (gnus-group-read-group all t)) -(defun gnus-group-quick-select-group (&optional all) - "Select the current group \"quickly\". -This means that no highlighting or scoring will be performed. -If ALL (the prefix argument) is 0, don't even generate the summary -buffer. +(defun gnus-group-quick-select-group (&optional all group) + "Select the GROUP \"quickly\". +This means that no highlighting or scoring will be performed. If +ALL (the prefix argument) is 0, don't even generate the summary +buffer. If GROUP is nil, use current group. This might be useful if you want to toggle threading before entering the group." @@ -2066,7 +2091,7 @@ before entering the group." gnus-home-score-file gnus-apply-kill-hook gnus-summary-expunge-below) - (gnus-group-read-group all t))) + (gnus-group-read-group all t group))) (defun gnus-group-visible-select-group (&optional all) "Select the current group without hiding any articles." @@ -2090,14 +2115,86 @@ be permanent." (gnus-group-read-ephemeral-group (gnus-group-prefixed-name group method) method))) +(defun gnus-group-name-at-point () + "Return a group name from around point if it exists, or nil." + (if (eq major-mode 'gnus-group-mode) + (let ((group (gnus-group-group-name))) + (when group + (gnus-group-decoded-name group))) + (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ +\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ +\[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ +\\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)") + (start (point)) + (case-fold-search nil)) + (prog1 + (if (or (and (not (or (eobp) + (looking-at "[][\C-@-*,/;-@\\^`{-\C-?]"))) + (prog1 t + (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?" + (point-at-bol)))) + (and (looking-at "[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*$") + (prog1 t + (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?") + (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?" + (point-at-bol)))) + (string-match "\\`[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*\\'" + (buffer-substring (point-at-bol) (point)))) + (when (looking-at regexp) + (match-string 1)) + (let (group distance) + (when (looking-at regexp) + (setq group (match-string 1) + distance (- (match-beginning 1) (match-beginning 0)))) + (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?") + (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?" + (point-at-bol)) + (if (looking-at regexp) + (if (and group (<= distance (- start (match-end 0)))) + group + (match-string 1)) + group))) + (goto-char start))))) + +(defun gnus-group-completing-read (prompt &optional collection predicate + require-match initial-input hist def + &rest args) + "Read a group name with completion. Non-ASCII group names are allowed. +The arguments are the same as `completing-read' except that COLLECTION +and HIST default to `gnus-active-hashtb' and `gnus-group-history' +respectively if they are omitted." + (let (group) + (mapatoms (lambda (symbol) + (setq group (symbol-name symbol)) + (set (intern (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group) + collection) + group)) + (prog1 + (or collection + (setq collection (or gnus-active-hashtb [0]))) + (setq collection (gnus-make-hashtable (length collection))))) + (setq group (apply 'completing-read prompt collection predicate + require-match initial-input + (or hist 'gnus-group-history) + def args)) + (or (prog1 + (symbol-value (intern-soft group collection)) + (setq collection nil)) + (mm-encode-coding-string group (gnus-group-name-charset nil group))))) + ;;;###autoload (defun gnus-fetch-group (group &optional articles) "Start Gnus if necessary and enter GROUP. +If ARTICLES, display those articles. Returns whether the fetching was successful or not." - (interactive (list (completing-read "Group name: " gnus-active-hashtb))) - (unless (get-buffer gnus-group-buffer) + (interactive (list (gnus-group-completing-read "Group name: " + nil nil nil + (gnus-group-name-at-point)))) + (unless (gnus-alive-p) (gnus-no-server)) - (gnus-group-read-group articles nil group)) + (gnus-group-read-group (if articles nil t) nil group articles)) ;;;###autoload (defun gnus-fetch-group-other-frame (group) @@ -2155,10 +2252,7 @@ Return the name of the group if selection was successful." (interactive (list ;; (gnus-read-group "Group name: ") - (completing-read - "Group: " gnus-active-hashtb - nil nil nil - 'gnus-group-history) + (gnus-group-completing-read "Group: ") (gnus-read-method "From method: "))) ;; Transform the select method into a unique server. (when (stringp method) @@ -2204,15 +2298,20 @@ Return the name of the group if selection was successful." (message "Quit reading the ephemeral group") nil))))) -(defun gnus-group-jump-to-group (group) - "Jump to newsgroup GROUP." +(defun gnus-group-jump-to-group (group &optional prompt) + "Jump to newsgroup GROUP. + +If PROMPT (the prefix) is a number, use the prompt specified in +`gnus-group-jump-to-group-prompt'." (interactive - (list (mm-string-make-unibyte - (completing-read - "Group: " gnus-active-hashtb nil - (gnus-read-active-file-p) - gnus-group-jump-to-group-prompt - 'gnus-group-history)))) + (list (gnus-group-completing-read + "Group: " nil nil (gnus-read-active-file-p) + (if current-prefix-arg + (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt)) + (or (and (stringp gnus-group-jump-to-group-prompt) + gnus-group-jump-to-group-prompt) + (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt)))) + (and (stringp p) p))))))) (when (equal group "") (error "Empty group name")) @@ -2360,6 +2459,25 @@ If EXCLUDE-GROUP, do not go to that group." (gnus-group-position-point) (and best-point (gnus-group-group-name)))) +;; Is there something like an after-point-motion-hook? +;; (inhibit-point-motion-hooks?). Is there a tool-bar-update function? + +;; (defun gnus-group-menu-bar-update () +;; (let* ((buf (list (with-current-buffer gnus-group-buffer +;; (current-buffer)))) +;; (name (buffer-name (car buf)))) +;; (setcdr buf +;; (if (> (length name) 27) +;; (concat (substring name 0 12) +;; "..." +;; (substring name -12)) +;; name)) +;; (menu-bar-update-buffers-1 buf))) + +;; (defun gnus-group-position-point () +;; (gnus-goto-colon) +;; (gnus-group-menu-bar-update)) + (defun gnus-group-first-unread-group () "Go to the first group with unread articles." (interactive) @@ -2381,10 +2499,19 @@ If EXCLUDE-GROUP, do not go to that group." (interactive) (gnus-enter-server-buffer)) -(defun gnus-group-make-group (name &optional method address args) +(defun gnus-group-make-group-simple (&optional group) + "Add a new newsgroup. +The user will be prompted for GROUP." + (interactive (list (gnus-group-completing-read "Group: "))) + (gnus-group-make-group (gnus-group-real-name group) + (gnus-group-server group) + nil nil t)) + +(defun gnus-group-make-group (name &optional method address args encoded) "Add a new newsgroup. The user will be prompted for a NAME, for a select METHOD, and an -ADDRESS." +ADDRESS. NAME should be a human-readable string (i.e., not be encoded +even if it contains non-ASCII characters) unless ENCODED is non-nil." (interactive (list (gnus-read-group "Group name: ") @@ -2392,6 +2519,10 @@ ADDRESS." (when (stringp method) (setq method (or (gnus-server-to-method method) method))) + (unless encoded + (setq name (mm-encode-coding-string + name + (gnus-group-name-charset method name)))) (let* ((meth (gnus-method-simplify (when (and method (not (gnus-server-equal method gnus-select-method))) @@ -2399,15 +2530,14 @@ ADDRESS." method)))) (nname (if method (gnus-group-prefixed-name name meth) name)) backend info) - (when (gnus-gethash nname gnus-newsrc-hashtb) + (when (gnus-group-entry nname) (error "Group %s already exists" (gnus-group-decoded-name nname))) ;; Subscribe to the new group. (gnus-group-change-level (setq info (list t nname gnus-level-default-subscribed nil nil meth)) gnus-level-default-subscribed gnus-level-killed (and (gnus-group-group-name) - (gnus-gethash (gnus-group-group-name) - gnus-newsrc-hashtb)) + (gnus-group-entry (gnus-group-group-name))) t) ;; Make it active. (gnus-set-active nname (cons 1 0)) @@ -2474,7 +2604,7 @@ be removed from the server, even when it's empty." (gnus-message 6 "Deleting group %s...done" group-decoded) (gnus-group-goto-group group) (gnus-group-kill-group 1 t) - (gnus-sethash group nil gnus-active-hashtb) + (gnus-set-active group nil) t))) (gnus-group-position-point))) @@ -2483,14 +2613,19 @@ be removed from the server, even when it's empty." When used interactively, GROUP is the group under point and NEW-NAME will be prompted for." (interactive - (list - (gnus-group-group-name) - (progn - (unless (gnus-check-backend-function - 'request-rename-group (gnus-group-group-name)) - (error "This back end does not support renaming groups")) - (gnus-read-group "Rename group to: " - (gnus-group-real-name (gnus-group-group-name)))))) + (let ((group (gnus-group-group-name)) + method new-name) + (unless (gnus-check-backend-function 'request-rename-group group) + (error "This back end does not support renaming groups")) + (setq new-name (gnus-read-group + "Rename group to: " + (gnus-group-real-name (gnus-group-decoded-name group))) + method (gnus-info-method (gnus-get-info group))) + (list group (mm-encode-coding-string + new-name + (gnus-group-name-charset + method + (gnus-group-prefixed-name new-name method)))))) (unless (gnus-check-backend-function 'request-rename-group group) (error "This back end does not support renaming groups")) @@ -2509,29 +2644,34 @@ and NEW-NAME will be prompted for." (gnus-group-real-name new-name) (gnus-info-method (gnus-get-info group))))) - (when (gnus-active new-name) - (error "The group %s already exists" new-name)) - - (gnus-message 6 "Renaming group %s to %s..." group new-name) - (prog1 - (if (progn - (gnus-group-goto-group group) - (not (when (< (gnus-group-group-level) gnus-level-zombie) - (gnus-request-rename-group group new-name)))) - (gnus-error 3 "Couldn't rename group %s to %s" group new-name) - ;; We rename the group internally by killing it... - (gnus-group-kill-group) - ;; ... changing its name ... - (setcar (cdar gnus-list-of-killed-groups) new-name) - ;; ... and then yanking it. Magic! - (gnus-group-yank-group) - (gnus-set-active new-name (gnus-active group)) - (gnus-message 6 "Renaming group %s to %s...done" group new-name) - new-name) - (setq gnus-killed-list (delete group gnus-killed-list)) - (gnus-set-active group nil) - (gnus-dribble-touch) - (gnus-group-position-point))) + (let ((decoded-group (gnus-group-decoded-name group)) + (decoded-new-name (gnus-group-decoded-name new-name))) + (when (gnus-active new-name) + (error "The group %s already exists" decoded-new-name)) + + (gnus-message 6 "Renaming group %s to %s..." + decoded-group decoded-new-name) + (prog1 + (if (progn + (gnus-group-goto-group group) + (not (when (< (gnus-group-group-level) gnus-level-zombie) + (gnus-request-rename-group group new-name)))) + (gnus-error 3 "Couldn't rename group %s to %s" + decoded-group decoded-new-name) + ;; We rename the group internally by killing it... + (gnus-group-kill-group) + ;; ... changing its name ... + (setcar (cdar gnus-list-of-killed-groups) new-name) + ;; ... and then yanking it. Magic! + (gnus-group-yank-group) + (gnus-set-active new-name (gnus-active group)) + (gnus-message 6 "Renaming group %s to %s...done" + decoded-group decoded-new-name) + new-name) + (setq gnus-killed-list (delete group gnus-killed-list)) + (gnus-set-active group nil) + (gnus-dribble-touch) + (gnus-group-position-point)))) (defun gnus-group-edit-group (group &optional part) "Edit the group on the current line." @@ -2641,7 +2781,7 @@ group already exists: (interactive) (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) (file (nnheader-find-etc-directory "gnus-tut.txt" t))) - (if (gnus-gethash name gnus-newsrc-hashtb) + (if (gnus-group-entry name) (cond ((eq noerror nil) (error "Documentation group already exists")) ((eq noerror t) @@ -2684,19 +2824,17 @@ If called with a prefix argument, ask for the file type." nil)))) (setq type found))) (setq file (expand-file-name file)) - (let ((name (gnus-generate-new-group-name - (gnus-group-prefixed-name - (file-name-nondirectory file) '(nndoc "")))) - (encodable (mm-coding-system-p 'utf-8))) + (let* ((name (gnus-generate-new-group-name + (gnus-group-prefixed-name + (file-name-nondirectory file) '(nndoc "")))) + (method (list 'nndoc file + (list 'nndoc-address file) + (list 'nndoc-article-type (or type 'guess)))) + (coding (gnus-group-name-charset method name))) + (setcar (cdr method) (mm-encode-coding-string file coding)) (gnus-group-make-group - (if encodable - (mm-encode-coding-string (gnus-group-real-name name) 'utf-8) - (gnus-group-real-name name)) - (list 'nndoc (if encodable - (mm-encode-coding-string file 'utf-8) - file) - (list 'nndoc-address file) - (list 'nndoc-article-type (or type 'guess)))))) + (mm-encode-coding-string (gnus-group-real-name name) coding) + method nil nil t))) (defvar nnweb-type-definition) (defvar gnus-group-web-type-history nil) @@ -2750,25 +2888,23 @@ If there is, use Gnus to create an nnrss group" (setq url (read-from-minibuffer "URL to Search for RSS: "))) (let ((feedinfo (nnrss-discover-feed url))) (if feedinfo - (let ((title (gnus-newsgroup-savable-name - (read-from-minibuffer "Title: " - (gnus-newsgroup-savable-name - (or (cdr (assoc 'title - feedinfo)) - ""))))) - (desc (read-from-minibuffer "Description: " - (cdr (assoc 'description - feedinfo)))) - (href (cdr (assoc 'href feedinfo))) - (encodable (mm-coding-system-p 'utf-8))) - (when encodable + (let* ((title (gnus-newsgroup-savable-name + (read-from-minibuffer "Title: " + (gnus-newsgroup-savable-name + (or (cdr (assoc 'title + feedinfo)) + ""))))) + (desc (read-from-minibuffer "Description: " + (cdr (assoc 'description + feedinfo)))) + (href (cdr (assoc 'href feedinfo))) + (coding (gnus-group-name-charset '(nnrss "") title))) + (when coding ;; Unify non-ASCII text. (setq title (mm-decode-coding-string - (mm-encode-coding-string title 'utf-8) 'utf-8))) - (gnus-group-make-group (if encodable - (mm-encode-coding-string title 'utf-8) - title) - '(nnrss "")) + (mm-encode-coding-string title coding) + coding))) + (gnus-group-make-group title '(nnrss "")) (push (list title href desc) nnrss-group-alist) (nnrss-save-server-data nil)) (error "No feeds found for %s" url)))) @@ -2815,7 +2951,7 @@ Given a prefix, create a full group." (interactive "P") (let ((group (gnus-group-prefixed-name (if all "ding.archives" "ding.recent") '(nndir "")))) - (when (gnus-gethash group gnus-newsrc-hashtb) + (when (gnus-group-entry group) (error "Archive group already exists")) (gnus-group-make-group (gnus-group-real-name group) @@ -2839,7 +2975,7 @@ mail messages or news articles in files that have numeric names." (let ((ext "") (i 0) group) - (while (or (not group) (gnus-gethash group gnus-newsrc-hashtb)) + (while (or (not group) (gnus-group-entry group)) (setq group (gnus-group-prefixed-name (expand-file-name ext dir) @@ -2858,7 +2994,7 @@ score file entries for articles to include in the group." (list (read-string "nnkiboze group name: ") (read-string "Source groups (regexp): ") - (let ((headers (mapcar (lambda (group) (list group)) + (let ((headers (mapcar 'list '("subject" "from" "number" "date" "message-id" "references" "chars" "lines" "xref" "followup" "all" "body" "head"))) @@ -2909,7 +3045,7 @@ score file entries for articles to include in the group." (let* ((method (list 'nnvirtual "^$")) (pgroup (gnus-group-prefixed-name group method))) ;; Check whether it exists already. - (when (gnus-gethash pgroup gnus-newsrc-hashtb) + (when (gnus-group-entry pgroup) (error "Group %s already exists" pgroup)) ;; Subscribe the new group after the group on the current line. (gnus-subscribe-group pgroup (gnus-group-group-name) method) @@ -3081,7 +3217,7 @@ If REVERSE, sort in reverse order." (let (entries infos) ;; First find all the group entries for these groups. (while groups - (push (nthcdr 2 (gnus-gethash (pop groups) gnus-newsrc-hashtb)) + (push (nthcdr 2 (gnus-group-entry (pop groups))) entries)) ;; Then sort the infos. (setq infos @@ -3162,8 +3298,8 @@ sort in reverse order." (defun gnus-group-sort-by-unread (info1 info2) "Sort by number of unread articles." - (let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb))) - (n2 (car (gnus-gethash (gnus-info-group info2) gnus-newsrc-hashtb)))) + (let ((n1 (gnus-group-unread (gnus-info-group info1))) + (n2 (gnus-group-unread (gnus-info-group info2)))) (< (or (and (numberp n1) n1) 0) (or (and (numberp n2) n2) 0)))) @@ -3283,13 +3419,15 @@ up is returned." (when (eq 'nnvirtual (car method)) (nnvirtual-catchup-group (gnus-group-real-name group) (nth 1 method) all))) - (if (>= (gnus-group-level group) gnus-level-zombie) - (gnus-message 2 "Dead groups can't be caught up") - (if (prog1 - (gnus-group-goto-group group) - (gnus-group-catchup group all)) - (gnus-group-update-group-line) - (setq ret (1+ ret))))) + (cond + ((>= (gnus-group-level group) gnus-level-zombie) + (gnus-message 2 "Dead groups can't be caught up")) + ((prog1 + (gnus-group-goto-group group) + (gnus-group-catchup group all)) + (gnus-group-update-group-line)) + (t + (setq ret (1+ ret))))) (gnus-group-next-unread-group 1) ret))) @@ -3304,9 +3442,9 @@ Cross references (Xref: header) of articles are ignored." If ALL is non-nil, all articles are marked as read. The return value is the number of articles that were marked as read, or nil if no action could be taken." - (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (let* ((entry (gnus-group-entry group)) (num (car entry)) - (marks (nth 3 (nth 2 entry))) + (marks (gnus-info-marks (nth 2 entry))) (unread (gnus-sequence-of-unread-articles group))) ;; Remove entries for this group. (nnmail-purge-split-history (gnus-group-real-name group)) @@ -3321,16 +3459,18 @@ or nil if no action could be taken." (list (cdr (assq 'dormant marks)) 'del '(dormant)))) (setq unread (gnus-range-add (gnus-range-add - unread (cdr (assq 'dormant marks))) - (cdr (assq 'tick marks)))) + unread (cdr (assq 'dormant marks))) + (cdr (assq 'tick marks)))) (gnus-add-marked-articles group 'tick nil nil 'force) (gnus-add-marked-articles group 'dormant nil nil 'force)) ;; Do auto-expirable marks if that's required. (when (gnus-group-auto-expirable-p group) - (gnus-range-map (lambda (article) - (gnus-add-marked-articles group 'expire (list article)) - (gnus-request-set-mark group (list (list (list article) 'add '(expire))))) - unread)) + (gnus-range-map + (lambda (article) + (gnus-add-marked-articles group 'expire (list article)) + (gnus-request-set-mark group (list (list (list article) + 'add '(expire))))) + unread)) (let ((gnus-newsgroup-name group)) (gnus-run-hooks 'gnus-group-catchup-group-hook)) num))) @@ -3412,17 +3552,15 @@ Uses the process/prefix convention." s)))))) (unless (and (>= level 1) (<= level gnus-level-killed)) (error "Invalid level: %d" level)) - (let ((groups (gnus-group-process-prefix n)) - group) - (while (setq group (pop groups)) - (gnus-group-remove-mark group) - (gnus-message 6 "Changed level of %s from %d to %d" - (gnus-group-decoded-name group) - (or (gnus-group-group-level) gnus-level-killed) - level) - (gnus-group-change-level - group level (or (gnus-group-group-level) gnus-level-killed)) - (gnus-group-update-group-line))) + (dolist (group (gnus-group-process-prefix n)) + (gnus-group-remove-mark group) + (gnus-message 6 "Changed level of %s from %d to %d" + (gnus-group-decoded-name group) + (or (gnus-group-group-level) gnus-level-killed) + level) + (gnus-group-change-level + group level (or (gnus-group-group-level) gnus-level-killed)) + (gnus-group-update-group-line)) (gnus-group-position-point)) (defun gnus-group-unsubscribe (&optional n) @@ -3460,13 +3598,9 @@ If given numerical prefix, toggle the N next groups." "Toggle subscription to GROUP. Killed newsgroups are subscribed. If SILENT, don't try to update the group line." - (interactive - (list (completing-read - "Group: " gnus-active-hashtb nil - (gnus-read-active-file-p) - nil - 'gnus-group-history))) - (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) + (interactive (list (gnus-group-completing-read + "Group: " nil nil (gnus-read-active-file-p)))) + (let ((newsrc (gnus-group-entry group))) (cond ((string-match "^[ \t]*$" group) (error "Empty group name")) @@ -3490,7 +3624,7 @@ group line." gnus-level-zombie) gnus-level-killed) (when (gnus-group-group-name) - (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb))) + (gnus-group-entry (gnus-group-group-name)))) (unless silent (gnus-group-update-group group))) (t (error "No such newsgroup: %s" group))) @@ -3529,12 +3663,10 @@ The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." (count-lines (progn (goto-char begin) - (beginning-of-line) - (point)) + (point-at-bol)) (progn (goto-char end) - (beginning-of-line) - (point)))))) + (point-at-bol)))))) (goto-char begin) (beginning-of-line) ;Important when LINES < 1 (gnus-group-kill-group lines))) @@ -3558,7 +3690,7 @@ of groups killed." (setq level (gnus-group-group-level)) (gnus-delete-line) (when (and (not discard) - (setq entry (gnus-gethash group gnus-newsrc-hashtb))) + (setq entry (gnus-group-entry group))) (gnus-undo-register `(progn (gnus-group-goto-group ,(gnus-group-group-name)) @@ -3581,7 +3713,7 @@ of groups killed." (funcall gnus-group-change-level-function group gnus-level-killed 3)) (cond - ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) + ((setq entry (gnus-group-entry group)) (push (cons (car entry) (nth 2 entry)) gnus-list-of-killed-groups) (setcdr (cdr entry) (cdddr entry))) @@ -3614,7 +3746,7 @@ yanked) a list of yanked groups is returned." (setq prev (gnus-group-group-name)) (gnus-group-change-level info (gnus-info-level (cdr info)) gnus-level-killed - (and prev (gnus-gethash prev gnus-newsrc-hashtb)) + (and prev (gnus-group-entry prev)) t) (gnus-group-insert-group-line-info group) (gnus-undo-register @@ -3773,6 +3905,7 @@ re-scanning. If ARG is non-nil and not a number, this will force (gnus-get-unread-articles arg)) (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) (gnus-get-unread-articles arg))) + (gnus-check-reasonable-setup) (gnus-run-hooks 'gnus-after-getting-new-news-hook) (gnus-group-list-groups (and (numberp arg) (max (car gnus-group-list-mode) arg))))) @@ -3797,15 +3930,17 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. (gnus-remove-denial (setq method (gnus-find-method-for-group group))) - (if (gnus-activate-group group (if dont-scan nil 'scan)) - (progn - (gnus-get-unread-articles-in-group - (gnus-get-info group) (gnus-active group) t) + (if (gnus-activate-group group (if dont-scan nil 'scan) nil method) + (let ((info (gnus-get-info group)) + (active (gnus-active group))) + (when info + (gnus-request-update-info info method)) + (gnus-get-unread-articles-in-group info active) (unless (gnus-virtual-group-p group) (gnus-close-group group)) (when gnus-agent (gnus-agent-save-group-info - method (gnus-group-real-name group) (gnus-active group))) + method (gnus-group-real-name group) active)) (gnus-group-update-group group)) (if (eq (gnus-server-status (gnus-find-method-for-group group)) 'denied) @@ -3851,7 +3986,7 @@ to use." If given a prefix argument, prompt for a group." (interactive (list (or (when current-prefix-arg - (completing-read "Group: " gnus-active-hashtb)) + (gnus-group-completing-read "Group: ")) (gnus-group-group-name) gnus-newsgroup-name))) (unless group @@ -3879,7 +4014,7 @@ If given a prefix argument, prompt for a group." If given a prefix argument, prompt for a group." (interactive (list (or (when current-prefix-arg - (completing-read "Group: " gnus-active-hashtb)) + (gnus-group-completing-read "Group: ")) (gnus-group-group-name) gnus-newsgroup-name))) (unless group @@ -4105,14 +4240,12 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending." (gnus-offer-save-summaries) ;; Kill Gnus buffers except for group mode buffer. (let ((group-buf (get-buffer gnus-group-buffer))) - (mapcar (lambda (buf) - (unless (or (member buf (list group-buf gnus-dribble-buffer)) - (progn - (save-excursion - (set-buffer buf) - (eq major-mode 'message-mode)))) - (gnus-kill-buffer buf))) - (gnus-buffers)) + (dolist (buf (gnus-buffers)) + (unless (or (eq buf group-buf) + (eq buf gnus-dribble-buffer) + (with-current-buffer buf + (eq major-mode 'message-mode))) + (gnus-kill-buffer buf))) (setq gnus-backlog-articles nil) (gnus-kill-gnus-frames) (when group-buf @@ -4196,17 +4329,15 @@ and the second element is the address." ;; Suggested by mapjph@bath.ac.uk. (completing-read "Address: " - (mapcar (lambda (server) (list server)) - gnus-secondary-servers))) + (mapcar 'list gnus-secondary-servers))) ;; We got a server name. how)))) (gnus-browse-foreign-server method)) (defun gnus-group-set-info (info &optional method-only-group part) (when (or info part) - (let* ((entry (gnus-gethash - (or method-only-group (gnus-info-group info)) - gnus-newsrc-hashtb)) + (let* ((entry (gnus-group-entry + (or method-only-group (gnus-info-group info)))) (part-info info) (info (if method-only-group (nth 2 entry) info)) method) @@ -4239,15 +4370,15 @@ and the second element is the address." (if (stringp method) method (prin1-to-string (car method))) (and (consp method) - (nth 1 (gnus-info-method info)))) + (nth 1 (gnus-info-method info))) + nil t) ;; It's a native group. - (gnus-group-make-group (gnus-info-group info)))) + (gnus-group-make-group (gnus-info-group info) nil nil nil t))) (gnus-message 6 "Note: New group created") (setq entry - (gnus-gethash (gnus-group-prefixed-name - (gnus-group-real-name (gnus-info-group info)) - (or (gnus-info-method info) gnus-select-method)) - gnus-newsrc-hashtb)))) + (gnus-group-entry (gnus-group-prefixed-name + (gnus-group-real-name (gnus-info-group info)) + (or (gnus-info-method info) gnus-select-method)))))) ;; Whether it was a new group or not, we now have the entry, so we ;; can do the update. (if entry @@ -4460,6 +4591,40 @@ This command may read the active file." (gnus-add-marked-articles group 'expire (list article)))))) + +;;; +;;; Group compaction. -- dvl +;;; + +(defun gnus-group-compact-group (group) + "Compact the current group. +Compaction means removing gaps between article numbers. Hence, this +operation is only meaningful for back ends using one file per article +\(e.g. nnml). + +Note: currently only implemented in nnml." + (interactive (list (gnus-group-group-name))) + (unless group + (error "No group to compact")) + (unless (gnus-check-backend-function 'request-compact-group group) + (error "This back end does not support group compaction")) + (let ((group-decoded (gnus-group-decoded-name group))) + (gnus-message 6 "\ +Compacting group %s... (this may take a long time)" + group-decoded) + (prog1 + (if (not (gnus-request-compact-group group)) + (gnus-error 3 "Couldn't compact group %s" group-decoded) + (gnus-message 6 "Compacting group %s...done" group-decoded) + t) + ;; Invalidate the "original article" buffer which might be out of date. + ;; #### NOTE: Yes, this might be a bit rude, but since compaction + ;; #### will not happen very often, I think this is acceptable. + (let ((original (get-buffer gnus-original-article-buffer))) + (and original (gnus-kill-buffer original))) + ;; Update the group line to reflect new information (art number etc). + (gnus-group-update-group-line)))) + (provide 'gnus-group) ;;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6 diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index bbd997aee8a..52b5e350653 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -75,7 +75,7 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." ;; Read server name with completion. (setq gnus-nntp-server (completing-read "NNTP server: " - (mapcar (lambda (server) (list server)) + (mapcar 'list (cons (list gnus-nntp-server) gnus-secondary-servers)) nil nil gnus-nntp-server))) @@ -209,11 +209,12 @@ If it is down, start it up (again)." "Open a connection to GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) - (let ((elem (assoc gnus-command-method gnus-opened-servers))) + (let ((elem (assoc gnus-command-method gnus-opened-servers)) + (server (gnus-method-to-server-name gnus-command-method))) ;; If this method was previously denied, we just return nil. (if (eq (nth 1 elem) 'denied) (progn - (gnus-message 1 "Denied server") + (gnus-message 1 "Denied server %s" server) nil) ;; Open the server. (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server)) @@ -224,11 +225,11 @@ If it is down, start it up (again)." (nthcdr 2 gnus-command-method)) (error (gnus-message 1 (format - "Unable to open server due to: %s" - (error-message-string err))) + "Unable to open server %s due to: %s" + server (error-message-string err))) nil) (quit - (gnus-message 1 "Quit trying to open server") + (gnus-message 1 "Quit trying to open server %s" server) nil))) open-offline) ;; If this hasn't been opened before, we add it to the list. @@ -253,9 +254,9 @@ If it is down, start it up (again)." ((and (not gnus-batch-mode) (gnus-y-or-n-p - (format "Unable to open %s:%s, go offline? " - (car gnus-command-method) - (cadr gnus-command-method)))) + (format + "Unable to open server %s, go offline? " + server))) (setq open-offline t) 'offline) (t @@ -335,6 +336,23 @@ name. The method this group uses will be queried." (funcall (gnus-get-function gnus-command-method 'request-regenerate) (nth 1 gnus-command-method))) +(defun gnus-request-compact-group (group) + (let* ((method (gnus-find-method-for-group group)) + (gnus-command-method method) + (result + (funcall (gnus-get-function gnus-command-method + 'request-compact-group) + (gnus-group-real-name group) + (nth 1 gnus-command-method) t))) + result)) + +(defun gnus-request-compact (gnus-command-method) + "Request groups compaction from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-compact) + (nth 1 gnus-command-method))) + (defun gnus-request-group (group &optional dont-check gnus-command-method) "Request GROUP. If DONT-CHECK, no information is required." (let ((gnus-command-method @@ -342,7 +360,7 @@ name. The method this group uses will be queried." (when (stringp gnus-command-method) (setq gnus-command-method (inline (gnus-server-to-method gnus-command-method)))) - (funcall (inline (gnus-get-function gnus-command-method 'request-group)) + (funcall (inline (gnus-get-function gnus-command-method 'request-group)) (gnus-group-real-name group) (nth 1 gnus-command-method) dont-check))) @@ -521,12 +539,11 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (if group (gnus-find-method-for-group group) gnus-command-method)) (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) - (if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) - (progn - (setq gnus-internal-registry-spool-current-method gnus-command-method) - (funcall (gnus-get-function gnus-command-method 'request-scan) - (and group (gnus-group-real-name group)) - (nth 1 gnus-command-method)))))) + (when (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) + (setq gnus-internal-registry-spool-current-method gnus-command-method) + (funcall (gnus-get-function gnus-command-method 'request-scan) + (and group (gnus-group-real-name group)) + (nth 1 gnus-command-method))))) (defsubst gnus-request-update-info (info gnus-command-method) "Request that GNUS-COMMAND-METHOD update INFO." @@ -566,12 +583,12 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." not-deleted)) (defun gnus-request-move-article (article group server accept-function - &optional last) + &optional last move-is-internal) (let* ((gnus-command-method (gnus-find-method-for-group group)) (result (funcall (gnus-get-function gnus-command-method 'request-move-article) article (gnus-group-real-name group) - (nth 1 gnus-command-method) accept-function last))) + (nth 1 gnus-command-method) accept-function last move-is-internal))) (when (and result gnus-agent (gnus-agent-method-p gnus-command-method)) (gnus-agent-unfetch-articles group (list article))) @@ -597,7 +614,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (message-encode-message-body))) -(let ((gnus-command-method (or gnus-command-method + (let ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) (result (funcall diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index edf463b8a2e..5778a02e168 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -497,7 +497,7 @@ Optional 1st argument COMMAND is default to (gnus-summary-mark-as-read nil \"X\"). If optional 2nd argument ALL is non-nil, articles marked are also applied to. If FIELD is an empty string (or nil), entire article body is searched for. -COMMAND must be a lisp expression or a string representing a key sequence." +COMMAND must be a Lisp expression or a string representing a key sequence." ;; We don't want to change current point nor window configuration. (let ((old-buffer (current-buffer))) (save-excursion @@ -625,7 +625,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." did-kill))) (defun gnus-execute (field regexp form &optional backward unread) - "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). + "If FIELD of article header matches REGEXP, execute Lisp FORM (or a string). If FIELD is an empty string (or nil), entire article body is searched for. If optional 1st argument BACKWARD is non-nil, do backward instead. If optional 2nd argument UNREAD is non-nil, articles which are @@ -691,7 +691,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (mail-sources nil) (gnus-use-dribble-file nil) (gnus-batch-mode t) - info group newsrc entry + info group newsrc unread ;; Disable verbose message. gnus-novice-user gnus-large-newsgroup gnus-options-subscribe gnus-auto-subscribed-groups @@ -703,11 +703,11 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) (setq group (gnus-info-group info) - entry (gnus-gethash group gnus-newsrc-hashtb)) + unread (gnus-group-unread group)) (when (and (<= (gnus-info-level info) gnus-level-subscribed) - (and (car entry) - (or (eq (car entry) t) - (not (zerop (car entry)))))) + (and unread + (or (eq unread t) + (not (zerop unread))))) (ignore-errors (gnus-summary-read-group group nil t nil t)) (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index b72179645ac..7f8eb2b2888 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -102,8 +102,8 @@ If FORCE is non-nil, replace the old ones." ;; Set up the menu. (when (gnus-visual-p 'mailing-list-menu 'menu) (gnus-mailing-list-make-menu-bar)) - (gnus-add-minor-mode 'gnus-mailing-list-mode " Mailing-List" - gnus-mailing-list-mode-map) + (add-minor-mode 'gnus-mailing-list-mode " Mailing-List" + gnus-mailing-list-mode-map) (gnus-run-hooks 'gnus-mailing-list-mode-hook)))) ;;; Commands diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el index 7f8323258ae..1a3467d42f0 100644 --- a/lisp/gnus/gnus-mlspl.el +++ b/lisp/gnus/gnus-mlspl.el @@ -34,31 +34,31 @@ (require 'nnmail) (defvar gnus-group-split-updated-hook nil - "Hook called just after nnmail-split-fancy is updated by -gnus-group-split-update.") + "Hook called just after `nnmail-split-fancy' is updated by +`gnus-group-split-update'.") (defvar gnus-group-split-default-catch-all-group "mail.misc" "Group name (or arbitrary fancy split) with default splitting rules. -Used by gnus-group-split and gnus-group-split-update as a fallback +Used by `gnus-group-split' and `gnus-group-split-update' as a fallback split, in case none of the group-based splits matches.") ;;;###autoload (defun gnus-group-split-setup (&optional auto-update catch-all) - "Set up the split for nnmail-split-fancy. + "Set up the split for `nnmail-split-fancy'. Sets things up so that nnmail-split-fancy is used for mail splitting, and defines the variable nnmail-split-fancy according with group parameters. If AUTO-UPDATE is non-nil (prefix argument accepted, if called interactively), it makes sure nnmail-split-fancy is re-computed before -getting new mail, by adding gnus-group-split-update to -nnmail-pre-get-new-mail-hook. +getting new mail, by adding `gnus-group-split-update' to +`nnmail-pre-get-new-mail-hook'. A non-nil CATCH-ALL replaces the current value of -gnus-group-split-default-catch-all-group. This variable is only used +`gnus-group-split-default-catch-all-group'. This variable is only used by gnus-group-split-update, and only when its CATCH-ALL argument is nil. This argument may contain any fancy split, that will be added as -the last split in a `|' split produced by gnus-group-split-fancy, +the last split in a `|' split produced by `gnus-group-split-fancy', unless overridden by any group marked as a catch-all group. Typical uses are as simple as the name of a default mail group, but more elaborate fancy splits may also be useful to split mail that doesn't @@ -78,8 +78,8 @@ match any of the group-specified splitting rules. See It does this by calling by calling (gnus-group-split-fancy nil nil CATCH-ALL). -If CATCH-ALL is nil, gnus-group-split-default-catch-all-group is used -instead. This variable is set by gnus-group-split-setup." +If CATCH-ALL is nil, `gnus-group-split-default-catch-all-group' is used +instead. This variable is set by `gnus-group-split-setup'." (interactive) (setq nnmail-split-fancy (gnus-group-split-fancy @@ -89,10 +89,10 @@ instead. This variable is set by gnus-group-split-setup." ;;;###autoload (defun gnus-group-split () - "Uses information from group parameters in order to split mail. + "Use information from group parameters in order to split mail. See `gnus-group-split-fancy' for more information. -gnus-group-split is a valid value for nnmail-split-methods." +`gnus-group-split' is a valid value for `nnmail-split-methods'." (let (nnmail-split-fancy) (gnus-group-split-update) (nnmail-split-fancy))) diff --git a/lisp/gnus/gnus-move.el b/lisp/gnus/gnus-move.el index 93fa5a6be08..0a97f8d5bd6 100644 --- a/lisp/gnus/gnus-move.el +++ b/lisp/gnus/gnus-move.el @@ -53,10 +53,8 @@ Update the .newsrc.eld file to reflect the change of nntp server." (save-excursion ;; Go through all groups and translate. - (let ((newsrc gnus-newsrc-alist) - (nntp-nov-gap nil) - info) - (while (setq info (pop newsrc)) + (let ((nntp-nov-gap nil)) + (dolist (info gnus-newsrc-alist) (when (gnus-group-native-p (gnus-info-group info)) (gnus-move-group-to-server info from-server to-server)))))) @@ -177,8 +175,7 @@ Update the .newsrc.eld file to reflect the change of nntp server." (new-name (gnus-group-prefixed-name (gnus-group-real-name group) to-server))) (gnus-info-set-group info new-name) - (gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb) - gnus-newsrc-hashtb) + (gnus-sethash new-name (gnus-group-entry group) gnus-newsrc-hashtb) (gnus-sethash group nil gnus-newsrc-hashtb)))) (provide 'gnus-move) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index f8e4a7a67d0..891ed1bc269 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -109,6 +109,7 @@ the second with the current group name." (defcustom gnus-message-setup-hook nil "Hook run after setting up a message buffer." :group 'gnus-message + :options '(message-remove-blank-cited-lines) :type 'hook) (defcustom gnus-bug-create-help-buffer t @@ -255,7 +256,8 @@ See also the `mml-default-encrypt-method' variable." :group 'gnus-message :type 'boolean) -(defcustom gnus-confirm-mail-reply-to-news nil +(defcustom gnus-confirm-mail-reply-to-news (and gnus-novice-user + (not gnus-expert-user)) "If non-nil, Gnus requests confirmation when replying to news. This is done because new users often reply by mistake when reading news. @@ -288,6 +290,16 @@ If nil, the address field will always be empty after invoking :group 'gnus-message :type 'boolean) +(defcustom gnus-message-highlight-citation + t ;; gnus-treat-highlight-citation ;; gnus-cite dependency + "Enable highlighting of different citation levels in message-mode." + :version "23.0" ;; No Gnus + :group 'gnus-cite + :group 'gnus-message + :type 'boolean) + +(autoload 'gnus-message-citation-mode "gnus-cite" nil t) + ;;; Internal variables. (defvar gnus-inhibit-posting-styles nil @@ -324,11 +336,7 @@ Thank you for your help in stamping out bugs. ") (eval-and-compile - (autoload 'gnus-uu-post-news "gnus-uu" nil t) - (autoload 'news-setup "rnewspost") - (autoload 'news-reply-mode "rnewspost") - (autoload 'rmail-dont-reply-to "mail-utils") - (autoload 'rmail-output "rmailout")) + (autoload 'gnus-uu-post-news "gnus-uu" nil t)) ;;; @@ -369,10 +377,10 @@ Thank you for your help in stamping out bugs. ;;; Internal functions. -(defun gnus-inews-make-draft () +(defun gnus-inews-make-draft (articles) `(lambda () (gnus-inews-make-draft-meta-information - ,gnus-newsgroup-name ',gnus-article-reply))) + ,(gnus-group-decoded-name gnus-newsgroup-name) ',articles))) (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) @@ -421,7 +429,7 @@ Thank you for your help in stamping out bugs. (not (string= ,group ""))) (push (cons (intern gnus-draft-meta-information-header) - (gnus-inews-make-draft)) + (gnus-inews-make-draft (or ,yanked ,article))) message-required-headers)) (unwind-protect (progn @@ -432,6 +440,9 @@ Thank you for your help in stamping out bugs. (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) (set (make-local-variable 'gnus-newsgroup-name) ,group) + ;; Enable highlighting of different citation levels + (when gnus-message-highlight-citation + (gnus-message-citation-mode 1)) (gnus-run-hooks 'gnus-message-setup-hook) (if (eq major-mode 'message-mode) (let ((mbl1 mml-buffer-list)) @@ -449,12 +460,20 @@ Thank you for your help in stamping out bugs. (run-hooks 'post-command-hook) (set-buffer-modified-p nil)))) -(defun gnus-inews-make-draft-meta-information (group article) - (concat "(\"" group "\" " - (if article (number-to-string - (if (listp article) - (car article) - article)) "\"\"") +(defun gnus-inews-make-draft-meta-information (group articles) + (when (numberp articles) + (setq articles (list articles))) + (concat "(\"" group "\"" + (if articles + (concat " " + (mapconcat + (lambda (elem) + (number-to-string + (if (consp elem) + (car elem) + elem))) + articles " ")) + "") ")")) ;;;###autoload @@ -519,7 +538,7 @@ Gcc: header for archiving purposes." (gnus-make-local-hook 'message-header-hook) (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t)) (setq message-post-method - `(lambda (arg) + `(lambda (&optional arg) (gnus-post-method arg ,gnus-newsgroup-name))) (message-add-action `(when (gnus-buffer-exists-p ,buffer) @@ -562,9 +581,9 @@ If ARG is 1, prompt for a group name to find the posting style." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (completing-read "Use posting style of group: " - gnus-active-hashtb nil - (gnus-read-active-file-p)) + (gnus-group-completing-read + "Use posting style of group: " + nil nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) ;; #### see comment in gnus-setup-message -- drv @@ -593,9 +612,9 @@ network. The corresponding back end must have a 'request-post method." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (completing-read "Use group: " - gnus-active-hashtb nil - (gnus-read-active-file-p)) + (gnus-group-completing-read "Use group: " + nil nil + (gnus-read-active-file-p)) (gnus-group-group-name)) "")) ;; #### see comment in gnus-setup-message -- drv @@ -615,8 +634,8 @@ a news." (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (completing-read "Newsgroup: " gnus-active-hashtb nil - (gnus-read-active-file-p)) + (gnus-group-completing-read "Newsgroup: " nil nil + (gnus-read-active-file-p)) (gnus-group-group-name)) "")) ;; make sure last viewed article doesn't affect posting styles: @@ -641,9 +660,9 @@ posting style." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (completing-read "Use group: " - gnus-active-hashtb nil - (gnus-read-active-file-p)) + (gnus-group-completing-read "Use group: " + nil nil + (gnus-read-active-file-p)) "") gnus-newsgroup-name)) ;; #### see comment in gnus-setup-message -- drv @@ -672,9 +691,9 @@ network. The corresponding back end must have a 'request-post method." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (completing-read "Use group: " - gnus-active-hashtb nil - (gnus-read-active-file-p)) + (gnus-group-completing-read "Use group: " + nil nil + (gnus-read-active-file-p)) "") gnus-newsgroup-name)) ;; #### see comment in gnus-setup-message -- drv @@ -682,9 +701,9 @@ network. The corresponding back end must have a 'request-post method." (progn (message-news (gnus-group-real-name gnus-newsgroup-name)) (set (make-local-variable 'gnus-discouraged-post-methods) - (delq + (remove (car (gnus-find-method-for-group gnus-newsgroup-name)) - (copy-sequence gnus-discouraged-post-methods)))))) + gnus-discouraged-post-methods))))) (save-excursion (set-buffer buffer) (setq gnus-newsgroup-name group))))) @@ -699,8 +718,8 @@ a news." (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (completing-read "Newsgroup: " gnus-active-hashtb nil - (gnus-read-active-file-p)) + (gnus-group-completing-read "Newsgroup: " nil nil + (gnus-read-active-file-p)) "") gnus-newsgroup-name)) ;; make sure last viewed article doesn't affect posting styles: @@ -784,12 +803,10 @@ Uses the process-prefix convention. If given the symbolic prefix `a', cancel using the standard posting method; if not post using the current select method." (interactive (gnus-interactive "P\ny")) - (let ((articles (gnus-summary-work-articles n)) - (message-post-method + (let ((message-post-method `(lambda (arg) - (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) - article) - (while (setq article (pop articles)) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))) + (dolist (article (gnus-summary-work-articles n)) (when (gnus-summary-select-article t nil nil article) (when (gnus-eval-in-buffer-window gnus-original-article-buffer (message-cancel-news)) @@ -1254,14 +1271,12 @@ For the `inline' alternatives, also see the variable (with-current-buffer gnus-original-article-buffer (nnmail-fetch-field "to")))) current-prefix-arg)) - (let ((articles (gnus-summary-work-articles n)) - article) - (while (setq article (pop articles)) - (gnus-summary-select-article nil nil nil article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (message-resend address)) - (gnus-summary-mark-article-as-forwarded article)))) + (dolist (article (gnus-summary-work-articles n)) + (gnus-summary-select-article nil nil nil article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (message-resend address)) + (gnus-summary-mark-article-as-forwarded article))) ;; From: Matthieu Moy <Matthieu.Moy@imag.fr> (defun gnus-summary-resend-message-edit () @@ -1322,37 +1337,35 @@ The current group name will be inserted at \"%s\".") (defun gnus-summary-mail-crosspost-complaint (n) "Send a complaint about crossposting to the current article(s)." (interactive "P") - (let ((articles (gnus-summary-work-articles n)) - article) - (while (setq article (pop articles)) - (set-buffer gnus-summary-buffer) - (gnus-summary-goto-subject article) - (let ((group (gnus-group-real-name gnus-newsgroup-name)) - newsgroups followup-to) - (gnus-summary-select-article) - (set-buffer gnus-original-article-buffer) - (if (and (<= (length (message-tokenize-header - (setq newsgroups - (mail-fetch-field "newsgroups")) - ", ")) - 1) - (or (not (setq followup-to (mail-fetch-field "followup-to"))) - (not (member group (message-tokenize-header - followup-to ", "))))) - (if followup-to - (gnus-message 1 "Followup-to restricted") - (gnus-message 1 "Not a crossposted article")) - (set-buffer gnus-summary-buffer) - (gnus-summary-reply-with-original 1) - (set-buffer gnus-message-buffer) - (message-goto-body) - (insert (format gnus-crosspost-complaint newsgroups group)) - (message-goto-subject) - (re-search-forward " *$") - (replace-match " (crosspost notification)" t t) - (gnus-deactivate-mark) - (when (gnus-y-or-n-p "Send this complaint? ") - (message-send-and-exit))))))) + (dolist (article (gnus-summary-work-articles n)) + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-subject article) + (let ((group (gnus-group-real-name gnus-newsgroup-name)) + newsgroups followup-to) + (gnus-summary-select-article) + (set-buffer gnus-original-article-buffer) + (if (and (<= (length (message-tokenize-header + (setq newsgroups + (mail-fetch-field "newsgroups")) + ", ")) + 1) + (or (not (setq followup-to (mail-fetch-field "followup-to"))) + (not (member group (message-tokenize-header + followup-to ", "))))) + (if followup-to + (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Not a crossposted article")) + (set-buffer gnus-summary-buffer) + (gnus-summary-reply-with-original 1) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-crosspost-complaint newsgroups group)) + (message-goto-subject) + (re-search-forward " *$") + (replace-match " (crosspost notification)" t t) + (gnus-deactivate-mark) + (when (gnus-y-or-n-p "Send this complaint? ") + (message-send-and-exit)))))) (defun gnus-mail-parse-comma-list () (let (accumulated @@ -1401,7 +1414,7 @@ The current group name will be inserted at \"%s\".") (not (gnus-group-read-only-p group))) (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (when (gnus-gethash group gnus-newsrc-hashtb) + (when (gnus-group-entry group) (error "No such group: %s" group)) (save-excursion (save-restriction @@ -1620,8 +1633,11 @@ this is a reply." (message-tokenize-header gcc " ,"))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) - (unless (gnus-check-server - (setq method (gnus-inews-group-method group))) + (setq method (gnus-inews-group-method group) + group (mm-encode-coding-string + group + (gnus-group-name-charset method group))) + (unless (gnus-check-server method) (error "Can't open server %s" (if (stringp method) method (car method)))) (unless (gnus-request-group group nil method) @@ -1667,11 +1683,13 @@ this is a reply." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) - (unless (setq group-art - (gnus-request-accept-article group method t t)) + (when (or (not (gnus-check-backend-function + 'request-accept-article group)) + (not (setq group-art + (gnus-request-accept-article + group method t t)))) (gnus-message 1 "Couldn't store article in group %s: %s" - group (gnus-status-message method)) - (sit-for 2)) + group (gnus-status-message method))) (when (and group-art ;; FIXME: Should gcc-mark-as-read work when ;; Gnus is not running? @@ -1709,8 +1727,13 @@ this is a reply." (defun gnus-inews-insert-archive-gcc (&optional group) "Insert the Gcc to say where the article is to be archived." + (setq group (cond (group + (gnus-group-decoded-name group)) + (gnus-newsgroup-name + (gnus-group-decoded-name gnus-newsgroup-name)) + (t + ""))) (let* ((var gnus-message-archive-group) - (group (or group gnus-newsgroup-name "")) (gcc-self-val (and gnus-newsgroup-name (not (equal gnus-newsgroup-name "")) @@ -1892,6 +1915,13 @@ this is a reply." ((eq element 'x-face-file) (setq element 'x-face filep t))) + ;; Post-processing for the signature posting-style: + (and (eq element 'signature) filep + message-signature-directory + ;; don't actually use the signature directory + ;; if message-signature-file contains a path. + (not (file-name-directory v)) + (setq v (nnheader-concat message-signature-directory v))) ;; Get the contents of file elems. (when (and filep v) (setq v (with-temp-buffer diff --git a/lisp/gnus/gnus-nocem.el b/lisp/gnus/gnus-nocem.el index 7b54687c84c..f3437c64bee 100644 --- a/lisp/gnus/gnus-nocem.el +++ b/lisp/gnus/gnus-nocem.el @@ -129,11 +129,12 @@ valid issuer, which is much faster if you are selective about the issuers." (defun gnus-fill-real-hashtb () "Fill up a hash table with the real-name mappings from the user's active file." - (setq gnus-nocem-real-group-hashtb (gnus-make-hashtable - (length gnus-newsrc-alist))) + (if (hash-table-p gnus-nocem-real-group-hashtb) + (clrhash gnus-nocem-real-group-hashtb) + (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal))) (mapcar (lambda (group) (setq group (gnus-group-real-name (car group))) - (gnus-sethash group t gnus-nocem-real-group-hashtb)) + (puthash group t gnus-nocem-real-group-hashtb)) gnus-newsrc-alist)) ;;;###autoload @@ -191,7 +192,7 @@ valid issuer, which is much faster if you are selective about the issuers." (and gnus-nocem-check-from (let ((case-fold-search t)) (catch 'ok - (mapcar + (mapc (lambda (author) (if (consp author) (setq author (car author))) @@ -237,11 +238,11 @@ valid issuer, which is much faster if you are selective about the issuers." (gnus-request-article-this-buffer (mail-header-number header) group) (goto-char (point-min)) (when (re-search-forward - "-----BEGIN PGP\\( SIGNED\\)? MESSAGE-----" + "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----" nil t) (delete-region (point-min) (match-beginning 0))) (when (re-search-forward - "-----END PGP \\(MESSAGE\\|SIGNATURE\\)-----\n?" + "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?" nil t) (delete-region (match-end 0) (point-max))) (goto-char (point-min)) @@ -304,34 +305,26 @@ valid issuer, which is much faster if you are selective about the issuers." (while (search-forward "\t" nil t) (cond ((not (ignore-errors - (setq group (let ((obarray gnus-nocem-real-group-hashtb)) - (read buf))))) + (setq group (gnus-group-real-name (symbol-name (read buf)))) + (gethash group gnus-nocem-real-group-hashtb))) ;; An error. ) - ((not (symbolp group)) - ;; Ignore invalid entries. - ) - ((not (boundp group)) - ;; Make sure all entries in the hashtb are bound. - (set group nil)) (t - (when (gnus-gethash (gnus-group-real-name (symbol-name group)) - gnus-nocem-real-group-hashtb) - ;; Valid group. - (beginning-of-line) - (while (eq (char-after) ?\t) - (forward-line -1)) - (setq id (buffer-substring (point) (1- (search-forward "\t")))) - (unless (if gnus-nocem-hashtb - (gnus-gethash id gnus-nocem-hashtb) - (setq gnus-nocem-hashtb (gnus-make-hashtable)) - nil) - ;; only store if not already present - (gnus-sethash id t gnus-nocem-hashtb) - (push id ncm)) - (forward-line 1) - (while (eq (char-after) ?\t) - (forward-line 1)))))) + ;; Valid group. + (beginning-of-line) + (while (eq (char-after) ?\t) + (forward-line -1)) + (setq id (buffer-substring (point) (1- (search-forward "\t")))) + (unless (if (hash-table-p gnus-nocem-hashtb) + (gethash id gnus-nocem-hashtb) + (setq gnus-nocem-hashtb (make-hash-table :test 'equal)) + nil) + ;; only store if not already present + (puthash id t gnus-nocem-hashtb) + (push id ncm)) + (forward-line 1) + (while (eq (char-after) ?\t) + (forward-line 1))))) (when ncm (setq gnus-nocem-touched-alist t) (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) @@ -370,7 +363,9 @@ valid issuer, which is much faster if you are selective about the issuers." (prev pprev) (expiry (days-to-time gnus-nocem-expiry-wait)) entry) - (setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51))) + (if (hash-table-p gnus-nocem-hashtb) + (clrhash gnus-nocem-hashtb) + (setq gnus-nocem-hashtb (make-hash-table :test 'equal))) (while (setq entry (car alist)) (if (not (time-less-p (time-since (car entry)) expiry)) ;; This entry has expired, so we remove it. @@ -379,7 +374,7 @@ valid issuer, which is much faster if you are selective about the issuers." ;; This is ok, so we enter it into the hashtable. (setq entry (cdr entry)) (while entry - (gnus-sethash (car entry) t gnus-nocem-hashtb) + (puthash (car entry) t gnus-nocem-hashtb) (setq entry (cdr entry)))) (setq alist (cdr alist))))) @@ -397,7 +392,7 @@ valid issuer, which is much faster if you are selective about the issuers." (defun gnus-nocem-unwanted-article-p (id) "Say whether article ID in the current group is wanted." (and gnus-nocem-hashtb - (gnus-gethash id gnus-nocem-hashtb))) + (gethash id gnus-nocem-hashtb))) (provide 'gnus-nocem) diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index a9303af5fc8..e9643399719 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -74,6 +74,15 @@ Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'gnus-picon) +(defcustom gnus-picon-style 'inline + "How should picons be displayed. +If `inline', the textual representation is replaced. If `right', picons are +added right to the textual representation." + ;; FIXME: `right' needs improvement for XEmacs. + :type '(choice (const inline) + (const right)) + :group 'gnus-picon) + (defface gnus-picon-xbm '((t (:foreground "black" :background "white"))) "Face to show xbm picon in." :group 'gnus-picon) @@ -139,14 +148,17 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") file nil))) -(defun gnus-picon-insert-glyph (glyph category) +(defun gnus-picon-insert-glyph (glyph category &optional nostring) "Insert GLYPH into the buffer. -GLYPH can be either a glyph or a string." +GLYPH can be either a glyph or a string. When NOSTRING, no textual +replacement is added." + ;; Using NOSTRING prevents wrong BBDB entries with `gnus-picon-style' set to + ;; 'right. (if (stringp glyph) (insert glyph) (gnus-add-wash-type category) (gnus-add-image category (car glyph)) - (gnus-put-image (car glyph) (cdr glyph) category))) + (gnus-put-image (car glyph) (unless nostring (cdr glyph)) category))) (defun gnus-picon-create-glyph (file) (or (cdr (assoc file gnus-picon-glyph-alist)) @@ -157,87 +169,107 @@ GLYPH can be either a glyph or a string." (defun gnus-picon-transform-address (header category) (gnus-with-article-headers - (let ((addresses - (mail-header-parse-addresses - ;; mail-header-parse-addresses does not work (reliably) on - ;; decoded headers. - (or - (ignore-errors - (mail-encode-encoded-word-string - (or (mail-fetch-field header) ""))) - (mail-fetch-field header)))) - spec file point cache) - (dolist (address addresses) - (setq address (car address)) - (when (and (stringp address) - (setq spec (gnus-picon-split-address address))) - (if (setq cache (cdr (assoc address gnus-picon-cache))) - (setq spec cache) - (when (setq file (or (gnus-picon-find-face - address gnus-picon-user-directories) - (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (cdr spec) ".")) - gnus-picon-user-directories))) - (setcar spec (cons (gnus-picon-create-glyph file) - (car spec)))) - - (dotimes (i (1- (length spec))) - (when (setq file (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (nthcdr (1+ i) spec) ".")) - gnus-picon-domain-directories t)) - (setcar (nthcdr (1+ i) spec) - (cons (gnus-picon-create-glyph file) - (nth (1+ i) spec))))) - (setq spec (nreverse spec)) - (push (cons address spec) gnus-picon-cache)) - - (gnus-article-goto-header header) - (mail-header-narrow-to-field) - (when (search-forward address nil t) - (delete-region (match-beginning 0) (match-end 0)) - (setq point (point)) - (while spec - (goto-char point) - (if (> (length spec) 2) - (insert ".") - (if (= (length spec) 2) - (insert "@"))) - (gnus-picon-insert-glyph (pop spec) category)))))))) + (let ((addresses + (mail-header-parse-addresses + ;; mail-header-parse-addresses does not work (reliably) on + ;; decoded headers. + (or + (ignore-errors + (mail-encode-encoded-word-string + (or (mail-fetch-field header) ""))) + (mail-fetch-field header)))) + spec file point cache len) + (dolist (address addresses) + (setq address (car address)) + (when (and (stringp address) + (setq spec (gnus-picon-split-address address))) + (if (setq cache (cdr (assoc address gnus-picon-cache))) + (setq spec cache) + (when (setq file (or (gnus-picon-find-face + address gnus-picon-user-directories) + (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (cdr spec) ".")) + gnus-picon-user-directories))) + (setcar spec (cons (gnus-picon-create-glyph file) + (car spec)))) + + (dotimes (i (1- (length spec))) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr (1+ i) spec) ".")) + gnus-picon-domain-directories t)) + (setcar (nthcdr (1+ i) spec) + (cons (gnus-picon-create-glyph file) + (nth (1+ i) spec))))) + (setq spec (nreverse spec)) + (push (cons address spec) gnus-picon-cache)) + + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (case gnus-picon-style + (right + (when (= (length addresses) 1) + (setq len (apply '+ (mapcar (lambda (x) + (condition-case nil + (car (image-size (car x))) + (error 0))) spec))) + (when (> len 0) + (goto-char (point-at-eol)) + (insert (propertize + " " 'display + (cons 'space + (list :align-to (- (window-width) 1 len)))))) + (goto-char (point-at-eol)) + (setq point (point-at-eol)) + (dolist (image spec) + (unless (stringp image) + (goto-char point) + (gnus-picon-insert-glyph image category 'nostring))))) + (inline + (when (search-forward address nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq point (point)) + (while spec + (goto-char point) + (if (> (length spec) 2) + (insert ".") + (if (= (length spec) 2) + (insert "@"))) + (gnus-picon-insert-glyph (pop spec) category)))))))))) (defun gnus-picon-transform-newsgroups (header) (interactive) (gnus-with-article-headers - (gnus-article-goto-header header) - (mail-header-narrow-to-field) - (let ((groups (message-tokenize-header (mail-fetch-field header))) - spec file point) - (dolist (group groups) - (unless (setq spec (cdr (assoc group gnus-picon-cache))) - (setq spec (nreverse (split-string group "[.]"))) - (dotimes (i (length spec)) - (when (setq file (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (nthcdr i spec) ".")) - gnus-picon-news-directories t)) - (setcar (nthcdr i spec) - (cons (gnus-picon-create-glyph file) - (nth i spec))))) - (push (cons group spec) gnus-picon-cache)) - (when (search-forward group nil t) - (delete-region (match-beginning 0) (match-end 0)) - (save-restriction - (narrow-to-region (point) (point)) - (while spec - (goto-char (point-min)) - (if (> (length spec) 1) - (insert ".")) - (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) - (goto-char (point-max)))))))) + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (let ((groups (message-tokenize-header (mail-fetch-field header))) + spec file point) + (dolist (group groups) + (unless (setq spec (cdr (assoc group gnus-picon-cache))) + (setq spec (nreverse (split-string group "[.]"))) + (dotimes (i (length spec)) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr i spec) ".")) + gnus-picon-news-directories t)) + (setcar (nthcdr i spec) + (cons (gnus-picon-create-glyph file) + (nth i spec))))) + (push (cons group spec) gnus-picon-cache)) + (when (search-forward group nil t) + (delete-region (match-beginning 0) (match-end 0)) + (save-restriction + (narrow-to-region (point) (point)) + (while spec + (goto-char (point-min)) + (if (> (length spec) 1) + (insert ".")) + (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) + (goto-char (point-max)))))))) ;;; Commands: @@ -251,10 +283,9 @@ If picons are already displayed, remove them." (interactive) (let ((wash-picon-p buffer-read-only)) (gnus-with-article-buffer - (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) - (gnus-delete-images 'from-picon) - (gnus-picon-transform-address "from" 'from-picon))) - )) + (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) + (gnus-delete-images 'from-picon) + (gnus-picon-transform-address "from" 'from-picon))))) ;;;###autoload (defun gnus-treat-mail-picon () @@ -263,11 +294,10 @@ If picons are already displayed, remove them." (interactive) (let ((wash-picon-p buffer-read-only)) (gnus-with-article-buffer - (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) - (gnus-delete-images 'mail-picon) - (gnus-picon-transform-address "cc" 'mail-picon) - (gnus-picon-transform-address "to" 'mail-picon))) - )) + (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) + (gnus-delete-images 'mail-picon) + (gnus-picon-transform-address "cc" 'mail-picon) + (gnus-picon-transform-address "to" 'mail-picon))))) ;;;###autoload (defun gnus-treat-newsgroups-picon () @@ -276,11 +306,10 @@ If picons are already displayed, remove them." (interactive) (let ((wash-picon-p buffer-read-only)) (gnus-with-article-buffer - (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) - (gnus-delete-images 'newsgroups-picon) - (gnus-picon-transform-newsgroups "newsgroups") - (gnus-picon-transform-newsgroups "followup-to"))) - )) + (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) + (gnus-delete-images 'newsgroups-picon) + (gnus-picon-transform-newsgroups "newsgroups") + (gnus-picon-transform-newsgroups "followup-to"))))) (provide 'gnus-picon) diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index b9b97797d17..d95269372f5 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -307,7 +307,7 @@ LIST1 and LIST2 have to be sorted over <." (cdr top))) (defun gnus-compress-sequence (numbers &optional always-list) - "Convert list of numbers to a list of ranges or a single range. + "Convert sorted list of numbers to a list of ranges or a single range. If ALWAYS-LIST is non-nil, this function will always release a list of ranges." (let* ((first (car numbers)) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 847cbf0a734..2ccf70efc46 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -25,11 +25,11 @@ ;;; Commentary: -;; This is the gnus-registry.el package, works with other backends -;; besides nnmail. The major issue is that it doesn't go across -;; backends, so for instance if an article is in nnml:sys and you see -;; a reference to it in nnimap splitting, the article will end up in -;; nnimap:sys +;; This is the gnus-registry.el package, which works with all +;; backends, not just nnmail (e.g. NNTP). The major issue is that it +;; doesn't go across backends, so for instance if an article is in +;; nnml:sys and you see a reference to it in nnimap splitting, the +;; article will end up in nnimap:sys ;; gnus-registry.el intercepts article respooling, moving, deleting, ;; and copying for all backends. If it doesn't work correctly for @@ -71,14 +71,19 @@ :version "22.1" :group 'gnus) -(defvar gnus-registry-hashtb nil +(defvar gnus-registry-hashtb (make-hash-table + :size 256 + :test 'equal) "*The article registry by Message ID.") -(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue") - "List of groups that gnus-registry-split-fancy-with-parent won't follow. -The group names are matched, they don't have to be fully qualified." +(defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$") + "List of groups that gnus-registry-split-fancy-with-parent won't return. +The group names are matched, they don't have to be fully +qualified. This parameter tells the Registry 'never split a +message into a group that matches one of these, regardless of +references.'" :group 'gnus-registry - :type '(repeat string)) + :type '(repeat regexp)) (defcustom gnus-registry-install nil "Whether the registry should be installed." @@ -87,7 +92,8 @@ The group names are matched, they don't have to be fully qualified." (defcustom gnus-registry-clean-empty t "Whether the empty registry entries should be deleted. -Registry entries are considered empty when they have no groups." +Registry entries are considered empty when they have no groups +and no extra data." :group 'gnus-registry :type 'boolean) @@ -121,7 +127,10 @@ way." :group 'gnus-registry :type 'boolean) -(defcustom gnus-registry-cache-file "~/.gnus.registry.eld" +(defcustom gnus-registry-cache-file + (nnheader-concat + (or gnus-dribble-directory gnus-home-directory "~/") + ".gnus.registry.eld") "File where the Gnus registry will be stored." :group 'gnus-registry :type 'file) @@ -132,13 +141,6 @@ way." :type '(radio (const :format "Unlimited " nil) (integer :format "Maximum number: %v"))) -;; Function(s) missing in Emacs 20 -(when (memq nil (mapcar 'fboundp '(puthash))) - (require 'cl) - (unless (fboundp 'puthash) - ;; alias puthash is missing from Emacs 20 cl-extra.el - (defalias 'puthash 'cl-puthash))) - (defun gnus-registry-track-subject-p () (memq 'subject gnus-registry-track-extra)) @@ -210,7 +212,7 @@ way." ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (set-file-modes startup-file setmodes))) + (gnus-set-file-modes startup-file setmodes))) (condition-case nil (delete-file working-file) (file-error nil))))) @@ -221,7 +223,7 @@ way." ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> ;; Save the gnus-registry file with extra line breaks. (defun gnus-registry-cache-whitespace (filename) - (gnus-message 5 "Adding whitespace to %s" filename) + (gnus-message 7 "Adding whitespace to %s" filename) (save-excursion (goto-char (point-min)) (while (re-search-forward "^(\\|(\\\"" nil t) @@ -244,10 +246,12 @@ way." ;; remove empty entries (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) - ;; now trim the registry appropriately - (setq gnus-registry-alist (gnus-registry-trim - (gnus-hashtable-to-alist - gnus-registry-hashtb))) + ;; now trim and clean text properties from the registry appropriately + (setq gnus-registry-alist + (gnus-registry-remove-alist-text-properties + (gnus-registry-trim + (gnus-hashtable-to-alist + gnus-registry-hashtb)))) ;; really save (gnus-registry-cache-save) (setq gnus-registry-entry-caching caching) @@ -256,11 +260,36 @@ way." (defun gnus-registry-clean-empty-function () "Remove all empty entries from the registry. Returns count thereof." (let ((count 0)) + (maphash (lambda (key value) - (unless (gnus-registry-fetch-group key) - (incf count) - (remhash key gnus-registry-hashtb))) + (when (stringp key) + (dolist (group (gnus-registry-fetch-groups key)) + (when (gnus-parameter-registry-ignore group) + (gnus-message + 10 + "gnus-registry: deleted ignored group %s from key %s" + group key) + (gnus-registry-delete-group key group))) + + (unless (gnus-registry-group-count key) + (gnus-registry-delete-id key)) + + (unless (or + (gnus-registry-fetch-group key) + ;; TODO: look for specific extra data here! + ;; in this example, we look for 'label + (gnus-registry-fetch-extra key 'label)) + (incf count) + (gnus-registry-delete-id key)) + + (unless (stringp key) + (gnus-message + 10 + "gnus-registry key %s was not a string, removing" + key) + (gnus-registry-delete-id key)))) + gnus-registry-hashtb) count)) @@ -269,8 +298,20 @@ way." (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) (setq gnus-registry-dirty nil)) +(defun gnus-registry-remove-alist-text-properties (v) + "Remove text properties from all strings in alist." + (if (stringp v) + (gnus-string-remove-all-properties v) + (if (and (listp v) (listp (cdr v))) + (mapcar 'gnus-registry-remove-alist-text-properties v) + (if (and (listp v) (stringp (cdr v))) + (cons (gnus-registry-remove-alist-text-properties (car v)) + (gnus-registry-remove-alist-text-properties (cdr v))) + v)))) + (defun gnus-registry-trim (alist) - "Trim alist to size, using gnus-registry-max-entries." + "Trim alist to size, using gnus-registry-max-entries. +Also, drop all gnus-registry-ignored-groups matches." (if (null gnus-registry-max-entries) alist ; just return the alist ;; else, when given max-entries, trim the alist @@ -283,27 +324,28 @@ way." (lambda (key value) (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) gnus-registry-hashtb) - + ;; we use the return value of this setq, which is the trimmed alist (setq alist - (nthcdr - trim-length - (sort alist - (lambda (a b) - (time-less-p - (cdr (gethash (car a) timehash)) - (cdr (gethash (car b) timehash)))))))))) + (nthcdr + trim-length + (sort alist + (lambda (a b) + (time-less-p + (or (cdr (gethash (car a) timehash)) '(0 0 0)) + (or (cdr (gethash (car b) timehash)) '(0 0 0)))))))))) (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) - (subject (gnus-registry-simplify-subject - (mail-header-subject data-header))) - (sender (mail-header-from data-header)) + (subject (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (mail-header-subject data-header)))) + (sender (gnus-string-remove-all-properties (mail-header-from data-header))) (from (gnus-group-guess-full-name-from-command-method from)) (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) (to-name (if to to "the Bit Bucket")) (old-entry (gethash id gnus-registry-hashtb))) - (gnus-message 5 "Registry: article %s %s from %s to %s" + (gnus-message 7 "Registry: article %s %s from %s to %s" id (if method "respooling" "going") from @@ -321,7 +363,7 @@ way." (let ((group (gnus-group-guess-full-name-from-command-method group))) (when (and (stringp id) (string-match "\r$" id)) (setq id (substring id 0 -1))) - (gnus-message 5 "Registry: article %s spooled to %s" + (gnus-message 7 "Registry: article %s spooled to %s" id group) (gnus-registry-add-group id group subject sender))) @@ -334,36 +376,46 @@ is obtained from the registry. This function can be used as an entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like this: (: gnus-registry-split-fancy-with-parent) +This function tracks ALL backends, unlike +`nnmail-split-fancy-with-parent' which tracks only nnmail +messages. + For a message to be split, it looks for the parent message in the -References or In-Reply-To header and then looks in the registry to -see which group that message was put in. This group is returned. +References or In-Reply-To header and then looks in the registry +to see which group that message was put in. This group is +returned, unless it matches one of the entries in +gnus-registry-unfollowed-groups or +nnmail-split-fancy-with-parent-ignore-groups. See the Info node `(gnus)Fancy Mail Splitting' for more details." - (let ((refstr (or (message-fetch-field "references") - (message-fetch-field "in-reply-to"))) + (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string + (reply-to (message-fetch-field "in-reply-to")) ; grab reply-to + ;; now, if reply-to is valid, append it to the References + (refstr (if reply-to + (concat refstr " " reply-to) + refstr)) (nnmail-split-fancy-with-parent-ignore-groups (if (listp nnmail-split-fancy-with-parent-ignore-groups) nnmail-split-fancy-with-parent-ignore-groups (list nnmail-split-fancy-with-parent-ignore-groups))) - references res) - (if refstr - (progn - (setq references (nreverse (gnus-split-references refstr))) - (mapcar (lambda (x) - (setq res (or (gnus-registry-fetch-group x) res)) - (when (or (gnus-registry-grep-in-list - res - gnus-registry-unfollowed-groups) - (gnus-registry-grep-in-list - res - nnmail-split-fancy-with-parent-ignore-groups)) - (setq res nil))) - references)) + res) + ;; the references string must be valid and parse to valid references + (if (and refstr (gnus-extract-references refstr)) + (dolist (reference (nreverse (gnus-extract-references refstr))) + (setq res (or (gnus-registry-fetch-group reference) res)) + (when (or (gnus-registry-grep-in-list + res + gnus-registry-unfollowed-groups) + (gnus-registry-grep-in-list + res + nnmail-split-fancy-with-parent-ignore-groups)) + (setq res nil))) ;; else: there were no references, now try the extra tracking - (let ((sender (message-fetch-field "from")) - (subject (gnus-registry-simplify-subject - (message-fetch-field "subject"))) + (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from"))) + (subject (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (message-fetch-field "subject")))) (single-match t)) (when (and single-match (gnus-registry-track-sender-p) @@ -379,13 +431,14 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (unless (equal res (gnus-registry-fetch-group key)) (setq single-match nil)) (setq res (gnus-registry-fetch-group key)) - (gnus-message - ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 5 9) - "%s (extra tracking) traced sender %s to group %s" - "gnus-registry-split-fancy-with-parent" - sender - (if res res "nil"))))) + (when (and sender res) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced sender %s to group %s" + "gnus-registry-split-fancy-with-parent" + sender + res))))) gnus-registry-hashtb)) (when (and single-match (gnus-registry-track-subject-p) @@ -402,24 +455,26 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (unless (equal res (gnus-registry-fetch-group key)) (setq single-match nil)) (setq res (gnus-registry-fetch-group key)) - (gnus-message - ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 5 9) - "%s (extra tracking) traced subject %s to group %s" - "gnus-registry-split-fancy-with-parent" - subject - (if res res "nil"))))) + (when (and subject res) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced subject %s to group %s" + "gnus-registry-split-fancy-with-parent" + subject + res))))) gnus-registry-hashtb)) (unless single-match (gnus-message - 5 + 3 "gnus-registry-split-fancy-with-parent: too many extra matches for %s" refstr) (setq res nil)))) - (gnus-message - 5 - "gnus-registry-split-fancy-with-parent traced %s to group %s" - refstr (if res res "nil")) + (when (and refstr res) + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent traced %s to group %s" + refstr res)) (when (and res gnus-registry-use-long-group-names) (let ((m1 (gnus-find-method-for-group res)) @@ -436,12 +491,45 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (setq res short-res)) ;; else... (gnus-message - 5 + 7 "gnus-registry-split-fancy-with-parent ignored foreign group %s" res) (setq res nil)))) res)) +(defun gnus-registry-wash-for-keywords (&optional force) + (interactive) + (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) + word words) + (if (or (not (gnus-registry-fetch-extra id 'keywords)) + force) + (save-excursion + (set-buffer gnus-article-buffer) + (article-goto-body) + (save-window-excursion + (save-restriction + (narrow-to-region (point) (point-max)) + (with-syntax-table gnus-adaptive-word-syntax-table + (while (re-search-forward "\\b\\w+\\b" nil t) + (setq word (gnus-registry-remove-alist-text-properties + (downcase (buffer-substring + (match-beginning 0) (match-end 0))))) + (if (> (length word) 3) + (push word words)))))) + (gnus-registry-store-extra-entry id 'keywords words))))) + +(defun gnus-registry-find-keywords (keyword) + (interactive "skeyword: ") + (let (articles) + (maphash + (lambda (key value) + (when (gnus-registry-grep-in-list + keyword + (cdr (gnus-registry-fetch-extra key 'keywords))) + (push key articles))) + gnus-registry-hashtb) + articles)) + (defun gnus-registry-register-message-ids () "Register the Message-ID of every article in the group" (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) @@ -472,17 +560,19 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." "Fetch the Subject quickly, using the internal gnus-data-list function" (if (and (numberp article) (assoc article (gnus-data-list nil))) - (gnus-registry-simplify-subject - (mail-header-subject (gnus-data-header - (assoc article (gnus-data-list nil))))) + (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (mail-header-subject (gnus-data-header + (assoc article (gnus-data-list nil)))))) nil)) (defun gnus-registry-fetch-sender-fast (article) "Fetch the Sender quickly, using the internal gnus-data-list function" (if (and (numberp article) (assoc article (gnus-data-list nil))) - (mail-header-from (gnus-data-header - (assoc article (gnus-data-list nil)))) + (gnus-string-remove-all-properties + (mail-header-from (gnus-data-header + (assoc article (gnus-data-list nil))))) nil)) (defun gnus-registry-grep-in-list (word list) @@ -491,9 +581,36 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (mapcar 'not (mapcar (lambda (x) - (string-match x word)) + (string-match word x)) list))))) +;;; if this extends to more than 'flags, it should be improved to be more generic. +(defun gnus-registry-fetch-extra-flags (id) + "Get the flags of a message, based on the message ID. +Returns a list of symbol flags or nil." + (car-safe (cdr (gnus-registry-fetch-extra id 'flags)))) + +(defun gnus-registry-has-extra-flag (id flag) + "Checks if a message has `flag', based on the message ID." + (memq flag (gnus-registry-fetch-extra-flags id))) + +(defun gnus-registry-store-extra-flags (id &rest flag-list) + "Set the flags of a message, based on the message ID. +The `flag-list' can be nil, in which case no flags are left." + (gnus-registry-store-extra-entry id 'flags (list flag-list))) + +(defun gnus-registry-delete-extra-flags (id &rest flag-delete-list) + "Delete the message flags in `flag-delete-list', based on the message ID." + (let ((flags (gnus-registry-fetch-extra-flags id))) + (when flags + (dolist (flag flag-delete-list) + (setq flags (delq flag flags)))) + (gnus-registry-store-extra-flags id (car flags)))) + +(defun gnus-registry-delete-all-extra-flags (id) + "Delete all the flags for a message ID." + (gnus-registry-store-extra-flags id nil)) + (defun gnus-registry-fetch-extra (id &optional entry) "Get the extra data of a message, based on the message ID. Returns the first place where the trail finds a nonstring." @@ -551,11 +668,20 @@ The message must have at least one group name." gnus-registry-hashtb) (setq gnus-registry-dirty t))))) +(defun gnus-registry-delete-extra-entry (id key) + "Delete a specific entry in the extras field of the registry entry for id." + (gnus-registry-store-extra-entry id key nil)) + (defun gnus-registry-store-extra-entry (id key value) "Put a specific entry in the extras field of the registry entry for id." (let* ((extra (gnus-registry-fetch-extra id)) - (alist (cons (cons key value) - (gnus-assq-delete-all key (gnus-registry-fetch-extra id))))) + ;; all the entries except the one for `key' + (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) + (alist (if value + (gnus-registry-remove-alist-text-properties + (cons (cons key value) + the-rest)) + the-rest))) (gnus-registry-store-extra id alist))) (defun gnus-registry-fetch-group (id) @@ -570,6 +696,23 @@ Returns the first place where the trail finds a group name." crumb (gnus-group-short-name crumb)))))))) +(defun gnus-registry-fetch-groups (id) + "Get the groups of a message, based on the message ID." + (let ((trail (gethash id gnus-registry-hashtb)) + groups) + (dolist (crumb trail) + (when (stringp crumb) + ;; push the group name into the list + (setq + groups + (cons + (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) + crumb + (gnus-group-short-name crumb)) + groups)))) + ;; return the list of groups + groups)) + (defun gnus-registry-group-count (id) "Get the number of groups of a message, based on the message ID." (let ((trail (gethash id gnus-registry-hashtb))) @@ -579,12 +722,11 @@ Returns the first place where the trail finds a group name." (defun gnus-registry-delete-group (id group) "Delete a group for a message, based on the message ID." - (when group - (when id + (when (and group id) (let ((trail (gethash id gnus-registry-hashtb)) - (group (gnus-group-short-name group))) + (short-group (gnus-group-short-name group))) (puthash id (if trail - (delete group trail) + (delete short-group (delete group trail)) nil) gnus-registry-hashtb)) ;; now, clear the entry if there are no more groups @@ -593,7 +735,7 @@ Returns the first place where the trail finds a group name." (gnus-registry-delete-id id))) ;; is this ID still in the registry? (when (gethash id gnus-registry-hashtb) - (gnus-registry-store-extra-entry id 'mtime (current-time)))))) + (gnus-registry-store-extra-entry id 'mtime (current-time))))) (defun gnus-registry-delete-id (id) "Delete a message ID from the registry." diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index e8d3e332ba3..6ecb7b4f3a6 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -128,7 +128,7 @@ It accepts the same format specs that `gnus-summary-line-format' does." ;; Set up the menu. (when (gnus-visual-p 'pick-menu 'menu) (gnus-pick-make-menu-bar)) - (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) + (add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) (gnus-run-hooks 'gnus-pick-mode-hook)))) (defun gnus-pick-setup-message () @@ -360,7 +360,7 @@ This must be bound to a button-down mouse event." ;; Set up the menu. (when (gnus-visual-p 'binary-menu 'menu) (gnus-binary-make-menu-bar)) - (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) + (add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) (gnus-run-hooks 'gnus-binary-mode-hook)))) (defun gnus-binary-display-article (article &optional all-header) @@ -719,7 +719,7 @@ Two predefined functions are available: (unless (zerop level) (gnus-tree-indent level) (insert (cadr gnus-tree-parent-child-edges)) - (setq col (- (setq beg (point)) (gnus-point-at-bol) 1)) + (setq col (- (setq beg (point)) (point-at-bol) 1)) ;; Draw "|" lines upwards. (while (progn (forward-line -1) @@ -743,7 +743,7 @@ Two predefined functions are available: (defsubst gnus-tree-indent-vertical () (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) - (- (point) (gnus-point-at-bol))))) + (- (point) (point-at-bol))))) (when (> len 0) (insert (make-string len ? ))))) @@ -1016,11 +1016,11 @@ The following commands are available: (setq button (car buttons) buttons (cdr buttons)) (if (stringp button) - (gnus-set-text-properties + (set-text-properties (point) (prog2 (insert button) (point) (insert " ")) (list 'face gnus-carpal-header-face)) - (gnus-set-text-properties + (set-text-properties (point) (prog2 (insert (car button)) (point) (insert " ")) (list 'gnus-callback (cdr button) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index f7ba9222937..f910bfb3ec3 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -37,8 +37,6 @@ (require 'message) (require 'score-mode) -(autoload 'ffap-string-at-point "ffap") - (defcustom gnus-global-score-files nil "List of global score files and directories. Set this variable if you want to use people's score files. One entry @@ -149,9 +147,15 @@ will be expired along with non-matching score entries." :type 'boolean) (defcustom gnus-decay-scores nil - "*If non-nil, decay non-permanent scores." + "*If non-nil, decay non-permanent scores. + +If it is a regexp, only decay score files matching regexp." :group 'gnus-score-decay - :type 'boolean) + :type `(choice (const :tag "never" nil) + (const :tag "always" t) + (const :tag "adaptive score files" + ,(concat "\\." gnus-adaptive-file-suffix "\\'")) + (regexp))) (defcustom gnus-decay-score-function 'gnus-decay-score "*Function called to decay a score. @@ -318,6 +322,13 @@ If this variable is nil, exact matching will always be used." :group 'gnus-score-files :type 'regexp) +(defcustom gnus-adaptive-pretty-print nil + "If non-nil, adaptive score files fill are pretty printed." + :group 'gnus-score-files + :group 'gnus-score-adapt + :version "23.0" ;; No Gnus + :type 'boolean) + (defcustom gnus-score-default-header nil "Default header when entering new scores. @@ -411,6 +422,18 @@ If nil, the user will be asked for a duration." :group 'gnus-score-various :type 'boolean) +(defcustom gnus-inhibit-slow-scoring nil + "Inhibit slow scoring, e.g. scoring on headers or body. + +If a regexp, scoring on headers or body is inhibited if the group +matches the regexp. If it is t, scoring on headers or body is +inhibited for all groups." + :group 'gnus-score-various + :version "23.0" ;; No Gnus + :type '(choice (const :tag "All" nil) + (const :tag "None" t) + regexp)) + ;; Internal variables. @@ -753,7 +776,7 @@ file for the command instead of the current score file." (setq i (1+ i)))) (goto-char (point-min)) ;; display ourselves in a small window at the bottom - (gnus-appt-select-lowest-window) + (gnus-select-lowest-window) (if (< (/ (window-height) 2) window-min-height) (switch-to-buffer "*Score Help*") (split-window) @@ -1099,6 +1122,16 @@ EXTRA is the possible non-standard header." 4 (substitute-command-keys "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))) +(defun gnus-score-edit-all-score () + "Edit the all.SCORE file." + (interactive) + (find-file (gnus-score-file-name "all")) + (gnus-score-mode) + (setq gnus-score-edit-exit-function 'gnus-score-edit-done) + (gnus-message + 4 (substitute-command-keys + "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) + (defun gnus-score-edit-file (file) "Edit a score file." (interactive @@ -1128,9 +1161,9 @@ If FORMAT, also format the current score file." (reg " -> +") (file (save-excursion (end-of-line) - (if (and (re-search-backward reg (gnus-point-at-bol) t) - (re-search-forward reg (gnus-point-at-eol) t)) - (buffer-substring (point) (gnus-point-at-eol)) + (if (and (re-search-backward reg (point-at-bol) t) + (re-search-forward reg (point-at-eol) t)) + (buffer-substring (point) (point-at-eol)) nil)))) (if (or (not file) (string-match "\\<\\(non-file rule\\|A file\\)\\>" file) @@ -1209,7 +1242,9 @@ If FORMAT, also format the current score file." (decay (car (gnus-score-get 'decay alist))) (eval (car (gnus-score-get 'eval alist)))) ;; Perform possible decays. - (when (and gnus-decay-scores + (when (and (if (stringp gnus-decay-scores) + (string-match gnus-decay-scores file) + gnus-decay-scores) (or cached (file-exists-p file)) (or (not decay) (gnus-decay-scores alist decay))) @@ -1219,8 +1254,7 @@ If FORMAT, also format the current score file." ;; files. (when (and files (not global)) (setq lists (apply 'append lists - (mapcar (lambda (file) - (gnus-score-load-file file)) + (mapcar 'gnus-score-load-file (if adapt-file (cons adapt-file files) files))))) (when (and eval (not global)) @@ -1412,12 +1446,13 @@ If FORMAT, also format the current score file." (setq score (setcdr entry (gnus-delete-alist 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) - (if (string-match - (concat (regexp-quote gnus-adaptive-file-suffix) "$") - file) - ;; This is an adaptive score file, so we do not run - ;; it through `pp'. These files can get huge, and - ;; are not meant to be edited by human hands. + (if (and (not gnus-adaptive-pretty-print) + (string-match + (concat (regexp-quote gnus-adaptive-file-suffix) "$") + file)) + ;; This is an adaptive score file, so we do not run it through + ;; `pp' unless requested. These files can get huge, and are + ;; not meant to be edited by human hands. (gnus-prin1 score) ;; This is a normal score file, so we print it very ;; prettily. @@ -1518,8 +1553,21 @@ If FORMAT, also format the current score file." (length (gnus-score-get header score))) scores))) ;; Call the scoring function for this type of "header". - (when (setq new (funcall (nth 2 entry) scores header - now expire trace)) + (when (if (and gnus-inhibit-slow-scoring + (if (and (stringp gnus-inhibit-slow-scoring) + ;; Always true here? + ;; (stringp gnus-newsgroup-name) + (string-match gnus-inhibit-slow-scoring + gnus-newsgroup-name)) + t + nil) + (> 0 (nth 1 (assoc header gnus-header-index)))) + (progn + (gnus-message + 7 "Scoring on headers or body skipped.") + nil) + (setq new (funcall (nth 2 entry) scores header + now expire trace))) (push new news)))) (when (gnus-buffer-live-p gnus-summary-buffer) (let ((scored gnus-newsgroup-scored)) @@ -1860,7 +1908,7 @@ score in `gnus-newsgroup-scored' by SCORE." (goto-char (point-min)) (if (= dmt ?e) (while (funcall search-func match nil t) - (and (= (gnus-point-at-bol) + (and (= (point-at-bol) (match-beginning 0)) (= (progn (end-of-line) (point)) (match-end 0)) @@ -2030,7 +2078,7 @@ score in `gnus-newsgroup-scored' by SCORE." (funcall search-func match nil t)) ;; Is it really exact? (and (eolp) - (= (gnus-point-at-bol) (match-beginning 0)) + (= (point-at-bol) (match-beginning 0)) ;; Yup. (progn (setq found (setq arts (get-text-property @@ -2120,7 +2168,7 @@ score in `gnus-newsgroup-scored' by SCORE." (goto-char (point-min)) (while (and (not (eobp)) (search-forward match nil t)) - (when (and (= (gnus-point-at-bol) (match-beginning 0)) + (when (and (= (point-at-bol) (match-beginning 0)) (eolp)) (setq found (setq arts (get-text-property (point) 'articles))) (if trace @@ -2194,23 +2242,19 @@ score in `gnus-newsgroup-scored' by SCORE." (defun gnus-enter-score-words-into-hashtb (hashtb) ;; Find all the words in the buffer and enter them into ;; the hashtable. - (let ((syntab (syntax-table)) - word val) + (let (word val) (goto-char (point-min)) - (unwind-protect - (progn - (set-syntax-table gnus-adaptive-word-syntax-table) - (while (re-search-forward "\\b\\w+\\b" nil t) - (setq val - (gnus-gethash - (setq word (downcase (buffer-substring - (match-beginning 0) (match-end 0)))) - hashtb)) - (gnus-sethash - word - (append (get-text-property (gnus-point-at-eol) 'articles) val) - hashtb))) - (set-syntax-table syntab)) + (with-syntax-table gnus-adaptive-word-syntax-table + (while (re-search-forward "\\b\\w+\\b" nil t) + (setq val + (gnus-gethash + (setq word (downcase (buffer-substring + (match-beginning 0) (match-end 0)))) + hashtb)) + (gnus-sethash + word + (append (get-text-property (point-at-eol) 'articles) val) + hashtb))) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words (if gnus-adaptive-word-no-group-words @@ -2313,39 +2357,35 @@ score in `gnus-newsgroup-scored' by SCORE." (let* ((hashtb (gnus-make-hashtable 1000)) (date (date-to-day (current-time-string))) (data gnus-newsgroup-data) - (syntab (syntax-table)) word d score val) - (unwind-protect - (progn - (set-syntax-table gnus-adaptive-word-syntax-table) - ;; Go through all articles. - (while (setq d (pop data)) - (when (and - (not (gnus-data-pseudo-p d)) - (setq score - (cdr (assq - (gnus-data-mark d) - gnus-adaptive-word-score-alist)))) - ;; This article has a mark that should lead to - ;; adaptive word rules, so we insert the subject - ;; and find all words in that string. - (insert (mail-header-subject (gnus-data-header d))) - (downcase-region (point-min) (point-max)) - (goto-char (point-min)) - (while (re-search-forward "\\b\\w+\\b" nil t) - ;; Put the word and score into the hashtb. - (setq val (gnus-gethash (setq word (match-string 0)) - hashtb)) - (when (or (not gnus-adaptive-word-length-limit) - (> (length word) - gnus-adaptive-word-length-limit)) - (setq val (+ score (or val 0))) - (if (and gnus-adaptive-word-minimum - (< val gnus-adaptive-word-minimum)) - (setq val gnus-adaptive-word-minimum)) - (gnus-sethash word val hashtb))) - (erase-buffer)))) - (set-syntax-table syntab)) + (with-syntax-table gnus-adaptive-word-syntax-table + ;; Go through all articles. + (while (setq d (pop data)) + (when (and + (not (gnus-data-pseudo-p d)) + (setq score + (cdr (assq + (gnus-data-mark d) + gnus-adaptive-word-score-alist)))) + ;; This article has a mark that should lead to + ;; adaptive word rules, so we insert the subject + ;; and find all words in that string. + (insert (mail-header-subject (gnus-data-header d))) + (downcase-region (point-min) (point-max)) + (goto-char (point-min)) + (while (re-search-forward "\\b\\w+\\b" nil t) + ;; Put the word and score into the hashtb. + (setq val (gnus-gethash (setq word (match-string 0)) + hashtb)) + (when (or (not gnus-adaptive-word-length-limit) + (> (length word) + gnus-adaptive-word-length-limit)) + (setq val (+ score (or val 0))) + (if (and gnus-adaptive-word-minimum + (< val gnus-adaptive-word-minimum)) + (setq val gnus-adaptive-word-minimum)) + (gnus-sethash word val hashtb))) + (erase-buffer)))) ;; Make all the ignorable words ignored. (let ((ignored (append gnus-ignored-adaptive-words (if gnus-adaptive-word-no-group-words @@ -2373,7 +2413,8 @@ score in `gnus-newsgroup-scored' by SCORE." (when winconf (set-window-configuration winconf)) (gnus-score-remove-from-cache bufnam) - (gnus-score-load-file bufnam))) + (gnus-score-load-file bufnam) + (run-hooks 'gnus-score-edit-done-hook))) (defun gnus-score-find-trace () "Find all score rules that applies to the current article." @@ -2401,6 +2442,11 @@ score in `gnus-newsgroup-scored' by SCORE." (interactive) (bury-buffer nil) (gnus-summary-expand-window))) + (local-set-key "k" + (lambda () + (interactive) + (kill-buffer (current-buffer)) + (gnus-summary-expand-window))) (local-set-key "e" (lambda () "Run `gnus-score-edit-file-at-point'." (interactive) @@ -2429,7 +2475,7 @@ score in `gnus-newsgroup-scored' by SCORE." Type `e' to edit score file corresponding to the score rule on current line, `f' to format (pretty print) the score file and edit it, `t' toggle to truncate long lines in this buffer, -`q' to quit. +`q' to quit, `k' to kill score trace buffer. The first sexp on each line is the score rule, followed by the file name of the score file and its full name, including the directory.") @@ -2775,9 +2821,7 @@ Destroys the current buffer." (lambda (file) (cons (inline (gnus-score-file-rank file)) file)) files))) - (mapcar - (lambda (f) (cdr f)) - (sort alist 'car-less-than-car))))) + (mapcar 'cdr (sort alist 'car-less-than-car))))) (defun gnus-score-find-alist (group) "Return list of score files for GROUP. diff --git a/lisp/gnus/gnus-setup.el b/lisp/gnus/gnus-setup.el index 55ab016a59e..fe261e119ee 100644 --- a/lisp/gnus/gnus-setup.el +++ b/lisp/gnus/gnus-setup.el @@ -140,8 +140,7 @@ (when gnus-use-sc (add-hook 'mail-citation-hook 'sc-cite-original) - (setq message-cite-function 'sc-cite-original) - (autoload 'sc-cite-original "supercite")) + (setq message-cite-function 'sc-cite-original)) ;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137)) ;;; Generated autoloads from lisp/gnus.el diff --git a/lisp/gnus/gnus-soup.el b/lisp/gnus/gnus-soup.el index 241fb6a2c86..f2aa34b1aa1 100644 --- a/lisp/gnus/gnus-soup.el +++ b/lisp/gnus/gnus-soup.el @@ -306,7 +306,7 @@ Note -- this function hasn't been implemented yet." If NOT-ALL, don't pack ticked articles." (let ((gnus-expert-user t) (gnus-large-newsgroup nil) - (entry (gnus-gethash group gnus-newsrc-hashtb))) + (entry (gnus-group-entry group))) (when (or (null entry) (eq (car entry) t) (and (car entry) diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 2197e286757..f87377cb1ed 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -140,7 +140,7 @@ text properties. This is only needed on XEmacs, as FSF Emacs does this anyway." (defvar gnus-format-specs `((version . ,emacs-version) (gnus-version . ,(gnus-continuum-version)) - (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec) + (group "%M\%S\%p\%P\%5y: %(%g%)\n" ,gnus-group-line-format-spec) (summary-dummy "* %(: :%) %S\n" ,gnus-summary-dummy-line-format-spec) (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n" @@ -198,12 +198,13 @@ Return a list of updated types." (not (equal emacs-version (cdr (assq 'version gnus-format-specs))))) (setq gnus-format-specs nil)) - ;; Flush the group format spec cache if it doesn't support decoded - ;; group names. + ;; Flush the group format spec cache if there's the grouplens stuff + ;; or it doesn't support decoded group names. (when (memq 'group types) - (let ((spec (assq 'group gnus-format-specs))) - (unless (string-match " gnus-tmp-decoded-group[ )]" - (gnus-prin1-to-string (nth 2 spec))) + (let* ((spec (assq 'group gnus-format-specs)) + (sspec (gnus-prin1-to-string (nth 2 spec)))) + (when (or (string-match " gnus-tmp-grouplens[ )]" sspec) + (not (string-match " gnus-tmp-decoded-group[ )]" sspec))) (setq gnus-format-specs (delq spec gnus-format-specs))))) ;; Go through all the formats and see whether they need updating. @@ -296,9 +297,7 @@ Return a list of updated types." (defun gnus-correct-length (string) "Return the correct width of STRING." - (let ((length 0)) - (mapcar (lambda (char) (incf length (gnus-char-width char))) string) - length)) + (apply #'+ (mapcar #'char-width string))) (defun gnus-correct-substring (string start &optional end) (let ((wstart 0) @@ -310,14 +309,14 @@ Return a list of updated types." ;; Find the start position. (while (and (< seek length) (< wseek start)) - (incf wseek (gnus-char-width (aref string seek))) + (incf wseek (char-width (aref string seek))) (incf seek)) (setq wstart seek) ;; Find the end position. (while (and (<= seek length) (or (not end) (<= wseek end))) - (incf wseek (gnus-char-width (aref string seek))) + (incf wseek (char-width (aref string seek))) (incf seek)) (setq wend seek) (substring string wstart (1- wend)))) @@ -622,6 +621,9 @@ are supported for %s." ?s))) ;; Find the specification from `spec-alist'. ((setq elem (cdr (assq (or extended-spec spec) spec-alist)))) + ;; We used to use "%l" for displaying the grouplens score. + ((eq spec ?l) + (setq elem '("" ?s))) (t (setq elem '("*" ?s)))) (setq elem-type (cadr elem)) @@ -672,7 +674,7 @@ are supported for %s." (list (car flist))) ;; A single number. ((string= fstring "%d") - (setq dontinsert) + (setq dontinsert t) (if insert (list `(princ ,(car flist))) (list `(int-to-string ,(car flist))))) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 9e709d0916c..ca087f9ca4d 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -52,7 +52,7 @@ with some simple extensions. The following specs are understood: -%h backend +%h back end %n name %w address %s status @@ -116,6 +116,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Copy" gnus-server-copy-server t] ["Edit" gnus-server-edit-server t] ["Regenerate" gnus-server-regenerate-server t] + ["Compact" gnus-server-compact-server t] ["Exit" gnus-server-exit t])) (easy-menu-define @@ -165,6 +166,8 @@ If nil, a faster, but more primitive, buffer is used instead." "g" gnus-server-regenerate-server + "z" gnus-server-compact-server + "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -189,7 +192,7 @@ If nil, a faster, but more primitive, buffer is used instead." (defface gnus-server-closed '((((class color) (background light)) (:foreground "Steel Blue" :italic t)) (((class color) (background dark)) - (:foreground "Light Steel Blue" :italic t)) + (:foreground "LightBlue" :italic t)) (t (:italic t))) "Face used for displaying CLOSED servers" :group 'gnus-server-visual) @@ -299,7 +302,6 @@ The following commands are available: (gnus-set-format 'server t) (let ((alist gnus-server-alist) (buffer-read-only nil) - (opened gnus-opened-servers) done server op-ser) (erase-buffer) (setq gnus-inserted-opened-servers nil) @@ -314,27 +316,26 @@ The following commands are available: (pop alist))) ;; Then we insert the list of servers that have been opened in ;; this session. - (while opened - (when (and (not (member (caar opened) done)) + (dolist (open gnus-opened-servers) + (when (and (not (member (car open) done)) ;; Just ignore ephemeral servers. - (not (member (caar opened) gnus-ephemeral-servers))) - (push (caar opened) done) + (not (member (car open) gnus-ephemeral-servers))) + (push (car open) done) (gnus-server-insert-server-line - (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) - (caar opened)) - (push (list op-ser (caar opened)) gnus-inserted-opened-servers)) - (setq opened (cdr opened)))) + (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open)))) + (car open)) + (push (list op-ser (car open)) gnus-inserted-opened-servers)))) (goto-char (point-min)) (gnus-server-position-point)) (defun gnus-server-server-name () - (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) + (let ((server (get-text-property (point-at-bol) 'gnus-server))) (and server (symbol-name server)))) (defun gnus-server-named-server () - "Returns a server name that matches one of the names returned by -gnus-method-to-server." - (let ((server (get-text-property (gnus-point-at-bol) 'gnus-named-server))) + "Return a server name that matches one of the names returned by +`gnus-method-to-server'." + (let ((server (get-text-property (point-at-bol) 'gnus-named-server))) (and server (symbol-name server)))) (defalias 'gnus-server-position-point 'gnus-goto-colon) @@ -377,7 +378,14 @@ gnus-method-to-server." (if cached (setq gnus-server-method-cache (delq cached gnus-server-method-cache))) - (if entry (setcdr entry info) + (if entry + (progn + ;; Remove the server from `gnus-opened-servers' since + ;; it has never been opened with the new `info' yet. + (gnus-opened-servers-remove (cdr entry)) + ;; Don't make a new Lisp object. + (setcar (cdr entry) (car info)) + (setcdr (cdr entry) (cdr info))) (setq gnus-server-alist (nconc gnus-server-alist (list (cons server info)))))))) @@ -478,9 +486,8 @@ gnus-method-to-server." (defun gnus-server-open-all-servers () "Open all servers." (interactive) - (let ((servers gnus-inserted-opened-servers)) - (while servers - (gnus-server-open-server (car (pop servers)))))) + (dolist (server gnus-inserted-opened-servers) + (gnus-server-open-server (car server)))) (defun gnus-server-close-server (server) "Close SERVER." @@ -510,6 +517,8 @@ gnus-method-to-server." "Close all servers." (interactive) (dolist (server gnus-inserted-opened-servers) + (gnus-server-close-server (car server))) + (dolist (server gnus-server-alist) (gnus-server-close-server (car server)))) (defun gnus-server-deny-server (server) @@ -586,7 +595,8 @@ gnus-method-to-server." `(lambda (form) (gnus-server-set-info ,server form) (gnus-server-list-servers) - (gnus-server-position-point))))) + (gnus-server-position-point)) + 'edit-server))) (defun gnus-server-scan-server (server) "Request a scan from the current server." @@ -717,11 +727,12 @@ gnus-method-to-server." (while (not (eobp)) (ignore-errors (push (cons - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point))) + (mm-string-as-unibyte + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point)))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -729,18 +740,19 @@ gnus-method-to-server." (while (not (eobp)) (ignore-errors (push (cons - (if (eq (char-after) ?\") - (read cur) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name)) + (mm-string-as-unibyte + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + name))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -783,18 +795,26 @@ gnus-method-to-server." (prog1 (1+ (point)) (insert (format "%c%7d: %s\n" - (let ((level (gnus-group-level - (concat prefix (setq name (car group)))))) - (cond - ((<= level gnus-level-subscribed) ? ) - ((<= level gnus-level-unsubscribed) ?U) - ((= level gnus-level-zombie) ?Z) - (t ?K))) + (let ((level + (if (string= prefix "") + (gnus-group-level (setq name (car group))) + (gnus-group-level + (concat prefix (setq name (car group))))))) + (cond + ((<= level gnus-level-subscribed) ? ) + ((<= level gnus-level-unsubscribed) ?U) + ((= level gnus-level-zombie) ?Z) + (t ?K))) (max 0 (- (1+ (cddr group)) (cadr group))) - (mm-decode-coding-string - name - (inline (gnus-group-name-charset method name)))))) - (list 'gnus-group name)))) + ;; Don't decode if name is ASCII + (if (and (fboundp 'detect-coding-string) + (eq (detect-coding-string name t) 'undecided)) + name + (mm-decode-coding-string + name + (inline (gnus-group-name-charset method name))))))) + (list 'gnus-group name) + ))) (switch-to-buffer (current-buffer))) (goto-char (point-min)) (gnus-group-position-point) @@ -885,7 +905,7 @@ If NUMBER, fetch this number of articles." (save-excursion (beginning-of-line) (let ((name (get-text-property (point) 'gnus-group))) - (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) + (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t) (concat (gnus-method-to-server-name gnus-browse-current-method) ":" (or name (match-string-no-properties 1))))))) @@ -926,8 +946,7 @@ If NUMBER, fetch this number of articles." gnus-browse-current-method)))) gnus-level-default-subscribed (gnus-group-level group) (and (car (nth 1 gnus-newsrc-alist)) - (gnus-gethash (car (nth 1 gnus-newsrc-alist)) - gnus-newsrc-hashtb)) + (gnus-group-entry (car (nth 1 gnus-newsrc-alist)))) (null (gnus-group-entry group))) (delete-char 1) (insert ? )) @@ -966,7 +985,7 @@ If NUMBER, fetch this number of articles." (gnus-get-function (gnus-server-to-method server) 'request-regenerate) (error - (error "This backend doesn't support regeneration"))) + (error "This back end doesn't support regeneration"))) (gnus-message 5 "Requesting regeneration of %s..." server) (unless (gnus-open-server server) (error "Couldn't open server")) @@ -974,6 +993,40 @@ If NUMBER, fetch this number of articles." (gnus-message 5 "Requesting regeneration of %s...done" server) (gnus-message 5 "Couldn't regenerate %s" server)))) + +;;; +;;; Server compaction. -- dvl +;;; + +;; #### FIXME: this function currently fails to update the Group buffer's +;; #### appearance. +(defun gnus-server-compact-server () + "Issue a command to the server to compact all its groups. + +Note: currently only implemented in nnml." + (interactive) + (let ((server (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (condition-case () + (gnus-get-function (gnus-server-to-method server) + 'request-compact) + (error + (error "This back end doesn't support compaction"))) + (gnus-message 5 "\ +Requesting compaction of %s... (this may take a long time)" + server) + (unless (gnus-open-server server) + (error "Couldn't open server")) + (if (not (gnus-request-compact server)) + (gnus-message 5 "Couldn't compact %s" server) + (gnus-message 5 "Requesting compaction of %s...done" server) + ;; Invalidate the original article buffer which might be out of date. + ;; #### NOTE: Yes, this might be a bit rude, but since compaction + ;; #### will not happen very often, I think this is acceptable. + (let ((original (get-buffer gnus-original-article-buffer))) + (and original (gnus-kill-buffer original)))))) + (provide 'gnus-srvr) ;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 220df957d13..39de524b156 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -508,19 +508,23 @@ Can be used to turn version control on or off." (defun gnus-subscribe-hierarchical-interactive (groups) (let ((groups (sort groups 'string<)) - prefixes prefix start ans group starts) + prefixes prefix start ans group starts real-group) (while groups (setq prefixes (list "^")) (while (and groups prefixes) - (while (not (string-match (car prefixes) (car groups))) + (while (not (string-match (car prefixes) + (gnus-group-real-name (car groups)))) (setq prefixes (cdr prefixes))) (setq prefix (car prefixes)) (setq start (1- (length prefix))) - (if (and (string-match "[^\\.]\\." (car groups) start) + (if (and (string-match "[^\\.]\\." (gnus-group-real-name (car groups)) + start) (cdr groups) (setq prefix - (concat "^" (substring (car groups) 0 (match-end 0)))) - (string-match prefix (cadr groups))) + (concat "^" (substring + (gnus-group-real-name (car groups)) + 0 (match-end 0)))) + (string-match prefix (gnus-group-real-name (cadr groups)))) (progn (push prefix prefixes) (message "Descend hierarchy %s? ([y]nsq): " @@ -532,16 +536,18 @@ Can be used to turn version control on or off." (substring prefix 1 (1- (length prefix))))) (cond ((= ans ?n) (while (and groups - (string-match prefix - (setq group (car groups)))) + (setq group (car groups) + real-group (gnus-group-real-name group)) + (string-match prefix real-group)) (push group gnus-killed-list) (gnus-sethash group group gnus-killed-hashtb) (setq groups (cdr groups))) (setq starts (cdr starts))) ((= ans ?s) (while (and groups - (string-match prefix - (setq group (car groups)))) + (setq group (car groups) + real-group (gnus-group-real-name group)) + (string-match prefix real-group)) (gnus-sethash group group gnus-killed-hashtb) (gnus-subscribe-alphabetically (car groups)) (setq groups (cdr groups))) @@ -634,8 +640,7 @@ the first newsgroup." ;; We subscribe the group by changing its level to `subscribed'. (gnus-group-change-level newsgroup gnus-level-default-subscribed - gnus-level-killed (gnus-gethash (or next "dummy.group") - gnus-newsrc-hashtb)) + gnus-level-killed (gnus-group-entry (or next "dummy.group"))) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup) t)) @@ -757,6 +762,13 @@ prompt the user for the name of an NNTP server to use." (nnheader-init-server-buffer) (setq gnus-slave slave) (gnus-read-init-file) + + ;; Add "native" to gnus-predefined-server-alist just to have a + ;; name for the native select method. + (when gnus-select-method + (push (cons "native" gnus-select-method) + gnus-predefined-server-alist)) + (if gnus-agent (gnus-agentize)) @@ -789,11 +801,6 @@ prompt the user for the name of an NNTP server to use." (when (or gnus-slave gnus-use-dribble-file) (gnus-dribble-read-file)) - ;; Allow using GroupLens predictions. - (when gnus-use-grouplens - (bbb-login) - (add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode)) - ;; Do the actual startup. (if gnus-agent (gnus-request-create-group "queue" '(nndraft ""))) @@ -811,8 +818,7 @@ prompt the user for the name of an NNTP server to use." (defun gnus-start-draft-setup () "Make sure the draft group exists." (gnus-request-create-group "drafts" '(nndraft "")) - (unless (gnus-gethash "nndraft:drafts" gnus-newsrc-hashtb) - (gnus-message 3 "Subscribing drafts group") + (unless (gnus-group-entry "nndraft:drafts") (let ((gnus-level-default-subscribed 1)) (gnus-subscribe-group "nndraft:drafts" nil '(nndraft "")))) (unless (equal (gnus-group-get-parameter "nndraft:drafts" 'gnus-dummy t) @@ -893,7 +899,7 @@ prompt the user for the name of an NNTP server to use." (when (and (file-exists-p gnus-current-startup-file) (file-exists-p dribble-file) (setq modes (file-modes gnus-current-startup-file))) - (set-file-modes dribble-file modes)) + (gnus-set-file-modes dribble-file modes)) (goto-char (point-min)) (when (search-forward "Gnus was exited on purpose" nil t) (setq purpose t)) @@ -963,30 +969,34 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-read-newsrc-file rawfile)) ;; Make sure the archive server is available to all and sundry. - (when gnus-message-archive-method - (unless (assoc "archive" gnus-server-alist) - (let ((method (or (and (stringp gnus-message-archive-method) - (gnus-server-to-method - gnus-message-archive-method)) - gnus-message-archive-method))) - ;; Check whether the archive method is writable. - (unless (or (stringp method) - (memq 'respool (assoc (format "%s" (car method)) - gnus-valid-select-methods))) - (setq method "archive")) ;; The default. - (push (if (stringp method) - `("archive" - nnfolder - ,method - (nnfolder-directory - ,(nnheader-concat message-directory method)) - (nnfolder-active-file - ,(nnheader-concat message-directory - (concat method "/active"))) - (nnfolder-get-new-mail nil) - (nnfolder-inhibit-expiry t)) - (cons "archive" method)) - gnus-server-alist)))) + (let ((method (or (and (stringp gnus-message-archive-method) + (gnus-server-to-method + gnus-message-archive-method)) + gnus-message-archive-method))) + ;; Check whether the archive method is writable. + (unless (or (not method) + (stringp method) + (memq 'respool (assoc (format "%s" (car method)) + gnus-valid-select-methods))) + (setq method "archive")) ;; The default. + (when (stringp method) + (setq method `(nnfolder + ,method + (nnfolder-directory + ,(nnheader-concat message-directory method)) + (nnfolder-active-file + ,(nnheader-concat message-directory + (concat method "/active"))) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t)))) + (if (assoc "archive" gnus-server-alist) + (when gnus-update-message-archive-method + (if method + (setcdr (assoc "archive" gnus-server-alist) method) + (setq gnus-server-alist (delq (assoc "archive" gnus-server-alist) + gnus-server-alist)))) + (when method + (push (cons "archive" method) gnus-server-alist)))) ;; If we don't read the complete active file, we fill in the ;; hashtb here. @@ -1336,16 +1346,16 @@ for new groups, and subscribe the new groups as zombies." (when (and (stringp entry) oldlevel (< oldlevel gnus-level-zombie)) - (setq entry (gnus-gethash entry gnus-newsrc-hashtb))) + (setq entry (gnus-group-entry entry))) (if (and (not oldlevel) (consp entry)) (setq oldlevel (gnus-info-level (nth 2 entry))) (setq oldlevel (or oldlevel gnus-level-killed))) (when (stringp previous) - (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) + (setq previous (gnus-group-entry previous))) (if (and (>= oldlevel gnus-level-zombie) - (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-entry group)) ;; We are trying to subscribe a group that is already ;; subscribed. () ; Do nothing. @@ -1369,8 +1379,7 @@ for new groups, and subscribe the new groups as zombies." entry) (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) (when (nth 3 entry) - (setcdr (gnus-gethash (car (nth 3 entry)) - gnus-newsrc-hashtb) + (setcdr (gnus-group-entry (car (nth 3 entry))) (cdr entry))) (setcdr (cdr entry) (cdddr entry))))) @@ -1430,7 +1439,7 @@ for new groups, and subscribe the new groups as zombies." (gnus-sethash group (cons num previous) gnus-newsrc-hashtb)) (when (cdr entry) - (setcdr (gnus-gethash (caadr entry) gnus-newsrc-hashtb) entry)) + (setcdr (gnus-group-entry (caadr entry)) entry)) (gnus-dribble-enter (format "(gnus-group-set-info '%S)" info))))) @@ -1441,7 +1450,7 @@ for new groups, and subscribe the new groups as zombies." (defun gnus-kill-newsgroup (newsgroup) "Obsolete function. Kills a newsgroup." (gnus-group-change-level - (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed)) + (gnus-group-entry newsgroup) gnus-level-killed)) (defun gnus-check-bogus-newsgroups (&optional confirm) "Remove bogus newsgroups. @@ -1469,14 +1478,14 @@ newsgroup." (lambda (group) ;; Remove all bogus subscribed groups by first killing them, and ;; then removing them from the list of killed groups. - (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (setq entry (gnus-group-entry group)) (gnus-group-change-level entry gnus-level-killed) (setq gnus-killed-list (delete group gnus-killed-list)))) bogus '("group" "groups" "remove")) (while (setq group (pop bogus)) ;; Remove all bogus subscribed groups by first killing them, and ;; then removing them from the list of killed groups. - (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (setq entry (gnus-group-entry group)) (gnus-group-change-level entry gnus-level-killed) (setq gnus-killed-list (delete group gnus-killed-list))))) ;; Then we remove all bogus groups from the list of killed and @@ -1545,8 +1554,8 @@ If SCAN, request a scan of that group as well." ;; command may have responded with the `(0 . 0)'. We ;; ignore this if we already have an active entry ;; for the group. - (if (and (zerop (car active)) - (zerop (cdr active)) + (if (and (zerop (or (car active) 0)) + (zerop (or (cdr active) 0)) (gnus-active group)) (gnus-active group) @@ -1654,8 +1663,8 @@ If SCAN, request a scan of that group as well." (setq num (max 0 (- (cdr active) num))))) ;; Set the number of unread articles. (when (and info - (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb)) - (setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num)) + (gnus-group-entry (gnus-info-group info))) + (setcar (gnus-group-entry (gnus-info-group info)) num)) num))) ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' @@ -1676,12 +1685,12 @@ If SCAN, request a scan of that group as well." (methods-cache nil) (type-cache nil) scanned-methods info group active method retrieve-groups cmethod - method-type) + method-type ignore) (gnus-message 6 "Checking new news...") (while newsrc (setq active (gnus-active (setq group (gnus-info-group - (setq info (pop newsrc)))))) + (setq info (pop newsrc)))))) ;; Check newsgroups. If the user doesn't want to check them, or ;; they can't be checked (for instance, if the news server can't @@ -1704,28 +1713,30 @@ If SCAN, request a scan of that group as well." (when (and method (not (setq method-type (cdr (assoc method type-cache))))) (setq method-type - (cond - ((gnus-secondary-method-p method) - 'secondary) - ((inline (gnus-server-equal gnus-select-method method)) - 'primary) - (t - 'foreign))) + (cond + ((gnus-secondary-method-p method) + 'secondary) + ((inline (gnus-server-equal gnus-select-method method)) + 'primary) + (t + 'foreign))) (push (cons method method-type) type-cache)) + (setq ignore nil) (cond ((and method (eq method-type 'foreign)) ;; These groups are foreign. Check the level. - (when (and (<= (gnus-info-level info) foreign-level) - (setq active (gnus-activate-group group 'scan))) - ;; Let the Gnus agent save the active file. - (when (and gnus-agent active (gnus-online method)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (unless (inline (gnus-virtual-group-p group)) - (inline (gnus-close-group group))) - (when (fboundp (intern (concat (symbol-name (car method)) - "-request-update-info"))) - (inline (gnus-request-update-info info method))))) + (if (<= (gnus-info-level info) foreign-level) + (when (setq active (gnus-activate-group group 'scan)) + ;; Let the Gnus agent save the active file. + (when (and gnus-agent active (gnus-online method)) + (gnus-agent-save-group-info + method (gnus-group-real-name group) active)) + (unless (inline (gnus-virtual-group-p group)) + (inline (gnus-close-group group))) + (when (fboundp (intern (concat (symbol-name (car method)) + "-request-update-info"))) + (inline (gnus-request-update-info info method)))) + (setq ignore t))) ;; These groups are native or secondary. ((> (gnus-info-level info) level) ;; We don't want these groups. @@ -1764,13 +1775,17 @@ If SCAN, request a scan of that group as well." ((eq active 'ignore) ;; Don't do anything. ) + ((and active ignore) + ;; The level of the foreign group is higher than the specified + ;; value. + ) (active (inline (gnus-get-unread-articles-in-group info active t))) (t ;; The group couldn't be reached, so we nix out the number of ;; unread articles and stuff. (gnus-set-active group nil) - (let ((tmp (gnus-gethash group gnus-newsrc-hashtb))) + (let ((tmp (gnus-group-entry group))) (when tmp (setcar tmp t)))))) @@ -1784,8 +1799,8 @@ If SCAN, request a scan of that group as well." (when (gnus-check-backend-function 'request-scan (car method)) (gnus-request-scan nil method)) (gnus-read-active-file-2 - (mapcar (lambda (group) (gnus-group-real-name group)) groups) - method) + (mapcar (lambda (group) (gnus-group-real-name group)) groups) + method) (dolist (group groups) (cond ((setq active (gnus-active (gnus-info-group @@ -1795,7 +1810,7 @@ If SCAN, request a scan of that group as well." ;; The group couldn't be reached, so we nix out the number of ;; unread articles and stuff. (gnus-set-active group nil) - (setcar (gnus-gethash group gnus-newsrc-hashtb) t))))))) + (setcar (gnus-group-entry group) t))))))) (gnus-message 6 "Checking new news...done"))) @@ -1804,7 +1819,7 @@ If SCAN, request a scan of that group as well." (defun gnus-make-hashtable-from-newsrc-alist () (let ((alist gnus-newsrc-alist) (ohashtb gnus-newsrc-hashtb) - prev) + prev info method rest methods) (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) (setq alist (setq prev (setq gnus-newsrc-alist @@ -1813,14 +1828,26 @@ If SCAN, request a scan of that group as well." gnus-newsrc-alist (cons (list "dummy.group" 0 nil) alist))))) (while alist + (setq info (car alist)) + ;; Make the same select-methods identical Lisp objects. + (when (setq method (gnus-info-method info)) + (if (setq rest (member method methods)) + (gnus-info-set-method info (car rest)) + (push method methods))) (gnus-sethash - (caar alist) + (car info) ;; Preserve number of unread articles in groups. - (cons (and ohashtb (car (gnus-gethash (caar alist) ohashtb))) + (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) prev) gnus-newsrc-hashtb) (setq prev alist - alist (cdr alist))))) + alist (cdr alist))) + ;; Make the same select-methods in `gnus-server-alist' identical + ;; as well. + (while methods + (setq method (pop methods)) + (when (setq rest (rassoc method gnus-server-alist)) + (setcdr rest method))))) (defun gnus-make-hashtable-from-killed () "Create a hash table from the killed and zombie lists." @@ -1847,9 +1874,9 @@ If SCAN, request a scan of that group as well." (defun gnus-make-articles-unread (group articles) "Mark ARTICLES in GROUP as unread." - (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb) - (gnus-gethash (gnus-group-real-name group) - gnus-newsrc-hashtb)))) + (let* ((info (nth 2 (or (gnus-group-entry group) + (gnus-group-entry + (gnus-group-real-name group))))) (ranges (gnus-info-read info)) news article) (while articles @@ -1869,9 +1896,8 @@ If SCAN, request a scan of that group as well." (defun gnus-make-ascending-articles-unread (group articles) "Mark ascending ARTICLES in GROUP as unread." - (let* ((entry (or (gnus-gethash group gnus-newsrc-hashtb) - (gnus-gethash (gnus-group-real-name group) - gnus-newsrc-hashtb))) + (let* ((entry (or (gnus-group-entry group) + (gnus-group-entry (gnus-group-real-name group)))) (info (nth 2 entry)) (ranges (gnus-info-read info)) (r ranges) @@ -1943,7 +1969,7 @@ If SCAN, request a scan of that group as well." (while lists (setq killed (car lists)) (while killed - (gnus-sethash (car killed) nil hashtb) + (gnus-sethash (mm-string-as-unibyte (car killed)) nil hashtb) (setq killed (cdr killed))) (setq lists (cdr lists))))) @@ -2120,7 +2146,7 @@ If SCAN, request a scan of that group as well." (while (not (eobp)) (condition-case () (progn - (narrow-to-region (point) (gnus-point-at-eol)) + (narrow-to-region (point) (point-at-eol)) ;; group gets set to a symbol interned in the hash table ;; (what a hack!!) - jwz (setq group (let ((obarray hashtb)) (read cur))) @@ -2152,7 +2178,7 @@ If SCAN, request a scan of that group as well." (unless ignore-errors (gnus-message 3 "Warning - invalid active: %s" (buffer-substring - (gnus-point-at-bol) (gnus-point-at-eol)))))) + (point-at-bol) (point-at-eol)))))) (widen) (forward-line 1))))) @@ -2388,6 +2414,8 @@ If FORCE is non-nil, the .newsrc file is read." (setq gnus-format-specs gnus-default-format-specs))) (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) + (dolist (elem gnus-newsrc-alist) + (setcar elem (mm-string-as-unibyte (car elem)))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file @@ -2503,10 +2531,10 @@ If FORCE is non-nil, the .newsrc file is read." ;; don't give a damn, frankly, my dear. (concat gnus-newsrc-options (buffer-substring - (gnus-point-at-bol) + (point-at-bol) ;; Options may continue on the next line. (or (and (re-search-forward "^[^ \t]" nil 'move) - (progn (beginning-of-line) (point))) + (point-at-bol)) (point))))) (forward-line -1)) (symbol @@ -2574,8 +2602,8 @@ If FORCE is non-nil, the .newsrc file is read." ;; The line was buggy. (setq group nil) (gnus-error 3.1 "Mangled line: %s" - (buffer-substring (gnus-point-at-bol) - (gnus-point-at-eol)))) + (buffer-substring (point-at-bol) + (point-at-eol)))) nil)) ;; Skip past ", ". Spaces are invalid in these ranges, but ;; we allow them, because it's a common mistake to put a @@ -2684,9 +2712,9 @@ If FORCE is non-nil, the .newsrc file is read." (while (re-search-forward "[ \t]-n" nil t) (setq eol (or (save-excursion - (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t) + (and (re-search-forward "[ \t]-n" (point-at-eol) t) (- (point) 2))) - (gnus-point-at-eol))) + (point-at-eol))) ;; Search for all "words"... (while (re-search-forward "[^ \t,\n]+" eol t) (if (eq (char-after (match-beginning 0)) ?!) @@ -2794,7 +2822,7 @@ If FORCE is non-nil, the .newsrc file is read." ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (set-file-modes startup-file setmodes))) + (gnus-set-file-modes startup-file setmodes))) (condition-case nil (delete-file working-file) (file-error nil))))) @@ -2847,7 +2875,7 @@ If FORCE is non-nil, the .newsrc file is read." (while variables (when (and (boundp (setq variable (pop variables))) (symbol-value variable)) - (princ "(setq ") + (princ "\n(setq ") (princ (symbol-name variable)) (princ " '") (prin1 (symbol-value variable)) @@ -2874,6 +2902,10 @@ If FORCE is non-nil, the .newsrc file is read." (setq default-directory (file-name-directory buffer-file-name)) (buffer-disable-undo) (erase-buffer) + ;; Use a unibyte buffer since group names are unibyte strings; + ;; in particular, non-ASCII group names are the ones encoded by + ;; a certain coding system. + (mm-disable-multibyte) ;; Write options. (when gnus-newsrc-options (insert gnus-newsrc-options)) @@ -2916,7 +2948,8 @@ If FORCE is non-nil, the .newsrc file is read." (delete-file gnus-startup-file) (clear-visited-file-modtime)) (gnus-run-hooks 'gnus-save-standard-newsrc-hook) - (save-buffer) + (let ((coding-system-for-write 'raw-text)) + (save-buffer)) (kill-buffer (current-buffer))))) @@ -2928,7 +2961,7 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-slave-mode () "Minor mode for slave Gnusae." - (gnus-add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) + (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) (gnus-run-hooks 'gnus-slave-mode-hook)) (defun gnus-slave-save-newsrc () @@ -2941,7 +2974,7 @@ If FORCE is non-nil, the .newsrc file is read." (let ((coding-system-for-write gnus-ding-file-coding-system)) (gnus-write-buffer slave-name)) (when modes - (set-file-modes slave-name modes))))) + (gnus-set-file-modes slave-name modes))))) (defun gnus-master-read-slave-newsrc () (let ((slave-files @@ -3119,6 +3152,41 @@ If this variable is nil, don't do anything." (symbol-value 'nnimap-mailbox-info) (make-vector 1 0))))) +(defun gnus-check-reasonable-setup () + ;; Check whether nnml and nnfolder share a directory. + (let ((display-warn + (if (fboundp 'display-warning) + 'display-warning + (lambda (type message) + (if noninteractive + (message "Warning (%s): %s" type message) + (let (window) + (with-current-buffer (get-buffer-create "*Warnings*") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert (format "Warning (%s): %s\n" type message)) + (setq window (display-buffer (current-buffer))) + (set-window-start + window + (prog2 + (forward-line (- 1 (window-height window))) + (point) + (goto-char (point-max)))))))))) + method active actives match) + (dolist (server gnus-server-alist) + (setq method (gnus-server-to-method server) + active (intern (format "%s-active-file" (car method)))) + (when (and (member (car method) '(nnml nnfolder)) + (gnus-server-opened method) + (boundp active)) + (when (setq match (assoc (symbol-value active) actives)) + (funcall display-warn 'gnus-server + (format "%s and %s share the same active file %s" + (car method) + (cadr match) + (car match)))) + (push (list (symbol-value active) method) actives))))) (provide 'gnus-start) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 8fb18d3a990..bc5ed9f0fb5 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -62,19 +62,31 @@ it will be killed sometime later." :group 'gnus-summary-exit :type 'boolean) +(defcustom gnus-summary-next-group-on-exit t + "If non-nil, go to the next unread newsgroup on summary exit. +See `gnus-group-goto-unread'." + :link '(custom-manual "(gnus)Group Maneuvering") + :group 'gnus-summary-exit + :version "23.0" ;; No Gnus + :type 'boolean) + (defcustom gnus-fetch-old-headers nil "*Non-nil means that Gnus will try to build threads by grabbing old headers. -If an unread article in the group refers to an older, already read (or -just marked as read) article, the old article will not normally be -displayed in the Summary buffer. If this variable is t, Gnus -will attempt to grab the headers to the old articles, and thereby -build complete threads. If it has the value `some', only enough -headers to connect otherwise loose threads will be displayed. This -variable can also be a number. In that case, no more than that number -of old headers will be fetched. If it has the value `invisible', all +If an unread article in the group refers to an older, already +read (or just marked as read) article, the old article will not +normally be displayed in the Summary buffer. If this variable is +t, Gnus will attempt to grab the headers to the old articles, and +thereby build complete threads. If it has the value `some', all +old headers will be fetched but only enough headers to connect +otherwise loose threads will be displayed. This variable can +also be a number. In that case, no more than that number of old +headers will be fetched. If it has the value `invisible', all old headers will be fetched, but none will be displayed. -The server has to support NOV for any of this to work." +The server has to support NOV for any of this to work. + +This feature can seriously impact performance it ignores all +locally cached header entries." :group 'gnus-thread :type '(choice (const :tag "off" nil) (const :tag "on" t) @@ -83,7 +95,7 @@ The server has to support NOV for any of this to work." number (sexp :menu-tag "other" t))) -(defcustom gnus-refer-thread-limit 200 +(defcustom gnus-refer-thread-limit 500 "*The number of old headers to fetch when doing \\<gnus-summary-mode-map>\\[gnus-summary-refer-thread]. If t, fetch all the available old headers." :group 'gnus-thread @@ -366,6 +378,28 @@ the first unread article." :group 'gnus-summary-maneuvering :type 'boolean) +(defcustom gnus-auto-select-on-ephemeral-exit 'next-noselect + "What article should be selected after exiting an ephemeral group. +Valid values include: + +`next' + Select the next article. +`next-unread' + Select the next unread article. +`next-noselect' + Move the cursor to the next article. This is the default. +`next-unread-noselect' + Move the cursor to the next unread article. + +If it has any other value or there is no next (unread) article, the +article selected before entering to the ephemeral group will appear." + :version "23.0" ;; No Gnus + :group 'gnus-summary-maneuvering + :type '(choice :format "%{%t%}:\n %[Value Menu%] %v" + (const next) (const next-unread) + (const next-noselect) (const next-unread-noselect) + (sexp :tag "other" :value nil))) + (defcustom gnus-auto-goto-ignores 'unfetched "*Says how to handle unfetched articles when maneuvering. @@ -391,7 +425,7 @@ current article is unread." :group 'gnus-summary-maneuvering :type 'boolean) -(defcustom gnus-auto-center-summary t +(defcustom gnus-auto-center-summary 2 "*If non-nil, always center the current summary buffer. In particular, if `vertical' do only vertical recentering. If non-nil and non-`vertical', do both horizontal and vertical recentering." @@ -438,6 +472,13 @@ this variable specifies group names." (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) +(defcustom gnus-move-group-prefix-function 'gnus-group-real-prefix + "Function used to compute default prefix for article move/copy/etc prompts. +The function should take one argument, a group name, and return a +string with the suggested prefix." + :group 'gnus-summary-mail + :type 'function) + ;; FIXME: Although the custom type is `character' for the following variables, ;; using multibyte characters (Latin-1, UTF-8) doesn't work. -- rs @@ -697,6 +738,40 @@ score file." :group 'gnus-score-default :type 'integer) +(defun gnus-widget-reversible-match (widget value) + "Ignoring WIDGET, convert VALUE to internal form. +VALUE should have the form `FOO' or `(not FOO)', where FOO is an symbol." + ;; (debug value) + (or (symbolp value) + (and (listp value) + (eq (length value) 2) + (eq (nth 0 value) 'not) + (symbolp (nth 1 value))))) + +(defun gnus-widget-reversible-to-internal (widget value) + "Ignoring WIDGET, convert VALUE to internal form. +VALUE should have the form `FOO' or `(not FOO)', where FOO is an atom. +FOO is converted to (FOO nil) and (not FOO) is converted to (FOO t)." + ;; (debug value) + (if (atom value) + (list value nil) + (list (nth 1 value) t))) + +(defun gnus-widget-reversible-to-external (widget value) + "Ignoring WIDGET, convert VALUE to external form. +VALUE should have the form `(FOO nil)' or `(FOO t)', where FOO is an atom. +\(FOO nil) is converted to FOO and (FOO t) is converted to (not FOO)." + ;; (debug value) + (if (nth 1 value) + (list 'not (nth 0 value)) + (nth 0 value))) + +(define-widget 'gnus-widget-reversible 'group + "A `group' that convert values." + :match 'gnus-widget-reversible-match + :value-to-internal 'gnus-widget-reversible-to-internal + :value-to-external 'gnus-widget-reversible-to-external) + (defcustom gnus-article-sort-functions '(gnus-article-sort-by-number) "*List of functions used for sorting articles in the summary buffer. @@ -709,6 +784,9 @@ is often much slower than sorting by number, and the sorting order is very similar. (Sorting by date means sorting by the time the message was sent, sorting by number means sorting by arrival time.) +Each item can also be a list `(not F)' where F is a function; +this reverses the sort order. + Ready-made functions include `gnus-article-sort-by-number', `gnus-article-sort-by-author', `gnus-article-sort-by-subject', `gnus-article-sort-by-date', `gnus-article-sort-by-random' @@ -717,13 +795,16 @@ and `gnus-article-sort-by-score'. When threading is turned on, the variable `gnus-thread-sort-functions' controls how articles are sorted." :group 'gnus-summary-sort - :type '(repeat (choice (function-item gnus-article-sort-by-number) - (function-item gnus-article-sort-by-author) - (function-item gnus-article-sort-by-subject) - (function-item gnus-article-sort-by-date) - (function-item gnus-article-sort-by-score) - (function-item gnus-article-sort-by-random) - (function :tag "other")))) + :type '(repeat (gnus-widget-reversible + (choice (function-item gnus-article-sort-by-number) + (function-item gnus-article-sort-by-author) + (function-item gnus-article-sort-by-subject) + (function-item gnus-article-sort-by-date) + (function-item gnus-article-sort-by-score) + (function-item gnus-article-sort-by-random) + (function :tag "other")) + (boolean :tag "Reverse order")))) + (defcustom gnus-thread-sort-functions '(gnus-thread-sort-by-number) "*List of functions used for sorting threads in the summary buffer. @@ -738,25 +819,34 @@ is often much slower than sorting by number, and the sorting order is very similar. (Sorting by date means sorting by the time the message was sent, sorting by number means sorting by arrival time.) +Each list item can also be a list `(not F)' where F is a +function; this specifies reversed sort order. + Ready-made functions include `gnus-thread-sort-by-number', -`gnus-thread-sort-by-author', `gnus-thread-sort-by-subject', -`gnus-thread-sort-by-date', `gnus-thread-sort-by-score', -`gnus-thread-sort-by-most-recent-number', -`gnus-thread-sort-by-most-recent-date', -`gnus-thread-sort-by-random', and -`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function'). +`gnus-thread-sort-by-author', `gnus-thread-sort-by-recipient' +`gnus-thread-sort-by-subject', `gnus-thread-sort-by-date', +`gnus-thread-sort-by-score', `gnus-thread-sort-by-most-recent-number', +`gnus-thread-sort-by-most-recent-date', `gnus-thread-sort-by-random', +and `gnus-thread-sort-by-total-score' (see +`gnus-thread-score-function'). When threading is turned off, the variable `gnus-article-sort-functions' controls how articles are sorted." :group 'gnus-summary-sort - :type '(repeat (choice (function-item gnus-thread-sort-by-number) - (function-item gnus-thread-sort-by-author) - (function-item gnus-thread-sort-by-subject) - (function-item gnus-thread-sort-by-date) - (function-item gnus-thread-sort-by-score) - (function-item gnus-thread-sort-by-total-score) - (function-item gnus-thread-sort-by-random) - (function :tag "other")))) + :type '(repeat + (gnus-widget-reversible + (choice (function-item gnus-thread-sort-by-number) + (function-item gnus-thread-sort-by-author) + (function-item gnus-thread-sort-by-recipient) + (function-item gnus-thread-sort-by-subject) + (function-item gnus-thread-sort-by-date) + (function-item gnus-thread-sort-by-score) + (function-item gnus-thread-sort-by-most-recent-number) + (function-item gnus-thread-sort-by-most-recent-date) + (function-item gnus-thread-sort-by-random) + (function-item gnus-thread-sort-by-total-score) + (function :tag "other")) + (boolean :tag "Reverse order")))) (defcustom gnus-thread-score-function '+ "*Function used for calculating the total score of a thread. @@ -990,6 +1080,7 @@ uncached: Non-nil if the article is uncached." :group 'gnus-summary-visual :type '(repeat (cons (sexp :tag "Form" nil) face))) +(put 'gnus-summary-highlight 'risky-local-variable t) (defcustom gnus-alter-header-function nil "Function called to allow alteration of article header structures. @@ -1016,10 +1107,29 @@ which it may alter in any way." (and user-mail-address (not (string= user-mail-address "")) (regexp-quote user-mail-address)) - "*Regexp of From headers that may be suppressed in favor of To headers." + "*From headers that may be suppressed in favor of To headers. +This can be a regexp or a list of regexps." :version "21.1" :group 'gnus-summary - :type 'regexp) + :type '(choice regexp + (repeat :tag "Regexp List" regexp))) + +(defsubst gnus-ignored-from-addresses () + (gmm-regexp-concat gnus-ignored-from-addresses)) + +(defcustom gnus-summary-to-prefix "-> " + "*String prefixed to the To field in the summary line when +using `gnus-ignored-from-addresses'." + :version "22.1" + :group 'gnus-summary + :type 'string) + +(defcustom gnus-summary-newsgroup-prefix "=> " + "*String prefixed to the Newsgroup field in the summary +line when using `gnus-ignored-from-addresses'." + :version "22.1" + :group 'gnus-summary + :type 'string) (defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit x-unknown) "List of charsets that should be ignored. @@ -1127,12 +1237,12 @@ that were fetched. Say, for nnultimate groups." :group 'gnus-summary :type 'string) -(defcustom gnus-article-loose-mime nil +(defcustom gnus-article-loose-mime t "If non-nil, don't require MIME-Version header. Some brain-damaged MUA/MTA, e.g. Lotus Domino 5.0.6 clients, does not supply the MIME-Version header or deliberately strip it from the mail. -Set it to non-nil, Gnus will treat some articles as MIME even if -the MIME-Version header is missed." +If non-nil (the default), Gnus will treat some articles as MIME +even if the MIME-Version header is missing." :version "22.1" :type 'boolean :group 'gnus-article-mime) @@ -1214,7 +1324,6 @@ the normal Gnus MIME machinery." (?\< (make-string (max 0 (- 20 gnus-tmp-level)) ? ) ?s) (?i gnus-tmp-score ?d) (?z gnus-tmp-score-char ?c) - (?l (bbb-grouplens-score gnus-tmp-header) ?s) (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) (?U gnus-tmp-unread ?c) (?f (gnus-summary-from-or-to-or-newsgroups gnus-tmp-header gnus-tmp-from) @@ -1463,7 +1572,6 @@ For example: nil (load "gnus-sum.el" t t t)) (require 'gnus) - (require 'gnus-agent) (require 'gnus-art))) ;; MIME stuff. @@ -1490,19 +1598,15 @@ For example: (eq gnus-newsgroup-name (car gnus-decode-encoded-word-methods-cache))) (setq gnus-decode-encoded-word-methods-cache (list gnus-newsgroup-name)) - (mapcar (lambda (x) - (if (symbolp x) - (nconc gnus-decode-encoded-word-methods-cache (list x)) - (if (and gnus-newsgroup-name - (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-encoded-word-methods-cache - (list (cdr x)))))) - gnus-decode-encoded-word-methods)) - (let ((xlist gnus-decode-encoded-word-methods-cache)) - (pop xlist) - (while xlist - (setq string (funcall (pop xlist) string)))) - string) + (dolist (method gnus-decode-encoded-word-methods) + (if (symbolp method) + (nconc gnus-decode-encoded-word-methods-cache (list method)) + (if (and gnus-newsgroup-name + (string-match (car method) gnus-newsgroup-name)) + (nconc gnus-decode-encoded-word-methods-cache + (list (cdr method))))))) + (dolist (method (cdr gnus-decode-encoded-word-methods-cache) string) + (setq string (funcall method string)))) ;; Subject simplification. @@ -1574,8 +1678,8 @@ matter is removed. Additional things can be deleted by setting (setq modified-tick (buffer-modified-tick)) (cond ((listp gnus-simplify-subject-fuzzy-regexp) - (mapcar 'gnus-simplify-buffer-fuzzy-step - gnus-simplify-subject-fuzzy-regexp)) + (mapc 'gnus-simplify-buffer-fuzzy-step + gnus-simplify-subject-fuzzy-regexp)) (gnus-simplify-subject-fuzzy-regexp (gnus-simplify-buffer-fuzzy-step gnus-simplify-subject-fuzzy-regexp))) (gnus-simplify-buffer-fuzzy-step "^ *\\[[-+?*!][-+?*!]\\] *") @@ -1612,8 +1716,8 @@ See `gnus-simplify-buffer-fuzzy' for details." ((eq gnus-summary-gather-subject-limit 'fuzzy) (gnus-simplify-subject-fuzzy subject)) ((numberp gnus-summary-gather-subject-limit) - (gnus-limit-string (gnus-simplify-subject-re subject) - gnus-summary-gather-subject-limit)) + (truncate-string-to-width (gnus-simplify-subject-re subject) + gnus-summary-gather-subject-limit)) (t subject))) @@ -1665,6 +1769,8 @@ increase the score of each group you read." "," gnus-summary-best-unread-article "\M-s" gnus-summary-search-article-forward "\M-r" gnus-summary-search-article-backward + "\M-S" gnus-summary-repeat-search-article-forward + "\M-R" gnus-summary-repeat-search-article-backward "<" gnus-summary-beginning-of-article ">" gnus-summary-end-of-article "j" gnus-summary-goto-article @@ -1704,6 +1810,7 @@ increase the score of each group you read." "\C-c\C-s\C-l" gnus-summary-sort-by-lines "\C-c\C-s\C-c" gnus-summary-sort-by-chars "\C-c\C-s\C-a" gnus-summary-sort-by-author + "\C-c\C-s\C-t" gnus-summary-sort-by-recipient "\C-c\C-s\C-s" gnus-summary-sort-by-subject "\C-c\C-s\C-d" gnus-summary-sort-by-date "\C-c\C-s\C-i" gnus-summary-sort-by-score @@ -1795,6 +1902,8 @@ increase the score of each group you read." (gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) "/" gnus-summary-limit-to-subject "n" gnus-summary-limit-to-articles + "b" gnus-summary-limit-to-bodies + "h" gnus-summary-limit-to-headers "w" gnus-summary-pop-limit "s" gnus-summary-limit-to-subject "a" gnus-summary-limit-to-author @@ -1814,7 +1923,11 @@ increase the score of each group you read." "c" gnus-summary-limit-exclude-childless-dormant "C" gnus-summary-limit-mark-excluded-as-read "o" gnus-summary-insert-old-articles - "N" gnus-summary-insert-new-articles) + "N" gnus-summary-insert-new-articles + "S" gnus-summary-limit-to-singletons + "r" gnus-summary-limit-to-replied + "R" gnus-summary-limit-to-recipient + "A" gnus-summary-limit-to-address) (gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) "n" gnus-summary-next-unread-article @@ -1834,11 +1947,13 @@ increase the score of each group you read." (gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) "k" gnus-summary-kill-thread + "E" gnus-summary-expire-thread "l" gnus-summary-lower-thread "i" gnus-summary-raise-thread "T" gnus-summary-toggle-threads "t" gnus-summary-rethread-current "^" gnus-summary-reparent-thread + "\M-^" gnus-summary-reparent-children "s" gnus-summary-show-thread "S" gnus-summary-show-all-threads "h" gnus-summary-hide-thread @@ -1854,7 +1969,8 @@ increase the score of each group you read." (gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) "g" gnus-summary-prepare "c" gnus-summary-insert-cached-articles - "d" gnus-summary-insert-dormant-articles) + "d" gnus-summary-insert-dormant-articles + "t" gnus-summary-insert-ticked-articles) (gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) "c" gnus-summary-catchup-and-exit @@ -1863,6 +1979,7 @@ increase the score of each group you read." "Q" gnus-summary-exit "Z" gnus-summary-exit "n" gnus-summary-catchup-and-goto-next-group + "p" gnus-summary-catchup-and-goto-prev-group "R" gnus-summary-reselect-current-group "G" gnus-summary-rescan-group "N" gnus-summary-next-group @@ -1889,6 +2006,7 @@ increase the score of each group you read." "g" gnus-summary-show-article "s" gnus-summary-isearch-article "P" gnus-summary-print-article + "S" gnus-sticky-article "M" gnus-mailing-list-insinuate "t" gnus-article-babel) @@ -1899,11 +2017,13 @@ increase the score of each group you read." "e" gnus-article-emphasize "w" gnus-article-fill-cited-article "Q" gnus-article-fill-long-lines + "L" gnus-article-toggle-truncate-lines "C" gnus-article-capitalize-sentences "c" gnus-article-remove-cr "q" gnus-article-de-quoted-unreadable "6" gnus-article-de-base64-unreadable "Z" gnus-article-decode-HZ + "A" gnus-article-treat-ansi-sequences "h" gnus-article-wash-html "u" gnus-article-unsplit-urls "s" gnus-summary-force-verify-and-decrypt @@ -1916,7 +2036,8 @@ increase the score of each group you read." "v" gnus-summary-verbose-headers "a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive "p" gnus-article-verify-x-pgp-sig - "d" gnus-article-treat-dumbquotes) + "d" gnus-article-treat-dumbquotes + "i" gnus-summary-idna-message) (gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map) ;; mnemonic: deuglif*Y* @@ -2028,9 +2149,15 @@ increase the score of each group you read." "m" gnus-summary-repair-multipart "v" gnus-article-view-part "o" gnus-article-save-part + "O" gnus-article-save-part-and-strip + "r" gnus-article-replace-part + "d" gnus-article-delete-part + "t" gnus-article-view-part-as-type + "j" gnus-article-jump-to-part "c" gnus-article-copy-part "C" gnus-article-view-part-as-charset "e" gnus-article-view-part-externally + "H" gnus-article-browse-html-article "E" gnus-article-encrypt-body "i" gnus-article-inline-part "|" gnus-article-pipe-part) @@ -2174,11 +2301,13 @@ increase the score of each group you read." ["Repair multipart" gnus-summary-repair-multipart t] ["Pipe part..." gnus-article-pipe-part t] ["Inline part" gnus-article-inline-part t] + ["View part as type..." gnus-article-view-part-as-type t] ["Encrypt body" gnus-article-encrypt-body :active (not (gnus-group-read-only-p)) ,@(if (featurep 'xemacs) nil '(:help "Encrypt the message body on disk"))] ["View part externally" gnus-article-view-part-externally t] + ["View HTML parts in browser" gnus-article-browse-html-article t] ["View part with charset..." gnus-article-view-part-as-charset t] ["Copy part" gnus-article-copy-part t] ["Save part..." gnus-article-save-part t] @@ -2233,6 +2362,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Emphasis" gnus-article-emphasize t] ["Word wrap" gnus-article-fill-cited-article t] ["Fill long lines" gnus-article-fill-long-lines t] + ["Toggle truncate long lines" gnus-article-toggle-truncate-lines t] ["Capitalize sentences" gnus-article-capitalize-sentences t] ["Remove CR" gnus-article-remove-cr t] ["Quoted-Printable" gnus-article-de-quoted-unreadable t] @@ -2240,6 +2370,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Rot 13" gnus-summary-caesar-message ,@(if (featurep 'xemacs) '(t) '(:help "\"Caesar rotate\" article by 13"))] + ["De-IDNA" gnus-summary-idna-message t] ["Morse decode" gnus-summary-morse-message t] ["Unix pipe..." gnus-summary-pipe-message t] ["Add buttons" gnus-article-add-buttons t] @@ -2253,6 +2384,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Unsplit URLs" gnus-article-unsplit-urls t] ["Verify X-PGP-Sig" gnus-article-verify-x-pgp-sig t] ["Decode HZ" gnus-article-decode-HZ t] + ["ANSI sequences" gnus-article-treat-ansi-sequences t] ("(Outlook) Deuglify" ["Unwrap lines" gnus-article-outlook-unwrap-lines t] ["Repair attribution" gnus-article-outlook-repair-attribution t] @@ -2322,6 +2454,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Remove article" gnus-cache-remove-article t]) ["Translate" gnus-article-babel t] ["Select article buffer" gnus-summary-select-article-buffer t] + ["Make article buffer sticky" gnus-sticky-article t] ["Enter digest buffer" gnus-summary-enter-digest-group t] ["Isearch article..." gnus-summary-isearch-article t] ["Beginning of the article" gnus-summary-beginning-of-article t] @@ -2362,6 +2495,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Go up thread" gnus-summary-up-thread t] ["Top of thread" gnus-summary-top-thread t] ["Mark thread as read" gnus-summary-kill-thread t] + ["Mark thread as expired" gnus-summary-expire-thread t] ["Lower thread score" gnus-summary-lower-thread t] ["Raise thread score" gnus-summary-raise-thread t] ["Rethread current" gnus-summary-rethread-current t])) @@ -2450,12 +2584,16 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Marks..." gnus-summary-limit-to-marks t] ["Subject..." gnus-summary-limit-to-subject t] ["Author..." gnus-summary-limit-to-author t] + ["Recipient..." gnus-summary-limit-to-recipient t] + ["Address..." gnus-summary-limit-to-address t] ["Age..." gnus-summary-limit-to-age t] ["Extra..." gnus-summary-limit-to-extra t] ["Score..." gnus-summary-limit-to-score t] ["Display Predicate" gnus-summary-limit-to-display-predicate t] ["Unread" gnus-summary-limit-to-unread t] ["Unseen" gnus-summary-limit-to-unseen t] + ["Singletons" gnus-summary-limit-to-singletons t] + ["Replied" gnus-summary-limit-to-replied t] ["Non-dormant" gnus-summary-limit-exclude-dormant t] ["Next or process marked articles" gnus-summary-limit-to-articles t] ["Pop limit" gnus-summary-pop-limit t] @@ -2469,6 +2607,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Set mark" gnus-summary-mark-as-processable t] ["Remove mark" gnus-summary-unmark-as-processable t] ["Remove all marks" gnus-summary-unmark-all-processable t] + ["Invert marks" gnus-uu-invert-processable t] ["Mark above" gnus-uu-mark-over t] ["Mark series" gnus-uu-mark-series t] ["Mark region" gnus-uu-mark-region (gnus-mark-active-p)] @@ -2512,6 +2651,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ("Sort" ["Sort by number" gnus-summary-sort-by-number t] ["Sort by author" gnus-summary-sort-by-author t] + ["Sort by recipient" gnus-summary-sort-by-recipient t] ["Sort by subject" gnus-summary-sort-by-subject t] ["Sort by date" gnus-summary-sort-by-date t] ["Sort by score" gnus-summary-sort-by-score t] @@ -2536,6 +2676,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Regenerate" gnus-summary-prepare t] ["Insert cached articles" gnus-summary-insert-cached-articles t] ["Insert dormant articles" gnus-summary-insert-dormant-articles t] + ["Insert ticked articles" gnus-summary-insert-ticked-articles t] ["Toggle threading" gnus-summary-toggle-threads t]) ["See old articles" gnus-summary-insert-old-articles t] ["See new articles" gnus-summary-insert-new-articles t] @@ -2559,6 +2700,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) '(:help "Mark unread articles in this group as read, then exit"))] ["Catchup all and exit" gnus-summary-catchup-all-and-exit t] ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] + ["Catchup and goto prev" gnus-summary-catchup-and-goto-prev-group t] ["Exit group" gnus-summary-exit ,@(if (featurep 'xemacs) '(t) '(:help "Exit current group, return to group selection mode"))] @@ -2602,7 +2744,7 @@ Pre-defined symbols include `gnus-summary-tool-bar-gnome' and (const :tag "Retro look" gnus-summary-tool-bar-retro) (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-summary-tool-bar-update :group 'gnus-summary) @@ -2653,7 +2795,7 @@ Pre-defined symbols include `gnus-summary-tool-bar-gnome' and See `gmm-tool-bar-from-list' for the format of the list." :type '(repeat gmm-tool-bar-item) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-summary-tool-bar-update :group 'gnus-summary) @@ -2688,7 +2830,7 @@ See `gmm-tool-bar-from-list' for the format of the list." See `gmm-tool-bar-from-list' for the format of the list." :type '(repeat gmm-tool-bar-item) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-summary-tool-bar-update :group 'gnus-summary) @@ -2699,7 +2841,7 @@ These items are not displayed in the Gnus summary mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-summary-tool-bar-update :group 'gnus-summary) @@ -2838,12 +2980,13 @@ The following commands are available: \\{gnus-summary-mode-map}" (interactive) (kill-all-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-make-local-variables)) + (gnus-summary-make-local-variables) + (setq gnus-newsgroup-name group) (when (gnus-visual-p 'summary-menu 'menu) (gnus-summary-make-menu-bar) (gnus-summary-make-tool-bar)) - (gnus-summary-make-local-variables) - (let ((gnus-summary-local-variables gnus-newsgroup-variables)) - (gnus-summary-make-local-variables)) (gnus-make-thread-indent-array) (gnus-simplify-mode-line) (setq major-mode 'gnus-summary-mode) @@ -2851,13 +2994,13 @@ The following commands are available: (make-local-variable 'minor-mode-alist) (use-local-map gnus-summary-mode-map) (buffer-disable-undo) - (setq buffer-read-only t) ;Disable modification + (setq buffer-read-only t ;Disable modification + show-trailing-whitespace nil) (setq truncate-lines t) (setq selective-display t) (setq selective-display-ellipses t) ;Display `...' (gnus-summary-set-display-table) (gnus-set-default-directory) - (setq gnus-newsgroup-name group) (make-local-variable 'gnus-summary-line-format) (make-local-variable 'gnus-summary-line-format-spec) (make-local-variable 'gnus-summary-dummy-line-format) @@ -2890,9 +3033,9 @@ The following commands are available: (let ((locals gnus-summary-local-variables)) (while locals (if (consp (car locals)) - (and (vectorp (caar locals)) + (and (symbolp (caar locals)) (set (caar locals) nil)) - (and (vectorp (car locals)) + (and (symbolp (car locals)) (set (car locals) nil))) (setq locals (cdr locals))))) @@ -2964,10 +3107,9 @@ The following commands are available: (setq gnus-newsgroup-data (nconc list gnus-newsgroup-data)) (when offset (gnus-data-update-list odata offset))) - ;; Find the last element in the list to be spliced into the main + ;; Find the last element in the list to be spliced into the main ;; list. - (while (cdr list) - (setq list (cdr list))) + (setq list (last list)) (if (not data) (progn (setcdr list gnus-newsgroup-data) @@ -3283,10 +3425,11 @@ display only a single character." (gnus-summary-mode group) (when gnus-carpal (gnus-carpal-setup-buffer 'summary)) - (unless gnus-single-article-buffer - (make-local-variable 'gnus-article-buffer) - (make-local-variable 'gnus-article-current) - (make-local-variable 'gnus-original-article-buffer)) + (when (gnus-group-quit-config group) + (set (make-local-variable 'gnus-single-article-buffer) nil)) + (make-local-variable 'gnus-article-buffer) + (make-local-variable 'gnus-article-current) + (make-local-variable 'gnus-original-article-buffer) (setq gnus-newsgroup-name group) ;; Set any local variables in the group parameters. (gnus-summary-set-local-parameters gnus-newsgroup-name) @@ -3319,8 +3462,7 @@ buffer that was in action when the last article was fetched." (push (eval (car locals)) vlist)) (setq locals (cdr locals))) (setq vlist (nreverse vlist))) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq gnus-newsgroup-name name gnus-newsgroup-marked marked gnus-newsgroup-spam-marked spam @@ -3444,25 +3586,33 @@ buffer that was in action when the last article was fetched." (defun gnus-summary-from-or-to-or-newsgroups (header gnus-tmp-from) (let ((mail-parse-charset gnus-newsgroup-charset) + (ignored-from-addresses (gnus-ignored-from-addresses)) ; Is it really necessary to do this next part for each summary line? ; Luckily, doesn't seem to slow things down much. (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (or - (and gnus-ignored-from-addresses - (string-match gnus-ignored-from-addresses gnus-tmp-from) + (and ignored-from-addresses + (string-match ignored-from-addresses gnus-tmp-from) (let ((extra-headers (mail-header-extra header)) to newsgroups) (cond ((setq to (cdr (assq 'To extra-headers))) - (concat "-> " + (concat gnus-summary-to-prefix (inline (gnus-summary-extract-address-component (funcall gnus-decode-encoded-address-function to))))) - ((setq newsgroups (cdr (assq 'Newsgroups extra-headers))) - (concat "=> " newsgroups))))) + ((setq newsgroups + (or + (cdr (assq 'Newsgroups extra-headers)) + (and + (memq 'Newsgroups gnus-extra-headers) + (eq (car (gnus-find-method-for-group + gnus-newsgroup-name)) 'nntp) + (gnus-group-real-name gnus-newsgroup-name)))) + (concat gnus-summary-newsgroup-prefix newsgroups))))) (inline (gnus-summary-extract-address-component gnus-tmp-from))))) (defun gnus-summary-insert-line (gnus-tmp-header @@ -3613,12 +3763,8 @@ This function is intended to be used in (defun gnus-summary-set-local-parameters (group) "Go through the local params of GROUP and set all variable specs in that list." - (let ((params (gnus-group-find-parameter group)) - (vars '(quit-config)) ; Ignore quit-config. - elem) - (while params - (setq elem (car params) - params (cdr params)) + (let ((vars '(quit-config))) ; Ignore quit-config. + (dolist (elem (gnus-group-find-parameter group)) (and (consp elem) ; Has to be a cons. (consp (cdr elem)) ; The cdr has to be a list. (symbolp (car elem)) ; Has to be a symbol in there. @@ -4140,21 +4286,19 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (erase-buffer))) (kill-buffer (current-buffer))) ;; Sort over trustworthiness. - (mapcar - (lambda (relation) - (when (gnus-dependencies-add-header - (make-full-mail-header - gnus-reffed-article-number - (nth 3 relation) "" (or (nth 4 relation) "") - (nth 1 relation) - (or (nth 2 relation) "") 0 0 "") - gnus-newsgroup-dependencies nil) - (push gnus-reffed-article-number gnus-newsgroup-limit) - (push gnus-reffed-article-number gnus-newsgroup-sparse) - (push (cons gnus-reffed-article-number gnus-sparse-mark) - gnus-newsgroup-reads) - (decf gnus-reffed-article-number))) - (sort relations 'car-less-than-car)) + (dolist (relation (sort relations 'car-less-than-car)) + (when (gnus-dependencies-add-header + (make-full-mail-header + gnus-reffed-article-number + (nth 3 relation) "" (or (nth 4 relation) "") + (nth 1 relation) + (or (nth 2 relation) "") 0 0 "") + gnus-newsgroup-dependencies nil) + (push gnus-reffed-article-number gnus-newsgroup-limit) + (push gnus-reffed-article-number gnus-newsgroup-sparse) + (push (cons gnus-reffed-article-number gnus-sparse-mark) + gnus-newsgroup-reads) + (decf gnus-reffed-article-number))) (gnus-message 7 "Making sparse threads...done"))) (defun gnus-build-old-threads () @@ -4182,13 +4326,12 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." "Translate STRING into something that doesn't contain weird characters." (mm-subst-char-in-string ?\r ?\- - (mm-subst-char-in-string - ?\n ?\- string))) + (mm-subst-char-in-string ?\n ?\- string t) t)) ;; This function has to be called with point after the article number ;; on the beginning of the line. (defsubst gnus-nov-parse-line (number dependencies &optional force-new) - (let ((eol (gnus-point-at-eol)) + (let ((eol (point-at-eol)) (buffer (current-buffer)) header references in-reply-to) @@ -4213,7 +4356,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (setq x (nnheader-nov-field)))) (error x)) (nnheader-nov-field) ; date - (nnheader-nov-read-message-id) ; id + (nnheader-nov-read-message-id number) ; id (setq references (nnheader-nov-field)) ; refs (nnheader-nov-read-integer) ; chars (nnheader-nov-read-integer) ; lines @@ -4287,8 +4430,7 @@ the id of the parent article (if any)." (setq article (read (current-buffer)) header (gnus-nov-parse-line article dependencies))) (when header - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (push header gnus-newsgroup-headers) (if (memq (setq article (mail-header-number header)) gnus-newsgroup-unselected) @@ -4385,7 +4527,7 @@ If LINE, insert the rebuilt thread starting on line LINE." (setq thread (list (car (gnus-id-to-thread id)))) ;; Get the thread this article is part of. (setq thread (gnus-remove-thread id))) - (setq old-pos (gnus-point-at-bol)) + (setq old-pos (point-at-bol)) (setq current (save-excursion (and (re-search-backward "[\r\n]" nil t) (gnus-summary-article-number)))) @@ -4567,9 +4709,9 @@ If LINE, insert the rebuilt thread starting on line LINE." (gnus-summary-show-thread) (gnus-data-remove number - (- (gnus-point-at-bol) + (- (point-at-bol) (prog1 - (1+ (gnus-point-at-eol)) + (1+ (point-at-eol)) (gnus-delete-line))))))) (defun gnus-sort-threads-recursive (threads func) @@ -4689,6 +4831,23 @@ using some other form will lead to serious barfage." (gnus-article-sort-by-author (gnus-thread-header h1) (gnus-thread-header h2))) +(defsubst gnus-article-sort-by-recipient (h1 h2) + "Sort articles by recipient." + (gnus-string< + (let ((extract (funcall + gnus-extract-address-components + (or (cdr (assq 'To (mail-header-extra h1))) "")))) + (or (car extract) (cadr extract))) + (let ((extract (funcall + gnus-extract-address-components + (or (cdr (assq 'To (mail-header-extra h2))) "")))) + (or (car extract) (cadr extract))))) + +(defun gnus-thread-sort-by-recipient (h1 h2) + "Sort threads by root recipient." + (gnus-article-sort-by-recipient + (gnus-thread-header h1) (gnus-thread-header h2))) + (defsubst gnus-article-sort-by-subject (h1 h2) "Sort articles by root subject." (gnus-string< @@ -4809,33 +4968,39 @@ If nil, use subject instead." :version "22.1" :type '(radio (const :format "%v " nil) string) :group 'gnus-thread) + (defcustom gnus-sum-thread-tree-false-root "> " "With %B spec, used for a false root of a thread. If nil, use subject instead." :version "22.1" :type '(radio (const :format "%v " nil) string) :group 'gnus-thread) + (defcustom gnus-sum-thread-tree-single-indent "" "With %B spec, used for a thread with just one message. If nil, use subject instead." :version "22.1" :type '(radio (const :format "%v " nil) string) :group 'gnus-thread) + (defcustom gnus-sum-thread-tree-vertical "| " "With %B spec, used for drawing a vertical line." :version "22.1" :type 'string :group 'gnus-thread) + (defcustom gnus-sum-thread-tree-indent " " "With %B spec, used for indenting." :version "22.1" :type 'string :group 'gnus-thread) + (defcustom gnus-sum-thread-tree-leaf-with-other "+-> " "With %B spec, used for a leaf with brothers." :version "22.1" :type 'string :group 'gnus-thread) + (defcustom gnus-sum-thread-tree-single-leaf "\\-> " "With %B spec, used for a leaf without brothers." :version "22.1" @@ -5194,23 +5359,20 @@ or a straight list of headers." gnus-list-identifiers)) changed subject) (when regexp + (setq regexp (concat "^\\(?:R[Ee]: +\\)*\\(" regexp " *\\)")) (dolist (header gnus-newsgroup-headers) (setq subject (mail-header-subject header) changed nil) - (while (string-match - (concat "^\\(R[Ee]: +\\)*\\(" regexp " *\\)") - subject) + (while (string-match regexp subject) (setq subject - (concat (substring subject 0 (match-beginning 2)) + (concat (substring subject 0 (match-beginning 1)) (substring subject (match-end 0))) changed t)) - (when (and changed - (string-match - "^\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" subject)) - (setq subject - (concat (substring subject 0 (match-beginning 1)) - (substring subject (match-end 1))))) (when changed + (when (string-match "^\\(\\(?:R[Ee]: +\\)+\\)R[Ee]: +" subject) + (setq subject + (concat (substring subject 0 (match-beginning 1)) + (substring subject (match-end 1))))) (mail-header-set-subject header subject)))))) (defun gnus-fetch-headers (articles) @@ -5238,33 +5400,37 @@ or a straight list of headers." "Select newsgroup GROUP. If READ-ALL is non-nil, all articles in the group are selected. If SELECT-ARTICLES, only select those articles from GROUP." - (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (let* ((entry (gnus-group-entry group)) ;;!!! Dirty hack; should be removed. (gnus-summary-ignore-duplicates (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) t gnus-summary-ignore-duplicates)) (info (nth 2 entry)) - articles fetched-articles cached) + charset articles fetched-articles cached) (unless (gnus-check-server (set (make-local-variable 'gnus-current-select-method) (gnus-find-method-for-group group))) (error "Couldn't open server")) + (setq charset (gnus-group-name-charset gnus-current-select-method group)) (or (and entry (not (eq (car entry) t))) ; Either it's active... (gnus-activate-group group) ; Or we can activate it... (progn ; Or we bug out. (when (equal major-mode 'gnus-summary-mode) (gnus-kill-buffer (current-buffer))) - (error "Couldn't activate group %s: %s" - (gnus-group-decoded-name group) (gnus-status-message group)))) + (error + "Couldn't activate group %s: %s" + (mm-decode-coding-string group charset) + (mm-decode-coding-string (gnus-status-message group) charset)))) (unless (gnus-request-group group t) - (when (equal major-mode 'gnus-summary-mode) - (gnus-kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" - (gnus-group-decoded-name group) (gnus-status-message group))) + (when (equal major-mode 'gnus-summary-mode) + (gnus-kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + (mm-decode-coding-string group charset) + (mm-decode-coding-string (gnus-status-message group) charset))) (when gnus-agent (gnus-agent-possibly-alter-active group (gnus-active group) info) @@ -5387,7 +5553,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq gnus-newsgroup-auto-expire (gnus-group-auto-expirable-p group)) ;; Set up the article buffer now, if necessary. - (unless gnus-single-article-buffer + (unless (and gnus-single-article-buffer + (equal gnus-article-buffer "*Article*")) (gnus-article-setup-buffer)) ;; First and last article in this newsgroup. (when gnus-newsgroup-headers @@ -5521,9 +5688,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (read-string (format "How many articles from %s (%s %d): " - (gnus-limit-string - (gnus-group-decoded-name gnus-newsgroup-name) - 35) + (gnus-group-decoded-name gnus-newsgroup-name) (if initial "max" "default") number) (if initial @@ -5849,7 +6014,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) "Look through all the headers and mark the Xrefs as read." (let ((virtual (gnus-virtual-group-p from-newsgroup)) - name entry info xref-hashtb idlist method nth4) + name info xref-hashtb idlist method nth4) (save-excursion (set-buffer gnus-group-buffer) (when (setq xref-hashtb @@ -5860,8 +6025,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (setq idlist (symbol-value group)) ;; Dead groups are not updated. (and (prog1 - (setq entry (gnus-gethash name gnus-newsrc-hashtb) - info (nth 2 entry)) + (setq info (gnus-get-info name)) (when (stringp (setq nth4 (gnus-info-method info))) (setq nth4 (gnus-server-to-method nth4)))) ;; Only do the xrefs if the group has the same @@ -5883,7 +6047,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." xref-hashtb))))) (defun gnus-compute-read-articles (group articles) - (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (let* ((entry (gnus-group-entry group)) (info (nth 2 entry)) (active (gnus-active group)) ninfo) @@ -5920,14 +6084,13 @@ The resulting hash table is returned, or nil if no Xrefs were found." (defun gnus-group-make-articles-read (group articles) "Update the info of GROUP to say that ARTICLES are read." (let* ((num 0) - (entry (gnus-gethash group gnus-newsrc-hashtb)) + (entry (gnus-group-entry group)) (info (nth 2 entry)) (active (gnus-active group)) range) (when entry (setq range (gnus-compute-read-articles group articles)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-undo-register `(progn (gnus-info-set-marks ',info ',(gnus-info-marks info) t) @@ -5966,9 +6129,9 @@ The resulting hash table is returned, or nil if no Xrefs were found." (let ((cur nntp-server-buffer) (dependencies (or dependencies - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-dependencies))) - headers id end ref + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-dependencies))) + headers id end ref number (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-excursion (condition-case nil @@ -6001,7 +6164,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (vector ;; Number. (prog1 - (read cur) + (setq number (read cur)) (end-of-line) (setq p (point)) (narrow-to-region (point) @@ -6038,7 +6201,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (match-end 1)) ;; If there was no message-id, we just fake one ;; to make subsequent routines simpler. - (nnheader-generate-fake-message-id)))) + (nnheader-generate-fake-message-id number)))) ;; References. (progn (goto-char p) @@ -6185,8 +6348,8 @@ Return a list of headers that match SEQUENCE (see (defun gnus-article-get-xrefs () "Fill in the Xref value in `gnus-current-headers', if necessary. This is meant to be called in `gnus-article-internal-prepare-hook'." - (let ((headers (save-excursion (set-buffer gnus-summary-buffer) - gnus-current-headers))) + (let ((headers (with-current-buffer gnus-summary-buffer + gnus-current-headers))) (or (not gnus-use-cross-reference) (not headers) (and (mail-header-xref headers) @@ -6201,7 +6364,7 @@ This is meant to be called in `gnus-article-internal-prepare-hook'." (looking-at "Xref:")) (search-forward "\nXref:" nil t)) (goto-char (1+ (match-end 0))) - (setq xref (buffer-substring (point) (gnus-point-at-eol))) + (setq xref (buffer-substring (point) (point-at-eol))) (mail-header-set-xref headers xref))))))) (defun gnus-summary-insert-subject (id &optional old-header use-old-header) @@ -6229,9 +6392,9 @@ the subject line on." (goto-char (gnus-data-pos d)) (gnus-data-remove number - (- (gnus-point-at-bol) + (- (point-at-bol) (prog1 - (1+ (gnus-point-at-eol)) + (1+ (point-at-eol)) (gnus-delete-line)))))) ;; Remove list identifiers from subject. (when gnus-list-identifiers @@ -6345,8 +6508,7 @@ executed with point over the summary line of the articles." (defun gnus-summary-process-mark-set (set) "Make SET into the current process marked articles." (gnus-summary-unmark-all-processable) - (while set - (gnus-summary-set-process-mark (pop set)))) + (mapc 'gnus-summary-set-process-mark set)) ;;; Searching and stuff @@ -6362,8 +6524,7 @@ If optional argument BACKWARD is non-nil, search backward instead." (defun gnus-summary-best-group (&optional exclude-group) "Find the name of the best unread group. If EXCLUDE-GROUP, do not go to this group." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (save-excursion (gnus-group-best-unread-group exclude-group)))) @@ -6494,7 +6655,7 @@ displayed, no centering will be performed." ((< (window-height) 7) 1) (t (if (numberp gnus-auto-center-summary) gnus-auto-center-summary - 2)))) + (/ (1- (window-height)) 2))))) (height (1- (window-height))) (bottom (save-excursion (goto-char (point-max)) (forward-line (- height)) @@ -6508,7 +6669,7 @@ displayed, no centering will be performed." (let ((top-pos (save-excursion (forward-line (- top)) (point)))) (if (> bottom top-pos) ;; Keep the second line from the top visible - (set-window-start window top-pos t) + (set-window-start window top-pos) ;; Try to keep the bottom line visible; if it's partially ;; obscured, either scroll one more line to make it fully ;; visible, or revert to using TOP-POS. @@ -6552,7 +6713,8 @@ displayed, no centering will be performed." (defun gnus-list-of-unread-articles (group) (let* ((read (gnus-info-read (gnus-get-info group))) (active (or (gnus-active group) (gnus-activate-group group))) - (last (cdr active)) + (last (or (cdr active) + (error "Group %s couldn't be activated " group))) (bottom (if gnus-newsgroup-maximum-articles (max (car active) (- last gnus-newsgroup-maximum-articles -1)) @@ -6752,8 +6914,7 @@ The prefix argument ALL means to select all articles." (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) (let ((headers gnus-newsgroup-headers)) ;; Set the new ranges of read articles. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-undo-force-boundary)) (gnus-update-read-articles group (gnus-sorted-union @@ -6813,8 +6974,13 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-run-hooks 'gnus-summary-prepare-exit-hook) ;; If we have several article buffers, we kill them at exit. (unless gnus-single-article-buffer - (gnus-kill-buffer gnus-original-article-buffer) - (setq gnus-article-current nil)) + (when (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + ;; Don't kill sticky article buffers + (unless (eq major-mode 'gnus-sticky-article-mode) + (gnus-kill-buffer gnus-article-buffer) + (setq gnus-article-current nil)))) + (gnus-kill-buffer gnus-original-article-buffer)) (when gnus-use-cache (gnus-cache-possibly-remove-articles) (gnus-cache-save-buffers)) @@ -6838,6 +7004,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-jump-to-group group)) (gnus-run-hooks 'gnus-summary-exit-hook) (unless (or quit-config + (not gnus-summary-next-group-on-exit) ;; If this group has disappeared from the summary ;; buffer, don't skip forwards. (not (string= group (gnus-group-group-name)))) @@ -6845,11 +7012,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (setq group-point (point)) (if temporary nil ;Nothing to do. - ;; If we have several article buffers, we kill them at exit. - (unless gnus-single-article-buffer - (gnus-kill-buffer gnus-article-buffer) - (gnus-kill-buffer gnus-original-article-buffer) - (setq gnus-article-current nil)) (set-buffer buf) (if (not gnus-kill-summary-on-exit) (progn @@ -6864,12 +7026,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-summary-clear-local-variables)) (when (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) - ;; We clear the global counterparts of the buffer-local - ;; variables as well, just to be on the safe side. - (set-buffer gnus-group-buffer) - (gnus-summary-clear-local-variables) - (let ((gnus-summary-local-variables gnus-newsgroup-variables)) - (gnus-summary-clear-local-variables)) ;; Return to group mode buffer. (when (eq mode 'gnus-summary-mode) (gnus-kill-buffer buf))) @@ -6919,10 +7075,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-summary-clear-local-variables) (let ((gnus-summary-local-variables gnus-newsgroup-variables)) (gnus-summary-clear-local-variables)) - (set-buffer gnus-group-buffer) - (gnus-summary-clear-local-variables) - (let ((gnus-summary-local-variables gnus-newsgroup-variables)) - (gnus-summary-clear-local-variables)) (gnus-kill-buffer gnus-summary-buffer)) (unless gnus-single-article-buffer (setq gnus-article-current nil)) @@ -6961,19 +7113,26 @@ The state which existed when entering the ephemeral is reset." (gnus-set-global-variables)))) (if (or (eq (cdr quit-config) 'article) (eq (cdr quit-config) 'pick)) - (progn - ;; The current article may be from the ephemeral group - ;; thus it is best that we reload this article - ;; - ;; If we're exiting from a large digest, this can be - ;; extremely slow. So, it's better not to reload it. -- jh. - ;;(gnus-summary-show-article) - (if (and (boundp 'gnus-pick-mode) (symbol-value 'gnus-pick-mode)) - (gnus-configure-windows 'pick 'force) - (gnus-configure-windows (cdr quit-config) 'force))) + (if (and (boundp 'gnus-pick-mode) (symbol-value 'gnus-pick-mode)) + (gnus-configure-windows 'pick 'force) + (gnus-configure-windows (cdr quit-config) 'force)) (gnus-configure-windows (cdr quit-config) 'force)) (when (eq major-mode 'gnus-summary-mode) - (gnus-summary-next-subject 1 nil t) + (if (memq gnus-auto-select-on-ephemeral-exit '(next-noselect + next-unread-noselect)) + (when (zerop (cond ((eq gnus-auto-select-on-ephemeral-exit + 'next-noselect) + (gnus-summary-next-subject 1 nil t)) + ((eq gnus-auto-select-on-ephemeral-exit + 'next-unread-noselect) + (gnus-summary-next-subject 1 t t)))) + ;; Hide the article buffer which displays the article different + ;; from the one that the cursor points to in the summary buffer. + (gnus-configure-windows 'summary 'force)) + (cond ((eq gnus-auto-select-on-ephemeral-exit 'next) + (gnus-summary-next-subject 1)) + ((eq gnus-auto-select-on-ephemeral-exit 'next-unread) + (gnus-summary-next-subject 1 t)))) (gnus-summary-recenter) (gnus-summary-position-point)))) @@ -7004,7 +7163,7 @@ The state which existed when entering the ephemeral is reset." (if (null arg) (not gnus-dead-summary-mode) (> (prefix-numeric-value arg) 0))) (when gnus-dead-summary-mode - (gnus-add-minor-mode + (add-minor-mode 'gnus-dead-summary-mode " Dead" gnus-dead-summary-mode-map)))) (defun gnus-deaden-summary () @@ -7012,8 +7171,7 @@ The state which existed when entering the ephemeral is reset." ;; Kill any previous dead summary buffer. (when (and gnus-dead-summary (buffer-name gnus-dead-summary)) - (save-excursion - (set-buffer gnus-dead-summary) + (with-current-buffer gnus-dead-summary (when gnus-dead-summary-mode (kill-buffer (current-buffer))))) ;; Make this the current dead summary. @@ -7032,8 +7190,7 @@ The state which existed when entering the ephemeral is reset." (save-excursion (when (and (buffer-name buffer) (not gnus-single-article-buffer)) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (gnus-kill-buffer gnus-article-buffer) (gnus-kill-buffer gnus-original-article-buffer))) (cond @@ -7073,7 +7230,7 @@ in." (when current-prefix-arg (completing-read "FAQ dir: " (and (listp gnus-group-faq-directory) - (mapcar (lambda (file) (list file)) + (mapcar 'list gnus-group-faq-directory)))))) (let (gnus-faq-buffer) (when (setq gnus-faq-buffer @@ -7287,15 +7444,15 @@ Given a prefix, will force an `article' buffer configuration." (defun gnus-summary-display-article (article &optional all-header) "Display ARTICLE in article buffer." - (when (gnus-buffer-live-p gnus-article-buffer) - (with-current-buffer gnus-article-buffer - (mm-enable-multibyte))) + (unless (and (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + (eq major-mode 'gnus-article-mode))) + (gnus-article-setup-buffer)) (gnus-set-global-variables) - (when (gnus-buffer-live-p gnus-article-buffer) - (with-current-buffer gnus-article-buffer - (setq gnus-article-charset gnus-newsgroup-charset) - (setq gnus-article-ignored-charsets gnus-newsgroup-ignored-charsets) - (mm-enable-multibyte))) + (with-current-buffer gnus-article-buffer + (setq gnus-article-charset gnus-newsgroup-charset) + (setq gnus-article-ignored-charsets gnus-newsgroup-ignored-charsets) + (mm-enable-multibyte)) (if (null article) nil (prog1 @@ -7402,8 +7559,7 @@ If BACKWARD, the previous article is selected instead of the next." (gnus-summary-jump-to-group gnus-newsgroup-name)) (let ((cmd last-command-char) (point - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (point))) (group (if (eq gnus-keep-same-level 'best) @@ -7456,7 +7612,7 @@ If BACKWARD, the previous article is selected instead of the next." (format " (Type %s for %s [%s])" (single-key-description cmd) (gnus-group-decoded-name group) - (car (gnus-gethash group gnus-newsrc-hashtb))) + (gnus-group-unread group)) (format " (Type %s to exit %s)" (single-key-description cmd) (gnus-group-decoded-name gnus-newsgroup-name))))) @@ -7844,6 +8000,123 @@ If NOT-MATCHING, excluding articles that have authors that match a regexp." current-prefix-arg)) (gnus-summary-limit-to-subject from "from" not-matching)) +(defun gnus-summary-limit-to-recipient (recipient &optional not-matching) + "Limit the summary buffer to articles with the given RECIPIENT. + +If NOT-MATCHING, exclude RECIPIENT. + +To and Cc headers are checked. You need to include them in +`nnmail-extra-headers'." + ;; Unlike `rmail-summary-by-recipients', doesn't include From. + (interactive + (list (read-string (format "%s recipient (regexp): " + (if current-prefix-arg "Exclude" "Limit to"))) + current-prefix-arg)) + (when (not (equal "" recipient)) + (prog1 (let* ((to + (if (memq 'To nnmail-extra-headers) + (gnus-summary-find-matching + (cons 'extra 'To) recipient 'all nil nil + not-matching) + (gnus-message + 1 "`To' isn't present in `nnmail-extra-headers'") + (sit-for 1) + nil)) + (cc + (if (memq 'Cc nnmail-extra-headers) + (gnus-summary-find-matching + (cons 'extra 'Cc) recipient 'all nil nil + not-matching) + (gnus-message + 1 "`Cc' isn't present in `nnmail-extra-headers'") + (sit-for 1) + nil)) + (articles + (if not-matching + ;; We need the numbers that are in both lists: + (mapcar (lambda (a) + (and (memq a to) a)) + cc) + (nconc to cc)))) + (unless articles + (error "Found no matches for \"%s\"" recipient)) + (gnus-summary-limit articles)) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-to-address (address &optional not-matching) + "Limit the summary buffer to articles with the given ADDRESS. + +If NOT-MATCHING, exclude ADDRESS. + +To, Cc and From headers are checked. You need to include `To' and `Cc' +in `nnmail-extra-headers'." + (interactive + (list (read-string (format "%s address (regexp): " + (if current-prefix-arg "Exclude" "Limit to"))) + current-prefix-arg)) + (when (not (equal "" address)) + (prog1 (let* ((to + (if (memq 'To nnmail-extra-headers) + (gnus-summary-find-matching + (cons 'extra 'To) address 'all nil nil + not-matching) + (gnus-message + 1 "`To' isn't present in `nnmail-extra-headers'") + (sit-for 1) + t)) + (cc + (if (memq 'Cc nnmail-extra-headers) + (gnus-summary-find-matching + (cons 'extra 'Cc) address 'all nil nil + not-matching) + (gnus-message + 1 "`Cc' isn't present in `nnmail-extra-headers'") + (sit-for 1) + t)) + (from + (gnus-summary-find-matching "from" address + 'all nil nil not-matching)) + (articles + (if not-matching + ;; We need the numbers that are in all lists: + (if (eq cc t) + (if (eq to t) + from + (mapcar (lambda (a) (car (memq a from))) to)) + (if (eq to t) + (mapcar (lambda (a) (car (memq a from))) cc) + (mapcar (lambda (a) (car (memq a from))) + (mapcar (lambda (a) (car (memq a to))) + cc)))) + (nconc (if (eq to t) nil to) + (if (eq cc t) nil cc) + from)))) + (unless articles + (error "Found no matches for \"%s\"" address)) + (gnus-summary-limit articles)) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-strange-charsets-predicate (header) + (let ((string (concat (mail-header-subject header) + (mail-header-from header))) + charset found) + (dotimes (i (1- (length string))) + (setq charset (format "%s" (char-charset (aref string (1+ i))))) + (when (string-match "unicode\\|big\\|japanese" charset) + (setq found t))) + found)) + +(defun gnus-summary-limit-to-predicate (predicate) + "Limit to articles where PREDICATE returns non-nil. +PREDICATE will be called with the header structures of the +articles." + (let ((articles nil) + (case-fold-search t)) + (dolist (header gnus-newsgroup-headers) + (when (funcall predicate header) + (push (mail-header-number header) articles))) + (gnus-summary-limit (nreverse articles)))) + (defun gnus-summary-limit-to-age (age &optional younger-p) "Limit the summary buffer to articles that are older than (or equal) AGE days. If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to @@ -7862,10 +8135,9 @@ articles that are younger than AGE days." (if (numberp days) (progn (setq days-got t) - (if (< days 0) - (progn - (setq younger (not younger)) - (setq days (* days -1))))) + (when (< days 0) + (setq younger (not younger)) + (setq days (* days -1)))) (message "Please enter a number.") (sleep-for 1))) (list days younger))) @@ -7950,6 +8222,81 @@ If ALL is non-nil, limit strictly to unread articles." gnus-duplicate-mark gnus-souped-mark) 'reverse))) +(defun gnus-summary-limit-to-headers (match &optional reverse) + "Limit the summary buffer to articles that have headers that match MATCH. +If REVERSE (the prefix), limit to articles that don't match." + (interactive "sMatch headers (regexp): \nP") + (gnus-summary-limit-to-bodies match reverse t)) + +(defun gnus-summary-limit-to-bodies (match &optional reverse headersp) + "Limit the summary buffer to articles that have bodies that match MATCH. +If REVERSE (the prefix), limit to articles that don't match." + (interactive "sMatch body (regexp): \nP") + (let ((articles nil) + (gnus-select-article-hook nil) ;Disable hook. + (gnus-article-prepare-hook nil) + (gnus-use-article-prefetch nil) + (gnus-keep-backlog nil) + (gnus-break-pages nil) + (gnus-summary-display-arrow nil) + (gnus-updated-mode-lines nil) + (gnus-auto-center-summary nil) + (gnus-display-mime-function nil)) + (dolist (data gnus-newsgroup-data) + (let (gnus-mark-article-hook) + (gnus-summary-select-article t t nil (gnus-data-number data))) + (save-excursion + (set-buffer gnus-article-buffer) + (article-goto-body) + (let* ((case-fold-search t) + (found (if headersp + (re-search-backward match nil t) + (re-search-forward match nil t)))) + (when (or (and found + (not reverse)) + (and (not found) + reverse)) + (push (gnus-data-number data) articles))))) + (if (not articles) + (message "No messages matched") + (gnus-summary-limit articles))) + (gnus-summary-position-point)) + +(defun gnus-summary-limit-to-singletons (&optional threadsp) + "Limit the summary buffer to articles that aren't part on any thread. +If THREADSP (the prefix), limit to articles that are in threads." + (interactive "P") + (let ((articles nil) + thread-articles + threads) + (dolist (thread gnus-newsgroup-threads) + (if (stringp (car thread)) + (dolist (thread (cdr thread)) + (push thread threads)) + (push thread threads))) + (dolist (thread threads) + (setq thread-articles (gnus-articles-in-thread thread)) + (when (or (and threadsp + (> (length thread-articles) 1)) + (and (not threadsp) + (= (length thread-articles) 1))) + (setq articles (nconc thread-articles articles)))) + (if (not articles) + (message "No messages matched") + (gnus-summary-limit articles)) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-to-replied (&optional unreplied) + "Limit the summary buffer to replied articles. +If UNREPLIED (the prefix), limit to unreplied articles." + (interactive "P") + (if unreplied + (gnus-summary-limit + (gnus-set-difference gnus-newsgroup-articles + gnus-newsgroup-replied)) + (gnus-summary-limit gnus-newsgroup-replied)) + (gnus-summary-position-point)) + (defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-exclude-marks) (make-obsolete 'gnus-summary-delete-marked-with 'gnus-summary-limit-exclude-marks) @@ -8035,6 +8382,14 @@ article." (gnus-message 3 "No dormant articles for this group") (gnus-summary-goto-subjects gnus-newsgroup-dormant)))) +(defun gnus-summary-insert-ticked-articles () + "Insert ticked articles for this group into the current buffer." + (interactive) + (let ((gnus-verbose (max 6 gnus-verbose))) + (if (not gnus-newsgroup-marked) + (gnus-message 3 "No ticked articles for this group") + (gnus-summary-goto-subjects gnus-newsgroup-marked)))) + (defun gnus-summary-limit-include-dormant () "Display all the hidden articles that are marked as dormant. Note that this command only works on a subset of the articles currently @@ -8295,13 +8650,12 @@ fetch-old-headers verbiage, and so on." (and gnus-newsgroup-display (not (funcall gnus-newsgroup-display))) ;; Check NoCeM things. - (if (and gnus-use-nocem - (gnus-nocem-unwanted-article-p - (mail-header-id (car thread)))) - (progn - (setq gnus-newsgroup-unreads - (delq number gnus-newsgroup-unreads)) - t)))) + (when (and gnus-use-nocem + (gnus-nocem-unwanted-article-p + (mail-header-id (car thread)))) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + t))) ;; Nope, invisible article. 0 ;; Ok, this article is to be visible, so we add it to the limit @@ -8513,8 +8867,7 @@ to guess what the document format is." (let* ((name (format "%s-%d" (gnus-group-prefixed-name gnus-newsgroup-name (list 'nndoc "")) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer gnus-current-article))) (ogroup gnus-newsgroup-name) (params (append (gnus-info-params (gnus-get-info ogroup)) @@ -8572,12 +8925,11 @@ This will allow you to read digests and other similar documents as newsgroups. Obeys the standard process/prefix convention." (interactive "P") - (let* ((articles (gnus-summary-work-articles n)) - (ogroup gnus-newsgroup-name) + (let* ((ogroup gnus-newsgroup-name) (params (append (gnus-info-params (gnus-get-info ogroup)) (list (cons 'to-group ogroup)))) - article group egroup groups vgroup) - (while (setq article (pop articles)) + group egroup groups vgroup) + (dolist (article (gnus-summary-work-articles n)) (setq group (format "%s-%d" gnus-newsgroup-name article)) (gnus-summary-remove-process-mark article) (when (gnus-summary-display-article article) @@ -8588,7 +8940,7 @@ Obeys the standard process/prefix convention." ;; the wrong guess. (message-narrow-to-head) (goto-char (point-min)) - (delete-matching-lines "^\\(Path\\):\\|^From ") + (delete-matching-lines "^Path:\\|^From ") (widen) (if (setq egroup (gnus-group-read-ephemeral-group @@ -8627,6 +8979,20 @@ If REGEXP-P (the prefix) is non-nil, do regexp isearch." (widen) (isearch-forward regexp-p)))) +(defun gnus-summary-repeat-search-article-forward () + "Repeat the previous search forwards." + (interactive) + (unless gnus-last-search-regexp + (error "No previous search")) + (gnus-summary-search-article-forward gnus-last-search-regexp)) + +(defun gnus-summary-repeat-search-article-backward () + "Repeat the previous search backwards." + (interactive) + (unless gnus-last-search-regexp + (error "No previous search")) + (gnus-summary-search-article-forward gnus-last-search-regexp t)) + (defun gnus-summary-search-article-forward (regexp &optional backward) "Search for an article containing REGEXP forward. If BACKWARD, search backward instead." @@ -8929,8 +9295,7 @@ strokes are `C-u g'." (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (mm-read-coding-system "View as charset: " ;; actually it is coding system. - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (mm-detect-coding-region (point) (point-max)))))) (gnus-newsgroup-ignored-charsets 'gnus-all)) (gnus-summary-select-article nil 'force) @@ -9054,8 +9419,8 @@ If ARG is a negative number, hide the unwanted header lines." (defun gnus-summary-caesar-message (&optional arg) "Caesar rotate the current article by 13. -The numerical prefix specifies how many places to rotate each letter -forward." +With a non-numerical prefix, also rotate headers. A numerical +prefix specifies how many places to rotate each letter forward." (interactive "P") (gnus-summary-select-article) (let ((mail-header-separator "")) @@ -9064,14 +9429,38 @@ forward." (widen) (let ((start (window-start)) buffer-read-only) - (message-caesar-buffer-body arg) + (if (equal arg '(4)) + (message-caesar-buffer-body nil t) + (message-caesar-buffer-body arg)) (set-window-start (get-buffer-window (current-buffer)) start))))) ;; Create buttons and stuff... (gnus-treat-article nil)) -(autoload 'unmorse-region "morse" - "Convert morse coded text in region to ordinary ASCII text." - t) +(defun gnus-summary-idna-message (&optional arg) + "Decode IDNA encoded domain names in the current articles. +IDNA encoded domain names looks like `xn--bar'. If a string +remain unencoded after running this function, it is likely an +invalid IDNA string (`xn--bar' is invalid). + +You must have GNU Libidn (`http://www.gnu.org/software/libidn/') +installed for this command to work." + (interactive "P") + (if (not (and (condition-case nil (require 'idna) + (file-error)) + (mm-coding-system-p 'utf-8) + (executable-find (symbol-value 'idna-program)))) + (gnus-message + 5 "GNU Libidn not installed properly (`idn' or `idna.el' missing)") + (gnus-summary-select-article) + (let ((mail-header-separator "")) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (let ((start (window-start)) + buffer-read-only) + (while (re-search-forward "\\(xn--[-0-9a-z]+\\)" nil t) + (replace-match (idna-to-unicode (match-string 1)))) + (set-window-start (get-buffer-window (current-buffer)) start))))))) (defun gnus-summary-morse-message (&optional arg) "Morse decode the current article." @@ -9088,7 +9477,7 @@ forward." (when (message-goto-body) (gnus-narrow-to-body)) (goto-char (point-min)) - (while (re-search-forward "·" (point-max) t) + (while (search-forward "·" (point-max) t) (replace-match ".")) (unmorse-region (point-min) (point-max)) (widen) @@ -9141,14 +9530,16 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (let ((articles (gnus-summary-work-articles n)) (prefix (if (gnus-check-backend-function 'request-move-article gnus-newsgroup-name) - (gnus-group-real-prefix gnus-newsgroup-name) + (funcall gnus-move-group-prefix-function + gnus-newsgroup-name) "")) (names '((move "Move" "Moving") (copy "Copy" "Copying") (crosspost "Crosspost" "Crossposting"))) (copy-buf (save-excursion (nnheader-set-temp-buffer " *copy article*"))) - art-group to-method new-xref article to-groups) + art-group to-method new-xref article to-groups + articles-to-update-marks encoded) (unless (assq action names) (error "Unknown action %s" action)) ;; Read the newsgroup name. @@ -9166,15 +9557,27 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (gnus-article-prepare-hook nil) (gnus-mark-article-hook nil)) (gnus-summary-select-article nil nil nil (car articles)))) - (setq to-newsgroup - (gnus-read-move-group-name - (cadr (assq action names)) - (symbol-value (intern (format "gnus-current-%s-group" action))) - articles prefix)) - (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) - (setq to-method (or select-method - (gnus-server-to-method - (gnus-group-method to-newsgroup)))) + (setq to-newsgroup (gnus-read-move-group-name + (cadr (assq action names)) + (symbol-value + (intern (format "gnus-current-%s-group" action))) + articles prefix) + encoded to-newsgroup + to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) + (set (intern (format "gnus-current-%s-group" action)) + (mm-decode-coding-string + to-newsgroup + (gnus-group-name-charset to-method to-newsgroup)))) + (unless to-method + (setq to-method (or select-method + (gnus-server-to-method + (gnus-group-method to-newsgroup))))) + (setq to-newsgroup + (or encoded + (and to-newsgroup + (mm-encode-coding-string + to-newsgroup + (gnus-group-name-charset to-method to-newsgroup))))) ;; Check the method we are to move this article to... (unless (gnus-check-backend-function 'request-accept-article (car to-method)) @@ -9183,7 +9586,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (error "Can't open server %s" (car to-method))) (gnus-message 6 "%s to %s: %s..." (caddr (assq action names)) - (or (car select-method) to-newsgroup) articles) + (or (car select-method) + (gnus-group-decoded-name to-newsgroup)) + articles) (while articles (setq article (pop articles)) (setq @@ -9193,20 +9598,30 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." ((eq action 'move) ;; Remove this article from future suppression. (gnus-dup-unsuppress-article article) - (gnus-request-move-article - article ; Article to move - gnus-newsgroup-name ; From newsgroup - (nth 1 (gnus-find-method-for-group - gnus-newsgroup-name)) ; Server - (list 'gnus-request-accept-article - to-newsgroup (list 'quote select-method) - (not articles) t) ; Accept form - (not articles))) ; Only save nov last time + (let* ((from-method (gnus-find-method-for-group + gnus-newsgroup-name)) + (to-method (or select-method + (gnus-find-method-for-group to-newsgroup))) + (move-is-internal (gnus-method-equal from-method to-method))) + (gnus-request-move-article + article ; Article to move + gnus-newsgroup-name ; From newsgroup + (nth 1 (gnus-find-method-for-group + gnus-newsgroup-name)) ; Server + (list 'gnus-request-accept-article + to-newsgroup (list 'quote select-method) + (not articles) t) ; Accept form + (not articles) ; Only save nov last time + move-is-internal))) ; is this move internal? ;; Copy the article. ((eq action 'copy) (save-excursion (set-buffer copy-buf) (when (gnus-request-article-this-buffer article gnus-newsgroup-name) + (save-restriction + (nnheader-narrow-to-headers) + (dolist (hdr gnus-copy-article-ignored-headers) + (message-remove-header hdr t))) (gnus-request-accept-article to-newsgroup select-method (not articles) t)))) ;; Crosspost the article. @@ -9259,9 +9674,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (t (let* ((pto-group (gnus-group-prefixed-name (car art-group) to-method)) - (entry - (gnus-gethash pto-group gnus-newsrc-hashtb)) - (info (nth 2 entry)) + (info (gnus-get-info pto-group)) (to-group (gnus-info-group info)) to-marks) ;; Update the group that has been moved to. @@ -9353,7 +9766,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (gnus-summary-goto-subject article) (when (eq action 'move) (gnus-summary-mark-article article gnus-canceled-mark)))) - (gnus-summary-remove-process-mark article)) + (push article articles-to-update-marks)) + + (apply 'gnus-summary-remove-process-mark articles-to-update-marks) ;; Re-activate all groups that have been moved to. (save-excursion (set-buffer gnus-group-buffer) @@ -9629,10 +10044,10 @@ confirmation before the articles are deleted." (unless (memq (car articles) not-deleted) (gnus-summary-mark-article (car articles) gnus-canceled-mark)) (let* ((article (car articles)) - (id (mail-header-id (gnus-data-header - (assoc article (gnus-data-list nil)))))) + (ghead (gnus-data-header + (assoc article (gnus-data-list nil))))) (run-hook-with-args 'gnus-summary-article-delete-hook - 'delete id gnus-newsgroup-name nil + 'delete ghead gnus-newsgroup-name nil nil)) (setq articles (cdr articles))) (when not-deleted @@ -9705,7 +10120,16 @@ groups." (message-options message-options) (message-options-set-recipient) (mail-parse-ignored-charsets - ',gnus-newsgroup-ignored-charsets)) + ',gnus-newsgroup-ignored-charsets) + (rfc2047-header-encoding-alist + ',(let ((charset (gnus-group-name-charset + (gnus-find-method-for-group + gnus-newsgroup-name) + gnus-newsgroup-name))) + (append (list (cons "Newsgroups" charset) + (cons "Followup-To" charset) + (cons "Xref" charset)) + rfc2047-header-encoding-alist)))) ,(if (not raw) '(progn (mml-to-mime) (mml-destroy-buffers) @@ -10013,8 +10437,7 @@ ARTICLE can also be a list of articles." ;; (article-number . line-number-in-body). (push (cons article - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (count-lines (min (point) (save-excursion @@ -10051,13 +10474,15 @@ the actual number of articles marked is returned." (gnus-summary-goto-subject article) (gnus-summary-update-secondary-mark article))) -(defun gnus-summary-remove-process-mark (article) - "Remove the process mark from ARTICLE and update the summary line." - (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) - (when (gnus-summary-goto-subject article) - (gnus-summary-show-thread) - (gnus-summary-goto-subject article) - (gnus-summary-update-secondary-mark article))) +(defun gnus-summary-remove-process-mark (&rest articles) + "Remove the process mark from ARTICLES and update the summary line." + (dolist (article articles) + (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) + (when (gnus-summary-goto-subject article) + (gnus-summary-show-thread) + (gnus-summary-goto-subject article) + (gnus-summary-update-secondary-mark article))) + t) (defun gnus-summary-set-saved-mark (article) "Set the process mark on ARTICLE and update the summary line." @@ -10258,7 +10683,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (defun gnus-summary-update-mark (mark type) (let ((forward (cdr (assq type gnus-summary-mark-positions))) (buffer-read-only nil)) - (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) + (re-search-backward "[\n\r]" (point-at-bol) 'move-to-limit) (when forward (when (looking-at "\r") (incf forward)) @@ -10501,9 +10926,8 @@ even ticked and dormant ones." (goto-char (point-min)) (push gnus-newsgroup-limit gnus-newsgroup-limits) (setq gnus-newsgroup-limit (copy-sequence gnus-newsgroup-limit)) - (mapcar (lambda (x) (push (mail-header-number x) - gnus-newsgroup-limit)) - headers) + (dolist (x headers) + (push (mail-header-number x) gnus-newsgroup-limit)) (gnus-summary-prepare-unthreaded (nreverse headers)) (goto-char (point-min)) (gnus-summary-position-point) @@ -10628,6 +11052,15 @@ read." (gnus-summary-catchup all)) (gnus-summary-next-group)) +(defun gnus-summary-catchup-and-goto-prev-group (&optional all) + "Mark all articles in this group as read and select the previous group. +If given a prefix, mark all articles, unread as well as ticked, as +read." + (interactive "P") + (save-excursion + (gnus-summary-catchup all)) + (gnus-summary-next-group nil nil t)) + ;;; ;;; with article ;;; @@ -10720,41 +11153,51 @@ is non-nil or the Subject: of both articles are the same." (error "The current newsgroup does not support article editing")) (unless (<= (length gnus-newsgroup-processable) 1) (error "No more than one article may be marked")) - (save-window-excursion - (let ((gnus-article-buffer " *reparent*") - (current-article (gnus-summary-article-number)) - ;; First grab the marked article, otherwise one line up. - (parent-article (if (not (null gnus-newsgroup-processable)) - (car gnus-newsgroup-processable) - (save-excursion - (if (eq (forward-line -1) 0) - (gnus-summary-article-number) - (error "Beginning of summary buffer")))))) - (unless (not (eq current-article parent-article)) - (error "An article may not be self-referential")) - (let ((message-id (mail-header-id - (gnus-summary-article-header parent-article)))) - (unless (and message-id (not (equal message-id ""))) - (error "No message-id in desired parent")) - (gnus-with-article current-article - (save-restriction - (goto-char (point-min)) - (message-narrow-to-head) - (if (re-search-forward "^References: " nil t) - (progn - (re-search-forward "^[^ \t]" nil t) - (forward-line -1) - (end-of-line) - (insert " " message-id)) - (insert "References: " message-id "\n")))) - (set-buffer gnus-summary-buffer) - (gnus-summary-unmark-all-processable) - (gnus-summary-update-article current-article) - (if (gnus-summary-goto-subject (cdr gnus-article-current) nil t) + (let ((child (gnus-summary-article-number)) + ;; First grab the marked article, otherwise one line up. + (parent (if (not (null gnus-newsgroup-processable)) + (car gnus-newsgroup-processable) + (save-excursion + (if (eq (forward-line -1) 0) + (gnus-summary-article-number) + (error "Beginning of summary buffer")))))) + (gnus-summary-reparent-children parent (list child)))) + +(defun gnus-summary-reparent-children (parent children) + "Make PARENT the parent of CHILDREN. +When called interactively, PARENT is the current article and CHILDREN +are the process-marked articles." + (interactive + (list (gnus-summary-article-number) + (gnus-summary-work-articles nil))) + (dolist (child children) + (save-window-excursion + (let ((gnus-article-buffer " *reparent*")) + (unless (not (eq parent child)) + (error "An article may not be self-referential")) + (let ((message-id (mail-header-id + (gnus-summary-article-header parent)))) + (unless (and message-id (not (equal message-id ""))) + (error "No message-id in desired parent")) + (gnus-with-article child + (save-restriction + (goto-char (point-min)) + (message-narrow-to-head) + (if (re-search-forward "^References: " nil t) + (progn + (re-search-forward "^[^ \t]" nil t) + (forward-line -1) + (end-of-line) + (insert " " message-id)) + (insert "References: " message-id "\n")))) + (set-buffer gnus-summary-buffer) + (gnus-summary-unmark-all-processable) + (gnus-summary-update-article child) + (when (gnus-summary-goto-subject (cdr gnus-article-current) nil t) (gnus-summary-update-secondary-mark (cdr gnus-article-current))) - (gnus-summary-rethread-current) - (gnus-message 3 "Article %d is now the child of article %d" - current-article parent-article))))) + (gnus-summary-rethread-current) + (gnus-message 3 "Article %d is now the child of article %d" + child parent)))))) (defun gnus-summary-toggle-threads (&optional arg) "Toggle showing conversation threads. @@ -10783,7 +11226,7 @@ Returns nil if no thread was there to be shown." (interactive) (let ((buffer-read-only nil) (orig (point)) - (end (gnus-point-at-eol)) + (end (point-at-eol)) ;; Leave point at bol (beg (progn (beginning-of-line) (point)))) (prog1 @@ -10947,14 +11390,21 @@ taken." (while (gnus-summary-go-up-thread)) (gnus-summary-article-number)) +(defun gnus-summary-expire-thread () + "Mark articles under current thread as expired." + (interactive) + (gnus-summary-kill-thread 0)) + (defun gnus-summary-kill-thread (&optional unmark) "Mark articles under current thread as read. If the prefix argument is positive, remove any kinds of marks. +If the prefix argument is zero, mark thread as expired. If the prefix argument is negative, tick articles instead." (interactive "P") (when unmark (setq unmark (prefix-numeric-value unmark))) - (let ((articles (gnus-summary-articles-in-thread))) + (let ((articles (gnus-summary-articles-in-thread)) + (hide (or (null unmark) (= unmark 0)))) (save-excursion ;; Expand the thread. (gnus-summary-show-thread) @@ -10965,15 +11415,17 @@ If the prefix argument is negative, tick articles instead." (gnus-summary-mark-article-as-read gnus-killed-mark)) ((> unmark 0) (gnus-summary-mark-article-as-unread gnus-unread-mark)) + ((= unmark 0) + (gnus-summary-mark-article-as-unread gnus-expirable-mark)) (t (gnus-summary-mark-article-as-unread gnus-ticked-mark))) (setq articles (cdr articles)))) - ;; Hide killed subtrees. - (and (null unmark) + ;; Hide killed subtrees when hide is true. + (and hide gnus-thread-hide-killed (gnus-summary-hide-thread)) - ;; If marked as read, go to next unread subject. - (when (null unmark) + ;; If hide is t, go to next unread subject. + (when hide ;; Go to next unread subject. (gnus-summary-next-subject 1 t))) (gnus-set-mode-line 'summary)) @@ -10999,6 +11451,13 @@ Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort 'author reverse)) +(defun gnus-summary-sort-by-recipient (&optional reverse) + "Sort the summary buffer by recipient name alphabetically. +If `case-fold-search' is non-nil, case of letters is ignored. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'recipient reverse)) + (defun gnus-summary-sort-by-subject (&optional reverse) "Sort the summary buffer by subject alphabetically. `Re:'s are ignored. If `case-fold-search' is non-nil, case of letters is ignored. @@ -11287,46 +11746,51 @@ save those articles instead." (format "these %d articles" (length articles)) "this article"))) (to-newsgroup - (cond - ((null split-name) - (gnus-completing-read-with-default - default prom - gnus-active-hashtb - 'gnus-valid-move-group-p - nil prefix - 'gnus-group-history)) - ((= 1 (length split-name)) - (gnus-completing-read-with-default - (car split-name) prom - gnus-active-hashtb - 'gnus-valid-move-group-p - nil nil - 'gnus-group-history)) - (t - (gnus-completing-read-with-default - nil prom - (mapcar (lambda (el) (list el)) - (nreverse split-name)) - nil nil nil - 'gnus-group-history)))) - (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))) + (let (active group) + (when (or (null split-name) (= 1 (length split-name))) + (setq active (gnus-make-hashtable (length gnus-active-hashtb))) + (mapatoms (lambda (symbol) + (setq group (symbol-name symbol)) + (when (string-match "[^\000-\177]" group) + (setq group (gnus-group-decoded-name group))) + (set (intern group active) group)) + gnus-active-hashtb)) + (cond + ((null split-name) + (gnus-completing-read-with-default + default prom active 'gnus-valid-move-group-p nil prefix + 'gnus-group-history)) + ((= 1 (length split-name)) + (gnus-completing-read-with-default + (car split-name) prom active 'gnus-valid-move-group-p nil nil + 'gnus-group-history)) + (t + (gnus-completing-read-with-default + nil prom (mapcar 'list (nreverse split-name)) nil nil nil + 'gnus-group-history))))) + (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) + encoded) (when to-newsgroup (if (or (string= to-newsgroup "") (string= to-newsgroup prefix)) (setq to-newsgroup default)) (unless to-newsgroup (error "No group name entered")) - (or (gnus-active to-newsgroup) - (gnus-activate-group to-newsgroup nil nil to-method) + (setq encoded (mm-encode-coding-string + to-newsgroup + (gnus-group-name-charset to-method to-newsgroup))) + (or (gnus-active encoded) + (gnus-activate-group encoded nil nil to-method) (if (gnus-y-or-n-p (format "No such group: %s. Create it? " to-newsgroup)) - (or (and (gnus-request-create-group to-newsgroup to-method) - (gnus-activate-group - to-newsgroup nil nil to-method) - (gnus-subscribe-group to-newsgroup)) + (or (and (gnus-request-create-group encoded to-method) + (gnus-activate-group encoded nil nil to-method) + (gnus-subscribe-group encoded)) (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup))) - to-newsgroup)) + (error "No such group: %s" to-newsgroup)) + encoded))) + +(defvar gnus-summary-save-parts-counter) (defun gnus-summary-save-parts (type dir n &optional reverse) "Save parts matching TYPE to DIR. @@ -11350,7 +11814,8 @@ If REVERSE, save parts that do not match TYPE." (let ((handles (or gnus-article-mime-handles (mm-dissect-buffer nil gnus-article-loose-mime) (and gnus-article-emulate-mime - (mm-uu-dissect))))) + (mm-uu-dissect)))) + (gnus-summary-save-parts-counter 1)) (when handles (gnus-summary-save-parts-1 type dir handles reverse) (unless gnus-article-mime-handles ;; Don't destroy this case. @@ -11372,10 +11837,11 @@ If REVERSE, save parts that do not match TYPE." (mm-handle-disposition handle) 'filename) (mail-content-type-get (mm-handle-type handle) 'name) - (concat gnus-newsgroup-name - "." (number-to-string - (cdr gnus-article-current)))))) + (format "%s.%d.%d" gnus-newsgroup-name + (cdr gnus-article-current) + gnus-summary-save-parts-counter)))) dir))) + (incf gnus-summary-save-parts-counter) (unless (file-exists-p file) (mm-save-part-to-file handle file)))))) @@ -11414,7 +11880,7 @@ If REVERSE, save parts that do not match TYPE." (lambda (f) (if (equal f " ") f - (mm-quote-arg f))) + (shell-quote-argument f))) files " "))))) (setq ps (cdr ps))))) (if (and gnus-view-pseudos (not not-view)) @@ -11530,11 +11996,14 @@ If REVERSE, save parts that do not match TYPE." () ; Malformed head. (unless (gnus-summary-article-sparse-p (mail-header-number header)) (when (and (stringp id) - (not (string= (gnus-group-real-name group) - (car where)))) - ;; If we fetched by Message-ID and the article came - ;; from a different group, we fudge some bogus article - ;; numbers for this article. + (or + (not (string= (gnus-group-real-name group) + (car where))) + (not (gnus-server-equal gnus-override-method + (gnus-group-method group))))) + ;; If we fetched by Message-ID and the article came from + ;; a different group (or server), we fudge some bogus + ;; article numbers for this article. (mail-header-set-number header gnus-reffed-article-number)) (save-excursion (set-buffer gnus-summary-buffer) @@ -11566,8 +12035,8 @@ If REVERSE, save parts that do not match TYPE." ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. (when gnus-summary-selected-face (save-excursion - (let* ((beg (gnus-point-at-bol)) - (end (gnus-point-at-eol)) + (let* ((beg (point-at-bol)) + (end (point-at-eol)) ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>. (from (if (get-text-property beg gnus-mouse-face-prop) beg @@ -11616,7 +12085,7 @@ If REVERSE, save parts that do not match TYPE." (defun gnus-summary-highlight-line () "Highlight current line according to `gnus-summary-highlight'." - (let* ((beg (gnus-point-at-bol)) + (let* ((beg (point-at-bol)) (article (or (gnus-summary-article-number) gnus-current-article)) (score (or (cdr (assq article gnus-newsgroup-scored)) @@ -11632,7 +12101,7 @@ If REVERSE, save parts that do not match TYPE." (let ((face (funcall (gnus-summary-highlight-line-0)))) (unless (eq face (get-text-property beg 'face)) (gnus-put-text-property-excluding-characters-with-faces - beg (gnus-point-at-eol) 'face + beg (point-at-eol) 'face (setq face (if (boundp face) (symbol-value face) face))) (when gnus-summary-highlight-line-function (funcall gnus-summary-highlight-line-function article face)))))) @@ -11640,11 +12109,10 @@ If REVERSE, save parts that do not match TYPE." (defun gnus-update-read-articles (group unread &optional compute) "Update the list of read articles in GROUP. UNREAD is a sorted list." - (let* ((active (or gnus-newsgroup-active (gnus-active group))) - (entry (gnus-gethash group gnus-newsrc-hashtb)) - (info (nth 2 entry)) - (prev 1) - read) + (let ((active (or gnus-newsgroup-active (gnus-active group))) + (info (gnus-get-info group)) + (prev 1) + read) (if (or (not info) (not active)) ;; There is no info on this group if it was, in fact, ;; killed. Gnus stores no information on killed groups, so @@ -11712,8 +12180,7 @@ UNREAD is a sorted list." (dolist (buffer (buffer-list)) (when (and (setq buffer (buffer-name buffer)) (string-match "Summary" buffer) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer ;; We check that this is, indeed, a summary buffer. (and (eq major-mode 'gnus-summary-mode) ;; Also make sure this isn't bogus. @@ -11774,7 +12241,7 @@ treated as multipart/mixed." (insert "Mime-Version: 1.0\n") (widen) (when (search-forward "\n--" nil t) - (let ((separator (buffer-substring (point) (gnus-point-at-eol)))) + (let ((separator (buffer-substring (point) (point-at-eol)))) (message-narrow-to-head) (message-remove-header "Content-Type") (goto-char (point-max)) @@ -11885,12 +12352,24 @@ returned." (when gnus-suppress-duplicates (gnus-dup-suppress-articles)) - ;; We might want to build some more threads first. - (when (and gnus-fetch-old-headers - (eq gnus-headers-retrieved-by 'nov)) - (if (eq gnus-fetch-old-headers 'invisible) - (gnus-build-all-threads) - (gnus-build-old-threads))) + (if (and gnus-fetch-old-headers + (eq gnus-headers-retrieved-by 'nov)) + ;; We might want to build some more threads first. + (if (eq gnus-fetch-old-headers 'invisible) + (gnus-build-all-threads) + (gnus-build-old-threads)) + ;; Mark the inserted articles that are unread as unread. + (setq gnus-newsgroup-unreads + (gnus-sorted-nunion + gnus-newsgroup-unreads + (gnus-sorted-nintersection + (gnus-list-of-unread-articles gnus-newsgroup-name) + articles))) + ;; Mark the inserted articles as selected so that the information + ;; of the marks having been changed by a user may be updated when + ;; exiting this group. See `gnus-summary-update-info'. + (dolist (art articles) + (setq gnus-newsgroup-unselected (delq art gnus-newsgroup-unselected)))) ;; Let the Gnus agent mark articles as read. (when gnus-agent (gnus-agent-get-undownloaded-list)) @@ -11950,8 +12429,7 @@ If ALL is a number, fetch this number of articles." (read-string (format "How many articles from %s (%s %d): " - (gnus-limit-string - (gnus-group-decoded-name gnus-newsgroup-name) 35) + (gnus-group-decoded-name gnus-newsgroup-name) (if initial "max" "default") len) (if initial @@ -11994,7 +12472,7 @@ If ALL is a number, fetch this number of articles." (push i new) (decf i)) (if (not new) - (message "No gnus is bad news.") + (message "No gnus is bad news") (gnus-summary-insert-articles new) (setq gnus-newsgroup-unreads (gnus-sorted-nunion gnus-newsgroup-unreads new)) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 3d85d4ccf5c..a05520ea1fd 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -105,16 +105,16 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-group-topic-name () "The name of the topic on the current line." - (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) + (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) (and topic (symbol-name topic)))) (defun gnus-group-topic-level () "The level of the topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) + (get-text-property (point-at-bol) 'gnus-topic-level)) (defun gnus-group-topic-unread () "The number of unread articles in topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) + (get-text-property (point-at-bol) 'gnus-topic-unread)) (defun gnus-topic-unread (topic) "Return the number of unread articles in TOPIC." @@ -127,7 +127,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-topic-visible-p () "Return non-nil if the current topic is visible." - (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) + (get-text-property (point-at-bol) 'gnus-topic-visible)) (defun gnus-topic-articles-in-topic (entries) (let ((total 0) @@ -167,9 +167,11 @@ See Info node `(gnus)Formatting Variables'." (list (completing-read "Go to topic: " (mapcar 'list (gnus-topic-list)) nil t))) - (dolist (topic (gnus-current-topics topic)) - (gnus-topic-goto-topic topic) - (gnus-topic-fold t)) + (let ((buffer-read-only nil)) + (dolist (topic (gnus-current-topics topic)) + (unless (gnus-topic-goto-topic topic) + (gnus-topic-goto-missing-topic topic) + (gnus-topic-display-missing-topic topic)))) (gnus-topic-goto-topic topic)) (defun gnus-current-topic () @@ -196,9 +198,7 @@ If TOPIC, start with that topic." (defun gnus-group-active-topic-p () "Say whether the current topic comes from the active topics." - (save-excursion - (beginning-of-line) - (get-text-property (point) 'gnus-active))) + (get-text-property (point-at-bol) 'gnus-active)) (defun gnus-topic-find-groups (topic &optional level all lowest recursive) "Return entries for all visible groups in TOPIC. @@ -210,7 +210,7 @@ If RECURSIVE is t, return groups in its subtopics too." ;; We go through the newsrc to look for matches. (while groups (when (setq group (pop groups)) - (setq entry (gnus-gethash group gnus-newsrc-hashtb) + (setq entry (gnus-group-entry group) info (nth 2 entry) params (gnus-info-params info) active (gnus-active group) @@ -244,13 +244,12 @@ If RECURSIVE is t, return groups in its subtopics too." (when recursive (if (eq recursive t) (setq recursive (cdr (gnus-topic-find-topology topic)))) - (mapcar (lambda (topic-topology) - (setq visible-groups - (nconc visible-groups - (gnus-topic-find-groups - (caar topic-topology) - level all lowest topic-topology)))) - (cdr recursive))) + (dolist (topic-topology (cdr recursive)) + (setq visible-groups + (nconc visible-groups + (gnus-topic-find-groups + (caar topic-topology) + level all lowest topic-topology))))) visible-groups)) (defun gnus-topic-goto-previous-topic (n) @@ -351,7 +350,7 @@ If RECURSIVE is t, return groups in its subtopics too." (setq topology gnus-topic-topology gnus-tmp-topics nil)) (push (caar topology) gnus-tmp-topics) - (mapcar 'gnus-topic-list (cdr topology)) + (mapc 'gnus-topic-list (cdr topology)) gnus-tmp-topics) ;;; Topic parameter jazz @@ -378,39 +377,50 @@ If RECURSIVE is t, return groups in its subtopics too." (format "(gnus-topic-set-parameters %S '%S)" topic parameters)))) (defun gnus-group-topic-parameters (group) - "Compute the group parameters for GROUP taking into account inheritance from topics." + "Compute the group parameters for GROUP in topic mode. +Possibly inherit parameters from topics above GROUP." (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) (save-excursion - (nconc params-list - (gnus-topic-hierarchical-parameters - ;; First we try to go to the group within the group - ;; buffer and find the topic for the group that way. - ;; This hopefully copes well with groups that are in - ;; more than one topic. Failing that (i.e. when the - ;; group isn't visible in the group buffer) we find a - ;; topic for the group via gnus-group-topic. - (or (and (gnus-group-goto-group group) - (gnus-current-topic)) - (gnus-group-topic group))))))) - -(defun gnus-topic-hierarchical-parameters (topic) - "Return a topic list computed for TOPIC." - (let ((topics (gnus-current-topics topic)) - params-list param out params) - (while topics - (push (gnus-topic-parameters (pop topics)) params-list)) - ;; We probably have lots of nil elements here, so - ;; we remove them. Probably faster than doing this "properly". - (setq params-list (delq nil params-list)) + (gnus-topic-hierarchical-parameters + ;; First we try to go to the group within the group buffer and find the + ;; topic for the group that way. This hopefully copes well with groups + ;; that are in more than one topic. Failing that (i.e. when the group + ;; isn't visible in the group buffer) we find a topic for the group via + ;; gnus-group-topic. + (or (and (gnus-group-goto-group group) + (gnus-current-topic)) + (gnus-group-topic group)) + params-list)))) + +(defun gnus-topic-hierarchical-parameters (topic &optional group-params-list) + "Compute the topic parameters for TOPIC. +Possibly inherit parameters from topics above TOPIC. +If optional argument GROUP-PARAMS-LIST is non-nil, use it as the basis for +inheritance." + (let ((params-list + ;; We probably have lots of nil elements here, so we remove them. + ;; Probably faster than doing this "properly". + (delq nil (cons group-params-list + (mapcar 'gnus-topic-parameters + (gnus-current-topics topic))))) + param out params) ;; Now we have all the parameters, so we go through them ;; and do inheritance in the obvious way. - (while (setq params (pop params-list)) - (while (setq param (pop params)) - (when (atom param) - (setq param (cons param t))) - ;; Override any old versions of this param. - (gnus-pull (car param) out) - (push param out))) + (let (posting-style) + (while (setq params (pop params-list)) + (while (setq param (pop params)) + (when (atom param) + (setq param (cons param t))) + (cond ((eq (car param) 'posting-style) + (let ((param (cdr param)) + elt) + (while (setq elt (pop param)) + (unless (assoc (car elt) posting-style) + (push elt posting-style))))) + (t + (unless (assq (car param) out) + (push param out)))))) + (and posting-style (push (cons 'posting-style posting-style) out))) ;; Return the resulting parameter list. out)) @@ -465,7 +475,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead (gnus-remove-if (lambda (group) - (or (gnus-gethash group gnus-newsrc-hashtb) + (or (gnus-group-entry group) (gnus-gethash group gnus-killed-hashtb))) not-in-list) gnus-level-killed ?K regexp))) @@ -727,6 +737,9 @@ articles in the topic and its subtopics." (not (gnus-topic-goto-missing-topic (caadr parent)))) (gnus-topic-display-missing-topic (caadr parent)))) (gnus-topic-goto-missing-topic topic) + ;; Skip past all groups in the topic we're in. + (while (gnus-group-group-name) + (forward-line 1)) (let* ((top (gnus-topic-find-topology topic)) (children (cddr top)) (type (cadr top)) @@ -848,8 +861,7 @@ articles in the topic and its subtopics." (pop topics))) ;; Go through all living groups and make sure that ;; they belong to some topic. - (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) - gnus-topic-alist))) + (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) (newsrc (cdr gnus-newsrc-alist)) group) @@ -863,7 +875,7 @@ articles in the topic and its subtopics." (while (setq topic (pop alist)) (while (cdr topic) (if (and (cadr topic) - (gnus-gethash (cadr topic) gnus-newsrc-hashtb)) + (gnus-group-entry (cadr topic))) (setq topic (cdr topic)) (setcdr topic (cddr topic))))))) @@ -893,7 +905,7 @@ articles in the topic and its subtopics." (let ((topic-name (pop topic)) group filtered-topic) (while (setq group (pop topic)) - (when (and (or (gnus-gethash group gnus-active-hashtb) + (when (and (or (gnus-active group) (gnus-info-method (gnus-get-info group))) (not (gnus-gethash group gnus-killed-hashtb))) (push group filtered-topic))) @@ -1142,7 +1154,7 @@ articles in the topic and its subtopics." (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (gnus-set-format 'topic t) - (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) + (add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) @@ -1297,15 +1309,13 @@ If COPYP, copy the groups instead." entry) (if (and (not groups) (not copyp) start-topic) (gnus-topic-move start-topic topic) - (mapcar - (lambda (g) - (gnus-group-remove-mark g use-marked) - (when (and - (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) - (not copyp)) - (setcdr entry (gnus-delete-first g (cdr entry)))) - (nconc topicl (list g))) - groups) + (dolist (g groups) + (gnus-group-remove-mark g use-marked) + (when (and + (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) + (not copyp)) + (setcdr entry (gnus-delete-first g (cdr entry)))) + (nconc topicl (list g))) (gnus-topic-enter-dribble) (if start-group (gnus-group-goto-group start-group) @@ -1318,7 +1328,7 @@ If COPYP, copy the groups instead." (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n))) - (mapcar + (mapc (lambda (group) (gnus-group-remove-mark group use-marked) (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) @@ -1735,9 +1745,7 @@ If REVERSE, reverse the sorting order." (if (gnus-topic-find-topology to current-top 0);; Don't care the level (error "Can't move `%s' to its sub-level" current)) (gnus-topic-find-topology current nil nil 'delete) - (while (cdr to-top) - (setq to-top (cdr to-top))) - (setcdr to-top (list current-top)) + (setcdr (last to-top) (list current-top)) (gnus-topic-enter-dribble) (gnus-group-list-groups) (gnus-topic-goto-topic current))) diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 47106a49aa5..855b527b883 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -50,7 +50,6 @@ (require 'gnus-util) (require 'gnus) -(require 'custom) (defgroup gnus-undo nil "Undoing in Gnus buffers." @@ -113,7 +112,7 @@ ;; Set up the menu. (when (gnus-visual-p 'undo-menu 'menu) (gnus-undo-make-menu-bar)) - (gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) + (add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) (gnus-make-local-hook 'post-command-hook) (add-hook 'post-command-hook 'gnus-undo-boundary nil t) (gnus-run-hooks 'gnus-undo-mode-hook))) @@ -187,8 +186,7 @@ A numeric argument serves as a repeat count." (error "Nothing further to undo")) (setq gnus-undo-actions (delq action gnus-undo-actions)) (setq gnus-undo-boundary t) - (while action - (funcall (pop action))))) + (mapc 'funcall action))) (provide 'gnus-undo) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 3d3e4148c2d..cf174d90ac8 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -31,11 +31,10 @@ ;; Gnus first. ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the -;; autoloads below...] +;; autoloads and defvars below...] ;;; Code: -(require 'custom) (eval-when-compile (require 'cl) ;; Fixme: this should be a gnus variable, not nnmail-. @@ -67,7 +66,7 @@ ;; (replace-in-string "foo" "/*$" "/") ;; (replace-in-string "xe" "\\(x\\)?" "") ((fboundp 'replace-regexp-in-string) - (defun gnus-replace-in-string (string regexp newtext &optional literal) + (defun gnus-replace-in-string (string regexp newtext &optional literal) "Replace all matches for REGEXP with NEWTEXT in STRING. If LITERAL is non-nil, insert NEWTEXT literally. Return a new string containing the replacements. @@ -75,25 +74,7 @@ string containing the replacements. This is a compatibility function for different Emacsen." (replace-regexp-in-string regexp newtext string nil literal))) ((fboundp 'replace-in-string) - (defalias 'gnus-replace-in-string 'replace-in-string)) - (t - (defun gnus-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. - -This is a compatibility function for different Emacsen." - (let ((start 0) tail) - (while (string-match regexp string start) - (setq tail (- (length string) (match-end 0))) - (setq string (replace-match newtext nil literal string)) - (setq start (- (length string) tail)))) - string)))) - -;;; bring in the netrc functions as aliases -(defalias 'gnus-netrc-get 'netrc-get) -(defalias 'gnus-netrc-machine 'netrc-machine) -(defalias 'gnus-parse-netrc 'netrc-parse) + (defalias 'gnus-replace-in-string 'replace-in-string)))) (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." @@ -128,15 +109,6 @@ This is a compatibility function for different Emacsen." (set symbol nil)) symbol)) -;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way -;; to limit the length of a string. This function is necessary since -;; `(substr "abc" 0 30)' pukes with "Args out of range". -;; Fixme: Why not `truncate-string-to-width'? -(defsubst gnus-limit-string (str width) - (if (> (length str) width) - (substring str 0 width) - str)) - (defsubst gnus-goto-char (point) (and point (goto-char point))) @@ -146,16 +118,6 @@ This is a compatibility function for different Emacsen." (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) -(defalias 'gnus-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - -(defalias 'gnus-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position)) - ;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and ;; XEmacs. In Emacs we don't need to call `make-local-hook' first. ;; It's harmless, though, so the main purpose of this alias is to shut @@ -180,7 +142,7 @@ This is a compatibility function for different Emacsen." ;; Delete the current line (and the next N lines). (defmacro gnus-delete-line (&optional n) - `(delete-region (gnus-point-at-bol) + `(delete-region (point-at-bol) (progn (forward-line ,(or n 1)) (point)))) (defun gnus-byte-code (func) @@ -235,8 +197,7 @@ is slower." "Return the value of the header FIELD of current article." (save-excursion (save-restriction - (let ((case-fold-search t) - (inhibit-point-motion-hooks t)) + (let ((inhibit-point-motion-hooks t)) (nnheader-narrow-to-headers) (message-fetch-field field))))) @@ -248,7 +209,7 @@ is slower." (defun gnus-goto-colon () (beginning-of-line) - (let ((eol (gnus-point-at-eol))) + (let ((eol (point-at-eol))) (goto-char (or (text-property-any (point) eol 'gnus-position t) (search-forward ":" eol t) (point))))) @@ -263,12 +224,15 @@ is slower." (defun gnus-remove-text-with-property (prop) "Delete all text in the current buffer with text property PROP." - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (while (get-text-property (point) prop) - (delete-char 1)) - (goto-char (next-single-property-change (point) prop nil (point-max)))))) + (let ((start (point-min)) + end) + (unless (get-text-property start prop) + (setq start (next-single-property-change start prop))) + (while start + (setq end (text-property-any start (point-max) prop nil)) + (delete-region start (or end (point-max))) + (setq start (when end + (next-single-property-change start prop)))))) (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." @@ -501,6 +465,79 @@ jabbering all the time." :group 'gnus-start :type 'integer) +(defcustom gnus-add-timestamp-to-message nil + "Non-nil means add timestamps to messages that Gnus issues. +If it is `log', add timestamps to only the messages that go into the +\"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer). +If it is neither nil nor `log', add timestamps not only to log messages +but also to the ones displayed in the echo area." + :version "23.0" ;; No Gnus + :group 'gnus-various + :type '(choice :format "%{%t%}:\n %[Value Menu%] %v" + (const :tag "Logged messages only" log) + (sexp :tag "All messages" + :match (lambda (widget value) value) + :value t) + (const :tag "No timestamp" nil))) + +(eval-when-compile + (defmacro gnus-message-with-timestamp-1 (format-string args) + (let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time) + "." (format "%03d" (/ (nth 2 time) 1000)) "> "))) + (if (featurep 'xemacs) + `(let (str time) + (if (or (and (null ,format-string) (null ,args)) + (progn + (setq str (apply 'format ,format-string ,args)) + (zerop (length str)))) + (prog1 + (and ,format-string str) + (clear-message nil)) + (cond ((eq gnus-add-timestamp-to-message 'log) + (setq time (current-time)) + (display-message 'no-log str) + (log-message 'message (concat ,@timestamp str))) + (gnus-add-timestamp-to-message + (setq time (current-time)) + (display-message 'message (concat ,@timestamp str))) + (t + (display-message 'message str)))) + str) + `(let (str time) + (cond ((eq gnus-add-timestamp-to-message 'log) + (setq str (let (message-log-max) + (apply 'message ,format-string ,args))) + (when (and message-log-max + (> message-log-max 0) + (/= (length str) 0)) + (setq time (current-time)) + (with-current-buffer (get-buffer-create "*Messages*") + (goto-char (point-max)) + (insert ,@timestamp str "\n") + (forward-line (- message-log-max)) + (delete-region (point-min) (point)) + (goto-char (point-max)))) + str) + (gnus-add-timestamp-to-message + (if (or (and (null ,format-string) (null ,args)) + (progn + (setq str (apply 'format ,format-string ,args)) + (zerop (length str)))) + (prog1 + (and ,format-string str) + (message nil)) + (setq time (current-time)) + (message "%s" (concat ,@timestamp str)) + str)) + (t + (apply 'message ,format-string ,args)))))))) + +(defun gnus-message-with-timestamp (format-string &rest args) + "Display message with timestamp. Arguments are the same as `message'. +The `gnus-add-timestamp-to-message' variable controls how to add +timestamp to message." + (gnus-message-with-timestamp-1 format-string args)) + (defun gnus-message (level &rest args) "If LEVEL is lower than `gnus-verbose' print ARGS using `message'. @@ -509,7 +546,9 @@ Guideline for numbers: that take a long time, 7 - not very important messages on stuff, 9 - messages inside loops." (if (<= level gnus-verbose) - (apply 'message args) + (if gnus-add-timestamp-to-message + (apply 'gnus-message-with-timestamp args) + (apply 'message args)) ;; We have to do this format thingy here even if the result isn't ;; shown - the return value has to be the same as the return value ;; from `message'. @@ -530,12 +569,23 @@ ARGS are passed to `message'." (defun gnus-split-references (references) "Return a list of Message-IDs in REFERENCES." (let ((beg 0) + (references (or references "")) ids) (while (string-match "<[^<]+[^< \t]" references beg) (push (substring references (match-beginning 0) (setq beg (match-end 0))) ids)) (nreverse ids))) +(defun gnus-extract-references (references) + "Return a list of Message-IDs in REFERENCES (in In-Reply-To + format), trimmed to only contain the Message-IDs." + (let ((ids (gnus-split-references references)) + refs) + (dolist (id ids) + (when (string-match "<[^<>]+>" id) + (push (match-string 0 id) refs))) + refs)) + (defsubst gnus-parent-id (references &optional n) "Return the last Message-ID in REFERENCES. If N, return the Nth ancestor instead." @@ -709,11 +759,11 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and `print-level' to nil. See also `gnus-bind-print-variables'." (gnus-bind-print-variables (prin1-to-string form))) -(defun gnus-pp (form) +(defun gnus-pp (form &optional stream) "Use `pp' on FORM in the current buffer. Bind `print-quoted' and `print-readably' to t, and `print-length' and `print-level' to nil. See also `gnus-bind-print-variables'." - (gnus-bind-print-variables (pp form (current-buffer)))) + (gnus-bind-print-variables (pp form (or stream (current-buffer))))) (defun gnus-pp-to-string (form) "The same as `pp-to-string'. @@ -732,9 +782,9 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." - ;; Make sure the directory exists. - (gnus-make-directory (file-name-directory file)) (let ((file-name-coding-system nnmail-pathname-coding-system)) + ;; Make sure the directory exists. + (gnus-make-directory (file-name-directory file)) ;; Write the buffer. (write-region (point-min) (point-max) file nil 'quietly))) @@ -1149,8 +1199,12 @@ Return the modified alist." t)) (defun gnus-write-active-file (file hashtb &optional full-names) + ;; `coding-system-for-write' should be `raw-text' or equivalent. (let ((coding-system-for-write nnmail-active-file-coding-system)) (with-temp-file file + ;; The buffer should be in the unibyte mode because group names + ;; are ASCII text or encoded non-ASCII text (i.e., unibyte). + (mm-disable-multibyte) (mapatoms (lambda (sym) (when (and sym @@ -1236,6 +1290,13 @@ Return the modified alist." (remove-text-properties start end properties object)) t)) +(defun gnus-string-remove-all-properties (string) + (condition-case () + (let ((s string)) + (set-text-properties 0 (length string) nil string) + s) + (error string))) + ;; This might use `compare-strings' to reduce consing in the ;; case-insensitive case, but it has to cope with null args. ;; (`string-equal' uses symbol print names.) @@ -1350,32 +1411,12 @@ SPEC is a predicate specifier that contains stuff like `or', `and', `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) -(defun gnus-local-map-property (map) - "Return a list suitable for a text property list specifying keymap MAP." - (cond - ((featurep 'xemacs) - (list 'keymap map)) - ((>= emacs-major-version 21) - (list 'keymap map)) - (t - (list 'local-map map)))) - -(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate - require-match initial-contents - history default) - "Like `completing-read', allowing for non-existent 7th arg in older XEmacsen." - `(completing-read ,prompt ,table ,predicate ,require-match - ,initial-contents ,history - ,@(if (and (featurep 'xemacs) (< emacs-minor-version 2)) - () - (list default)))) - (defun gnus-completing-read (prompt table &optional predicate require-match history) (when (and history (not (boundp history))) (set history nil)) - (gnus-completing-read-maybe-default + (completing-read (if (symbol-value history) (concat prompt " (" (car (symbol-value history)) "): ") (concat prompt ": ")) @@ -1616,13 +1657,16 @@ predicate on the elements." ((or (featurep 'sxemacs) (featurep 'xemacs)) ;; XEmacs or SXEmacs: (concat emacsname "/" emacs-program-version - " (" - (when (and (memq 'codename lst) - codename) - (concat codename - (when system-v ", "))) - (when system-v system-v) - ")")) + (let (plst) + (when (memq 'codename lst) + (push codename plst)) + (when system-v + (push system-v plst)) + (unless (featurep 'mule) + (push "no MULE" plst)) + (when (> (length plst) 0) + (concat + " (" (mapconcat 'identity (reverse plst) ", ") ")"))))) (t emacs-version)))) (defun gnus-rename-file (old-path new-path &optional trim) @@ -1646,6 +1690,11 @@ empty directories from OLD-PATH." (file-truename (concat old-dir ".."))))))))) +(defun gnus-set-file-modes (filename mode) + "Wrapper for set-file-modes." + (ignore-errors + (set-file-modes filename mode))) + (if (fboundp 'set-process-query-on-exit-flag) (defalias 'gnus-set-process-query-on-exit-flag 'set-process-query-on-exit-flag) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 86253f0deef..20937562096 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -393,7 +393,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (list current-prefix-arg (read-file-name (if gnus-uu-save-separate-articles - "Save articles is dir: " + "Save articles in dir: " "Save articles in file: ") gnus-uu-default-dir gnus-uu-default-dir))) @@ -482,11 +482,24 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (setq message-forward-as-mime (not message-forward-as-mime) n nil)) (let ((gnus-article-reply (gnus-summary-work-articles n))) + (when (and (not n) + (= (length gnus-article-reply) 1)) + ;; The case where neither a number of articles nor a region is + ;; specified. + (gnus-summary-top-thread) + (setq gnus-article-reply (nreverse (gnus-uu-find-articles-matching)))) (gnus-setup-message 'forward (setq gnus-uu-digest-from-subject nil) (setq gnus-uu-digest-buffer (gnus-get-buffer-create " *gnus-uu-forward*")) - (gnus-uu-decode-save n file) + ;; Specify articles to be forwarded. Note that they should be + ;; reversed; see `gnus-uu-get-list-of-articles'. + (let ((gnus-newsgroup-processable (reverse gnus-article-reply))) + (gnus-uu-decode-save n file) + (setq gnus-article-reply gnus-newsgroup-processable)) + ;; Restore the value of `gnus-newsgroup-processable' to which + ;; it should be set when it is not `let'-bound. + (setq gnus-newsgroup-processable (reverse gnus-article-reply)) (switch-to-buffer gnus-uu-digest-buffer) (let ((fs gnus-uu-digest-from-subject)) (when fs @@ -511,11 +524,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time." "Various")))) (goto-char (point-min)) (when (re-search-forward "^Subject: ") - (delete-region (point) (gnus-point-at-eol)) + (delete-region (point) (point-at-eol)) (insert subject)) (goto-char (point-min)) (when (re-search-forward "^From:") - (delete-region (point) (gnus-point-at-eol)) + (delete-region (point) (point-at-eol)) (insert " " from)) (let ((message-forward-decoded-p t)) (message-forward post t)))) @@ -530,19 +543,19 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (defun gnus-message-process-mark (unmarkp new-marked) (let ((old (- (length gnus-newsgroup-processable) (length new-marked)))) - (message "%d mark%s %s%s" - (length new-marked) - (if (= (length new-marked) 1) "" "s") - (if unmarkp "removed" "added") - (cond - ((and (zerop old) - (not unmarkp)) - "") - (unmarkp - (format ", %d remain marked" - (length gnus-newsgroup-processable))) - (t - (format ", %d already marked" old)))))) + (gnus-message 6 "%d mark%s %s%s" + (length new-marked) + (if (= (length new-marked) 1) "" "s") + (if unmarkp "removed" "added") + (cond + ((and (zerop old) + (not unmarkp)) + "") + (unmarkp + (format ", %d remain marked" + (length gnus-newsgroup-processable))) + (t + (format ", %d already marked" old)))))) (defun gnus-new-processable (unmarkp articles) (if unmarkp @@ -570,16 +583,18 @@ When called interactively, prompt for REGEXP." (interactive "sUnmark (regexp): ") (gnus-uu-mark-by-regexp regexp t)) -(defun gnus-uu-mark-series () +(defun gnus-uu-mark-series (&optional silent) "Mark the current series with the process mark." (interactive) (let* ((articles (gnus-uu-find-articles-matching)) - (l (length articles))) + (l (length articles))) (while articles (gnus-summary-set-process-mark (car articles)) (setq articles (cdr articles))) - (message "Marked %d articles" l)) - (gnus-summary-position-point)) + (unless silent + (gnus-message 6 "Marked %d articles" l)) + (gnus-summary-position-point) + l)) (defun gnus-uu-mark-region (beg end &optional unmark) "Set the process mark on all articles between point and mark." @@ -687,14 +702,16 @@ When called interactively, prompt for REGEXP." (setq gnus-newsgroup-processable nil) (save-excursion (let ((data gnus-newsgroup-data) + (count 0) number) (while data (when (and (not (memq (setq number (gnus-data-number (car data))) gnus-newsgroup-processable)) (vectorp (gnus-data-header (car data)))) (gnus-summary-goto-subject number) - (gnus-uu-mark-series)) - (setq data (cdr data))))) + (setq count (+ count (gnus-uu-mark-series t)))) + (setq data (cdr data))) + (gnus-message 6 "Marked %d articles" count))) (gnus-summary-position-point)) ;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>. @@ -852,7 +869,7 @@ When called interactively, prompt for REGEXP." (save-restriction (set-buffer buffer) (let (buffer-read-only) - (gnus-set-text-properties (point-min) (point-max) nil) + (set-text-properties (point-min) (point-max) nil) ;; These two are necessary for XEmacs 19.12 fascism. (put-text-property (point-min) (point-max) 'invisible nil) (put-text-property (point-min) (point-max) 'intangible nil)) @@ -862,7 +879,7 @@ When called interactively, prompt for REGEXP." (mm-enable-multibyte) (mime-to-mml)) (goto-char (point-min)) - (re-search-forward "\n\n") + (search-forward "\n\n") (unless (and message-forward-as-mime gnus-uu-digest-buffer) ;; Quote all 30-dash lines. (save-excursion @@ -1153,7 +1170,7 @@ When called interactively, prompt for REGEXP." ;; Expand numbers, sort, and return the list of article ;; numbers. - (mapcar (lambda (sub) (cdr sub)) + (mapcar 'cdr (sort (gnus-uu-expand-numbers list-of-subjects (not do-not-translate)) @@ -1406,7 +1423,7 @@ When called interactively, prompt for REGEXP." (setq part (match-string 0 subject)) (setq subject (substring subject (match-end 0))))) (or part - (while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject) + (while (string-match "[0-9]+[^0-9]+[0-9]+" subject) (setq part (match-string 0 subject)) (setq subject (substring subject (match-end 0))))) (or part ""))) @@ -1708,8 +1725,7 @@ Gnus might fail to display all of it.") (defun gnus-uu-check-correct-stripped-uucode (start end) (save-excursion (let (found beg length) - (if (not gnus-uu-correct-stripped-uucode) - () + (unless gnus-uu-correct-stripped-uucode (goto-char start) (if (re-search-forward " \\|`" end t) @@ -1722,19 +1738,15 @@ Gnus might fail to display all of it.") (forward-line 1)))) (while (not (eobp)) - (if (looking-at (concat gnus-uu-begin-string "\\|" - gnus-uu-end-string)) - () + (unless (looking-at (concat gnus-uu-begin-string "\\|" + gnus-uu-end-string)) (when (not found) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq length (- (point) beg))) + (setq length (- (point-at-eol) (point-at-bol)))) (setq found t) (beginning-of-line) (setq beg (point)) (end-of-line) - (when (not (= length (- (point) beg))) + (unless (= length (- (point) beg)) (insert (make-string (- length (- (point) beg)) ? )))) (forward-line 1))))))) @@ -1759,7 +1771,7 @@ Gnus might fail to display all of it.") (setq gnus-uu-work-dir (mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) - (set-file-modes gnus-uu-work-dir 448) + (gnus-set-file-modes gnus-uu-work-dir 448) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) gnus-uu-tmp-alist)))) @@ -1779,7 +1791,7 @@ Gnus might fail to display all of it.") ;; that the filename will be treated as a single argument when the shell ;; executes the command. (defun gnus-uu-command (action file) - (let ((quoted-file (mm-quote-arg file))) + (let ((quoted-file (shell-quote-argument file))) (if (string-match "%s" action) (format action quoted-file) (concat action " " quoted-file)))) @@ -1903,7 +1915,7 @@ The user will be asked for a file name." (when (gnus-uu-post-encode-file "uuencode" path file-name) (goto-char (point-min)) (forward-line 1) - (while (re-search-forward " " nil t) + (while (search-forward " " nil t) (replace-match "`")) t)) @@ -2034,8 +2046,7 @@ If no file has been included, the user will be asked for a file." (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) - (beginning-of-line) - (setq header (buffer-substring (point-min) (point))) + (setq header (buffer-substring (point-min) (point-at-bol))) (goto-char (point-min)) (when gnus-uu-post-separate-description @@ -2111,8 +2122,7 @@ If no file has been included, the user will be asked for a file." (when (not gnus-uu-post-separate-description) (set-buffer-modified-p nil) - (when (fboundp 'bury-buffer) - (bury-buffer))))) + (bury-buffer)))) (provide 'gnus-uu) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 7e1609cc196..60cc5247d05 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -120,6 +120,10 @@ used to display Gnus windows." (vertical 1.0 (summary 0.25) (edit-score 1.0 point))) + (edit-server + (vertical 1.0 + (server 0.5) + (edit-form 1.0 point))) (post (vertical 1.0 (post 1.0 point))) @@ -166,8 +170,12 @@ used to display Gnus windows." (article 0.5) (message 1.0 point))) (display-term - (vertical 1.0 - ("*display*" 1.0)))) + (vertical 1.0 + ("*display*" 1.0))) + (mml-preview + (vertical 1.0 + (message 0.5) + (mml-preview 1.0 point)))) "Window configuration for all possible Gnus buffers. See the Gnus manual for an explanation of the syntax used.") @@ -195,7 +203,8 @@ See the Gnus manual for an explanation of the syntax used.") (info . gnus-info-buffer) (category . gnus-category-buffer) (article-copy . gnus-article-copy) - (draft . gnus-draft-buffer)) + (draft . gnus-draft-buffer) + (mml-preview . mml-preview-buffer)) "Mapping from short symbols to buffer names or buffer variables.") (defcustom gnus-configure-windows-hook nil diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 6fe8b1c3cbe..b09511ea9c4 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -289,7 +289,7 @@ is restarted, and sometimes reloaded." :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "5.11" +(defconst gnus-version-number "5.13" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -310,9 +310,6 @@ be set in `.emacs' instead." (unless (fboundp 'gnus-group-remove-excess-properties) (defalias 'gnus-group-remove-excess-properties 'ignore)) -(unless (fboundp 'gnus-set-text-properties) - (defalias 'gnus-set-text-properties 'set-text-properties)) - (unless (featurep 'gnus-xmas) (defalias 'gnus-make-overlay 'make-overlay) (defalias 'gnus-delete-overlay 'delete-overlay) @@ -323,7 +320,6 @@ be set in `.emacs' instead." (defalias 'gnus-overlay-end 'overlay-end) (defalias 'gnus-extent-detached-p 'ignore) (defalias 'gnus-extent-start-open 'ignore) - (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window) (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) (defalias 'gnus-character-to-event 'identity) (defalias 'gnus-assq-delete-all 'assq-delete-all) @@ -563,7 +559,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-1 '((((class color) (background dark)) - (:foreground "aquamarine1" :bold t)) + (:foreground "#e1ffe1" :bold t)) (((class color) (background light)) (:foreground "DeepPink3" :bold t)) @@ -577,7 +573,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-1-empty '((((class color) (background dark)) - (:foreground "aquamarine1")) + (:foreground "#e1ffe1")) (((class color) (background light)) (:foreground "DeepPink3")) @@ -591,7 +587,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-2 '((((class color) (background dark)) - (:foreground "aquamarine2" :bold t)) + (:foreground "DarkSeaGreen1" :bold t)) (((class color) (background light)) (:foreground "HotPink3" :bold t)) @@ -605,7 +601,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-2-empty '((((class color) (background dark)) - (:foreground "aquamarine2")) + (:foreground "DarkSeaGreen1")) (((class color) (background light)) (:foreground "HotPink3")) @@ -619,7 +615,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-3 '((((class color) (background dark)) - (:foreground "aquamarine3" :bold t)) + (:foreground "aquamarine1" :bold t)) (((class color) (background light)) (:foreground "magenta4" :bold t)) @@ -633,7 +629,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-3-empty '((((class color) (background dark)) - (:foreground "aquamarine3")) + (:foreground "aquamarine1")) (((class color) (background light)) (:foreground "magenta4")) @@ -647,7 +643,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-low '((((class color) (background dark)) - (:foreground "aquamarine4" :bold t)) + (:foreground "aquamarine2" :bold t)) (((class color) (background light)) (:foreground "DeepPink4" :bold t)) @@ -661,7 +657,7 @@ be set in `.emacs' instead." (defface gnus-group-mail-low-empty '((((class color) (background dark)) - (:foreground "aquamarine4")) + (:foreground "aquamarine2")) (((class color) (background light)) (:foreground "DeepPink4")) @@ -923,7 +919,7 @@ be set in `.emacs' instead." (defface gnus-splash '((((class color) (background dark)) - (:foreground "#888888")) + (:foreground "#cccccc")) (((class color) (background light)) (:foreground "#888888")) @@ -978,12 +974,12 @@ be set in `.emacs' instead." (storm "#666699" "#99ccff") (pdino "#9999cc" "#99ccff") (purp "#9999cc" "#666699") - (no "#000000" "#ff0000") + (no "#ff0000" "#ffff00") (neutral "#b4b4b4" "#878787") (september "#bf9900" "#ffcc00")) "Color alist used for the Gnus logo.") -(defcustom gnus-logo-color-style 'oort +(defcustom gnus-logo-color-style 'no "*Color styles used for the Gnus logo." :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) gnus-logo-color-alist)) @@ -1034,23 +1030,23 @@ be set in `.emacs' instead." (t (insert (format " %s - _ ___ _ _ - _ ___ __ ___ __ _ ___ - __ _ ___ __ ___ - _ ___ _ - _ _ __ _ - ___ __ _ - __ _ - _ _ _ - _ _ _ - _ _ _ - __ ___ - _ _ _ _ - _ _ - _ _ - _ _ - _ - __ + _ ___ _ _ + _ ___ __ ___ __ _ ___ + __ _ ___ __ ___ + _ ___ _ + _ _ __ _ + ___ __ _ + __ _ + _ _ _ + _ _ _ + _ _ _ + __ ___ + _ _ _ _ + _ _ + _ _ + _ _ + _ + __ " "")) @@ -1294,12 +1290,30 @@ see the manual for details." (defcustom gnus-message-archive-method "archive" "*Method used for archiving messages you've sent. -This should be a mail method." +This should be a mail method. + +See also `gnus-update-message-archive-method'." :group 'gnus-server :group 'gnus-message :type '(choice (const :tag "Default archive method" "archive") gnus-select-method)) +(defcustom gnus-update-message-archive-method nil + "Non-nil means always update the saved \"archive\" method. + +The archive method is initially set according to the value of +`gnus-message-archive-method' and is saved in the \"~/.newsrc.eld\" file +so that it may be used as a real method of the server which is named +\"archive\" ever since. If it once has been saved, it will never be +updated if the value of this variable is nil, even if you change the +value of `gnus-message-archive-method' afterward. If you want the +saved \"archive\" method to be updated whenever you change the value of +`gnus-message-archive-method', set this variable to a non-nil value." + :version "23.0" ;; No Gnus + :group 'gnus-server + :group 'gnus-message + :type 'boolean) + (defcustom gnus-message-archive-group nil "*Name of the group in which to save the messages you've written. This can either be a string; a list of strings; or an alist @@ -1466,6 +1480,7 @@ When FORM is evaluated `name' is bound to the name of the group." :version "22.1" :group 'gnus-group-various :type '(repeat (cons (string :tag "Hierarchy") (sexp :tag "Form")))) +(put 'gnus-group-charter-alist 'risky-local-variable t) (defcustom gnus-group-fetch-control-use-browse-url nil "*Non-nil means that control messages are displayed using `browse-url'. @@ -1566,11 +1581,6 @@ cache to the full extent of the law." :group 'gnus-meta :type 'boolean) -(defcustom gnus-use-grouplens nil - "*If non-nil, use GroupLens ratings." - :group 'gnus-meta - :type 'boolean) - (defcustom gnus-keep-backlog 20 "*If non-nil, Gnus will keep read articles for later re-retrieval. If it is a number N, then Gnus will only keep the last N articles @@ -2007,6 +2017,42 @@ When a spam group is entered, all unread articles are marked as spam. There is other behavior associated with ham and no classification when spam.el is loaded - see the manual.") + (gnus-define-group-parameter + spam-resend-to + :type list + :function-document + "The address to get spam resent (through spam-report-resend)." + :variable gnus-spam-resend-to + :variable-default nil + :variable-document + "The address to get spam resent (through spam-report-resend)." + :variable-group spam + :variable-type '(repeat + (list :tag "Group address for resending spam" + (regexp :tag "Group") + (string :tag "E-mail address for resending spam (requires the spam-use-resend exit processor)"))) + :parameter-type 'string :tag "E-mail address for resending spam (requires the spam-use-resend exit processor)" + :parameter-document + "The address to get spam resent (through spam-report-resend).") + + (gnus-define-group-parameter + ham-resend-to + :type list + :function-document + "The address to get ham resent (through spam-report-resend)." + :variable gnus-ham-resend-to + :variable-default nil + :variable-document + "The address to get ham resent (through spam-report-resend)." + :variable-group spam + :variable-type '(repeat + (list :tag "Group address for resending ham" + (regexp :tag "Group") + (string :tag "E-mail address for resending ham (requires the spam-use-resend exit processor)"))) + :parameter-type 'string :tag "E-mail address for resending ham (requires the spam-use-resend exit processor)" + :parameter-document + "The address to get ham resent (through spam-report-resend).") + (defvar gnus-group-spam-exit-processor-ifile "ifile" "OBSOLETE: The ifile summary exit spam processor.") @@ -2063,6 +2109,27 @@ Only applicable to non-spam (unclassified and ham) groups.") :value nil (list :tag "Spam Summary Exit Processor Choices" (set + (const :tag "Spam: Bogofilter" (spam spam-use-bogofilter)) + (const :tag "Spam: Blacklist" (spam spam-use-blacklist)) + (const :tag "Spam: Bsfilter" (spam spam-use-bsfilter)) + (const :tag "Spam: Gmane Report" (spam spam-use-gmane)) + (const :tag "Spam: Resend Message"(spam spam-use-resend)) + (const :tag "Spam: ifile" (spam spam-use-ifile)) + (const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle)) + (const :tag "Spam: Spam-stat" (spam spam-use-stat)) + (const :tag "Spam: SpamAssassin" (spam spam-use-spamassassin)) + (const :tag "Spam: CRM114" (spam spam-use-crm114)) + (const :tag "Ham: BBDB" (ham spam-use-BBDB)) + (const :tag "Ham: Bogofilter" (ham spam-use-bogofilter)) + (const :tag "Ham: Bsfilter" (ham spam-use-bsfilter)) + (const :tag "Ham: Copy" (ham spam-use-ham-copy)) + (const :tag "Ham: Resend Message" (ham spam-use-resend)) + (const :tag "Ham: ifile" (ham spam-use-ifile)) + (const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle)) + (const :tag "Ham: Spam-stat" (ham spam-use-stat)) + (const :tag "Ham: SpamAssassin" (ham spam-use-spamassassin)) + (const :tag "Ham: CRM114" (ham spam-use-crm114)) + (const :tag "Ham: Whitelist" (ham spam-use-whitelist)) (variable-item gnus-group-spam-exit-processor-ifile) (variable-item gnus-group-spam-exit-processor-stat) (variable-item gnus-group-spam-exit-processor-bogofilter) @@ -2075,20 +2142,7 @@ Only applicable to non-spam (unclassified and ham) groups.") (variable-item gnus-group-ham-exit-processor-whitelist) (variable-item gnus-group-ham-exit-processor-BBDB) (variable-item gnus-group-ham-exit-processor-spamoracle) - (variable-item gnus-group-ham-exit-processor-copy) - (const :tag "Spam: Gmane Report" (spam spam-use-gmane)) - (const :tag "Spam: Bogofilter" (spam spam-use-bogofilter)) - (const :tag "Spam: Blacklist" (spam spam-use-blacklist)) - (const :tag "Spam: ifile" (spam spam-use-ifile)) - (const :tag "Spam: Spam-stat" (spam spam-use-stat)) - (const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle)) - (const :tag "Ham: ifile" (ham spam-use-ifile)) - (const :tag "Ham: Bogofilter" (ham spam-use-bogofilter)) - (const :tag "Ham: Spam-stat" (ham spam-use-stat)) - (const :tag "Ham: Whitelist" (ham spam-use-whitelist)) - (const :tag "Ham: BBDB" (ham spam-use-BBDB)) - (const :tag "Ham: Copy" (ham spam-use-ham-copy)) - (const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle))))) + (variable-item gnus-group-ham-exit-processor-copy)))) :function-document "Which spam or ham processors will be applied when the summary is exited." :variable gnus-spam-process-newsgroups @@ -2105,6 +2159,27 @@ spam processing, associated with the appropriate processor." (regexp :tag "Group Regexp") (set :tag "Spam/Ham Summary Exit Processor" + (const :tag "Spam: Bogofilter" (spam spam-use-bogofilter)) + (const :tag "Spam: Blacklist" (spam spam-use-blacklist)) + (const :tag "Spam: Bsfilter" (spam spam-use-bsfilter)) + (const :tag "Spam: Gmane Report" (spam spam-use-gmane)) + (const :tag "Spam: Resend Message"(spam spam-use-resend)) + (const :tag "Spam: ifile" (spam spam-use-ifile)) + (const :tag "Spam: Spam-stat" (spam spam-use-stat)) + (const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle)) + (const :tag "Spam: SpamAssassin" (spam spam-use-spamassassin)) + (const :tag "Spam: CRM114" (spam spam-use-crm114)) + (const :tag "Ham: BBDB" (ham spam-use-BBDB)) + (const :tag "Ham: Bogofilter" (ham spam-use-bogofilter)) + (const :tag "Ham: Bsfilter" (ham spam-use-bsfilter)) + (const :tag "Ham: Copy" (ham spam-use-ham-copy)) + (const :tag "Ham: Resend Message" (ham spam-use-resend)) + (const :tag "Ham: ifile" (ham spam-use-ifile)) + (const :tag "Ham: Spam-stat" (ham spam-use-stat)) + (const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle)) + (const :tag "Ham: SpamAssassin" (ham spam-use-spamassassin)) + (const :tag "Ham: CRM114" (ham spam-use-crm114)) + (const :tag "Ham: Whitelist" (ham spam-use-whitelist)) (variable-item gnus-group-spam-exit-processor-ifile) (variable-item gnus-group-spam-exit-processor-stat) (variable-item gnus-group-spam-exit-processor-bogofilter) @@ -2117,20 +2192,7 @@ spam processing, associated with the appropriate processor." (variable-item gnus-group-ham-exit-processor-whitelist) (variable-item gnus-group-ham-exit-processor-BBDB) (variable-item gnus-group-ham-exit-processor-spamoracle) - (variable-item gnus-group-ham-exit-processor-copy) - (const :tag "Spam: Gmane Report" (spam spam-use-gmane)) - (const :tag "Spam: Bogofilter" (spam spam-use-bogofilter)) - (const :tag "Spam: Blacklist" (spam spam-use-blacklist)) - (const :tag "Spam: ifile" (spam spam-use-ifile)) - (const :tag "Spam: Spam-stat" (spam spam-use-stat)) - (const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle)) - (const :tag "Ham: ifile" (ham spam-use-ifile)) - (const :tag "Ham: Bogofilter" (ham spam-use-bogofilter)) - (const :tag "Ham: Spam-stat" (ham spam-use-stat)) - (const :tag "Ham: Whitelist" (ham spam-use-whitelist)) - (const :tag "Ham: BBDB" (ham spam-use-BBDB)) - (const :tag "Ham: Copy" (ham spam-use-ham-copy)) - (const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle))))) + (variable-item gnus-group-ham-exit-processor-copy)))) :parameter-document "Which spam or ham processors will be applied when the summary is exited.") @@ -2169,12 +2231,18 @@ spam-autodetect-recheck-messages is set.") (const default) (set :tag "Use specific methods" (variable-item spam-use-blacklist) + (variable-item spam-use-gmane-xref) (variable-item spam-use-regex-headers) (variable-item spam-use-regex-body) (variable-item spam-use-whitelist) (variable-item spam-use-BBDB) (variable-item spam-use-ifile) (variable-item spam-use-spamoracle) + (variable-item spam-use-crm114) + (variable-item spam-use-spamassassin) + (variable-item spam-use-spamassassin-headers) + (variable-item spam-use-bsfilter) + (variable-item spam-use-bsfilter-headers) (variable-item spam-use-stat) (variable-item spam-use-blackholes) (variable-item spam-use-hashcash) @@ -2200,15 +2268,21 @@ set." (const default) (set :tag "Use specific methods" (variable-item spam-use-blacklist) + (variable-item spam-use-gmane-xref) (variable-item spam-use-regex-headers) (variable-item spam-use-regex-body) (variable-item spam-use-whitelist) (variable-item spam-use-BBDB) (variable-item spam-use-ifile) (variable-item spam-use-spamoracle) + (variable-item spam-use-crm114) (variable-item spam-use-stat) (variable-item spam-use-blackholes) (variable-item spam-use-hashcash) + (variable-item spam-use-spamassassin) + (variable-item spam-use-spamassassin-headers) + (variable-item spam-use-bsfilter) + (variable-item spam-use-bsfilter-headers) (variable-item spam-use-bogofilter-headers) (variable-item spam-use-bogofilter))))) :parameter-document @@ -2387,8 +2461,7 @@ It is called with three parameters -- GROUP, LEVEL and OLDLEVEL." summary-menu group-menu article-menu tree-highlight menu highlight browse-menu server-menu - page-marker tree-menu binary-menu pick-menu - grouplens-menu) + page-marker tree-menu binary-menu pick-menu) "*Enable visual features. If `visual' is disabled, there will be no menus and few faces. Most of the visual customization options below will be ignored. Gnus will use @@ -2402,8 +2475,7 @@ instance, to switch off all visual things except menus, you can say: Valid elements include `summary-highlight', `group-highlight', `article-highlight', `mouse-face', `summary-menu', `group-menu', `article-menu', `tree-highlight', `menu', `highlight', `browse-menu', -`server-menu', `page-marker', `tree-menu', `binary-menu', `pick-menu', -and `grouplens-menu'." +`server-menu', `page-marker', `tree-menu', `binary-menu', and`pick-menu'." :group 'gnus-meta :group 'gnus-visual :type '(set (const summary-highlight) @@ -2421,8 +2493,7 @@ and `grouplens-menu'." (const page-marker) (const tree-menu) (const binary-menu) - (const pick-menu) - (const grouplens-menu))) + (const pick-menu))) ;; Byte-compiler warning. (defvar gnus-visual) @@ -2527,7 +2598,7 @@ a string, be sure to use a valid format, see RFC 2616." (const codename :tag "Emacs codename"))) (string))) -;; Convert old (No Gnus < 2005-01-10, v5-10 < 2005-09-05) symbol type values: +;; Convert old (< 2005-01-10) symbol type values: (when (symbolp gnus-user-agent) (setq gnus-user-agent (cond ((eq gnus-user-agent 'emacs-gnus-config) @@ -2642,7 +2713,6 @@ such as a mark that says whether an article is stored in the cache (defvar gnus-headers-retrieved-by nil) (defvar gnus-article-reply nil) (defvar gnus-override-method nil) -(defvar gnus-article-check-size nil) (defvar gnus-opened-servers nil) (defvar gnus-current-kill-article nil) @@ -2737,7 +2807,7 @@ gnus-registry.el will populate this if it's loaded.") ;; This little mapcar goes through the list below and marks the ;; symbols in question as autoloaded functions. - (mapcar + (mapc (lambda (package) (let ((interactive (nth 1 (memq ':interactive package)))) (mapcar @@ -2836,7 +2906,7 @@ gnus-registry.el will populate this if it's loaded.") gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view gnus-uu-decode-binhex-view gnus-uu-unmark-thread - gnus-uu-mark-over gnus-uu-post-news) + gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable) ("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread) ("gnus-msg" (gnus-summary-send-map keymap) gnus-article-mail gnus-copy-article-buffer gnus-extended-version) @@ -2854,8 +2924,6 @@ gnus-registry.el will populate this if it's loaded.") gnus-summary-post-forward gnus-summary-wide-reply-with-original gnus-summary-post-forward) ("gnus-picon" :interactive t gnus-treat-from-picon) - ("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p - gnus-grouplens-mode) ("smiley" :interactive t smiley-region) ("gnus-win" gnus-configure-windows gnus-add-configuration) ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group @@ -2890,14 +2958,15 @@ gnus-registry.el will populate this if it's loaded.") gnus-article-hide-pem gnus-article-hide-signature gnus-article-strip-leading-blank-lines gnus-article-date-local gnus-article-date-original gnus-article-date-lapsed -;; gnus-article-show-all-headers + ;;gnus-article-show-all-headers gnus-article-edit-mode gnus-article-edit-article gnus-article-edit-done gnus-article-decode-encoded-words gnus-start-date-timer gnus-stop-date-timer gnus-mime-view-all-parts) ("gnus-int" gnus-request-type) ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 - gnus-dribble-enter gnus-read-init-file gnus-dribble-touch) + gnus-dribble-enter gnus-read-init-file gnus-dribble-touch + gnus-check-reasonable-setup) ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article gnus-dup-enter-articles) ("gnus-range" gnus-copy-sequence) @@ -2967,7 +3036,6 @@ with some simple extensions. %z Article zcore (character) %t Number of articles under the current thread (number). %e Whether the thread is empty or not (character). -%l GroupLens score (string). %V Total thread score (number). %P The line number (number). %O Download mark (character). @@ -3146,11 +3214,9 @@ Return nil if not defined." (defun gnus-shutdown (symbol) "Shut down everything that waits for SYMBOL." - (let ((alist gnus-shutdown-alist) - entry) - (while (setq entry (pop alist)) - (when (memq symbol (cdr entry)) - (funcall (car entry)))))) + (dolist (entry gnus-shutdown-alist) + (when (memq symbol (cdr entry)) + (funcall (car entry))))) ;;; @@ -3416,7 +3482,7 @@ that that variable is buffer-local to the summary buffers." (defun gnus-generate-new-group-name (leaf) (let ((name leaf) (num 0)) - (while (gnus-gethash name gnus-newsrc-hashtb) + (while (gnus-group-entry name) (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">"))) name)) @@ -3459,30 +3525,27 @@ that that variable is buffer-local to the summary buffers." ;; Perhaps it is already in the cache. (mapc (lambda (name-method) - (if (equal (cdr name-method) method) - (throw 'server-name (car name-method)))) - gnus-server-method-cache) + (if (equal (cdr name-method) method) + (throw 'server-name (car name-method)))) + gnus-server-method-cache) (mapc (lambda (server-alist) (mapc (lambda (name-method) - (when (gnus-methods-equal-p (cdr name-method) method) - (unless (member name-method gnus-server-method-cache) - (push name-method gnus-server-method-cache)) - (throw 'server-name (car name-method)))) - server-alist)) - (let ((alists (list gnus-server-alist - gnus-predefined-server-alist))) - (if gnus-select-method - (push (list (cons "native" gnus-select-method)) alists)) - alists)) + (when (gnus-methods-equal-p (cdr name-method) method) + (unless (member name-method gnus-server-method-cache) + (push name-method gnus-server-method-cache)) + (throw 'server-name (car name-method)))) + server-alist)) + (list gnus-server-alist + gnus-predefined-server-alist)) (let* ((name (if (member (cadr method) '(nil "")) - (format "%s" (car method)) - (format "%s:%s" (car method) (cadr method)))) - (name-method (cons name method))) + (format "%s" (car method)) + (format "%s:%s" (car method) (cadr method)))) + (name-method (cons name method))) (unless (member name-method gnus-server-method-cache) - (push name-method gnus-server-method-cache)) + (push name-method gnus-server-method-cache)) name))) (defsubst gnus-server-to-method (server) @@ -3795,7 +3858,7 @@ The function `gnus-group-find-parameter' will do that for you." (if simple-results ;; Found results; return them. (car simple-results) - ;; We didn't found it there, try `gnus-parameters'. + ;; We didn't find it there, try `gnus-parameters'. (let ((result nil) (head nil) (tail gnus-parameters)) @@ -4082,12 +4145,12 @@ If NEWSGROUP is nil, return the global kill file name instead." (and (not group) gnus-select-method) (and (not (gnus-group-entry group)) - ;; Killed or otherwise unknown group. - (or - ;; If we know a virtual server by that name, return its method. - (gnus-server-to-method (gnus-group-server group)) - ;; Guess a new method as last resort. - (gnus-group-name-to-method group))) + ;; Killed or otherwise unknown group. + (or + ;; If we know a virtual server by that name, return its method. + (gnus-server-to-method (gnus-group-server group)) + ;; Guess a new method as last resort. + (gnus-group-name-to-method group))) (let ((info (or info (gnus-get-info group))) method) (if (or (not info) @@ -4193,10 +4256,10 @@ Allow completion over sensible values." "Say whether METHOD is covered by the agent." (or (eq (car gnus-agent-method-p-cache) method) (setq gnus-agent-method-p-cache - (cons method - (member (if (stringp method) - method - (gnus-method-to-server method)) gnus-agent-covered-methods)))) + (cons method + (member (if (stringp method) + method + (gnus-method-to-server method)) gnus-agent-covered-methods)))) (cdr gnus-agent-method-p-cache)) (defun gnus-online (method) diff --git a/lisp/gnus/hashcash.el b/lisp/gnus/hashcash.el new file mode 100644 index 00000000000..737178b8218 --- /dev/null +++ b/lisp/gnus/hashcash.el @@ -0,0 +1,370 @@ +;;; hashcash.el --- Add hashcash payments to email + +;; Copyright (C) 2003, 2004, 2005, 2007 Free Software Foundation + +;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002) +;; Maintainer: Paul Foley <mycroft@actrix.gen.nz> +;; Keywords: mail, hashcash + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; The hashcash binary is at http://www.hashcash.org/. +;; +;; Call mail-add-payment to add a hashcash payment to a mail message +;; in the current buffer. +;; +;; Call mail-add-payment-async after writing the addresses but before +;; writing the mail to start calculating the hashcash payment +;; asynchronously. +;; +;; The easiest way to do this automatically for all outgoing mail +;; is to set `message-generate-hashcash' to t. If you want more +;; control, try the following hooks. +;; +;; To automatically add payments to all outgoing mail when sending: +;; (add-hook 'message-send-hook 'mail-add-payment) +;; +;; To start calculations automatically when addresses are prefilled: +;; (add-hook 'message-setup-hook 'mail-add-payment-async) +;; +;; To check whether calculations are done before sending: +;; (add-hook 'message-send-hook 'hashcash-wait-or-cancel) + +;;; Code: + +(defgroup hashcash nil + "Hashcash configuration." + :group 'mail) + +(defcustom hashcash-default-payment 20 + "*The default number of bits to pay to unknown users. +If this is zero, no payment header will be generated. +See `hashcash-payment-alist'." + :type 'integer + :group 'hashcash) + +(defcustom hashcash-payment-alist '() + "*An association list mapping email addresses to payment amounts. +Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where +ADDR is the email address of the intended recipient and AMOUNT is +the value of hashcash payment to be made to that user. STRING, if +present, is the string to be hashed; if not present ADDR will be used." + :type '(repeat (choice (list :tag "Normal" + (string :name "Address") + (integer :name "Amount")) + (list :tag "Replace hash input" + (string :name "Address") + (string :name "Hash input") + (integer :name "Amount")))) + :group 'hashcash) + +(defcustom hashcash-default-accept-payment 20 + "*The default minimum number of bits to accept on incoming payments." + :type 'integer + :group 'hashcash) + +(defcustom hashcash-accept-resources `((,user-mail-address nil)) + "*An association list mapping hashcash resources to payment amounts. +Resources named here are to be accepted in incoming payments. If the +corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment' +is used instead." + :group 'hashcash) + +(defcustom hashcash-path (executable-find "hashcash") + "*The path to the hashcash binary." + :group 'hashcash) + +(defcustom hashcash-extra-generate-parameters nil + "*A list of parameter strings passed to `hashcash-path' when minting. +For example, you may want to set this to '(\"-Z2\") to reduce header length." + :type '(repeat string) + :group 'hashcash) + +(defcustom hashcash-double-spend-database "hashcash.db" + "*The path to the double-spending database." + :group 'hashcash) + +(defcustom hashcash-in-news nil + "*Specifies whether or not hashcash payments should be made to newsgroups." + :type 'boolean + :group 'hashcash) + +(defvar hashcash-process-alist nil + "Alist of asynchronous hashcash processes and buffers.") + +(require 'mail-utils) + +(eval-and-compile + (if (fboundp 'point-at-bol) + (defalias 'hashcash-point-at-bol 'point-at-bol) + (defalias 'hashcash-point-at-bol 'line-beginning-position)) + + (if (fboundp 'point-at-eol) + (defalias 'hashcash-point-at-eol 'point-at-eol) + (defalias 'hashcash-point-at-eol 'line-end-position))) + +(defun hashcash-strip-quoted-names (addr) + (setq addr (mail-strip-quoted-names addr)) + (if (and addr (string-match "\\`\\([^+@]+\\)\\+[^@]*\\(@.+\\)" addr)) + (concat (match-string 1 addr) (match-string 2 addr)) + addr)) + +(defun hashcash-token-substring () + (save-excursion + (let ((token "")) + (loop + (setq token + (concat token (buffer-substring (point) (hashcash-point-at-eol)))) + (goto-char (hashcash-point-at-eol)) + (forward-char 1) + (unless (looking-at "[ \t]") (return token)) + (while (looking-at "[ \t]") (forward-char 1)))))) + +(defun hashcash-payment-required (addr) + "Return the hashcash payment value required for the given address." + (let ((val (assoc addr hashcash-payment-alist))) + (or (nth 2 val) (nth 1 val) hashcash-default-payment))) + +(defun hashcash-payment-to (addr) + "Return the string with which hashcash payments should collide." + (let ((val (assoc addr hashcash-payment-alist))) + (or (nth 1 val) (nth 0 val) addr))) + +(defun hashcash-generate-payment (str val) + "Generate a hashcash payment by finding a VAL-bit collison on STR." + (if (and (> val 0) + hashcash-path) + (save-excursion + (set-buffer (get-buffer-create " *hashcash*")) + (erase-buffer) + (apply 'call-process hashcash-path nil t nil + "-m" "-q" "-b" (number-to-string val) str + hashcash-extra-generate-parameters) + (goto-char (point-min)) + (hashcash-token-substring)) + (error "No `hashcash' binary found"))) + +(defun hashcash-generate-payment-async (str val callback) + "Generate a hashcash payment by finding a VAL-bit collison on STR. +Return immediately. Call CALLBACK with process and result when ready." + (if (and (> val 0) + hashcash-path) + (let ((process (apply 'start-process "hashcash" nil + hashcash-path "-m" "-q" + "-b" (number-to-string val) str + hashcash-extra-generate-parameters))) + (setq hashcash-process-alist (cons + (cons process (current-buffer)) + hashcash-process-alist)) + (set-process-filter process `(lambda (process output) + (funcall ,callback process output)))) + (funcall callback nil nil))) + +(defun hashcash-check-payment (token str val) + "Check the validity of a hashcash payment." + (if hashcash-path + (zerop (call-process hashcash-path nil nil nil "-c" + "-d" "-f" hashcash-double-spend-database + "-b" (number-to-string val) + "-r" str + token)) + (progn + (message "No hashcash binary found") + (sleep-for 1) + nil))) + +(defun hashcash-version (token) + "Find the format version of a hashcash token." + ;; Version 1.2 looks like n:yymmdd:rrrrr:xxxxxxxxxxxxxxxx + ;; This carries its own version number embedded in the token, + ;; so no further format number changes should be necessary + ;; in the X-Payment header. + ;; + ;; Version 1.1 looks like yymmdd:rrrrr:xxxxxxxxxxxxxxxx + ;; You need to upgrade your hashcash binary. + ;; + ;; Version 1.0 looked like nnnnnrrrrrxxxxxxxxxxxxxxxx + ;; This is no longer supported. + (cond ((equal (aref token 1) ?:) 1.2) + ((equal (aref token 6) ?:) 1.1) + (t (error "Unknown hashcash format version")))) + +(defun hashcash-already-paid-p (recipient) + "Check for hashcash token to RECIPIENT in current buffer." + (save-excursion + (save-restriction + (message-narrow-to-headers-or-head) + (let ((token (message-fetch-field "x-hashcash")) + (case-fold-search t)) + (and (stringp token) + (string-match (regexp-quote recipient) token)))))) + +;;;###autoload +(defun hashcash-insert-payment (arg) + "Insert X-Payment and X-Hashcash headers with a payment for ARG" + (interactive "sPay to: ") + (unless (hashcash-already-paid-p arg) + (let ((pay (hashcash-generate-payment (hashcash-payment-to arg) + (hashcash-payment-required arg)))) + (when pay + (insert-before-markers "X-Hashcash: " pay "\n"))))) + +;;;###autoload +(defun hashcash-insert-payment-async (arg) + "Insert X-Payment and X-Hashcash headers with a payment for ARG +Only start calculation. Results are inserted when ready." + (interactive "sPay to: ") + (unless (hashcash-already-paid-p arg) + (hashcash-generate-payment-async + (hashcash-payment-to arg) + (hashcash-payment-required arg) + `(lambda (process payment) + (hashcash-insert-payment-async-2 ,(current-buffer) process payment))))) + +(defun hashcash-insert-payment-async-2 (buffer process pay) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (save-restriction + (setq hashcash-process-alist (delq + (assq process hashcash-process-alist) + hashcash-process-alist)) + (message-goto-eoh) + (when pay + (insert-before-markers "X-Hashcash: " pay))))))) + +(defun hashcash-cancel-async (&optional buffer) + "Delete any hashcash processes associated with BUFFER. +BUFFER defaults to the current buffer." + (interactive) + (unless buffer (setq buffer (current-buffer))) + (let (entry) + (while (setq entry (rassq buffer hashcash-process-alist)) + (delete-process (car entry)) + (setq hashcash-process-alist + (delq entry hashcash-process-alist))))) + +(defun hashcash-wait-async (&optional buffer) + "Wait for asynchronous hashcash processes in BUFFER to finish. +BUFFER defaults to the current buffer." + (interactive) + (unless buffer (setq buffer (current-buffer))) + (let (entry) + (while (setq entry (rassq buffer hashcash-process-alist)) + (accept-process-output (car entry))))) + +(defun hashcash-processes-running-p (buffer) + "Return non-nil if hashcash processes in BUFFER are still running." + (rassq buffer hashcash-process-alist)) + +(defun hashcash-wait-or-cancel () + "Ask user whether to wait for hashcash processes to finish." + (interactive) + (when (hashcash-processes-running-p (current-buffer)) + (if (y-or-n-p + "Hashcash process(es) still running; wait for them to finish? ") + (hashcash-wait-async) + (hashcash-cancel-async)))) + +;;;###autoload +(defun hashcash-verify-payment (token &optional resource amount) + "Verify a hashcash payment" + (let* ((split (split-string token ":")) + (key (if (< (hashcash-version token) 1.2) + (nth 1 split) + (case (string-to-number (nth 0 split)) + (0 (nth 2 split)) + (1 (nth 3 split)))))) + (cond ((null resource) + (let ((elt (assoc key hashcash-accept-resources))) + (and elt (hashcash-check-payment token (car elt) + (or (cadr elt) hashcash-default-accept-payment))))) + ((equal token key) + (hashcash-check-payment token resource + (or amount hashcash-default-accept-payment))) + (t nil)))) + +;;;###autoload +(defun mail-add-payment (&optional arg async) + "Add X-Payment: and X-Hashcash: headers with a hashcash payment +for each recipient address. Prefix arg sets default payment temporarily. +Set ASYNC to t to start asynchronous calculation. (See +`mail-add-payment-async')." + (interactive "P") + (let ((hashcash-default-payment (if arg (prefix-numeric-value arg) + hashcash-default-payment)) + (addrlist nil)) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t))) + (cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t))) + (ng (hashcash-strip-quoted-names (mail-fetch-field "Newsgroups" + nil t)))) + (when to + (setq addrlist (split-string to ",[ \t\n]*"))) + (when cc + (setq addrlist (nconc addrlist (split-string cc ",[ \t\n]*")))) + (when (and hashcash-in-news ng) + (setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*"))))) + (when addrlist + (mapc (if async + #'hashcash-insert-payment-async + #'hashcash-insert-payment) + addrlist))))) + t) + +;;;###autoload +(defun mail-add-payment-async (&optional arg) + "Add X-Payment: and X-Hashcash: headers with a hashcash payment +for each recipient address. Prefix arg sets default payment temporarily. +Calculation is asynchronous." + (interactive "P") + (mail-add-payment arg t)) + +;;;###autoload +(defun mail-check-payment (&optional arg) + "Look for a valid X-Payment: or X-Hashcash: header. +Prefix arg sets default accept amount temporarily." + (interactive "P") + (let ((hashcash-default-accept-payment (if arg (prefix-numeric-value arg) + hashcash-default-accept-payment)) + (version (hashcash-version (hashcash-generate-payment "x" 1)))) + (save-excursion + (goto-char (point-min)) + (search-forward "\n\n") + (beginning-of-line) + (let ((end (point)) + (ok nil)) + (goto-char (point-min)) + (while (and (not ok) (search-forward "X-Payment: hashcash " end t)) + (let ((value (split-string (hashcash-token-substring) " "))) + (when (equal (car value) (number-to-string version)) + (setq ok (hashcash-verify-payment (cadr value)))))) + (goto-char (point-min)) + (while (and (not ok) (search-forward "X-Hashcash: " end t)) + (setq ok (hashcash-verify-payment (hashcash-token-substring)))) + (when ok + (message "Payment valid")) + ok)))) + +(provide 'hashcash) + +;;; arch-tag: 0e7fe983-a124-4392-9788-0dbcbd2c4d62 diff --git a/lisp/gnus/hmac-def.el b/lisp/gnus/hmac-def.el new file mode 100644 index 00000000000..58491ec4f4a --- /dev/null +++ b/lisp/gnus/hmac-def.el @@ -0,0 +1,86 @@ +;;; hmac-def.el --- A macro for defining HMAC functions. + +;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. + +;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> +;; Keywords: HMAC, RFC 2104 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program 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 3, or +;; (at your option) any later version. + +;; This program 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This program is implemented from RFC 2104, +;; "HMAC: Keyed-Hashing for Message Authentication". + +;;; Code: + +(defmacro define-hmac-function (name H B L &optional bit) + "Define a function NAME(TEXT KEY) which computes HMAC with function H. + +HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)): + +H is a cryptographic hash function, such as SHA1 and MD5, which takes +a string and return a digest of it (in binary form). +B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.) +L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.) +If BIT is non-nil, truncate output to specified bits." + `(defun ,name (text key) + ,(concat "Compute " + (upcase (symbol-name name)) + " over TEXT with KEY.") + (let ((key-xor-ipad (make-string ,B ?\x36)) + (key-xor-opad (make-string ,B ?\x5C)) + (len (length key)) + (pos 0)) + (unwind-protect + (progn + ;; if `key' is longer than the block size, apply hash function + ;; to `key' and use the result as a real `key'. + (if (> len ,B) + (setq key (,H key) + len ,L)) + (while (< pos len) + (aset key-xor-ipad pos (logxor (aref key pos) ?\x36)) + (aset key-xor-opad pos (logxor (aref key pos) ?\x5C)) + (setq pos (1+ pos))) + (setq key-xor-ipad (unwind-protect + (concat key-xor-ipad text) + (fillarray key-xor-ipad 0)) + key-xor-ipad (unwind-protect + (,H key-xor-ipad) + (fillarray key-xor-ipad 0)) + key-xor-opad (unwind-protect + (concat key-xor-opad key-xor-ipad) + (fillarray key-xor-opad 0)) + key-xor-opad (unwind-protect + (,H key-xor-opad) + (fillarray key-xor-opad 0))) + ;; now `key-xor-opad' contains + ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)). + ,(if (and bit (< (/ bit 8) L)) + `(substring key-xor-opad 0 ,(/ bit 8)) + ;; return a copy of `key-xor-opad'. + `(concat key-xor-opad))) + ;; cleanup. + (fillarray key-xor-ipad 0) + (fillarray key-xor-opad 0))))) + +(provide 'hmac-def) + +;;; arch-tag: 645adcef-b835-4900-a10a-11f636c982b9 +;;; hmac-def.el ends here diff --git a/lisp/gnus/hmac-md5.el b/lisp/gnus/hmac-md5.el new file mode 100644 index 00000000000..21fc91992ad --- /dev/null +++ b/lisp/gnus/hmac-md5.el @@ -0,0 +1,85 @@ +;;; hmac-md5.el --- Compute HMAC-MD5. + +;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. + +;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> +;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program 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 3, or +;; (at your option) any later version. + +;; This program 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". +;; +;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) +;; => "9294727a3638bb1c13f48ef8158bfc9d" +;; +;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) +;; => "750c783e6ab0b503eaa86e310a5db738" +;; +;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) +;; => "56be34521d144c88dbb8c733f0e8b3f6" +;; +;; (encode-hex-string +;; (hmac-md5 +;; (make-string 50 ?\xcd) +;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) +;; => "697eaf0aca3a3aea3a75164746ffaa79" +;; +;; (encode-hex-string +;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995690efd4c" +;; +;; (encode-hex-string +;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) +;; => "56461ef2342edc00f9bab995" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key - Hash Key First" +;; (make-string 80 ?\xaa))) +;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" +;; +;; (encode-hex-string +;; (hmac-md5 +;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" +;; (make-string 80 ?\xaa))) +;; => "6f630fad67cda0ee1fb1f562db3aa53e" + +;;; Code: + +(eval-when-compile (require 'hmac-def)) +(require 'hex-util) ; (decode-hex-string STRING) +(require 'md5) ; expects (md5 STRING) + +(defun md5-binary (string) + "Return the MD5 of STRING in binary form." + (if (condition-case nil + ;; `md5' of v21 takes 4th arg CODING (and 5th arg NOERROR). + (md5 "" nil nil 'binary) ; => "d41d8cd98f00b204e9800998ecf8427e" + (wrong-number-of-arguments nil)) + (decode-hex-string (md5 string nil nil 'binary)) + (decode-hex-string (md5 string)))) + +(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY) +(define-hmac-function hmac-md5-96 md5-binary 64 16 96) + +(provide 'hmac-md5) + +;;; arch-tag: 0ab3f4f6-3d4b-4167-a9fa-635b7fed7f27 +;;; hmac-md5.el ends here diff --git a/lisp/gnus/html2text.el b/lisp/gnus/html2text.el index 9f0916f797b..6de2904adb4 100644 --- a/lisp/gnus/html2text.el +++ b/lisp/gnus/html2text.el @@ -43,8 +43,42 @@ (defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr))) (defvar html2text-replace-list - '((" " . " ") (">" . ">") ("<" . "<") (""" . "\"") - ("&" . "&") ("'" . "'")) + '(("´" . "`") + ("&" . "&") + ("'" . "'") + ("¦" . "|") + ("¢" . "c") + ("ˆ" . "^") + ("©" . "(C)") + ("¤" . "(#)") + ("°" . "degree") + ("÷" . "/") + ("€" . "e") + ("½" . "1/2") + (">" . ">") + ("¿" . "?") + ("«" . "<<") + ("&ldquo" . "\"") + ("‹" . "(") + ("‘" . "`") + ("<" . "<") + ("—" . "--") + (" " . " ") + ("–" . "-") + ("‰" . "%%") + ("±" . "+-") + ("£" . "£") + (""" . "\"") + ("»" . ">>") + ("&rdquo" . "\"") + ("®" . "(R)") + ("›" . ")") + ("’" . "'") + ("§" . "§") + ("¹" . "^1") + ("²" . "^2") + ("³" . "^3") + ("˜" . "~")) "The map of entity to text. This is an alist were each element is a dotted pair consisting of an @@ -229,12 +263,12 @@ formatting, and then moved afterward.") (goto-char p1) (let ((item-nr 0) (items 0)) - (while (re-search-forward "<li>" p2 t) + (while (search-forward "<li>" p2 t) (setq items (1+ items))) (goto-char p1) (while (< item-nr items) (setq item-nr (1+ item-nr)) - (re-search-forward "<li>" (point-max) t) + (search-forward "<li>" (point-max) t) (cond ((string= list-type "ul") (insert " o ")) ((string= list-type "ol") (insert (format " %s: " item-nr))) @@ -244,7 +278,7 @@ formatting, and then moved afterward.") (goto-char p1) (let ((items 0) (item-nr 0)) - (while (re-search-forward "<dt>" p2 t) + (while (search-forward "<dt>" p2 t) (setq items (1+ items))) (goto-char p1) (while (< item-nr items) @@ -342,8 +376,7 @@ formatting, and then moved afterward.") (defun html2text-fix-paragraph (p1 p2) (goto-char p1) - (let ((has-br-line) - (refill-start) + (let ((refill-start) (refill-stop)) (when (re-search-forward "<br>$" p2 t) (goto-char p1) diff --git a/lisp/gnus/ietf-drums.el b/lisp/gnus/ietf-drums.el index a02762804f7..81d66aa3093 100644 --- a/lisp/gnus/ietf-drums.el +++ b/lisp/gnus/ietf-drums.el @@ -99,14 +99,14 @@ backslash and doublequote.") (push c out))) (range (while (<= b c) - (push (mm-make-char 'ascii b) out) + (push (make-char 'ascii b) out) (incf b)) (setq range nil)) ((= i (length token)) - (push (mm-make-char 'ascii c) out)) + (push (make-char 'ascii c) out)) (t (when b - (push (mm-make-char 'ascii b) out)) + (push (make-char 'ascii b) out)) (setq b c)))) (nreverse out))) @@ -200,7 +200,9 @@ backslash and doublequote.") (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))))))) - (t (error "Unknown symbol: %c" c)))) + (t + (message "Unknown symbol: %c" c) + (forward-char 1)))) ;; If we found no display-name, then we look for comments. (if display-name (setq display-string @@ -213,8 +215,10 @@ backslash and doublequote.") (ietf-drums-get-comment string))) (cons mailbox display-string))))) -(defun ietf-drums-parse-addresses (string) - "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs." +(defun ietf-drums-parse-addresses (string &optional rawp) + "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. +If RAWP, don't actually parse the addresses, but instead return +a list of address strings." (if (null string) nil (with-temp-buffer @@ -231,20 +235,24 @@ backslash and doublequote.") (skip-chars-forward "^,")))) ((eq c ?,) (setq address - (condition-case nil - (ietf-drums-parse-address - (buffer-substring beg (point))) - (error nil))) + (if rawp + (buffer-substring beg (point)) + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil)))) (if address (push address pairs)) (forward-char 1) (setq beg (point))) (t (forward-char 1)))) (setq address - (condition-case nil - (ietf-drums-parse-address - (buffer-substring beg (point))) - (error nil))) + (if rawp + (buffer-substring beg (point)) + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil)))) (if address (push address pairs)) (nreverse pairs))))) @@ -274,6 +282,11 @@ backslash and doublequote.") (concat "\"" string "\"") string)) +(defun ietf-drums-make-address (name address) + (if name + (concat (ietf-drums-quote-string name) " <" address ">") + address)) + (provide 'ietf-drums) ;;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9 diff --git a/lisp/gnus/imap.el b/lisp/gnus/imap.el index f60801e9ba8..7643ef4a53d 100644 --- a/lisp/gnus/imap.el +++ b/lisp/gnus/imap.el @@ -74,13 +74,13 @@ ;; explanatory for someone that know IMAP. All functions have ;; additional documentation on how to invoke them. ;; -;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP -;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 +;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented +;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS, ;; LOGINDISABLED) (with use of external library starttls.el and -;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731 -;; (with use of external program `imtest'). It also takes advantage of -;; the UNSELECT extension in Cyrus IMAPD. +;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731 +;; (with use of external program `imtest'), RFC2971 (ID). It also +;; takes advantage of the UNSELECT extension in Cyrus IMAPD. ;; ;; Without the work of John McClary Prevost and Jim Radford this library ;; would not have seen the light of day. Many thanks. @@ -140,29 +140,19 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'base64-decode-string "base64") - (autoload 'base64-encode-string "base64") (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") + (autoload 'sasl-find-mechanism "sasl") (autoload 'digest-md5-parse-digest-challenge "digest-md5") (autoload 'digest-md5-digest-response "digest-md5") (autoload 'digest-md5-digest-uri "digest-md5") (autoload 'digest-md5-challenge "digest-md5") (autoload 'rfc2104-hash "rfc2104") - (autoload 'md5 "md5") (autoload 'utf7-encode "utf7") (autoload 'utf7-decode "utf7") (autoload 'format-spec "format-spec") (autoload 'format-spec-make "format-spec") - (autoload 'open-tls-stream "tls") - ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These - ;; days we have point-at-eol anyhow. - (if (fboundp 'point-at-eol) - (defalias 'imap-point-at-eol 'point-at-eol) - (defun imap-point-at-eol () - (save-excursion - (end-of-line) - (point))))) + (autoload 'open-tls-stream "tls")) ;; User variables. @@ -311,6 +301,7 @@ stream.") kerberos4 digest-md5 cram-md5 + ;;sasl login anonymous) "Priority of authenticators to consider when authenticating to server.") @@ -318,6 +309,7 @@ stream.") (defvar imap-authenticator-alist '((gssapi imap-gssapi-auth-p imap-gssapi-auth) (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth) + (sasl imap-sasl-auth-p imap-sasl-auth) (cram-md5 imap-cram-md5-p imap-cram-md5-auth) (login imap-login-p imap-login-auth) (anonymous imap-anonymous-p imap-anonymous-auth) @@ -333,6 +325,13 @@ for doing the actual authentication.") (defvar imap-error nil "Error codes from the last command.") +(defvar imap-logout-timeout nil + "Close server immediately if it can't logout in this number of seconds. +If it is nil, never close server until logout completes. Normally, +the value of this variable will be bound to a certain value to which +an application program that uses this module specifies on a per-server +basis.") + ;; Internal constants. Change these and die. (defconst imap-default-port 143) @@ -353,6 +352,7 @@ for doing the actual authentication.") imap-current-target-mailbox imap-message-data imap-capability + imap-id imap-namespace imap-state imap-reached-tag @@ -408,6 +408,10 @@ and `examine'.") (defvar imap-capability nil "Capability for server.") +(defvar imap-id nil + "Identity of server. +See RFC 2971.") + (defvar imap-namespace nil "Namespace for current server.") @@ -557,7 +561,7 @@ sure of changing the value of `foo'." (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command "LOGOUT")) + (imap-logout)) (delete-process process) nil))))) done)) @@ -632,7 +636,7 @@ sure of changing the value of `foo'." (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command "LOGOUT")) + (imap-logout)) (delete-process process) nil))))) done)) @@ -915,14 +919,27 @@ Returns t if login was successful, nil otherwise." (and (not (imap-capability 'LOGINDISABLED buffer)) (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) +(defun imap-quote-specials (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "[\\\"]" nil t) + (forward-char -1) + (insert "\\") + (forward-char 1)) + (buffer-string))) + (defun imap-login-auth (buffer) "Login to server using the LOGIN command." (message "imap: Plaintext authentication...") (imap-interactive-login buffer (lambda (user passwd) (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" user "\" \"" - passwd "\"")))))) + (concat "LOGIN \"" + (imap-quote-specials user) + "\" \"" + (imap-quote-specials passwd) + "\"")))))) (defun imap-anonymous-p (buffer) t) @@ -934,6 +951,66 @@ Returns t if login was successful, nil otherwise." (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) +;;; Compiler directives. + +(defvar imap-sasl-client) +(defvar imap-sasl-step) + +(defun imap-sasl-make-mechanisms (buffer) + (let ((mecs '())) + (mapc (lambda (sym) + (let ((name (symbol-name sym))) + (if (and (> (length name) 5) + (string-equal "AUTH=" (substring name 0 5 ))) + (setq mecs (cons (substring name 5) mecs))))) + (imap-capability nil buffer)) + mecs)) + +(defun imap-sasl-auth-p (buffer) + (and (condition-case () + (require 'sasl) + (error nil)) + (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))) + +(defun imap-sasl-auth (buffer) + "Login to server using the SASL method." + (message "imap: Authenticating using SASL...") + (with-current-buffer buffer + (make-local-variable 'imap-username) + (make-local-variable 'imap-sasl-client) + (make-local-variable 'imap-sasl-step) + (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))) + logged user) + (while (not logged) + (setq user (or imap-username + (read-from-minibuffer + (concat "IMAP username for " imap-server " using SASL " + (sasl-mechanism-name mechanism) ": ") + (or user imap-default-user)))) + (when user + (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server) + imap-sasl-step (sasl-next-step imap-sasl-client nil)) + (let ((tag (imap-send-command + (if (sasl-step-data imap-sasl-step) + (format "AUTHENTICATE %s %s" + (sasl-mechanism-name mechanism) + (sasl-step-data imap-sasl-step)) + (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism))) + buffer))) + (while (eq (imap-wait-for-tag tag) 'INCOMPLETE) + (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation)) + (setq imap-continuation nil + imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step)) + (imap-send-command-1 (if (sasl-step-data imap-sasl-step) + (base64-encode-string (sasl-step-data imap-sasl-step) t) + ""))) + (if (imap-ok-p (imap-wait-for-tag tag)) + (setq imap-username user + logged t) + (message "Login failed...") + (sit-for 1))))) + logged))) + (defun imap-digest-md5-p (buffer) (and (imap-capability 'AUTH=DIGEST-MD5 buffer) (condition-case () @@ -1006,7 +1083,7 @@ necessary. If nil, the buffer name is generated." (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapcar 'make-local-variable imap-local-variables) + (mapc 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -1029,7 +1106,7 @@ necessary. If nil, the buffer name is generated." (if (not (eq imap-default-stream stream)) (with-current-buffer (get-buffer-create (generate-new-buffer-name " *temp*")) - (mapcar 'make-local-variable imap-local-variables) + (mapc 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -1084,7 +1161,7 @@ password is remembered in the buffer." (with-current-buffer (or buffer (current-buffer)) (if (not (eq imap-state 'nonauth)) (or (eq imap-state 'auth) - (eq imap-state 'select) + (eq imap-state 'selected) (eq imap-state 'examine)) (make-local-variable 'imap-username) (make-local-variable 'imap-password) @@ -1118,7 +1195,7 @@ If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) (when (imap-opened) (condition-case nil - (imap-send-command-wait "LOGOUT") + (imap-logout-wait) (quit nil))) (when (and imap-process (memq (process-status imap-process) '(open run))) @@ -1141,6 +1218,26 @@ If BUFFER is nil, the current buffer is assumed." (memq (intern (upcase (symbol-name identifier))) imap-capability) imap-capability))) +(defun imap-id (&optional list-of-values buffer) + "Identify client to server in BUFFER, and return server identity. +LIST-OF-VALUES is nil, or a plist with identifier and value +strings to send to the server to identify the client. + +Return a list of identifiers which server in BUFFER support, or +nil if it doesn't support ID or returns no information. + +If BUFFER is nil, the current buffer is assumed." + (with-current-buffer (or buffer (current-buffer)) + (when (and (imap-capability 'ID) + (imap-ok-p (imap-send-command-wait + (if (null list-of-values) + "ID NIL" + (concat "ID (" (mapconcat (lambda (el) + (concat "\"" el "\"")) + list-of-values + " ") ")"))))) + imap-id))) + (defun imap-namespace (&optional buffer) "Return a namespace hierarchy at server in BUFFER. If BUFFER is nil, the current buffer is assumed." @@ -1153,6 +1250,28 @@ If BUFFER is nil, the current buffer is assumed." (defun imap-send-command-wait (command &optional buffer) (imap-wait-for-tag (imap-send-command command buffer) buffer)) +(defun imap-logout (&optional buffer) + (or buffer (setq buffer (current-buffer))) + (if imap-logout-timeout + (with-timeout (imap-logout-timeout + (condition-case nil + (with-current-buffer buffer + (delete-process imap-process)) + (error))) + (imap-send-command "LOGOUT" buffer)) + (imap-send-command "LOGOUT" buffer))) + +(defun imap-logout-wait (&optional buffer) + (or buffer (setq buffer (current-buffer))) + (if imap-logout-timeout + (with-timeout (imap-logout-timeout + (condition-case nil + (with-current-buffer buffer + (delete-process imap-process)) + (error))) + (imap-send-command-wait "LOGOUT" buffer)) + (imap-send-command-wait "LOGOUT" buffer))) + ;; Mailbox functions: @@ -2106,6 +2225,8 @@ Return nil if no complete line has arrived." (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) + (ID (setq imap-id (read (buffer-substring (point) + (point-max))))) (ACL (imap-parse-acl)) (t (case (prog1 (read (current-buffer)) (imap-forward)) @@ -2460,7 +2581,7 @@ Return nil if no complete line has arrived." ;; next line for Courier IMAP bug. (skip-chars-forward " ") (point))) - (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) + (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list") (imap-forward) @@ -2740,99 +2861,99 @@ Return nil if no complete line has arrived." (when imap-debug ; (untrace-all) (require 'trace) (buffer-disable-undo (get-buffer-create imap-debug-buffer)) - (mapcar (lambda (f) (trace-function-background f imap-debug-buffer)) - '( - imap-utf7-encode - imap-utf7-decode - imap-error-text - imap-kerberos4s-p - imap-kerberos4-open - imap-ssl-p - imap-ssl-open - imap-network-p - imap-network-open - imap-interactive-login - imap-kerberos4a-p - imap-kerberos4-auth - imap-cram-md5-p - imap-cram-md5-auth - imap-login-p - imap-login-auth - imap-anonymous-p - imap-anonymous-auth - imap-open-1 - imap-open - imap-opened - imap-authenticate - imap-close - imap-capability - imap-namespace - imap-send-command-wait - imap-mailbox-put - imap-mailbox-get - imap-mailbox-map-1 - imap-mailbox-map - imap-current-mailbox - imap-current-mailbox-p-1 - imap-current-mailbox-p - imap-mailbox-select-1 - imap-mailbox-select - imap-mailbox-examine-1 - imap-mailbox-examine - imap-mailbox-unselect - imap-mailbox-expunge - imap-mailbox-close - imap-mailbox-create-1 - imap-mailbox-create - imap-mailbox-delete - imap-mailbox-rename - imap-mailbox-lsub - imap-mailbox-list - imap-mailbox-subscribe - imap-mailbox-unsubscribe - imap-mailbox-status - imap-mailbox-acl-get - imap-mailbox-acl-set - imap-mailbox-acl-delete - imap-current-message - imap-list-to-message-set - imap-fetch-asynch - imap-fetch - imap-message-put - imap-message-get - imap-message-map - imap-search - imap-message-flag-permanent-p - imap-message-flags-set - imap-message-flags-del - imap-message-flags-add - imap-message-copyuid-1 - imap-message-copyuid - imap-message-copy - imap-message-appenduid-1 - imap-message-appenduid - imap-message-append - imap-body-lines - imap-envelope-from - imap-send-command-1 - imap-send-command - imap-wait-for-tag - imap-sentinel - imap-find-next-line - imap-arrival-filter - imap-parse-greeting - imap-parse-response - imap-parse-resp-text - imap-parse-resp-text-code - imap-parse-data-list - imap-parse-fetch - imap-parse-status - imap-parse-acl - imap-parse-flag-list - imap-parse-envelope - imap-parse-body-extension - imap-parse-body - ))) + (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) + '( + imap-utf7-encode + imap-utf7-decode + imap-error-text + imap-kerberos4s-p + imap-kerberos4-open + imap-ssl-p + imap-ssl-open + imap-network-p + imap-network-open + imap-interactive-login + imap-kerberos4a-p + imap-kerberos4-auth + imap-cram-md5-p + imap-cram-md5-auth + imap-login-p + imap-login-auth + imap-anonymous-p + imap-anonymous-auth + imap-open-1 + imap-open + imap-opened + imap-authenticate + imap-close + imap-capability + imap-namespace + imap-send-command-wait + imap-mailbox-put + imap-mailbox-get + imap-mailbox-map-1 + imap-mailbox-map + imap-current-mailbox + imap-current-mailbox-p-1 + imap-current-mailbox-p + imap-mailbox-select-1 + imap-mailbox-select + imap-mailbox-examine-1 + imap-mailbox-examine + imap-mailbox-unselect + imap-mailbox-expunge + imap-mailbox-close + imap-mailbox-create-1 + imap-mailbox-create + imap-mailbox-delete + imap-mailbox-rename + imap-mailbox-lsub + imap-mailbox-list + imap-mailbox-subscribe + imap-mailbox-unsubscribe + imap-mailbox-status + imap-mailbox-acl-get + imap-mailbox-acl-set + imap-mailbox-acl-delete + imap-current-message + imap-list-to-message-set + imap-fetch-asynch + imap-fetch + imap-message-put + imap-message-get + imap-message-map + imap-search + imap-message-flag-permanent-p + imap-message-flags-set + imap-message-flags-del + imap-message-flags-add + imap-message-copyuid-1 + imap-message-copyuid + imap-message-copy + imap-message-appenduid-1 + imap-message-appenduid + imap-message-append + imap-body-lines + imap-envelope-from + imap-send-command-1 + imap-send-command + imap-wait-for-tag + imap-sentinel + imap-find-next-line + imap-arrival-filter + imap-parse-greeting + imap-parse-response + imap-parse-resp-text + imap-parse-resp-text-code + imap-parse-data-list + imap-parse-fetch + imap-parse-status + imap-parse-acl + imap-parse-flag-list + imap-parse-envelope + imap-parse-body-extension + imap-parse-body + ))) (provide 'imap) diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el index 7ee6ac7f744..d0b4d10d680 100644 --- a/lisp/gnus/legacy-gnus-agent.el +++ b/lisp/gnus/legacy-gnus-agent.el @@ -110,23 +110,20 @@ converted to the compressed format." (throw 'found-file-to-convert t)) (erase-buffer) - (let ((compressed nil)) - (mapcar (lambda (pair) - (let* ((article-id (car pair)) - (day-of-download (cdr pair)) - (comp-list (assq day-of-download compressed))) - (if comp-list - (setcdr comp-list - (cons article-id (cdr comp-list))) - (setq compressed - (cons (list day-of-download article-id) - compressed))) - nil)) alist) - (mapcar (lambda (comp-list) - (setcdr comp-list - (gnus-compress-sequence - (nreverse (cdr comp-list))))) - compressed) + (let (article-id day-of-download comp-list compressed) + (while alist + (setq article-id (caar alist) + day-of-download (cdar alist) + comp-list (assq day-of-download compressed) + alist (cdr alist)) + (if comp-list + (setcdr comp-list (cons article-id (cdr comp-list))) + (push (list day-of-download article-id) compressed))) + (setq alist compressed) + (while alist + (setq comp-list (pop alist)) + (setcdr comp-list + (gnus-compress-sequence (nreverse (cdr comp-list))))) (princ compressed (current-buffer))) (insert "\n2\n") (write-file file) diff --git a/lisp/gnus/mail-parse.el b/lisp/gnus/mail-parse.el index d9f3d08537b..9868370ce6d 100644 --- a/lisp/gnus/mail-parse.el +++ b/lisp/gnus/mail-parse.el @@ -59,6 +59,7 @@ (defalias 'mail-header-parse-date 'ietf-drums-parse-date) (defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) (defalias 'mail-quote-string 'ietf-drums-quote-string) +(defalias 'mail-header-make-address 'ietf-drums-make-address) (defalias 'mail-header-fold-field 'rfc2047-fold-field) (defalias 'mail-header-unfold-field 'rfc2047-unfold-field) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 0dc77f59e96..abf32756498 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -34,8 +34,7 @@ (eval-and-compile (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") - (autoload 'nnheader-cancel-timer "nnheader") - (autoload 'nnheader-run-at-time "nnheader")) + (autoload 'nnheader-cancel-timer "nnheader")) (require 'format-spec) (require 'mm-util) (require 'message) ;; for `message-directory' @@ -111,7 +110,7 @@ See Info node `(gnus)Mail Source Specifiers'." (const :format "" :value :port) (choice :tag "Port" :value "pop3" - (number :format "%v") + (integer :format "%v") (string :format "%v"))) (group :inline t (const :format "" :value :user) @@ -127,13 +126,15 @@ See Info node `(gnus)Mail Source Specifiers'." (choice :tag "Prescript" :value nil (string :format "%v") - (function :format "%v"))) + (function :format "%v") + (const :tag "None" nil))) (group :inline t (const :format "" :value :postscript) (choice :tag "Postscript" :value nil (string :format "%v") - (function :format "%v"))) + (function :format "%v") + (const :tag "None" nil))) (group :inline t (const :format "" :value :function) (function :tag "Function")) @@ -146,7 +147,14 @@ See Info node `(gnus)Mail Source Specifiers'." (const apop))) (group :inline t (const :format "" :value :plugged) - (boolean :tag "Plugged")))) + (boolean :tag "Plugged")) + (group :inline t + (const :format "" :value :stream) + (choice :tag "Stream" + :value nil + (const :tag "Clear" nil) + (const starttls) + (const :tag "SSL/TLS" ssl))))) (cons :tag "Maildir (qmail, postfix...)" (const :format "" maildir) (checklist :tag "Options" :greedy t @@ -166,7 +174,7 @@ See Info node `(gnus)Mail Source Specifiers'." (const :format "" :value :port) (choice :tag "Port" :value 143 - number string)) + integer string)) (group :inline t (const :format "" :value :user) (string :tag "User")) @@ -210,17 +218,17 @@ See Info node `(gnus)Mail Source Specifiers'." (const :format "" webmail) (checklist :tag "Options" :greedy t (group :inline t - (const :format "" :value :subtype) - ;; Should be generated from - ;; `webmail-type-definition', but we - ;; can't require webmail without W3. - (choice :tag "Subtype" - :value hotmail - (const hotmail) - (const yahoo) - (const netaddress) - (const netscape) - (const my-deja))) + (const :format "" :value :subtype) + ;; Should be generated from + ;; `webmail-type-definition', but we + ;; can't require webmail without W3. + (choice :tag "Subtype" + :value hotmail + (const hotmail) + (const yahoo) + (const netaddress) + (const netscape) + (const my-deja))) (group :inline t (const :format "" :value :user) (string :tag "User")) @@ -269,7 +277,7 @@ If non-nil, this maildrop will be checked periodically for new mail." :group 'mail-source :type 'integer) -(defcustom mail-source-delete-incoming t +(defcustom mail-source-delete-incoming nil "*If non-nil, delete incoming files after handling. If t, delete immediately, if nil, never delete. If a positive number, delete files older than number of days." @@ -350,7 +358,8 @@ Common keywords should be listed here.") (:program) (:function) (:password) - (:authentication password)) + (:authentication password) + (:stream nil)) (maildir (:path (or (getenv "MAILDIR") "~/Maildir/")) (:subdirs ("cur" "new")) @@ -502,7 +511,8 @@ Return the number of files that were found." (when (file-exists-p mail-source-crash-box) (message "Processing mail from %s..." mail-source-crash-box) (setq found (mail-source-callback - callback mail-source-crash-box))) + callback mail-source-crash-box)) + (mail-source-delete-crash-box)) (+ found (if (or debug-on-quit debug-on-error) (funcall function source callback) @@ -552,33 +562,33 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (delete-file ffile)))))) (defun mail-source-callback (callback info) - "Call CALLBACK on the mail file, and then remove the mail file. -Pass INFO on to CALLBACK." + "Call CALLBACK on the mail file. Pass INFO on to CALLBACK." (if (or (not (file-exists-p mail-source-crash-box)) (zerop (nth 7 (file-attributes mail-source-crash-box)))) (progn (when (file-exists-p mail-source-crash-box) (delete-file mail-source-crash-box)) 0) - (prog1 - (funcall callback mail-source-crash-box info) - (when (file-exists-p mail-source-crash-box) - ;; Delete or move the incoming mail out of the way. - (if (eq mail-source-delete-incoming t) - (delete-file mail-source-crash-box) - (let ((incoming - (mm-make-temp-file - (expand-file-name - mail-source-incoming-file-prefix - mail-source-directory)))) - (unless (file-exists-p (file-name-directory incoming)) - (make-directory (file-name-directory incoming) t)) - (rename-file mail-source-crash-box incoming t) - ;; remove old incoming files? - (when (natnump mail-source-delete-incoming) - (mail-source-delete-old-incoming - mail-source-delete-incoming - mail-source-delete-old-incoming-confirm)))))))) + (funcall callback mail-source-crash-box info))) + +(defun mail-source-delete-crash-box () + (when (file-exists-p mail-source-crash-box) + ;; Delete or move the incoming mail out of the way. + (if (eq mail-source-delete-incoming t) + (delete-file mail-source-crash-box) + (let ((incoming + (mm-make-temp-file + (expand-file-name + mail-source-incoming-file-prefix + mail-source-directory)))) + (unless (file-exists-p (file-name-directory incoming)) + (make-directory (file-name-directory incoming) t)) + (rename-file mail-source-crash-box incoming t) + ;; remove old incoming files? + (when (natnump mail-source-delete-incoming) + (mail-source-delete-old-incoming + mail-source-delete-incoming + mail-source-delete-old-incoming-confirm)))))) (defun mail-source-movemail (from to) "Move FROM to TO using movemail." @@ -670,12 +680,20 @@ Pass INFO on to CALLBACK." (sleep-for delay))) (defun mail-source-call-script (script) - (let ((background nil)) + (let ((background nil) + (stderr (get-buffer-create " *mail-source-stderr*")) + result) (when (string-match "& *$" script) (setq script (substring script 0 (match-beginning 0)) background 0)) - (call-process shell-file-name nil background nil - shell-command-switch script))) + (setq result + (call-process shell-file-name nil background nil + shell-command-switch script)) + (when (and result + (not (zerop result))) + (set-buffer stderr) + (message "Mail source error: %s" (buffer-string))) + (kill-buffer stderr))) ;;; ;;; Different fetchers @@ -692,7 +710,8 @@ Pass INFO on to CALLBACK." (prog1 (mail-source-callback callback path) (mail-source-run-script - postscript (format-spec-make ?t mail-source-crash-box))) + postscript (format-spec-make ?t mail-source-crash-box)) + (mail-source-delete-crash-box)) 0)))) (defun mail-source-fetch-directory (source callback) @@ -707,13 +726,15 @@ Pass INFO on to CALLBACK." (when (and (file-regular-p file) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) - (incf found (mail-source-callback callback file)))) - (mail-source-run-script postscript (format-spec-make ?t path)) + (incf found (mail-source-callback callback file)) + (mail-source-run-script postscript (format-spec-make ?t path)) + (mail-source-delete-crash-box))) found))) (defun mail-source-fetch-pop (source callback) "Fetcher for single-file sources." (mail-source-bind (pop source) + ;; fixme: deal with stream type in format specs (mail-source-run-script prescript (format-spec-make ?p password ?t mail-source-crash-box @@ -748,7 +769,8 @@ Pass INFO on to CALLBACK." (pop3-mailhost server) (pop3-port port) (pop3-authentication-scheme - (if (eq authentication 'apop) 'apop 'pass))) + (if (eq authentication 'apop) 'apop 'pass)) + (pop3-stream-type stream)) (if (or debug-on-quit debug-on-error) (save-excursion (pop3-movemail mail-source-crash-box)) (condition-case err @@ -773,7 +795,8 @@ Pass INFO on to CALLBACK." (mail-source-run-script postscript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)))) + ?s server ?P port ?u user)) + (mail-source-delete-crash-box))) ;; We nix out the password in case the error ;; was because of a wrong password being given. (setq mail-source-password-cache @@ -865,11 +888,6 @@ See the Gnus manual for details." (defvar mail-source-report-new-mail-timer nil) (defvar mail-source-report-new-mail-idle-timer nil) -(eval-when-compile - (if (featurep 'xemacs) - (require 'timer-funcs) - (require 'timer))) - (defun mail-source-start-idle-timer () ;; Start our idle timer if necessary, so we delay the check until the ;; user isn't typing. @@ -912,7 +930,7 @@ This only works when `display-time' is enabled." (setq display-time-mail-function #'mail-source-new-mail-p) ;; Set up the main timer. (setq mail-source-report-new-mail-timer - (nnheader-run-at-time + (run-at-time (* 60 mail-source-report-new-mail-interval) (* 60 mail-source-report-new-mail-interval) #'mail-source-start-idle-timer)) @@ -957,7 +975,8 @@ This only works when `display-time' is enabled." ;; MMDF mail format (insert "\001\001\001\001\n")) (delete-file file))))) - (incf found (mail-source-callback callback file)))))) + (incf found (mail-source-callback callback file)) + (mail-source-delete-crash-box))))) found))) (eval-and-compile @@ -1018,11 +1037,13 @@ This only works when `display-time' is enabled." (insert "From imap " (current-time-string) "\n") (save-excursion (insert str "\n\n")) - (while (re-search-forward "^From " nil t) + (while (let ((case-fold-search nil)) + (re-search-forward "^From " nil t)) (replace-match ">From ")) (goto-char (point-max)))) (nnheader-ms-strip-cr)) (incf found (mail-source-callback callback server)) + (mail-source-delete-crash-box) (when (and remove fetchflag) (setq remove (nreverse remove)) (imap-message-flags-add @@ -1068,7 +1089,8 @@ This only works when `display-time' is enabled." (push (cons (format "webmail:%s:%s" subtype user) password) mail-source-password-cache))) (webmail-fetch mail-source-crash-box subtype user password) - (mail-source-callback callback (symbol-name subtype))))) + (mail-source-callback callback (symbol-name subtype)) + (mail-source-delete-crash-box)))) (provide 'mail-source) diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el index e8b624aa546..6839a6472b7 100644 --- a/lisp/gnus/mailcap.el +++ b/lisp/gnus/mailcap.el @@ -254,7 +254,11 @@ ("html" (viewer . mm-w3-prepare-buffer) (test . (fboundp 'w3-prepare-buffer)) - (type . "text/html"))) + (type . "text/html")) + ("dns" + (viewer . dns-mode) + (test . (fboundp 'dns-mode)) + (type . "text/dns"))) ("video" ("mpeg" (viewer . "mpeg_play %s") @@ -852,6 +856,7 @@ this type is returned." (".sit" . "application/x-stuffit") (".siv" . "application/sieve") (".snd" . "audio/basic") + (".soa" . "text/dns") (".src" . "application/x-wais-source") (".tar" . "archive/tar") (".tcl" . "application/x-tcl") diff --git a/lisp/gnus/md4.el b/lisp/gnus/md4.el new file mode 100644 index 00000000000..aa9bc543203 --- /dev/null +++ b/lisp/gnus/md4.el @@ -0,0 +1,228 @@ +;;; md4.el --- MD4 Message Digest Algorithm. + +;; Copyright (C) 2004 Free Software Foundation, Inc. +;; Copyright (C) 2001 Taro Kawagishi +;; Author: Taro Kawagishi <tarok@transpulse.org> +;; Keywords: MD4 +;; Version: 1.00 +;; Created: February 2001 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program 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 3, or (at your option) +;; any later version. +;; +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Code: + +;;; +;;; MD4 hash calculation + +(defvar md4-buffer (make-vector 4 '(0 . 0)) + "work buffer of four 32-bit integers") + +(defun md4 (in n) + "Returns the MD4 hash string of 16 bytes long for a string IN of N +bytes long. N is required to handle strings containing character 0." + (let (m + (b (cons 0 (* n 8))) + (i 0) + (buf (make-string 128 0)) c4) + ;; initial values + (aset md4-buffer 0 '(26437 . 8961)) ;0x67452301 + (aset md4-buffer 1 '(61389 . 43913)) ;0xefcdab89 + (aset md4-buffer 2 '(39098 . 56574)) ;0x98badcfe + (aset md4-buffer 3 '(4146 . 21622)) ;0x10325476 + + ;; process the string in 64 bits chunks + (while (> n 64) + (setq m (md4-copy64 (substring in 0 64))) + (md4-64 m) + (setq in (substring in 64)) + (setq n (- n 64))) + + ;; process the rest of the string (length is now n <= 64) + (setq i 0) + (while (< i n) + (aset buf i (aref in i)) + (setq i (1+ i))) + (aset buf n 128) ;0x80 + (if (<= n 55) + (progn + (setq c4 (md4-pack-int32 b)) + (aset buf 56 (aref c4 0)) + (aset buf 57 (aref c4 1)) + (aset buf 58 (aref c4 2)) + (aset buf 59 (aref c4 3)) + (setq m (md4-copy64 buf)) + (md4-64 m)) + ;; else + (setq c4 (md4-pack-int32 b)) + (aset buf 120 (aref c4 0)) + (aset buf 121 (aref c4 1)) + (aset buf 122 (aref c4 2)) + (aset buf 123 (aref c4 3)) + (setq m (md4-copy64 buf)) + (md4-64 m) + (setq m (md4-copy64 (substring buf 64))) + (md4-64 m))) + + (concat (md4-pack-int32 (aref md4-buffer 0)) + (md4-pack-int32 (aref md4-buffer 1)) + (md4-pack-int32 (aref md4-buffer 2)) + (md4-pack-int32 (aref md4-buffer 3)))) + +(defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z))) +(defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z))) +(defsubst md4-H (x y z) (logxor x y z)) + +(defmacro md4-make-step (name func) + `(defun ,name (a b c d xk s ac) + (let* + ((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac))) + (l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac))) + (h2 (logand 65535 (+ h1 (lsh l1 -16)))) + (l2 (logand 65535 l1)) + ;; cyclic shift of 32 bits integer + (h3 (logand 65535 (if (> s 15) + (+ (lsh h2 (- s 32)) (lsh l2 (- s 16))) + (+ (lsh h2 s) (lsh l2 (- s 16)))))) + (l3 (logand 65535 (if (> s 15) + (+ (lsh l2 (- s 32)) (lsh h2 (- s 16))) + (+ (lsh l2 s) (lsh h2 (- s 16))))))) + (cons h3 l3)))) + +(md4-make-step md4-round1 md4-F) +(md4-make-step md4-round2 md4-G) +(md4-make-step md4-round3 md4-H) + +(defsubst md4-add (x y) + "Return 32-bit sum of 32-bit integers X and Y." + (let ((h (+ (car x) (car y))) + (l (+ (cdr x) (cdr y)))) + (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l)))) + +(defsubst md4-and (x y) + (cons (logand (car x) (car y)) (logand (cdr x) (cdr y)))) + +(defun md4-64 (m) + "Calculate md4 of 64 bytes chunk M which is represented as 16 pairs of +32 bits integers. The resulting md4 value is placed in md4-buffer." + (let ((a (aref md4-buffer 0)) + (b (aref md4-buffer 1)) + (c (aref md4-buffer 2)) + (d (aref md4-buffer 3))) + (setq a (md4-round1 a b c d (aref m 0) 3 '(0 . 0)) + d (md4-round1 d a b c (aref m 1) 7 '(0 . 0)) + c (md4-round1 c d a b (aref m 2) 11 '(0 . 0)) + b (md4-round1 b c d a (aref m 3) 19 '(0 . 0)) + a (md4-round1 a b c d (aref m 4) 3 '(0 . 0)) + d (md4-round1 d a b c (aref m 5) 7 '(0 . 0)) + c (md4-round1 c d a b (aref m 6) 11 '(0 . 0)) + b (md4-round1 b c d a (aref m 7) 19 '(0 . 0)) + a (md4-round1 a b c d (aref m 8) 3 '(0 . 0)) + d (md4-round1 d a b c (aref m 9) 7 '(0 . 0)) + c (md4-round1 c d a b (aref m 10) 11 '(0 . 0)) + b (md4-round1 b c d a (aref m 11) 19 '(0 . 0)) + a (md4-round1 a b c d (aref m 12) 3 '(0 . 0)) + d (md4-round1 d a b c (aref m 13) 7 '(0 . 0)) + c (md4-round1 c d a b (aref m 14) 11 '(0 . 0)) + b (md4-round1 b c d a (aref m 15) 19 '(0 . 0)) + + a (md4-round2 a b c d (aref m 0) 3 '(23170 . 31129)) ;0x5A827999 + d (md4-round2 d a b c (aref m 4) 5 '(23170 . 31129)) + c (md4-round2 c d a b (aref m 8) 9 '(23170 . 31129)) + b (md4-round2 b c d a (aref m 12) 13 '(23170 . 31129)) + a (md4-round2 a b c d (aref m 1) 3 '(23170 . 31129)) + d (md4-round2 d a b c (aref m 5) 5 '(23170 . 31129)) + c (md4-round2 c d a b (aref m 9) 9 '(23170 . 31129)) + b (md4-round2 b c d a (aref m 13) 13 '(23170 . 31129)) + a (md4-round2 a b c d (aref m 2) 3 '(23170 . 31129)) + d (md4-round2 d a b c (aref m 6) 5 '(23170 . 31129)) + c (md4-round2 c d a b (aref m 10) 9 '(23170 . 31129)) + b (md4-round2 b c d a (aref m 14) 13 '(23170 . 31129)) + a (md4-round2 a b c d (aref m 3) 3 '(23170 . 31129)) + d (md4-round2 d a b c (aref m 7) 5 '(23170 . 31129)) + c (md4-round2 c d a b (aref m 11) 9 '(23170 . 31129)) + b (md4-round2 b c d a (aref m 15) 13 '(23170 . 31129)) + + a (md4-round3 a b c d (aref m 0) 3 '(28377 . 60321)) ;0x6ED9EBA1 + d (md4-round3 d a b c (aref m 8) 9 '(28377 . 60321)) + c (md4-round3 c d a b (aref m 4) 11 '(28377 . 60321)) + b (md4-round3 b c d a (aref m 12) 15 '(28377 . 60321)) + a (md4-round3 a b c d (aref m 2) 3 '(28377 . 60321)) + d (md4-round3 d a b c (aref m 10) 9 '(28377 . 60321)) + c (md4-round3 c d a b (aref m 6) 11 '(28377 . 60321)) + b (md4-round3 b c d a (aref m 14) 15 '(28377 . 60321)) + a (md4-round3 a b c d (aref m 1) 3 '(28377 . 60321)) + d (md4-round3 d a b c (aref m 9) 9 '(28377 . 60321)) + c (md4-round3 c d a b (aref m 5) 11 '(28377 . 60321)) + b (md4-round3 b c d a (aref m 13) 15 '(28377 . 60321)) + a (md4-round3 a b c d (aref m 3) 3 '(28377 . 60321)) + d (md4-round3 d a b c (aref m 11) 9 '(28377 . 60321)) + c (md4-round3 c d a b (aref m 7) 11 '(28377 . 60321)) + b (md4-round3 b c d a (aref m 15) 15 '(28377 . 60321))) + + (aset md4-buffer 0 (md4-add a (aref md4-buffer 0))) + (aset md4-buffer 1 (md4-add b (aref md4-buffer 1))) + (aset md4-buffer 2 (md4-add c (aref md4-buffer 2))) + (aset md4-buffer 3 (md4-add d (aref md4-buffer 3))) + )) + +(defun md4-copy64 (seq) + "Unpack a 64 bytes string into 16 pairs of 32 bits integers." + (let ((int32s (make-vector 16 0)) (i 0) j) + (while (< i 16) + (setq j (* i 4)) + (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8)) + (+ (aref seq j) (lsh (aref seq (1+ j)) 8)))) + (setq i (1+ i))) + int32s)) + +;;; +;;; sub functions + +(defun md4-pack-int16 (int16) + "Pack 16 bits integer in 2 bytes string as little endian." + (let ((str (make-string 2 0))) + (aset str 0 (logand int16 255)) + (aset str 1 (lsh int16 -8)) + str)) + +(defun md4-pack-int32 (int32) + "Pack 32 bits integer in a 4 bytes string as little endian. A 32 bits +integer is represented as a pair of two 16 bits integers (cons high low)." + (let ((str (make-string 4 0)) + (h (car int32)) (l (cdr int32))) + (aset str 0 (logand l 255)) + (aset str 1 (lsh l -8)) + (aset str 2 (logand h 255)) + (aset str 3 (lsh h -8)) + str)) + +(defun md4-unpack-int16 (str) + (if (eq 2 (length str)) + (+ (lsh (aref str 1) 8) (aref str 0)) + (error "%s is not 2 bytes long" str))) + +(defun md4-unpack-int32 (str) + (if (eq 4 (length str)) + (cons (+ (lsh (aref str 3) 8) (aref str 2)) + (+ (lsh (aref str 1) 8) (aref str 0))) + (error "%s is not 4 bytes long" str))) + +(provide 'md4) + +;;; arch-tag: 99d706fe-089b-42ea-9507-67ae41091e6e +;;; md4.el ends here diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 419fd07727c..895c36a6beb 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -35,6 +35,7 @@ (require 'cl) (defvar gnus-message-group-art) (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary +(require 'hashcash) (require 'canlock) (require 'mailheader) (require 'gmm-utils) @@ -48,10 +49,8 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(eval-and-compile - (autoload 'gnus-find-method-for-group "gnus") - (autoload 'nnvirtual-find-group-art "nnvirtual") - (autoload 'gnus-group-decoded-name "gnus-group")) +(require 'ecomplete) + (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -156,7 +155,6 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) -;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -190,8 +188,8 @@ To disable checking of long signatures, for instance, add Don't touch this variable unless you really know what you're doing. -Checks include `approved', `continuation-headers', `control-chars', -`empty', `existing-newsgroups', `from', `illegible-text', +Checks include `approved', `bogus-recipient', `continuation-headers', +`control-chars', `empty', `existing-newsgroups', `from', `illegible-text', `invisible-text', `long-header-lines', `long-lines', `message-id', `multiple-headers', `new-text', `newsgroups', `quoting-style', `repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot', @@ -211,7 +209,7 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From) +(defcustom message-draft-headers '(References From Date) "*Headers to be generated when saving a draft message." :version "22.1" :group 'message-news @@ -271,7 +269,7 @@ included. Organization and User-Agent are optional." :link '(custom-manual "(message)Mail Headers") :type 'regexp) -(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." @@ -304,7 +302,7 @@ used." :version "22.1" :type '(choice (const :tag "never" nil) (const :tag "always strip" t) - (const ask)) + (const ask)) :link '(custom-manual "(message)Message Headers") :group 'message-various) @@ -411,7 +409,6 @@ for `message-cross-post-insert-note'." ;;; End of variables adopted from `message-utils.el'. -;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." :type 'regexp @@ -470,6 +467,13 @@ function :link '(custom-manual "(message)Message Buffers") :type 'boolean) +(defcustom message-kill-buffer-query t + "*Non-nil means that killing a modified message buffer has to be confirmed. +This is used by `message-kill-buffer'." + :version "23.0" ;; No Gnus + :group 'message-buffers + :type 'boolean) + (eval-when-compile (defvar gnus-local-organization)) (defcustom message-user-organization @@ -484,8 +488,14 @@ If t, use `message-user-organization-file'." :type '(choice string (const :tag "consult file" t))) -;;;###autoload -(defcustom message-user-organization-file "/usr/lib/news/organization" +(defcustom message-user-organization-file + (let (orgfile) + (dolist (f (list "/etc/organization" + "/etc/news/organization" + "/usr/lib/news/organization")) + (when (file-readable-p f) + (setq orgfile f))) + orgfile) "*Local news organization file." :type 'file :link '(custom-manual "(message)News Headers") @@ -578,15 +588,13 @@ Done before generating the new subject of a forward." (if (string-match "[[:digit:]]" "1") ;; support POSIX? "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. - (let ((old-table (syntax-table)) - non-word-constituents) - (set-syntax-table text-mode-syntax-table) - (setq non-word-constituents - (concat - (if (string-match "\\w" "-") "" "-") - (if (string-match "\\w" "_") "" "_") - (if (string-match "\\w" ".") "" "."))) - (set-syntax-table old-table) + (let (non-word-constituents) + (with-syntax-table text-mode-syntax-table + (setq non-word-constituents + (concat + (if (string-match "\\w" "-") "" "-") + (if (string-match "\\w" "_") "" "_") + (if (string-match "\\w" ".") "" ".")))) (if (equal non-word-constituents "") "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" (concat "\\([ \t]*\\(\\w\\|[" @@ -596,7 +604,13 @@ Done before generating the new subject of a forward." :version "22.1" :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") - :type 'regexp) + :type 'regexp + :set (lambda (symbol value) + (prog1 + (custom-set-default symbol value) + (if (boundp 'gnus-message-cite-prefix-regexp) + (setq gnus-message-cite-prefix-regexp + (concat "^\\(?:" value "\\)")))))) (defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." @@ -605,8 +619,20 @@ Done before generating the new subject of a forward." :type 'string) ;; Useful to set in site-init.el -;;;###autoload -(defcustom message-send-mail-function 'message-send-mail-with-sendmail +(defcustom message-send-mail-function + (let ((program (if (boundp 'sendmail-program) + ;; see paths.el + sendmail-program))) + (cond + ((and program + (string-match "/" program) ;; Skip path + (file-executable-p program)) + 'message-send-mail-with-sendmail) + ((and program + (executable-find program)) + 'message-send-mail-with-sendmail) + (t + 'smtpmail-send-it))) "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the variable `mail-header-separator'. @@ -660,6 +686,12 @@ and respond with new To and Cc headers." :link '(custom-manual "(message)Followup") :type '(choice function (const nil))) +(defcustom message-extra-wide-headers nil + "If non-nil, a list of additional address headers. +These are used when composing a wide reply." + :group 'message-sending + :type '(repeat string)) + (defcustom message-use-followup-to 'ask "*Specifies what to do with Followup-To header. If nil, always ignore the header. If it is t, use its value, but @@ -756,6 +788,14 @@ If this is nil, use `user-mail-address'. If it is the symbol :link '(custom-manual "(message)Mail Variables") :group 'message-sending) +(defcustom message-sendmail-extra-arguments nil + "Additional arguments to `sendmail-program'." + ;; E.g. '("-a" "account") for msmtp + :version "23.0" ;; No Gnus + :type '(repeat string) + ;; :link '(custom-manual "(message)Mail Variables") + :group 'message-sending) + ;; qmail-related stuff (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" "Location of the qmail-inject program." @@ -776,11 +816,6 @@ might set this variable to '(\"-f\" \"you@some.where\")." :type '(choice (function) (repeat string))) -(defvar message-cater-to-broken-inn t - "Non-nil means Gnus should not fold the `References' header. -Folding `References' makes ancient versions of INN create incorrect -NOV lines.") - (eval-when-compile (defvar gnus-post-method) (defvar gnus-select-method)) @@ -817,9 +852,18 @@ will not have a visible effect for those headers." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "None" nil) - (const :tag "References" '(references)) - (const :tag "All" t) - (repeat (sexp :tag "Header")))) + (const :tag "References" '(references)) + (const :tag "All" t) + (repeat (sexp :tag "Header")))) + +(defcustom message-fill-column 72 + "Column beyond which automatic line-wrapping should happen. +Local value for message buffers. If non-nil, also turn on +auto-fill in message buffers." + :group 'message-various + ;; :link '(custom-manual "(message)Message Headers") + :type '(choice (const :tag "Don't turn on auto fill" nil) + (integer))) (defcustom message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. @@ -866,31 +910,71 @@ the signature is inserted." :version "22.1" :group 'message-various) -;;;###autoload (defcustom message-citation-line-function 'message-insert-citation-line "*Function called to insert the \"Whomever writes:\" line. +Predefined functions include `message-insert-citation-line' and +`message-insert-formatted-citation-line' (see the variable +`message-citation-line-format'). + Note that Gnus provides a feature where the reader can click on `writes:' to hide the cited text. If you change this line too much, people who read your message will have to change their Gnus configuration. See the variable `gnus-cite-attribution-suffix'." - :type 'function + :type '(choice + (function-item :tag "plain" message-insert-citation-line) + (function-item :tag "formatted" message-insert-formatted-citation-line) + (function :tag "Other")) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload +(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n" + "Format of the \"Whomever writes:\" line. + +The string is formatted using `format-spec'. The following +constructs are replaced: + + %f The full From, e.g. \"John Doe <john.doe@example.invalid>\". + %n The mail address, e.g. \"john.doe@example.invalid\". + %N The real name if present, e.g.: \"John Doe\", else fall + back to the mail address. + %F The first name if present, e.g.: \"John\". + %L The last name if present, e.g.: \"Doe\". + +All other format specifiers are passed to `format-time-string' +which is called using the date from the article your replying to. +Extracting the first (%F) and last name (%L) is done +heuristically, so you should always check it yourself. + +Please also read the note in the documentation of +`message-citation-line-function'." + :type '(choice (const :tag "Plain" "%f writes:") + (const :tag "Include date" "On %a, %b %d %Y, %n wrote:") + string) + :link '(custom-manual "(message)Insertion Variables") + :version "23.0" ;; No Gnus + :group 'message-insertion) + (defcustom message-yank-prefix "> " "*Prefix inserted on the lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. -See also `message-yank-cited-prefix'." +See also `message-yank-cited-prefix' and `message-yank-empty-prefix'." :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-yank-cited-prefix ">" - "*Prefix inserted on cited or empty lines of yanked messages. + "*Prefix inserted on cited lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. -See also `message-yank-prefix'." +See also `message-yank-prefix' and `message-yank-empty-prefix'." + :version "22.1" + :type 'string + :link '(custom-manual "(message)Insertion Variables") + :group 'message-insertion) + +(defcustom message-yank-empty-prefix ">" + "*Prefix inserted on empty lines of yanked messages. +See also `message-yank-prefix' and `message-yank-cited-prefix'." :version "22.1" :type 'string :link '(custom-manual "(message)Insertion Variables") @@ -903,12 +987,11 @@ Used by `message-yank-original' via `message-yank-cite'." :link '(custom-manual "(message)Insertion Variables") :type 'integer) -;;;###autoload (defcustom message-cite-function 'message-cite-original "*Function for citing an original message. Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. -Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." +Note that these functions use `mail-citation-hook' if that is non-nil." :type '(radio (function-item message-cite-original) (function-item message-cite-original-without-signature) (function-item sc-cite-original) @@ -916,7 +999,6 @@ Note that `message-cite-original' uses `mail-citation-hook' if that is non-nil." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-indent-citation-function 'message-indent-citation "*Function for modifying a citation just inserted in the mail buffer. This can also be a list of functions. Each function can find the @@ -926,7 +1008,6 @@ point and mark around the citation text as modified." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-signature t "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. @@ -936,16 +1017,26 @@ If a form, the result from the form will be used instead." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload (defcustom message-signature-file "~/.signature" "*Name of file containing the text inserted at end of message buffer. Ignored if the named file doesn't exist. -If nil, don't insert a signature." +If nil, don't insert a signature. +If a path is specified, the value of `message-signature-directory' is ignored, +even if set." :type '(choice file (const :tags "None" nil)) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -;;;###autoload +(defcustom message-signature-directory nil + "*Name of directory containing signature files. +Comes in handy if you have many such files, handled via posting styles for +instance. +If nil, `message-signature-file' is expected to specify the directory if +needed." + :type '(choice string (const :tags "None" nil)) + :link '(custom-manual "(message)Insertion Variables") + :group 'message-insertion) + (defcustom message-signature-insert-empty-line t "*If non-nil, insert an empty line before the signature separator." :version "22.1" @@ -1075,13 +1166,25 @@ the prefix.") (defcustom message-mail-alias-type 'abbrev "*What alias expansion type to use in Message buffers. -The default is `abbrev', which uses mailabbrev. nil switches -mail aliases off." +The default is `abbrev', which uses mailabbrev. `ecomplete' uses +an electric completion mode. nil switches mail aliases off. +This can also be a list of values." :group 'message :link '(custom-manual "(message)Mail Aliases") :type '(choice (const :tag "Use Mailabbrev" abbrev) + (const :tag "Use ecomplete" ecomplete) (const :tag "No expansion" nil))) +(defcustom message-self-insert-commands '(self-insert-command) + "List of `self-insert-command's used to trigger ecomplete. +When one of those commands is invoked to enter a character in To or Cc +header, ecomplete will suggest the candidates of recipients (see also +`message-mail-alias-type'). If you use some tool to enter non-ASCII +text and it replaces `self-insert-command' with the other command, e.g. +`egg-self-insert-command', you may want to add it to this list." + :group 'message-various + :type '(repeat function)) + (defcustom message-auto-save-directory (file-name-as-directory (nnheader-concat message-directory "drafts")) "*Directory where Message auto-saves buffers if Gnus isn't running. @@ -1101,13 +1204,18 @@ If nil, you might be asked to input the charset." (defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) - "*A regexp specifying addresses to prune when doing wide replies. -A value of nil means exclude your own user name only." + "*Addresses to prune when doing wide replies. +This can be a regexp or a list of regexps. Also, a value of nil means +exclude your own user name only." :version "21.1" :group 'message :link '(custom-manual "(message)Wide Reply") :type '(choice (const :tag "Yourself" nil) - regexp)) + regexp + (repeat :tag "Regexp List" regexp))) + +(defsubst message-dont-reply-to-names () + (gmm-regexp-concat message-dont-reply-to-names)) (defvar message-shoot-gnksa-feet nil "*A list of GNKSA feet you are allowed to shoot. @@ -1119,20 +1227,34 @@ candidates: `quoted-text-only' Allow you to post quoted text only; `multiple-copies' Allow you to post multiple copies; `cancel-messages' Allow you to cancel or supersede messages from - your other email addresses.") + your other email addresses.") (defsubst message-gnksa-enable-p (feature) (or (not (listp message-shoot-gnksa-feet)) (memq feature message-shoot-gnksa-feet))) -(defcustom message-hidden-headers nil +(defcustom message-hidden-headers '("^References:" "^Face:" "^X-Face:" + "^X-Draft-From:") "Regexp of headers to be hidden when composing new messages. This can also be a list of regexps to match headers. Or a list starting with `not' and followed by regexps." :version "22.1" :group 'message :link '(custom-manual "(message)Message Headers") - :type '(repeat regexp)) + :type '(choice + :format "%{%t%}: %[Value Type%] %v" + (regexp :menu-tag "regexp" :format "regexp\n%t: %v") + (repeat :menu-tag "(regexp ...)" :format "(regexp ...)\n%v%i" + (regexp :format "%t: %v")) + (cons :menu-tag "(not regexp ...)" :format "(not regexp ...)\n%v" + (const not) + (repeat :format "%v%i" + (regexp :format "%t: %v"))))) + +(defcustom message-cite-articles-with-x-no-archive t + "If non-nil, cite text from articles that has X-No-Archive set." + :group 'message + :type 'boolean) ;;; Internal variables. ;;; Well, not really internal. @@ -1148,7 +1270,7 @@ starting with `not' and followed by regexps." (defface message-header-to '((((class color) (background dark)) - (:foreground "green2" :bold t)) + (:foreground "DarkOliveGreen1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue" :bold t)) @@ -1162,7 +1284,7 @@ starting with `not' and followed by regexps." (defface message-header-cc '((((class color) (background dark)) - (:foreground "green4" :bold t)) + (:foreground "chartreuse1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue")) @@ -1176,7 +1298,7 @@ starting with `not' and followed by regexps." (defface message-header-subject '((((class color) (background dark)) - (:foreground "green3")) + (:foreground "OliveDrab1")) (((class color) (background light)) (:foreground "navy blue" :bold t)) @@ -1204,7 +1326,7 @@ starting with `not' and followed by regexps." (defface message-header-other '((((class color) (background dark)) - (:foreground "#b00000")) + (:foreground "VioletRed1")) (((class color) (background light)) (:foreground "steel blue")) @@ -1218,7 +1340,7 @@ starting with `not' and followed by regexps." (defface message-header-name '((((class color) (background dark)) - (:foreground "DarkGreen")) + (:foreground "green")) (((class color) (background light)) (:foreground "cornflower blue")) @@ -1232,7 +1354,7 @@ starting with `not' and followed by regexps." (defface message-header-xheader '((((class color) (background dark)) - (:foreground "blue")) + (:foreground "DeepSkyBlue1")) (((class color) (background light)) (:foreground "blue")) @@ -1246,7 +1368,7 @@ starting with `not' and followed by regexps." (defface message-separator '((((class color) (background dark)) - (:foreground "blue3")) + (:foreground "LightSkyBlue1")) (((class color) (background light)) (:foreground "brown")) @@ -1260,7 +1382,7 @@ starting with `not' and followed by regexps." (defface message-cited-text '((((class color) (background dark)) - (:foreground "red")) + (:foreground "LightPink1")) (((class color) (background light)) (:foreground "red")) @@ -1274,7 +1396,7 @@ starting with `not' and followed by regexps." (defface message-mml '((((class color) (background dark)) - (:foreground "ForestGreen")) + (:foreground "MediumSpringGreen")) (((class color) (background light)) (:foreground "ForestGreen")) @@ -1322,13 +1444,13 @@ starting with `not' and followed by regexps." (1 'message-header-name) (2 'message-header-newsgroups nil t)) (,(message-font-lock-make-header-matcher - (concat "^\\([A-Z][^: \n\t]+:\\)" content)) + (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) (1 'message-header-name) - (2 'message-header-other nil t)) + (2 'message-header-xheader)) (,(message-font-lock-make-header-matcher - (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) + (concat "^\\([A-Z][^: \n\t]+:\\)" content)) (1 'message-header-name) - (2 'message-header-name)) + (2 'message-header-other nil t)) ,@(if (and mail-header-separator (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") @@ -1350,10 +1472,10 @@ starting with `not' and followed by regexps." (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) (defvar message-face-alist - '((bold . bold-region) + '((bold . message-bold-region) (underline . underline-region) (default . (lambda (b e) - (unbold-region b e) + (message-unbold-region b e) (ununderline-region b e)))) "Alist of mail and news faces for facemenu. The cdr of each entry is a function for applying the face to a region.") @@ -1493,6 +1615,19 @@ functionality to work." (const :tag "Never" nil) (const :tag "Always" t))) +(defcustom message-generate-hashcash (if (executable-find "hashcash") t) + "*Whether to generate X-Hashcash: headers. +If `t', always generate hashcash headers. If `opportunistic', +only generate hashcash headers if it can be done without the user +waiting (i.e., only asynchronously). + +You must have the \"hashcash\" binary installed, see `hashcash-path'." + :group 'message-headers + :link '(custom-manual "(message)Mail Headers") + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Opportunistic" opportunistic))) + ;;; Internal variables. (defvar message-sending-message "Sending...") @@ -1575,10 +1710,17 @@ functionality to work." "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") +(defvar message-field-fillers + '((To message-fill-field-address) + (Cc message-fill-field-address) + (From message-fill-field-address)) + "Alist of header names/filler functions.") + (defvar message-header-format-alist - `((Newsgroups) - (To . message-fill-address) - (Cc . message-fill-address) + `((From) + (Newsgroups) + (To) + (Cc) (Subject) (In-Reply-To) (Fcc) @@ -1622,28 +1764,32 @@ functionality to work." :type 'regexp) (eval-and-compile + (autoload 'gnus-alive-p "gnus-util") + (autoload 'gnus-delay-article "gnus-delay") + (autoload 'gnus-extract-address-components "gnus-util") + (autoload 'gnus-find-method-for-group "gnus") + (autoload 'gnus-group-decoded-name "gnus-group") + (autoload 'gnus-group-name-charset "gnus-group") + (autoload 'gnus-group-name-decode "gnus-group") + (autoload 'gnus-groups-from-server "gnus") + (autoload 'gnus-make-local-hook "gnus-util") + (autoload 'gnus-open-server "gnus-int") + (autoload 'gnus-output-to-mail "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") + (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-select-frame-set-input-focus "gnus-util") + (autoload 'gnus-server-string "gnus") (autoload 'idna-to-ascii "idna") (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-new-draft-name "mh-comp") (autoload 'mh-send-letter "mh-comp") - (autoload 'gnus-point-at-eol "gnus-util") - (autoload 'gnus-point-at-bol "gnus-util") - (autoload 'gnus-output-to-rmail "gnus-util") - (autoload 'gnus-output-to-mail "gnus-util") (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") - (autoload 'gnus-open-server "gnus-int") - (autoload 'gnus-request-post "gnus-int") - (autoload 'gnus-alive-p "gnus-util") - (autoload 'gnus-server-string "gnus") - (autoload 'gnus-group-name-charset "gnus-group") - (autoload 'gnus-group-name-decode "gnus-group") - (autoload 'gnus-groups-from-server "gnus") - (autoload 'rmail-output "rmailout") - (autoload 'gnus-delay-article "gnus-delay") - (autoload 'gnus-make-local-hook "gnus-util") - (autoload 'gnus-extract-address-components "gnus-util") - (autoload 'gnus-select-frame-set-input-focus "gnus-util")) + (autoload 'nnvirtual-find-group-art "nnvirtual") + (autoload 'rmail-dont-reply-to "mail-utils") + (autoload 'rmail-msg-is-pruned "rmail") + (autoload 'rmail-msg-restore-non-pruned-header "rmail") + (autoload 'rmail-output "rmailout")) @@ -1723,12 +1869,10 @@ is used by default." The buffer is expected to be narrowed to just the header of the message; see `message-narrow-to-headers-or-head'." (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) (value (mail-fetch-field header nil (not not-all)))) (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - (set-text-properties 0 (length value) nil value) value))) (defun message-field-value (header &optional not-all) @@ -1741,14 +1885,14 @@ see `message-narrow-to-headers-or-head'." (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." (beginning-of-line) + (while (looking-at "[ \t]") + (forward-line -1)) (narrow-to-region (point) (progn (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) - (progn - (beginning-of-line) - (point)) + (point-at-bol) (point-max)))) (goto-char (point-min))) @@ -1964,28 +2108,30 @@ Leading \"Re: \" is not stripped by this function. Use the function " (was: " old-subject ")\n"))))))))) -(defun message-mark-inserted-region (beg end) +(defun message-mark-inserted-region (beg end &optional verbatim) "Mark some region in the current article with enclosing tags. -See `message-mark-insert-begin' and `message-mark-insert-end'." - (interactive "r") +See `message-mark-insert-begin' and `message-mark-insert-end'. +If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")." + (interactive "r\nP") (save-excursion ;; add to the end of the region first, otherwise end would be invalid (goto-char end) - (insert message-mark-insert-end) + (insert (if verbatim "#v-\n" message-mark-insert-end)) (goto-char beg) - (insert message-mark-insert-begin))) + (insert (if verbatim "#v+\n" message-mark-insert-begin)))) -(defun message-mark-insert-file (file) +(defun message-mark-insert-file (file &optional verbatim) "Insert FILE at point, marking it with enclosing tags. -See `message-mark-insert-begin' and `message-mark-insert-end'." - (interactive "fFile to insert: ") +See `message-mark-insert-begin' and `message-mark-insert-end'. +If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")." + (interactive "fFile to insert: \nP") ;; reverse insertion to get correct result. (let ((p (point))) - (insert message-mark-insert-end) + (insert (if verbatim "#v-\n" message-mark-insert-end)) (goto-char p) (insert-file-contents file) (goto-char p) - (insert message-mark-insert-begin))) + (insert (if verbatim "#v+\n" message-mark-insert-begin)))) (defun message-add-archive-header () "Insert \"X-No-Archive: Yes\" in the header and a note in the body. @@ -2304,6 +2450,14 @@ Point is left at the beginning of the narrowed-to region." (1+ max))))) (message-sort-headers-1)))) +(defun message-kill-address () + "Kill the address under point." + (interactive) + (let ((start (point))) + (message-skip-to-next-address) + (kill-region start (point)))) + + (defun message-info (&optional arg) "Display the Message manual. @@ -2365,6 +2519,7 @@ Prefixed with two \\[universal-argument]'s, display the PGG manual." (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply) (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-l" 'message-to-list-only) + (define-key message-mode-map "\C-c\C-f\C-e" 'message-insert-expires) (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance) (define-key message-mode-map "\C-c\M-n" @@ -2385,18 +2540,20 @@ Prefixed with two \\[universal-argument]'s, display the PGG manual." (define-key message-mode-map "\C-c\C-d" 'message-dont-send) (define-key message-mode-map "\C-c\n" 'gnus-delay-article) + (define-key message-mode-map "\C-c\M-k" 'message-kill-address) (define-key message-mode-map "\C-c\C-e" 'message-elide-region) (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) - ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph) (define-key message-mode-map [remap split-line] 'message-split-line) (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) (define-key message-mode-map "\C-a" 'message-beginning-of-line) (define-key message-mode-map "\t" 'message-tab) - (define-key message-mode-map "\M-;" 'comment-region)) + (define-key message-mode-map "\M-;" 'comment-region) + + (define-key message-mode-map "\M-n" 'message-display-abbrev)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -2477,7 +2634,8 @@ Prefixed with two \\[universal-argument]'s, display the PGG manual." ;; ["Followup-To (with note in body)" message-cross-post-followup-to t] ["Crosspost / Followup-To..." message-cross-post-followup-to t] ["Distribution" message-goto-distribution t] - ["X-No-Archive:" message-add-archive-header t ] + ["Expires" message-insert-expires t ] + ["X-No-Archive" message-add-archive-header t ] "----" ;; (typical) mailing-lists stuff ["Fetch To" message-insert-to @@ -2497,6 +2655,8 @@ Prefixed with two \\[universal-argument]'s, display the PGG manual." "----" ["Sort Headers" message-sort-headers t] ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t] + ;; We hide `message-hidden-headers' by narrowing the buffer. + ["Show Hidden Headers" widen t] ["Goto Body" message-goto-body t] ["Goto Signature" message-goto-signature t])) @@ -2555,19 +2715,23 @@ These properties are essential to work, so we should never strip them." (get-text-property pos 'egg-lang) (get-text-property pos 'egg-start))))) +(defsubst message-mail-alias-type-p (type) + (if (atom message-mail-alias-type) + (eq message-mail-alias-type type) + (memq type message-mail-alias-type))) + (defun message-strip-forbidden-properties (begin end &optional old-length) "Strip forbidden properties between BEGIN and END, ignoring the third arg. This function is intended to be called from `after-change-functions'. See also `message-forbidden-properties'." + (when (and (message-mail-alias-type-p 'ecomplete) + (memq this-command message-self-insert-commands)) + (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) (let ((buffer-read-only nil) (inhibit-read-only t)) - (while (not (= begin end)) - (when (not (get-text-property begin 'message-hidden)) - (remove-text-properties begin (1+ begin) - message-forbidden-properties)) - (incf begin))))) + (remove-text-properties begin end message-forbidden-properties)))) ;;;###autoload (define-derived-mode message-mode text-mode "Message" @@ -2581,9 +2745,10 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to From (\"Originator\") + C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To C-c C-f C-m move to Mail-Followup-To + C-c C-f C-e move to Expires C-c C-f C-i cycle through Importance values C-c C-f s change subject and append \"(was: <Old Subject>)\" C-c C-f x crossposting with FollowUp-To header and note in body @@ -2632,6 +2797,9 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'message-checksum) nil) (set (make-local-variable 'message-mime-part) 0) (message-setup-fill-variables) + (when message-fill-column + (setq fill-column message-fill-column) + (turn-on-auto-fill)) ;; Allow using comment commands to add/remove quoting. ;; (set (make-local-variable 'comment-start) message-yank-prefix) (when message-yank-prefix @@ -2651,11 +2819,14 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (add-hook 'after-change-functions 'message-strip-forbidden-properties nil 'local) ;; Allow mail alias things. - (when (eq message-mail-alias-type 'abbrev) + (cond + ((message-mail-alias-type-p 'abbrev) (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) (if (fboundp 'mail-aliases-setup) ; warning avoidance (mail-aliases-setup)))) + ((message-mail-alias-type-p 'ecomplete) + (ecomplete-setup))) (unless buffer-file-name (message-set-auto-save-file-name)) (unless (buffer-base-buffer) @@ -2706,6 +2877,8 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." ;; solution would be not to use `define-derived-mode', and run ;; `text-mode-hook' ourself at the end of the mode. ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19. + ;; This kludge is unneeded in Emacs>=21 since define-derived-mode is + ;; now careful to run parent hooks after the body. --Stef (when auto-fill-function (setq auto-fill-function normal-auto-fill-function))) @@ -2845,11 +3018,11 @@ If the original author requested not to be sent mail, don't insert unless the prefix FORCE is given." (interactive "P") (let* ((mct (message-fetch-reply-field "mail-copies-to")) - (dont (and mct (or (equal (downcase mct) "never") + (dont (and mct (or (equal (downcase mct) "never") (equal (downcase mct) "nobody")))) - (to (or (message-fetch-reply-field "mail-reply-to") - (message-fetch-reply-field "reply-to") - (message-fetch-reply-field "from")))) + (to (or (message-fetch-reply-field "mail-reply-to") + (message-fetch-reply-field "reply-to") + (message-fetch-reply-field "from")))) (when (and dont to) (message (if force @@ -2889,21 +3062,21 @@ or in the synonym headers, defined by `message-header-synonyms'." ;; (mail-strip-quoted-names "Foo Bar <foo@bar>, bla@fasel (Bla Fasel)") (dolist (header headers) (let* ((header-name (symbol-name (car header))) - (new-header (cdr header)) - (synonyms (loop for synonym in message-header-synonyms + (new-header (cdr header)) + (synonyms (loop for synonym in message-header-synonyms when (memq (car header) synonym) return synonym)) - (old-header - (loop for synonym in synonyms + (old-header + (loop for synonym in synonyms for old-header = (mail-fetch-field (symbol-name synonym)) when (and old-header (string-match new-header old-header)) return synonym))) (if old-header - (message "already have `%s' in `%s'" new-header old-header) + (message "already have `%s' in `%s'" new-header old-header) (when (and (message-position-on-field header-name) - (setq old-header (mail-fetch-field header-name)) - (not (string-match "\\` *\\'" old-header))) + (setq old-header (mail-fetch-field header-name)) + (not (string-match "\\` *\\'" old-header))) (insert ", ")) - (insert new-header))))) + (insert new-header))))) (defun message-widen-reply () "Widen the reply to include maximum recipients." @@ -2961,22 +3134,30 @@ or in the synonym headers, defined by `message-header-synonyms'." (when (message-goto-signature) (forward-line -2))) -(defun message-kill-to-signature () - "Deletes all text up to the signature." - (interactive) - (let ((point (point))) - (message-goto-signature) - (unless (eobp) - (end-of-line -1)) - (kill-region point (point)) - (unless (bolp) - (insert "\n")))) +(defun message-kill-to-signature (&optional arg) + "Kill all text up to the signature. +If a numberic argument or prefix arg is given, leave that number +of lines before the signature intact." + (interactive "P") + (save-excursion + (save-restriction + (let ((point (point))) + (narrow-to-region point (point-max)) + (message-goto-signature) + (unless (eobp) + (if (and arg (numberp arg)) + (forward-line (- -1 arg)) + (end-of-line -1))) + (unless (= point (point)) + (kill-region point (point)) + (unless (bolp) + (insert "\n"))))))) (defun message-newline-and-reformat (&optional arg not-break) "Insert four newlines, and then reformat if inside quoted text. Prefix arg means justify as well." (interactive (list (if current-prefix-arg 'full))) - (let (quoted point beg end leading-space bolp) + (let (quoted point beg end leading-space bolp fill-paragraph-function) (setq point (point)) (beginning-of-line) (setq beg (point)) @@ -3061,22 +3242,22 @@ Prefix arg means justify as well." (if point (goto-char point))))) (defun message-fill-paragraph (&optional arg) - "Like `fill-paragraph'." + "Message specific function to fill a paragraph. +This function is used as the value of `fill-paragraph-function' in +Message buffers and is not meant to be called directly." (interactive (list (if current-prefix-arg 'full))) (if (if (boundp 'filladapt-mode) filladapt-mode) nil - (message-newline-and-reformat arg t) + (if (message-point-in-header-p) + (message-fill-field) + (message-newline-and-reformat arg t)) t)) -;; Is it better to use `mail-header-end'? (defun message-point-in-header-p () "Return t if point is in the header." (save-excursion - (let ((p (point))) - (goto-char (point-min)) - (not (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") - p t))))) + (not (re-search-backward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t)))) (defun message-do-auto-fill () "Like `do-auto-fill', but don't fill in message header." @@ -3101,13 +3282,21 @@ Prefix arg means justify as well." ((listp message-signature) (eval message-signature)) (t message-signature))) - (signature + signature-file) + (setq signature (cond ((stringp signature) signature) - ((and (eq t signature) - message-signature-file - (file-exists-p message-signature-file)) - signature)))) + ((and (eq t signature) message-signature-file) + (setq signature-file + (if (and message-signature-directory + ;; don't actually use the signature directory + ;; if message-signature-file contains a path. + (not (file-name-directory + message-signature-file))) + (nnheader-concat message-signature-directory + message-signature-file) + message-signature-file)) + (file-exists-p signature-file)))) (when signature (goto-char (point-max)) ;; Insert the signature. @@ -3117,7 +3306,7 @@ Prefix arg means justify as well." (insert "\n")) (insert "-- \n") (if (eq signature t) - (insert-file-contents message-signature-file) + (insert-file-contents signature-file) (insert signature)) (goto-char (point-max)) (or (bolp) (insert "\n"))))) @@ -3222,17 +3411,17 @@ text was killed." (substring table ?a (+ ?a n)) (substring table (+ ?a 26) 255)))) -(defun message-caesar-buffer-body (&optional rotnum) +(defun message-caesar-buffer-body (&optional rotnum wide) "Caesar rotate all letters in the current buffer by 13 places. Used to encode/decode possibly offensive messages (commonly in rec.humor). With prefix arg, specifies the number of places to rotate each letter forward. -Mail and USENET news headers are not rotated." +Mail and USENET news headers are not rotated unless WIDE is non-nil." (interactive (if current-prefix-arg (list (prefix-numeric-value current-prefix-arg)) (list nil))) (save-excursion (save-restriction - (when (message-goto-body) + (when (and (not wide) (message-goto-body)) (narrow-to-region (point) (point-max))) (message-caesar-region (point-min) (point-max) rotnum)))) @@ -3279,14 +3468,15 @@ Numeric argument means justify as well." (let ((fill-prefix message-yank-prefix)) (fill-individual-paragraphs (point) (point-max) justifyp)))) -(defun message-indent-citation () +(defun message-indent-citation (&optional start end yank-only) "Modify text just inserted from a message to be cited. The inserted text should be the region. When this function returns, the region is again around the modified text. Normally, indent each nonblank line `message-indentation-spaces' spaces. However, if `message-yank-prefix' is non-nil, insert that prefix on each line." - (let ((start (point))) + (unless start (setq start (point))) + (unless yank-only ;; Remove unwanted headers. (when message-ignored-cited-headers (let (all-removed) @@ -3314,18 +3504,53 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (insert "\n")) (while (and (zerop (forward-line -1)) (looking-at "$")) - (message-delete-line)) - ;; Do the indentation. - (if (null message-yank-prefix) - (indent-rigidly start (mark t) message-indentation-spaces) - (save-excursion - (goto-char start) - (while (< (point) (mark t)) - (if (or (looking-at ">") (looking-at "^$")) - (insert message-yank-cited-prefix) - (insert message-yank-prefix)) - (forward-line 1)))) - (goto-char start))) + (message-delete-line))) + ;; Do the indentation. + (if (null message-yank-prefix) + (indent-rigidly start (or end (mark t)) message-indentation-spaces) + (save-excursion + (goto-char start) + (while (< (point) (or end (mark t))) + (cond ((looking-at ">") + (insert message-yank-cited-prefix)) + ((looking-at "^$") + (insert message-yank-empty-prefix)) + (t + (insert message-yank-prefix))) + (forward-line 1)))) + (goto-char start)) + +(defun message-remove-blank-cited-lines (&optional remove) + "Remove cited lines containing only blanks. +If REMOVE is non-nil, remove newlines, too. + +To use this automatically, you may add this function to +`gnus-message-setup-hook'." + (interactive "P") + (let ((citexp + (concat + "^\\(" + (when (boundp 'message-yank-cited-prefix) + (concat message-yank-cited-prefix "\\|")) + message-yank-prefix + "\\)+ *\n" + ))) + (gnus-message 8 "removing `%s'" citexp) + (save-excursion + (message-goto-body) + (while (re-search-forward citexp nil t) + (replace-match (if remove "" "\n")))))) + +(defvar message-cite-reply-above nil + "If non-nil, start own text above the quote. + +Note: Top posting is bad netiquette. Don't use it unless you +really must. You probably want to set variable only for specific +groups, e.g. using `gnus-posting-styles': + + (eval (set (make-local-variable 'message-cite-reply-above) t)) + +This variable has no effect in news postings.") (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. @@ -3338,9 +3563,22 @@ This function uses `message-cite-function' to do the actual citing. Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") - (let ((modified (buffer-modified-p))) + (let ((modified (buffer-modified-p)) + body-text) (when (and message-reply-buffer message-cite-function) + (when message-cite-reply-above + (if (and (not (message-news-p)) + (or (eq message-cite-reply-above 'is-evil) + (y-or-n-p "\ +Top posting is bad netiquette. Please don't top post unless you really must. +Really top post? "))) + (save-excursion + (setq body-text + (buffer-substring (message-goto-body) + (point-max))) + (delete-region (message-goto-body) (point-max))) + (set (make-local-variable 'message-cite-reply-above) nil))) (delete-windows-on message-reply-buffer t) (push-mark (save-excursion (insert-buffer-substring message-reply-buffer) @@ -3354,6 +3592,13 @@ prefix, and don't delete any headers." (goto-char (mark t)) (insert-before-markers ?\n) (goto-char pt)))) + (when message-cite-reply-above + (message-goto-body) + (insert body-text) + (insert (if (bolp) "\n" "\n\n")) + (message-goto-body)) + ;; Add a `message-setup-very-last-hook' here? + ;; Add `gnus-article-highlight-citation' here? (unless modified (setq message-checksum (message-checksum)))))) @@ -3375,59 +3620,20 @@ prefix, and don't delete any headers." (push (buffer-name buffer) buffers)))) (nreverse buffers))) -(defun message-cite-original-without-signature () - "Cite function in the standard Message manner." - (let* ((start (point)) - (end (mark t)) - (functions - (when message-indent-citation-function - (if (listp message-indent-citation-function) - message-indent-citation-function - (list message-indent-citation-function)))) - ;; This function may be called by `gnus-summary-yank-message' and - ;; may insert a different article from the original. So, we will - ;; modify the value of `message-reply-headers' with that article. - (message-reply-headers - (save-restriction - (narrow-to-region start end) - (message-narrow-to-head-1) - (vector 0 - (or (message-fetch-field "subject") "none") - (or (message-fetch-field "from") "nobody") - (message-fetch-field "date") - (message-fetch-field "message-id" t) - (message-fetch-field "references") - 0 0 "")))) - (mml-quote-region start end) - ;; Allow undoing. - (undo-boundary) - (goto-char end) - (when (re-search-backward message-signature-separator start t) - ;; Also peel off any blank lines before the signature. - (forward-line -1) - (while (looking-at "^[ \t]*$") - (forward-line -1)) - (forward-line 1) - (delete-region (point) end) - (unless (search-backward "\n\n" start t) - ;; Insert a blank line if it is peeled off. - (insert "\n"))) - (goto-char start) - (while functions - (funcall (pop functions))) - (when message-citation-line-function - (unless (bolp) - (insert "\n")) - (funcall message-citation-line-function)))) +(eval-when-compile (defvar mail-citation-hook)) ; Compiler directive -(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive -(defun message-cite-original () - "Cite function in the standard Message manner." +(defun message-cite-original-1 (strip-signature) + "Cite an original message. +If STRIP-SIGNATURE is non-nil, strips off the signature from the +original message. + +This function uses `mail-citation-hook' if that is non-nil." (if (and (boundp 'mail-citation-hook) mail-citation-hook) (run-hooks 'mail-citation-hook) (let* ((start (point)) (end (mark t)) + (x-no-archive nil) (functions (when message-indent-citation-function (if (listp message-indent-citation-function) @@ -3440,6 +3646,7 @@ prefix, and don't delete any headers." (save-restriction (narrow-to-region start end) (message-narrow-to-head-1) + (setq x-no-archive (message-fetch-field "x-no-archive")) (vector 0 (or (message-fetch-field "subject") "none") (or (message-fetch-field "from") "nobody") @@ -3448,13 +3655,129 @@ prefix, and don't delete any headers." (message-fetch-field "references") 0 0 "")))) (mml-quote-region start end) + (when strip-signature + ;; Allow undoing. + (undo-boundary) + (goto-char end) + (when (re-search-backward message-signature-separator start t) + ;; Also peel off any blank lines before the signature. + (forward-line -1) + (while (looking-at "^[ \t]*$") + (forward-line -1)) + (forward-line 1) + (delete-region (point) end) + (unless (search-backward "\n\n" start t) + ;; Insert a blank line if it is peeled off. + (insert "\n")))) (goto-char start) - (while functions - (funcall (pop functions))) + (mapc 'funcall functions) (when message-citation-line-function (unless (bolp) (insert "\n")) - (funcall message-citation-line-function))))) + (funcall message-citation-line-function)) + (when (and x-no-archive + (not message-cite-articles-with-x-no-archive) + (string-match "yes" x-no-archive)) + (undo-boundary) + (delete-region (point) (mark t)) + (insert "> [Quoted text removed due to X-No-Archive]\n") + (push-mark) + (forward-line -1))))) + +(defun message-cite-original () + "Cite function in the standard Message manner." + (message-cite-original-1 nil)) + +(defun message-insert-formatted-citation-line (&optional from date) + "Function that inserts a formatted citation line. + +See `message-citation-line-format'." + ;; The optional args are for testing/debugging. They will disappear later. + ;; Example: + ;; (with-temp-buffer + ;; (message-insert-formatted-citation-line + ;; "John Doe <john.doe@example.invalid>" + ;; (current-time)) + ;; (buffer-string)) + (when (or message-reply-headers (and from date)) + (unless from + (setq from (mail-header-from message-reply-headers))) + (let* ((data (condition-case () + (funcall (if (boundp gnus-extract-address-components) + gnus-extract-address-components + 'mail-extract-address-components) + from) + (error nil))) + (name (car data)) + (fname name) + (lname name) + (net (car (cdr data))) + (name-or-net (or (car data) + (car (cdr data)) from)) + (replydate + (or + date + ;; We need Gnus functionality if the user wants date or time from + ;; the original article: + (when (string-match "%[^fnNFL]" message-citation-line-format) + (autoload 'gnus-date-get-time "gnus-util") + (gnus-date-get-time (mail-header-date message-reply-headers))))) + (flist + (let ((i ?A) lst) + (when (stringp name) + ;; Guess first name and last name: + (cond ((string-match + "\\`\\(\\w\\|[-.]\\)+ \\(\\w\\|[-.]\\)+\\'" name) + (setq fname (nth 0 (split-string name "[ \t]+")) + lname (nth 1 (split-string name "[ \t]+")))) + ((string-match + "\\`\\(\\w\\|[-.]\\)+, \\(\\w\\|[-.]\\)+\\'" name) + (setq fname (nth 1 (split-string name "[ \t,]+")) + lname (nth 0 (split-string name "[ \t,]+")))) + ((string-match + "\\`\\(\\w\\|[-.]\\)+\\'" name) + (setq fname name + lname "")))) + ;; The following letters are not used in `format-time-string': + (push ?E lst) (push "<E>" lst) + (push ?F lst) (push fname lst) + ;; We might want to use "" instead of "<X>" later. + (push ?J lst) (push "<J>" lst) + (push ?K lst) (push "<K>" lst) + (push ?L lst) (push lname lst) + (push ?N lst) (push name-or-net lst) + (push ?O lst) (push "<O>" lst) + (push ?P lst) (push "<P>" lst) + (push ?Q lst) (push "<Q>" lst) + (push ?f lst) (push from lst) + (push ?i lst) (push "<i>" lst) + (push ?n lst) (push net lst) + (push ?o lst) (push "<o>" lst) + (push ?q lst) (push "<q>" lst) + (push ?t lst) (push "<t>" lst) + (push ?v lst) (push "<v>" lst) + ;; Delegate the rest to `format-time-string': + (while (<= i ?z) + (when (and (not (memq i lst)) + ;; Skip (Z,a) + (or (<= i ?Z) + (>= i ?a))) + (push i lst) + (push (condition-case nil + (progn (format-time-string (format "%%%c" i) + replydate)) + (format ">%c<" i)) + lst)) + (setq i (1+ i))) + (reverse lst))) + (spec (apply 'format-spec-make flist))) + (insert (format-spec message-citation-line-format spec))) + (newline))) + +(defun message-cite-original-without-signature () + "Cite function in the standard Message manner. +This function strips off the signature from the original message." + (message-cite-original-1 t)) (defun message-insert-citation-line () "Insert a simple citation line." @@ -3548,6 +3871,7 @@ Instead, just auto-save the buffer and then bury it." "Kill the current buffer." (interactive) (when (or (not (buffer-modified-p)) + (not message-kill-buffer-query) (yes-or-no-p "Message modified; kill anyway? ")) (let ((actions message-kill-actions) (draft-article message-draft-article) @@ -3640,6 +3964,9 @@ It should typically alter the sending method in some way or other." (save-excursion (run-hooks 'message-sent-hook)) (message "Sending...done") + ;; Do ecomplete address snarfing. + (when (message-mail-alias-type-p 'ecomplete) + (message-put-addresses-in-ecomplete)) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t) @@ -3667,16 +3994,37 @@ It should typically alter the sending method in some way or other." (put 'message-check 'lisp-indent-function 1) (put 'message-check 'edebug-form-spec '(form body)) -(defun message-text-with-property (prop) - "Return a list of all points where the text has PROP." - (let ((points nil) - (point (point-min))) - (save-excursion - (while (< point (point-max)) - (when (get-text-property point prop) - (push point points)) - (incf point))) - (nreverse points))) +(defun message-text-with-property (prop &optional start end reverse) + "Return a list of start and end positions where the text has PROP. +START and END bound the search, they default to `point-min' and +`point-max' respectively. If REVERSE is non-nil, find text which does +not have PROP." + (unless start + (setq start (point-min))) + (unless end + (setq end (point-max))) + (let (next regions) + (if reverse + (while (and start + (setq start (text-property-any start end prop nil))) + (setq next (next-single-property-change start prop nil end)) + (push (cons start (or next end)) regions) + (setq start next)) + (while (and start + (or (get-text-property start prop) + (and (setq start (next-single-property-change + start prop nil end)) + (get-text-property start prop)))) + (setq next (text-property-any start end prop nil)) + (push (cons start (or next end)) regions) + (setq start next))) + (nreverse regions))) + +(defcustom message-bogus-address-regexp nil ;; "noreply\\|nospam\\|invalid" + "Regexp of potentially bogus mail addresses." + :version "23.0" ;; No Gnus + :group 'message-headers + :type 'regexp) (defun message-fix-before-sending () "Do various things to make the message nice before sending it." @@ -3685,44 +4033,49 @@ It should typically alter the sending method in some way or other." (unless (bolp) (insert "\n")) ;; Make the hidden headers visible. - (let ((points (message-text-with-property 'message-hidden))) - (when points - (goto-char (car points)) - (dolist (point points) - (add-text-properties point (1+ point) - '(invisible nil intangible nil))))) + (widen) + ;; Sort headers before sending the message. + (message-sort-headers) ;; Make invisible text visible. ;; It doesn't seem as if this is useful, since the invisible property ;; is clobbered by an after-change hook anyhow. (message-check 'invisible-text - (let ((points (message-text-with-property 'invisible))) - (when points - (goto-char (car points)) - (dolist (point points) - (put-text-property point (1+ point) 'invisible nil) - (message-overlay-put (message-make-overlay point (1+ point)) + (let ((regions (message-text-with-property 'invisible)) + from to) + (when regions + (while regions + (setq from (caar regions) + to (cdar regions) + regions (cdr regions)) + (put-text-property from to 'invisible nil) + (message-overlay-put (message-make-overlay from to) 'face 'highlight)) (unless (yes-or-no-p "Invisible text found and made visible; continue sending? ") (error "Invisible text found and made visible"))))) (message-check 'illegible-text - (let (found choice) + (let (char found choice) (message-goto-body) - (skip-chars-forward mm-7bit-chars) - (while (not (eobp)) - (when (let ((char (char-after))) - (or (< (mm-char-int char) 128) - (and (mm-multibyte-p) - (memq (char-charset char) - '(eight-bit-control eight-bit-graphic - control-1)) - (not (get-text-property - (point) 'untranslated-utf-8))))) + (while (progn + (skip-chars-forward mm-7bit-chars) + (when (get-text-property (point) 'no-illegible-text) + ;; There is a signed or encrypted raw message part + ;; that is considered to be safe. + (goto-char (or (next-single-property-change + (point) 'no-illegible-text) + (point-max)))) + (setq char (char-after))) + (when (or (< (mm-char-int char) 128) + (and (mm-multibyte-p) + (memq (char-charset char) + '(eight-bit-control eight-bit-graphic + control-1)) + (not (get-text-property + (point) 'untranslated-utf-8)))) (message-overlay-put (message-make-overlay (point) (1+ (point))) 'face 'highlight) (setq found t)) - (forward-char) - (skip-chars-forward mm-7bit-chars)) + (forward-char)) (when found (setq choice (gnus-multiple-choice @@ -3755,7 +4108,54 @@ It should typically alter the sending method in some way or other." (when (eq choice ?r) (insert message-replacement-char)))) (forward-char) - (skip-chars-forward mm-7bit-chars)))))) + (skip-chars-forward mm-7bit-chars))))) + (message-check 'bogus-recipient + ;; Warn before composing or sending a mail to an invalid address. + (message-check-recipients))) + +(defun message-bogus-recipient-p (recipients) + "Check if a mail address in RECIPIENTS looks bogus. + +RECIPIENTS is a mail header. Return a list of potentially bogus +addresses. If none is found, return nil. + +An addresses might be bogus if the domain part is not fully +qualified, see `message-valid-fqdn-regexp', or if it matches +`message-bogus-address-regexp'." + ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? + (let (found) + (mapc (lambda (address) + (setq address (cadr address)) + (when + (or (not + (or + (not (string-match "@" address)) + (string-match + (concat ".@.*\\(" + message-valid-fqdn-regexp "\\)\\'") address))) + (and (stringp message-bogus-address-regexp) + (string-match message-bogus-address-regexp address))) + (push address found))) + ;; + (mail-extract-address-components recipients t)) + found)) + +(defun message-check-recipients () + "Warn before composing or sending a mail to an invalid address. + +This function could be useful in `message-setup-hook'." + (interactive) + (save-restriction + (message-narrow-to-headers) + (dolist (hdr '("To" "Cc" "Bcc")) + (let ((addr (message-fetch-field hdr))) + (when (stringp addr) + (dolist (bog (message-bogus-recipient-p addr)) + (and bog + (not (y-or-n-p + (format + "Address `%s' might be bogus. Continue? " bog))) + (error "Bogus address.")))))))) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." @@ -3773,16 +4173,15 @@ It should typically alter the sending method in some way or other." (defun message-do-actions (actions) "Perform all actions in ACTIONS." ;; Now perform actions on successful sending. - (while actions + (dolist (action actions) (ignore-errors (cond ;; A simple function. - ((functionp (car actions)) - (funcall (car actions))) + ((functionp action) + (funcall action)) ;; Something to be evaled. (t - (eval (car actions))))) - (pop actions))) + (eval action)))))) (defun message-send-mail-partially () "Send mail as message/partial." @@ -3867,6 +4266,15 @@ It should typically alter the sending method in some way or other." (gnus-setup-posting-charset nil) message-posting-charset)) (headers message-required-mail-headers)) + (when (and message-generate-hashcash + (not (eq message-generate-hashcash 'opportunistic))) + (message "Generating hashcash...") + ;; Wait for calculations already started to finish... + (hashcash-wait-async) + ;; ...and do calculations not already done. mail-add-payment + ;; will leave existing X-Hashcash headers alone. + (mail-add-payment) + (message "Generating hashcash...done")) (save-restriction (message-narrow-to-headers) ;; Generate the Mail-Followup-To header if the header is not there... @@ -4003,8 +4411,7 @@ If you always want Gnus to send messages in one piece, set (when (eval message-mailer-swallows-blank-line) (newline)) (when message-interactive - (save-excursion - (set-buffer errbuf) + (with-current-buffer errbuf (erase-buffer)))) (let* ((default-directory "/") (coding-system-for-write message-send-coding-system) @@ -4022,6 +4429,7 @@ If you always want Gnus to send messages in one piece, set "/usr/ucblib/sendmail") (t "fakemail")) nil errbuf nil "-oi") + message-sendmail-extra-arguments ;; Always specify who from, ;; since some systems have broken sendmails. ;; But some systems are more broken with -f, so @@ -4045,7 +4453,7 @@ If you always want Gnus to send messages in one piece, set (save-excursion (set-buffer errbuf) (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) + (while (re-search-forward "\n+ *" nil t) (replace-match "; ")) (if (not (zerop (buffer-size))) (error "Sending...failed to %s" @@ -4086,9 +4494,9 @@ to find out how to use this." ;; free for -inject-arguments -- a big win for the user and for us ;; since we don't have to play that double-guessing game and the user ;; gets full control (no gestapo'ish -f's, for instance). --sj - (if (functionp message-qmail-inject-args) - (funcall message-qmail-inject-args) - message-qmail-inject-args))) + (if (functionp message-qmail-inject-args) + (funcall message-qmail-inject-args) + message-qmail-inject-args))) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) @@ -4599,7 +5007,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check for control characters. (message-check 'control-chars (if (re-search-forward - (mm-string-as-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") + (mm-string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") nil t) (y-or-n-p "The article contains control characters. Really post? ") @@ -4753,29 +5161,27 @@ Otherwise, generate and save a value for `canlock-password' first." (when (re-search-forward ",+$" nil t) (replace-match "" t t)))))) -(eval-when-compile (require 'parse-time)) (defun message-make-date (&optional now) "Make a valid data header. If NOW, use that time instead." - (require 'parse-time) - (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) - (when (< zone 0) - (setq sign "-") - (setq zone (- zone))) - (concat - ;; The day name of the %a spec is locale-specific. Pfff. - (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now)) - parse-time-weekdays)))) - (format-time-string "%d" now) - ;; The month name of the %b spec is locale-specific. Pfff. - (format " %s " - (capitalize (car (rassoc (nth 4 (decode-time now)) - parse-time-months)))) - (format-time-string "%Y %H:%M:%S " now) - ;; We do all of this because XEmacs doesn't have the %z spec. - (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) + (let ((system-time-locale "C")) + (format-time-string "%a, %d %b %Y %T %z" now))) + +(defun message-insert-expires (days) + "Insert the Expires header. Expiry in DAYS days." + (interactive "NExpire article in how many days? ") + (save-excursion + (message-position-on-field "Expires" "X-Draft-From") + (insert (message-make-expires-date days)))) + +(defun message-make-expires-date (days) + "Make date string for the Expires header. Expiry in DAYS days. + +In posting styles use `(\"Expires\" (make-expires-date 30))'." + (let* ((cur (decode-time (current-time))) + (nday (+ days (nth 3 cur)))) + (setf (nth 3 cur) nday) + (message-make-date (apply 'encode-time cur)))) (defun message-make-message-id () "Make a unique Message-ID." @@ -4940,14 +5346,14 @@ If NOW, use that time instead." (concat message-user-path "!" login-name)) (t login-name)))) -(defun message-make-from () +(defun message-make-from (&optional name address) "Make a From header." (let* ((style message-from-style) - (login (message-make-address)) - (fullname - (or (and (boundp 'user-full-name) - user-full-name) - (user-full-name)))) + (login (or address (message-make-address))) + (fullname (or name + (and (boundp 'user-full-name) + user-full-name) + (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) (with-temp-buffer @@ -4968,15 +5374,15 @@ If NOW, use that time instead." (string-match "[\\()]" tmp))))) (insert fullname) (goto-char (point-min)) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) - ;; Quote fullname, escaping specials. - (goto-char (point-min)) - (insert "\"") - (while (re-search-forward "[\"\\]" nil 1) - (replace-match "\\\\\\&" t)) - (insert "\"")) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) + ;; Quote fullname, escaping specials. + (goto-char (point-min)) + (insert "\"") + (while (re-search-forward "[\"\\]" nil 1) + (replace-match "\\\\\\&" t)) + (insert "\"")) (insert " <" login ">")) (t ; 'parens or default (insert login " (") @@ -5279,19 +5685,21 @@ Headers already prepared in the buffer are not modified." (if formatter (funcall formatter header value) (insert header-string ": " value)) + (goto-char (message-fill-field)) ;; We check whether the value was ended by a - ;; newline. If now, we insert one. + ;; newline. If not, we insert one. (unless (bolp) (insert "\n")) (forward-line -1))) ;; The value of this header was empty, so we clear ;; totally and insert the new value. - (delete-region (point) (gnus-point-at-eol)) + (delete-region (point) (point-at-eol)) ;; If the header is optional, and the header was - ;; empty, we con't insert it anyway. + ;; empty, we can't insert it anyway. (unless optionalp (push header-string message-inserted-headers) - (insert value))) + (insert value) + (message-fill-field))) ;; Add the deletable property to the headers that require it. (and (memq header message-deletable-headers) (progn (beginning-of-line) (looking-at "[^:]+: ")) @@ -5347,35 +5755,29 @@ Headers already prepared in the buffer are not modified." ;;; Setting up a message buffer ;;; +(defun message-skip-to-next-address () + (let ((end (save-excursion + (message-next-header) + (point))) + quoted char) + (when (looking-at ",") + (forward-char 1)) + (while (and (not (= (point) end)) + (or (not (eq char ?,)) + quoted)) + (skip-chars-forward "^,\"" (point-max)) + (when (eq (setq char (following-char)) ?\") + (setq quoted (not quoted))) + (unless (= (point) end) + (forward-char 1))) + (skip-chars-forward " \t\n"))) + (defun message-fill-address (header value) - (save-restriction - (narrow-to-region (point) (point)) - (insert (capitalize (symbol-name header)) - ": " - (if (consp value) (car value) value) - "\n") - (narrow-to-region (point-min) (1- (point-max))) - (let (quoted last) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^,\"" (point-max)) - (if (or (eq (char-after) ?,) - (eobp)) - (when (not quoted) - (if (and (> (current-column) 78) - last) - (progn - (save-excursion - (goto-char last) - (insert "\n\t")) - (setq last (1+ (point)))) - (setq last (1+ (point))))) - (setq quoted (not quoted))) - (unless (eobp) - (forward-char 1)))) - (goto-char (point-max)) - (widen) - (forward-line 1))) + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n") + (message-fill-field-address)) (defun message-split-line () "Split current line, moving portion beyond point vertically down. @@ -5386,26 +5788,56 @@ If the current line has `message-yank-prefix', insert it on the new line." (error (split-line)))) -(defun message-fill-header (header value) +(defun message-insert-header (header value) + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value))) + +(defun message-field-name () + (save-excursion + (goto-char (point-min)) + (when (looking-at "\\([^:]+\\):") + (intern (capitalize (match-string 1)))))) + +(defun message-fill-field () + (save-excursion + (save-restriction + (message-narrow-to-field) + (let ((field-name (message-field-name))) + (funcall (or (cadr (assq field-name message-field-fillers)) + 'message-fill-field-general))) + (point-max)))) + +(defun message-fill-field-address () + (while (not (eobp)) + (message-skip-to-next-address) + (let (last) + (if (and (> (current-column) 78) + last) + (progn + (save-excursion + (goto-char last) + (insert "\n\t")) + (setq last (1+ (point)))) + (setq last (1+ (point))))))) + +(defun message-fill-field-general () (let ((begin (point)) (fill-column 78) (fill-prefix "\t")) - (insert (capitalize (symbol-name header)) - ": " - (if (consp value) (car value) value) - "\n") - (save-restriction - (narrow-to-region begin (point)) - (fill-region-as-paragraph begin (point)) - ;; Tapdance around looong Message-IDs. - (forward-line -1) - (when (looking-at "[ \t]*$") - (message-delete-line)) - (goto-char begin) - (re-search-forward ":" nil t) - (when (looking-at "\n[ \t]+") - (replace-match " " t t)) - (goto-char (point-max))))) + (while (and (search-forward "\n" nil t) + (not (eobp))) + (replace-match " " t t)) + (fill-region-as-paragraph begin (point-max)) + ;; Tapdance around looong Message-IDs. + (forward-line -1) + (when (looking-at "[ \t]*$") + (message-delete-line)) + (goto-char begin) + (search-forward ":" nil t) + (when (looking-at "\n[ \t]+") + (replace-match " " t t)) + (goto-char (point-max)))) (defun message-shorten-1 (list cut surplus) "Cut SURPLUS elements out of LIST, beginning with CUTth one." @@ -5414,8 +5846,9 @@ If the current line has `message-yank-prefix', insert it on the new line." (defun message-shorten-references (header references) "Trim REFERENCES to be 21 Message-ID long or less, and fold them. -If folding is disallowed, also check that the REFERENCES are less -than 988 characters long, and if they are not, trim them until they are." +When sending via news, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until +they are." (let ((maxcount 21) (count 0) (cut 2) @@ -5437,33 +5870,26 @@ than 988 characters long, and if they are not, trim them until they are." (message-shorten-1 refs cut surplus) (decf count surplus))) - ;; If folding is disallowed, make sure the total length (including - ;; the spaces between) will be less than MAXSIZE characters. + ;; When sending via news, make sure the total folded length will + ;; be less than 998 characters. This is to cater to broken INN + ;; 2.3 which counts the total number of characters in a header + ;; rather than the physical line length of each line, as it should. ;; - ;; Only disallow folding for News messages. At this point the headers - ;; have not been generated, thus we use message-this-is-news directly. - (when (and message-this-is-news message-cater-to-broken-inn) - (let ((maxsize 988) - (totalsize (+ (apply #'+ (mapcar #'length refs)) - (1- count))) - (surplus 0) - (ptr (nthcdr (1- cut) refs))) - ;; Decide how many elements to cut off... - (while (> totalsize maxsize) - (decf totalsize (1+ (length (car ptr)))) - (incf surplus) - (setq ptr (cdr ptr))) - ;; ...and do it. - (when (> surplus 0) - (message-shorten-1 refs cut surplus)))) - + ;; This hack should be removed when it's believed than INN 2.3 is + ;; no longer widely used. + ;; + ;; At this point the headers have not been generated, thus we use + ;; message-this-is-news directly. + (when message-this-is-news + (while (< 998 + (with-temp-buffer + (message-insert-header + header (mapconcat #'identity refs " ")) + (buffer-size))) + (message-shorten-1 refs cut 1))) ;; Finally, collect the references back into a string and insert ;; it into the buffer. - (let ((refstring (mapconcat #'identity refs " "))) - (if (and message-this-is-news message-cater-to-broken-inn) - (insert (capitalize (symbol-name header)) ": " - refstring "\n") - (message-fill-header header refstring))))) + (message-insert-header header (mapconcat #'identity refs " ")))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -5513,7 +5939,7 @@ between beginning of field and beginning of line." (message-point-in-header-p)) (let* ((here (point)) (bol (progn (beginning-of-line n) (point))) - (eol (gnus-point-at-eol)) + (eol (point-at-eol)) (eoh (re-search-forward ": *" eol t))) (goto-char (if (and eoh (or (< eoh here) (= bol here))) @@ -5726,12 +6152,7 @@ are not included." (when message-default-headers (insert message-default-headers) (or (bolp) (insert ?\n))) - (put-text-property - (point) - (progn - (insert mail-header-separator "\n") - (1- (point))) - 'read-only nil) + (insert mail-header-separator "\n") (forward-line -1) (when (message-news-p) (when message-default-news-headers @@ -5762,6 +6183,9 @@ are not included." (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) + (when message-generate-hashcash + ;; Generate hashcash headers for recipients already known + (mail-add-payment-async)) (run-hooks 'message-setup-hook) ;; Do this last to give it precedence over posting styles, etc. (when (message-mail-p) @@ -5864,8 +6288,8 @@ is a function used to switch to and display the mail buffer." (Subject . ,(or subject "")))))) (defun message-get-reply-headers (wide &optional to-address address-headers) - (let (follow-to mct never-mct to cc author mft recipients) - ;; Find all relevant headers we need. + (let (follow-to mct never-mct to cc author mft recipients extra) + ;; Find all relevant headers we need. (save-restriction (message-narrow-to-headers-or-head) ;; Gmane renames "To". Look at "Original-To", too, if it is present in @@ -5876,6 +6300,11 @@ is a function used to switch to and display the mail buffer." return t) (message-fetch-field "original-to"))) cc (message-fetch-field "cc") + extra (when message-extra-wide-headers + (mapconcat 'identity + (mapcar 'message-fetch-field + message-extra-wide-headers) + ", ")) mct (message-fetch-field "mail-copies-to") author (or (message-fetch-field "mail-reply-to") (message-fetch-field "reply-to") @@ -5938,8 +6367,9 @@ want to get rid of this query permanently."))) (if mct (setq recipients (concat recipients ", " mct)))) (t (setq recipients (if never-mct "" (concat ", " author))) - (if to (setq recipients (concat recipients ", " to))) - (if cc (setq recipients (concat recipients ", " cc))) + (if to (setq recipients (concat recipients ", " to))) + (if cc (setq recipients (concat recipients ", " cc))) + (if extra (setq recipients (concat recipients ", " extra))) (if mct (setq recipients (concat recipients ", " mct))))) (if (>= (length recipients) 2) ;; Strip the leading ", ". @@ -5948,7 +6378,7 @@ want to get rid of this query permanently."))) (while (string-match "[ \t][ \t]+" recipients) (setq recipients (replace-match " " t t recipients))) ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (let ((rmail-dont-reply-to-names (message-dont-reply-to-names))) (setq recipients (rmail-dont-reply-to recipients))) ;; Perhaps "Mail-Copies-To: never" removed the only address? (if (string-equal recipients "") @@ -6233,16 +6663,16 @@ regexp to match all of yours addresses." ;; Email address in From field equals to our address (and (setq from (message-fetch-field "from")) (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components - (message-make-from)))))) + (downcase (car (mail-header-parse-address from))) + (downcase (car (mail-header-parse-address + (message-make-from)))))) ;; Email address in From field matches ;; 'message-alternative-emails' regexp (and from message-alternative-emails (string-match message-alternative-emails - (cadr (mail-extract-address-components from)))))))))) + (car (mail-header-parse-address from)))))))))) ;;;###autoload (defun message-cancel-news (&optional arg) @@ -6382,7 +6812,9 @@ news, Source is the list of newsgroups is was posted to." (prefix (if group (gnus-group-decoded-name group) - (or (and from (car (gnus-extract-address-components from))) + (or (and from (or + (car (gnus-extract-address-components from)) + (cadr (gnus-extract-address-components from)))) "(nowhere)")))) (concat "[" (if message-forward-decoded-p @@ -6428,18 +6860,17 @@ the message." subject (mail-decode-encoded-word-string subject)) "")) - (if message-wash-forwarded-subjects - (setq subject (message-wash-subject subject))) + (when message-wash-forwarded-subjects + (setq subject (message-wash-subject subject))) ;; Make sure funcs is a list. (and funcs (not (listp funcs)) (setq funcs (list funcs))) ;; Apply funcs in order, passing subject generated by previous ;; func to the next one. - (while funcs - (when (functionp (car funcs)) - (setq subject (funcall (car funcs) subject))) - (setq funcs (cdr funcs))) + (dolist (func funcs) + (when (functionp func) + (setq subject (funcall func subject)))) subject)))) (eval-when-compile @@ -6482,17 +6913,24 @@ Optional DIGEST will use digest to forward." (setq e (point)) (insert "\n-------------------- End of forwarded message --------------------\n") - (when message-forward-ignored-headers - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) - (or (search-forward "\n\n" nil t) (point))) - (message-remove-header message-forward-ignored-headers t))))) + (message-remove-ignored-headers b e))) + +(defun message-remove-ignored-headers (b e) + (when message-forward-ignored-headers + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (let ((ignored (if (stringp message-forward-ignored-headers) + (list message-forward-ignored-headers) + message-forward-ignored-headers))) + (dolist (elem ignored) + (message-remove-header elem t)))))) (defun message-forward-make-body-mime (forward-buffer) - (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") - (let ((b (point)) e) + (let ((b (point))) + (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction (narrow-to-region (point) (point)) (mml-insert-buffer forward-buffer) @@ -6500,8 +6938,11 @@ Optional DIGEST will use digest to forward." (when (looking-at "From ") (replace-match "X-From-Line: ")) (goto-char (point-max))) - (setq e (point)) - (insert "<#/part>\n"))) + (insert "<#/part>\n") + ;; Consider there is no illegible text. + (add-text-properties + b (point) + `(no-illegible-text t rear-nonsticky t start-open t)))) (defun message-forward-make-body-mml (forward-buffer) (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") @@ -6530,12 +6971,7 @@ Optional DIGEST will use digest to forward." (insert "<#/mml>\n") (when (and (not message-forward-decoded-p) message-forward-ignored-headers) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) - (or (search-forward "\n\n" nil t) (point))) - (message-remove-header message-forward-ignored-headers t))))) + (message-remove-ignored-headers b e)))) (defun message-forward-make-body-digest-plain (forward-buffer) (insert @@ -6564,6 +7000,62 @@ Optional DIGEST will use digest to forward." (message-forward-make-body-digest-mime forward-buffer) (message-forward-make-body-digest-plain forward-buffer))) +(eval-and-compile + (autoload 'mm-uu-dissect-text-parts "mm-uu") + (autoload 'mm-uu-dissect "mm-uu")) + +(defun message-signed-or-encrypted-p (&optional dont-emulate-mime handles) + "Say whether the current buffer contains signed or encrypted message. +If DONT-EMULATE-MIME is nil, this function does the MIME emulation on +messages that don't conform to PGP/MIME described in RFC2015. HANDLES +is for the internal use." + (unless handles + (let ((mm-decrypt-option 'never) + (mm-verify-option 'never)) + (if (setq handles (mm-dissect-buffer nil t)) + (unless dont-emulate-mime + (mm-uu-dissect-text-parts handles)) + (unless dont-emulate-mime + (setq handles (mm-uu-dissect)))))) + ;; Check text/plain message in which there is a signed or encrypted + ;; body that has been encoded by B or Q. + (unless (or handles dont-emulate-mime) + (let ((cur (current-buffer)) + (mm-decrypt-option 'never) + (mm-verify-option 'never)) + (with-temp-buffer + (insert-buffer-substring cur) + (when (setq handles (mm-dissect-buffer t t)) + (if (and (prog1 + (bufferp (car handles)) + (mm-destroy-parts handles)) + (equal (mm-handle-media-type handles) "text/plain")) + (progn + (mm-decode-content-transfer-encoding + (mm-handle-encoding handles)) + (setq handles (mm-uu-dissect))) + (setq handles nil)))))) + (when handles + (prog1 + (catch 'found + (dolist (handle (if (stringp (car handles)) + (if (member (car handles) + '("multipart/signed" + "multipart/encrypted")) + (throw 'found t) + (cdr handles)) + (list handles))) + (if (stringp (car handle)) + (when (message-signed-or-encrypted-p dont-emulate-mime handle) + (throw 'found t)) + (when (and (bufferp (car handle)) + (equal (mm-handle-media-type handle) + "message/rfc822")) + (with-current-buffer (mm-handle-buffer handle) + (when (message-signed-or-encrypted-p dont-emulate-mime) + (throw 'found t))))))) + (mm-destroy-parts handles)))) + ;;;###autoload (defun message-forward-make-body (forward-buffer &optional digest) ;; Put point where we want it before inserting the forwarded @@ -6576,11 +7068,13 @@ Optional DIGEST will use digest to forward." (if message-forward-as-mime (if (and message-forward-show-mml (not (and (eq message-forward-show-mml 'best) + ;; Use the raw form in the body if it contains + ;; signed or encrypted message so as not to be + ;; destroyed by re-encoding. (with-current-buffer forward-buffer - (goto-char (point-min)) - (re-search-forward - "Content-Type: *multipart/\\(signed\\|encrypted\\)" - nil t))))) + (condition-case nil + (message-signed-or-encrypted-p) + (error t)))))) (message-forward-make-body-mml forward-buffer) (message-forward-make-body-mime forward-buffer)) (message-forward-make-body-plain forward-buffer))) @@ -6590,8 +7084,6 @@ Optional DIGEST will use digest to forward." (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) - ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs - ;; 20. FIXIT, or we drop support for rmail in Emacs 20. (if (rmail-msg-is-pruned) (rmail-msg-restore-non-pruned-header))) (message-forward-make-body forward-buffer)) @@ -6621,6 +7113,7 @@ Optional DIGEST will use digest to forward." (set-buffer (get-buffer-create " *message resend*")) (erase-buffer)) (let ((message-this-is-mail t) + message-generate-hashcash message-setup-hook) (message-setup `((To . ,address)))) ;; Insert our usual headers. @@ -6658,6 +7151,7 @@ Optional DIGEST will use digest to forward." ;; Send it. (let ((message-inhibit-body-encoding t) message-required-mail-headers + message-generate-hashcash rfc2047-encode-encoded-words) (message-send-mail)) (kill-buffer (current-buffer))) @@ -6772,7 +7266,7 @@ you." ;; This code should be moved to underline.el (from which it is stolen). ;;;###autoload -(defun bold-region (start end) +(defun message-bold-region (start end) "Bold all nonblank characters in the region. Works by overstriking characters. Called from program, takes two arguments START and END @@ -6788,7 +7282,7 @@ which specify the range to operate on." (forward-char 1))))) ;;;###autoload -(defun unbold-region (start end) +(defun message-unbold-region (start end) "Remove all boldness (overstruck characters) in the region. Called from program, takes two arguments START and END which specify the range to operate on." @@ -6797,7 +7291,7 @@ which specify the range to operate on." (let ((end1 (make-marker))) (move-marker end1 (max start end)) (goto-char (min start end)) - (while (re-search-forward "\b" end1 t) + (while (search-forward "\b" end1 t) (if (eq (char-after) (char-after (- (point) 2))) (delete-char -2)))))) @@ -6847,7 +7341,7 @@ Pre-defined symbols include `message-tool-bar-gnome' and (const :tag "Retro look" message-tool-bar-retro) (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -6866,7 +7360,7 @@ Pre-defined symbols include `message-tool-bar-gnome' and (message-kill-buffer "close") ;; stock_cancel (mml-attach-file "attach" mml-mode-map) (mml-preview "mail/preview" mml-mode-map) - ;; (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) + (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) (message-insert-importance-high "important" nil :visible nil) (message-insert-importance-low "unimportant" nil :visible nil) (message-insert-disposition-notification-to "receipt" nil :visible nil) @@ -6876,7 +7370,7 @@ Pre-defined symbols include `message-tool-bar-gnome' and See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -6896,7 +7390,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -6909,7 +7403,7 @@ These items are not displayed on the message mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list - :version "22.1" ;; Gnus 5.10.9 + :version "23.0" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) @@ -6956,6 +7450,13 @@ When FORCE, rebuild the tool bar." :group 'message :type '(alist :key-type regexp :value-type function)) +(defcustom message-expand-name-databases + (list 'bbdb 'eudc) + "List of databases to try for name completion (`message-expand-name'). +Each element is a symbol and can be `bbdb' or `eudc'." + :group 'message + :type '(set (const bbdb) (const eudc))) + (defcustom message-tab-body-function nil "*Function to execute when `message-tab' (TAB) is executed in the body. If nil, the function bound in `text-mode-map' or `global-map' is executed." @@ -7036,9 +7537,15 @@ those headers." (delete-region (point) (progn (forward-line 3) (point)))))))))) (defun message-expand-name () - (if (fboundp 'bbdb-complete-name) - (bbdb-complete-name) - (expand-abbrev))) + (cond ((and (memq 'eudc message-expand-name-databases) + (boundp 'eudc-protocol) + eudc-protocol) + (eudc-expand-inline)) + ((and (memq 'bbdb message-expand-name-databases) + (fboundp 'bbdb-complete-name)) + (bbdb-complete-name)) + (t + (expand-abbrev)))) ;;; Help stuff. @@ -7053,7 +7560,7 @@ The following arguments may contain lists of values." (with-output-to-temp-buffer " *MESSAGE information message*" (set-buffer " *MESSAGE information message*") (fundamental-mode) ; for Emacs 20.4+ - (mapcar 'princ text) + (mapc 'princ text) (goto-char (point-min)))) (funcall ask question)) (funcall ask question))) @@ -7164,7 +7671,7 @@ regexp VARSTR." address in `message-alternative-emails', looking at To, Cc and From headers in the original article." (require 'mail-utils) - (let* ((fields '("To" "Cc")) + (let* ((fields '("To" "Cc" "From")) (emails (split-string (mail-strip-quoted-names @@ -7179,7 +7686,8 @@ From headers in the original article." (unless (or (not email) (equal email user-mail-address)) (message-remove-header "From") (goto-char (point-max)) - (insert "From: " email "\n")))) + (insert "From: " (let ((user-mail-address email)) (message-make-from)) + "\n")))) (defun message-options-get (symbol) (cdr (assq symbol message-options))) @@ -7218,7 +7726,8 @@ From headers in the original article." (list message-hidden-headers) message-hidden-headers)) (inhibit-point-motion-hooks t) - (after-change-functions nil)) + (after-change-functions nil) + (end-of-headers (point-min))) (when regexps (save-excursion (save-restriction @@ -7227,11 +7736,17 @@ From headers in the original article." (while (not (eobp)) (if (not (message-hide-header-p regexps)) (message-next-header) - (let ((begin (point))) + (let ((begin (point)) + header header-len) (message-next-header) - (add-text-properties - begin (point) - '(invisible t message-hidden t)))))))))) + (setq header (buffer-substring begin (point)) + header-len (- (point) begin)) + (delete-region begin (point)) + (goto-char end-of-headers) + (insert header) + (setq end-of-headers + (+ end-of-headers header-len)))))))) + (narrow-to-region end-of-headers (point-max)))) (defun message-hide-header-p (regexps) (let ((result nil) @@ -7245,6 +7760,39 @@ From headers in the original article." (not result) result))) +(defun message-put-addresses-in-ecomplete () + (dolist (header '("to" "cc" "from" "reply-to")) + (let ((value (message-field-value header))) + (dolist (string (mail-header-parse-addresses value 'raw)) + (setq string + (gnus-replace-in-string + (gnus-replace-in-string string "^ +\\| +$" "") "\n" "")) + (ecomplete-add-item 'mail (car (mail-header-parse-address string)) + string)))) + (ecomplete-save)) + +(defun message-display-abbrev (&optional choose) + "Display the next possible abbrev for the text before point." + (interactive (list t)) + (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) + (message-point-in-header-p) + (save-excursion + (beginning-of-line) + (while (and (memq (char-after) '(?\t ? )) + (zerop (forward-line -1)))) + (looking-at "To:\\|Cc:"))) + (let* ((end (point)) + (start (save-excursion + (and (re-search-backward "[\n\t ]" nil t) + (1+ (point))))) + (word (when start (buffer-substring start end))) + (match (when (and word + (not (zerop (length word)))) + (ecomplete-display-matches 'mail word choose)))) + (when (and choose match) + (delete-region start end) + (insert match))))) + (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine)) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 38a5fd4f68a..20af36564f7 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -26,10 +26,6 @@ ;;; Code: -(eval-and-compile - (or (fboundp 'base64-decode-region) - (require 'base64))) - (eval-when-compile (defvar mm-uu-decode-function) (defvar mm-uu-binhex-decode-function)) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index f8de1a77f71..14e5c255d2a 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -33,7 +33,6 @@ (require 'term)) (eval-and-compile - (autoload 'executable-find "executable") (autoload 'mm-inline-partial "mm-partial") (autoload 'mm-inline-external-body "mm-extern") (autoload 'mm-extern-cache-contents "mm-extern") @@ -231,6 +230,7 @@ before the external MIME handler is invoked." (fboundp 'diff-mode))) ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) + ("text/dns" mm-display-dns-inline identity) ("text/html" mm-inline-text-html (lambda (handle) @@ -299,9 +299,9 @@ when selecting a different article." :group 'mime-display) (defcustom mm-automatic-display - '("text/plain" "text/enriched" "text/richtext" "text/html" + '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" - "message/rfc822" "text/x-patch" "application/pgp-signature" + "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature" "application/emacs-lisp" "application/x-emacs-lisp" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" @@ -364,20 +364,34 @@ enables you to choose manually one of two types those mails include." :type 'boolean :group 'mime-display) -(defvar mm-file-name-rewrite-functions +(defcustom mm-file-name-rewrite-functions '(mm-file-name-delete-control mm-file-name-delete-gotchas) - "*List of functions used for rewriting file names of MIME parts. + "List of functions used for rewriting file names of MIME parts. Each function takes a file name as input and returns a file name. -Ready-made functions include -`mm-file-name-delete-control' -`mm-file-name-delete-gotchas' -`mm-file-name-delete-whitespace', -`mm-file-name-trim-whitespace', -`mm-file-name-collapse-whitespace', -`mm-file-name-replace-whitespace', -`capitalize', `downcase', `upcase', and -`upcase-initials'.") +Ready-made functions include `mm-file-name-delete-control', +`mm-file-name-delete-gotchas' (you should not remove these two +functions), `mm-file-name-delete-whitespace', +`mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace', +`mm-file-name-replace-whitespace', `capitalize', `downcase', +`upcase', and `upcase-initials'." + :type '(list (set :inline t + (const mm-file-name-delete-control) + (const mm-file-name-delete-gotchas) + (const mm-file-name-delete-whitespace) + (const mm-file-name-trim-whitespace) + (const mm-file-name-collapse-whitespace) + (const mm-file-name-replace-whitespace) + (const capitalize) + (const downcase) + (const upcase) + (const upcase-initials) + (repeat :inline t + :tag "Function" + function))) + :version "23.0" ;; No Gnus + :group 'mime-display) + (defvar mm-path-name-rewrite-functions nil "*List of functions for rewriting the full file names of MIME parts. @@ -436,7 +450,11 @@ If not set, `default-directory' will be used." (defcustom mm-verify-option 'never "Option of verifying signed parts. `never', not verify; `always', always verify; -`known', only verify known protocols. Otherwise, ask user." +`known', only verify known protocols. Otherwise, ask user. + +When set to `always' or `known', you should add +\"multipart/signed\" to `gnus-buttonized-mime-types' to see +result of the verification." :version "22.1" :type '(choice (item always) (item never) @@ -548,15 +566,11 @@ Postpone undisplaying of viewers for types in ;; solution, avoids most of them. (if from (setq from (cadr (mail-extract-address-components from)))))) - (when cte - (setq cte (mail-header-strip cte))) (if (or (not ctl) (not (string-match "/" (car ctl)))) (mm-dissect-singlepart (list mm-dissect-default-type) - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) + (and cte (intern (downcase (mail-header-strip cte)))) no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description) @@ -589,9 +603,7 @@ Postpone undisplaying of viewers for types in (mm-possibly-verify-or-decrypt (mm-dissect-singlepart ctl - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) + (and cte (intern (downcase (mail-header-strip cte)))) no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description id) @@ -922,16 +934,16 @@ external if displayed external." (string= total "'%s'") (string= total "\"%s\"")) (setq uses-stdin nil) - (push (mm-quote-arg + (push (shell-quote-argument (gnus-map-function mm-path-name-rewrite-functions file)) out)) ((string= total "%t") - (push (mm-quote-arg (car type-list)) out)) + (push (shell-quote-argument (car type-list)) out)) (t - (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) + (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out)))) (push (substring method beg (length method)) out) (when uses-stdin (push "<" out) - (push (mm-quote-arg + (push (shell-quote-argument (gnus-map-function mm-path-name-rewrite-functions file)) out)) (mapconcat 'identity (nreverse out) ""))) @@ -1136,16 +1148,26 @@ are ignored." "Insert the contents of HANDLE in the current buffer. If NO-CACHE is non-nil, cached contents of a message/external-body part are ignored." - (save-excursion - (insert - (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset) - 'gnus-decoded) - (with-current-buffer (mm-handle-buffer handle) - (buffer-string))) - ((mm-multibyte-p) - (mm-string-to-multibyte (mm-get-part handle no-cache))) - (t - (mm-get-part handle no-cache)))))) + (let ((text (cond ((eq (mail-content-type-get (mm-handle-type handle) + 'charset) + 'gnus-decoded) + (with-current-buffer (mm-handle-buffer handle) + (buffer-string))) + ((mm-multibyte-p) + (mm-string-to-multibyte (mm-get-part handle no-cache))) + (t + (mm-get-part handle no-cache))))) + (save-restriction + (widen) + (goto-char + (prog1 + (point) + (if (and (eq (get-char-property (max (point-min) (1- (point))) 'face) + 'mm-uu-extract) + (eq (get-char-property 0 'face text) 'mm-uu-extract)) + ;; Separate the extracted parts that have the same faces. + (insert "\n" text) + (insert text))))))) (defun mm-file-name-delete-whitespace (file-name) "Remove all whitespace characters from FILE-NAME." @@ -1185,8 +1207,9 @@ string if you do not like underscores." (setq filename (gnus-replace-in-string filename "[<>|]" "")) (gnus-replace-in-string filename "^[.-]+" "")) -(defun mm-save-part (handle) - "Write HANDLE to a file." +(defun mm-save-part (handle &optional prompt) + "Write HANDLE to a file. +PROMPT overrides the default one used to ask user for a file name." (let ((filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) (mail-content-type-get @@ -1197,7 +1220,7 @@ string if you do not like underscores." (file-name-nondirectory filename)))) (setq file (mm-with-multibyte - (read-file-name "Save MIME part to: " + (read-file-name (or prompt "Save MIME part to: ") (or mm-default-directory default-directory) nil nil (or filename "")))) (setq mm-default-directory (file-name-directory file)) @@ -1211,17 +1234,13 @@ string if you do not like underscores." (defun mm-save-part-to-file (handle file) (mm-with-unibyte-buffer (mm-insert-part handle) - (let ((coding-system-for-write 'binary) - (current-file-modes (default-file-modes)) + (let ((current-file-modes (default-file-modes))) + (set-default-file-modes mm-attachment-file-modes) + (unwind-protect ;; Don't re-compress .gz & al. Arguably we should make ;; `file-name-handler-alist' nil, but that would chop ;; ange-ftp, which is reasonable to use here. - (inhibit-file-name-operation 'write-region) - (inhibit-file-name-handlers - (cons 'jka-compr-handler inhibit-file-name-handlers))) - (set-default-file-modes mm-attachment-file-modes) - (unwind-protect - (write-region (point-min) (point-max) file) + (mm-write-region (point-min) (point-max) file nil nil nil 'binary t) (set-default-file-modes current-file-modes))))) (defun mm-pipe-part (handle) @@ -1517,7 +1536,7 @@ If RECURSIVE, search recursively." (format "protocol=%s" protocol)))))) (save-excursion (if func - (funcall func parts ctl) + (setq parts (funcall func parts ctl)) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (format "Unknown sign protocol (%s)" protocol)))))) diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el index 1fa3e6967e7..f59ca10d783 100644 --- a/lisp/gnus/mm-partial.el +++ b/lisp/gnus/mm-partial.el @@ -34,8 +34,7 @@ (require 'mm-decode) (defun mm-partial-find-parts (id &optional art) - (let ((headers (save-excursion - (set-buffer gnus-summary-buffer) + (let ((headers (with-current-buffer gnus-summary-buffer gnus-newsgroup-headers)) phandles header) (while (setq header (pop headers)) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index dedc03a2edf..a143089750c 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -35,14 +35,6 @@ (require 'mm-util) (require 'gnus) -(eval-and-compile - (autoload 'executable-find "executable")) - -(eval-when-compile - (if (featurep 'xemacs) - (require 'timer-funcs) - (require 'timer))) - (defvar url-current-object) (defvar url-package-name) (defvar url-package-version) diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 2c9e4045eca..cfc6c949be0 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -30,7 +30,14 @@ (require 'mail-prsvr) (eval-and-compile - (mapcar + (if (featurep 'xemacs) + (unless (ignore-errors + (require 'timer-funcs)) + (require 'timer)) + (require 'timer))) + +(eval-and-compile + (mapc (lambda (elem) (let ((nfunc (intern (format "mm-%s" (car elem))))) (if (fboundp (car elem)) @@ -41,9 +48,6 @@ (coding-system-equal . equal) (annotationp . ignore) (set-buffer-file-coding-system . ignore) - (make-char - . (lambda (charset int) - (int-to-char int))) (read-charset . (lambda (prompt) "Return a charset." @@ -67,6 +71,10 @@ (aset string idx to)) (setq idx (1+ idx))) string))) + (replace-in-string + . (lambda (string regexp rep &optional literal) + "See `replace-regexp-in-string', only the order of args differs." + (replace-regexp-in-string regexp rep string nil literal))) (string-as-unibyte . identity) (string-make-unibyte . identity) ;; string-as-multibyte often doesn't really do what you think it does. @@ -90,7 +98,22 @@ (string-as-multibyte . identity) (multibyte-string-p . ignore) (insert-byte . insert-char) - (multibyte-char-to-unibyte . identity)))) + (multibyte-char-to-unibyte . identity) + (special-display-p + . (lambda (buffer-name) + "Returns non-nil if a buffer named BUFFER-NAME gets a special frame." + (and special-display-function + (or (and (member buffer-name special-display-buffer-names) t) + (cdr (assoc buffer-name special-display-buffer-names)) + (catch 'return + (dolist (elem special-display-regexps) + (and (stringp elem) + (string-match elem buffer-name) + (throw 'return t)) + (and (consp elem) + (stringp (car elem)) + (string-match (car elem) buffer-name) + (throw 'return (cdr elem)))))))))))) (eval-and-compile (if (featurep 'xemacs) @@ -120,32 +143,6 @@ (defalias 'mm-decode-coding-region 'decode-coding-region) (defalias 'mm-encode-coding-region 'encode-coding-region))) -(eval-and-compile - (cond - ((fboundp 'replace-in-string) - (defalias 'mm-replace-in-string 'replace-in-string)) - ((fboundp 'replace-regexp-in-string) - (defun mm-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. - -This is a compatibility function for different Emacsen." - (replace-regexp-in-string regexp newtext string nil literal))) - (t - (defun mm-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. - -This is a compatibility function for different Emacsen." - (let ((start 0) tail) - (while (string-match regexp string start) - (setq tail (- (length string) (match-end 0))) - (setq string (replace-match newtext nil literal string)) - (setq start (- (length string) tail)))) - string)))) - (defalias 'mm-string-to-multibyte (cond ((featurep 'xemacs) @@ -262,6 +259,10 @@ the alias. Else windows-NUMBER is used." ,@(when (and (not (mm-coding-system-p 'gbk)) (mm-coding-system-p 'cp936)) '((gbk . cp936))) + ;; ISO8859-1 is a bogus name for ISO-8859-1 + ,@(when (and (not (mm-coding-system-p 'iso8859-1)) + (mm-coding-system-p 'iso-8859-1)) + '((iso8859-1 . iso-8859-1))) ) "A mapping from unknown or invalid charset names to the real charset names. @@ -378,7 +379,9 @@ Unless LIST is given, `mm-codepage-ibm-list' is used." (mm-setup-codepage-ibm) (defcustom mm-charset-override-alist - `((iso-8859-1 . windows-1252)) + '((iso-8859-1 . windows-1252) + (iso-8859-8 . windows-1255) + (iso-8859-9 . windows-1254)) "A mapping from undesired charset names to their replacement. You may add pairs like (iso-8859-1 . windows-1252) here, @@ -386,6 +389,8 @@ i.e. treat iso-8859-1 as windows-1252. windows-1252 is a superset of iso-8859-1." :type '(list (set :inline t (const (iso-8859-1 . windows-1252)) + (const (iso-8859-8 . windows-1255)) + (const (iso-8859-9 . windows-1254)) (const (undecided . windows-1252))) (repeat :inline t :tag "Other options" @@ -420,6 +425,7 @@ could use `autoload-coding-system' here." (cons (symbol :tag "charset") (symbol :tag "form")))) :group 'mime) +(put 'mm-charset-eval-alist 'risky-local-variable t) (defvar mm-binary-coding-system (cond @@ -695,9 +701,6 @@ only be used for decoding, not for encoding." (message "Unknown charset: %s" charset))) cs)))) -(defsubst mm-replace-chars-in-string (string from to) - (mm-subst-char-in-string from to string)) - (eval-and-compile (defvar mm-emacs-mule (and (not (featurep 'xemacs)) (boundp 'default-enable-multibyte-characters) @@ -860,7 +863,7 @@ But this is very much a corner case, so don't worry about it." ;; Load the Latin Unity library, if available. (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity")) - (ignore-errors (require 'latin-unity))) + (require 'latin-unity)) ;; Now, can we use it? (if (featurep 'latin-unity) @@ -1028,10 +1031,10 @@ Emacs 23 (unicode)." ;; Remove composition since the base charsets have been included. ;; Remove eight-bit-*, treat them as ascii. (let ((css (find-charset-region b e))) - (mapcar (lambda (cs) (setq css (delq cs css))) - '(composition eight-bit-control eight-bit-graphic - control-1)) - css)) + (dolist (cs + '(composition eight-bit-control eight-bit-graphic control-1) + css) + (setq css (delq cs css))))) (t ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit. (save-excursion @@ -1054,21 +1057,6 @@ Emacs 23 (unicode)." mm-mime-mule-charset-alist))))) (list 'ascii (or charset 'latin-iso8859-1))))))))) -(if (fboundp 'shell-quote-argument) - (defalias 'mm-quote-arg 'shell-quote-argument) - (defun mm-quote-arg (arg) - "Return a version of ARG that is safe to evaluate in a shell." - (let ((pos 0) new-pos accum) - ;; *** bug: we don't handle newline characters properly - (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos)) - (push (substring arg pos new-pos) accum) - (push "\\" accum) - (push (list (aref arg new-pos)) accum) - (setq pos (1+ new-pos))) - (if (= pos 0) - arg - (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))) - (defun mm-auto-mode-alist () "Return an `auto-mode-alist' with only the .gz (etc) thingies." (let ((alist auto-mode-alist) @@ -1080,7 +1068,7 @@ Emacs 23 (unicode)." (nreverse out))) (defvar mm-inhibit-file-name-handlers - '(jka-compr-handler image-file-handler) + '(jka-compr-handler image-file-handler epa-file-handler) "A list of handlers doing (un)compression (etc) thingies.") (defun mm-insert-file-contents (filename &optional visit beg end replace @@ -1166,7 +1154,7 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (>= (length def) 4) (eq (nth 3 def) 'suffix))))) (defalias 'mm-make-temp-file 'make-temp-file) - ;; Stolen (and modified for Emacs 20 and XEmacs) from Emacs 22. + ;; Stolen (and modified for XEmacs) from Emacs 22. (defun mm-make-temp-file (prefix &optional dir-flag suffix) "Create a temporary file. The returned file name (created by appending some random characters at the end @@ -1206,10 +1194,9 @@ If SUFFIX is non-nil, add that at the end of the file name." nil 'excl)) nil) (file-already-exists t) - ;; The Emacs 20 and XEmacs versions of - ;; `make-directory' issue `file-error'. - (file-error (or (and (or (featurep 'xemacs) - (= emacs-major-version 20)) + ;; The XEmacs version of `make-directory' issues + ;; `file-error'. + (file-error (or (and (featurep 'xemacs) (file-exists-p file)) (signal (car err) (cdr err))))) ;; the file was somehow created by someone else between @@ -1257,6 +1244,187 @@ If SUFFIX is non-nil, add that at the end of the file name." (let ((cs (mm-detect-coding-region start end))) cs))) +(eval-when-compile + (unless (fboundp 'coding-system-to-mime-charset) + (defalias 'coding-system-to-mime-charset 'ignore))) + +(defun mm-coding-system-to-mime-charset (coding-system) + "Return the MIME charset corresponding to CODING-SYSTEM. +To make this function work with XEmacs, the APEL package is required." + (when coding-system + (or (and (fboundp 'coding-system-get) + (or (coding-system-get coding-system :mime-charset) + (coding-system-get coding-system 'mime-charset))) + (and (featurep 'xemacs) + (or (and (fboundp 'coding-system-to-mime-charset) + (not (eq (symbol-function 'coding-system-to-mime-charset) + 'ignore))) + (and (condition-case nil + (require 'mcharset) + (error nil)) + (fboundp 'coding-system-to-mime-charset))) + (coding-system-to-mime-charset coding-system))))) + +(eval-when-compile + (require 'jka-compr)) + +(defun mm-decompress-buffer (filename &optional inplace force) + "Decompress buffer's contents, depending on jka-compr. +Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME +agrees with `jka-compr-compression-info-list', decompression is done. +Signal an error if FORCE is neither nil nor t and compressed data are +not decompressed because `auto-compression-mode' is disabled. +If INPLACE is nil, return decompressed data or nil without modifying +the buffer. Otherwise, replace the buffer's contents with the +decompressed data. The buffer's multibyteness must be turned off." + (when (and filename + (if force + (prog1 t (require 'jka-compr)) + (and (fboundp 'jka-compr-installed-p) + (jka-compr-installed-p)))) + (let ((info (jka-compr-get-compression-info filename))) + (when info + (unless (or (memq force (list nil t)) + (jka-compr-installed-p)) + (error "")) + (let ((prog (jka-compr-info-uncompress-program info)) + (args (jka-compr-info-uncompress-args info)) + (msg (format "%s %s..." + (jka-compr-info-uncompress-message info) + filename)) + (err-file (jka-compr-make-temp-name)) + (cur (current-buffer)) + (coding-system-for-read mm-binary-coding-system) + (coding-system-for-write mm-binary-coding-system) + retval err-msg) + (message "%s" msg) + (mm-with-unibyte-buffer + (insert-buffer-substring cur) + (condition-case err + (progn + (unless (memq (apply 'call-process-region + (point-min) (point-max) + prog t (list t err-file) nil args) + jka-compr-acceptable-retval-list) + (erase-buffer) + (insert (mapconcat + 'identity + (delete "" (split-string + (prog2 + (insert-file-contents err-file) + (buffer-string) + (erase-buffer)))) + " ") + "\n") + (setq err-msg + (format "Error while executing \"%s %s < %s\"" + prog (mapconcat 'identity args " ") + filename))) + (setq retval (buffer-string))) + (error + (setq err-msg (error-message-string err))))) + (when (file-exists-p err-file) + (ignore-errors (jka-compr-delete-temp-file err-file))) + (when inplace + (unless err-msg + (delete-region (point-min) (point-max)) + (insert retval)) + (setq retval nil)) + (message "%s" (or err-msg (concat msg "done"))) + retval))))) + +(eval-when-compile + (unless (fboundp 'coding-system-name) + (defalias 'coding-system-name 'ignore)) + (unless (fboundp 'find-file-coding-system-for-read-from-filename) + (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) + (unless (fboundp 'find-operation-coding-system) + (defalias 'find-operation-coding-system 'ignore))) + +(defun mm-find-buffer-file-coding-system (&optional filename) + "Find coding system used to decode the contents of the current buffer. +This function looks for the coding system magic cookie or examines the +coding system specified by `file-coding-system-alist' being associated +with FILENAME which defaults to `buffer-file-name'. Data compressed by +gzip, bzip2, etc. are allowed." + (unless filename + (setq filename buffer-file-name)) + (save-excursion + (let ((decomp (unless ;; No worth to examine charset of tar files. + (and filename + (string-match + "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'" + filename)) + (mm-decompress-buffer filename nil t)))) + (when decomp + (set-buffer (let (default-enable-multibyte-characters) + (generate-new-buffer " *temp*"))) + (insert decomp) + (setq filename (file-name-sans-extension filename))) + (goto-char (point-min)) + (prog1 + (cond + ((boundp 'set-auto-coding-function) ;; Emacs + (if filename + (or (funcall (symbol-value 'set-auto-coding-function) + filename (- (point-max) (point-min))) + (car (find-operation-coding-system 'insert-file-contents + filename))) + (let (auto-coding-alist) + (condition-case nil + (funcall (symbol-value 'set-auto-coding-function) + nil (- (point-max) (point-min))) + (error nil))))) + ((featurep 'file-coding) ;; XEmacs + (let ((case-fold-search t) + (end (point-at-eol)) + codesys start) + (or + (and (re-search-forward "-\\*-+[\t ]*" end t) + (progn + (setq start (match-end 0)) + (re-search-forward "[\t ]*-+\\*-" end t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") + (re-search-forward + "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" + end t))) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" + nil t) + (progn + (setq start (match-end 0)) + (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (re-search-forward + "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" + end t)) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (progn + (goto-char (point-min)) + (setq case-fold-search nil) + (re-search-forward "^;;;coding system: " + ;;(+ (point-min) 3000) t)) + nil t)) + (looking-at "[^\t\n\r ]+") + (find-coding-system + (setq codesys (intern (match-string 0)))) + codesys) + (and filename + (setq codesys + (find-file-coding-system-for-read-from-filename + filename)) + (coding-system-name (coding-system-base codesys))))))) + (when decomp + (kill-buffer (current-buffer))))))) (provide 'mm-util) diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 81d8088535f..c7f6b16a1c8 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -68,9 +68,6 @@ decoder, such as hexbin." (defvar mm-uu-yenc-decode-function 'yenc-decode-region) -(defvar mm-uu-pgp-beginning-signature - "^-----BEGIN PGP SIGNATURE-----") - (defvar mm-uu-beginning-regexp nil) (defvar mm-dissect-disposition "inline" @@ -90,19 +87,25 @@ This can be either \"inline\" or \"attachment\".") :type 'regexp :group 'gnus-article-mime) +(defcustom mm-uu-tex-groups-regexp "\\.tex\\>" + "*Regexp matching TeX groups." + :version "23.0" + :type 'regexp + :group 'gnus-article-mime) + (defvar mm-uu-type-alist '((postscript "^%!PS-" "^%%EOF$" mm-uu-postscript-extract nil) - (uu + (uu ;; Maybe we should have a more strict test here. "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+" "^end[ \t]*$" mm-uu-uu-extract mm-uu-uu-filename) (binhex - "^:...............................................................$" + "^:.\\{63,63\\}$" ":$" mm-uu-binhex-extract nil @@ -157,7 +160,35 @@ This can be either \"inline\" or \"attachment\".") nil mm-uu-diff-extract nil - mm-uu-diff-test)) + mm-uu-diff-test) + (message-marks + ;; Text enclosed with tags similar to `message-mark-insert-begin' and + ;; `message-mark-insert-end'. Don't use those variables to avoid + ;; dependency on `message.el'. + "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" + "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" + (lambda () (mm-uu-verbatim-marks-extract 0 -1 1 -1)) + nil) + ;; Omitting [a-z8<] leads to false positives (bogus signature separators + ;; and mailing list banners). + (insert-marks + "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" + "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" + (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) + nil) + (verbatim-marks + ;; slrn-style verbatim marks, see + ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81 + "^#v\\+" + "^#v\\-$" + (lambda () (mm-uu-verbatim-marks-extract 0 0)) + nil) + (LaTeX + "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" + "^\\\\end{document}" + mm-uu-latex-extract + nil + mm-uu-latex-test)) "A list of specifications for non-MIME attachments. Each element consist of the following entries: label, start-regexp, end-regexp, extract-function, test-function. @@ -201,9 +232,45 @@ To disable dissecting shar codes, for instance, add (defsubst mm-uu-function-2 (entry) (nth 5 entry)) -(defun mm-uu-copy-to-buffer (&optional from to) +;; In Emacs 22, we could use `min-colors' in the face definition. But Emacs +;; 21 and XEmacs don't support it. +(defcustom mm-uu-hide-markers + (< 16 (or (and (fboundp 'defined-colors) + (length (defined-colors))) + (and (fboundp 'device-color-cells) + (device-color-cells)) + 0)) + "If non-nil, hide verbatim markers. +The value should be nil on displays where the face +`mm-uu-extract' isn't distinguishable to the face `default'." + :type '(choice (const :tag "Hide" t) + (const :tag "Don't hide" nil)) + :version "23.0" ;; No Gnus + :group 'gnus-article-mime) + +(defface mm-uu-extract '(;; Colors from `gnus-cite-3' plus background: + (((class color) + (background dark)) + (:foreground "light yellow" + :background "dark green")) + (((class color) + (background light)) + (:foreground "dark green" + :background "light yellow")) + (t + ())) + "Face for extracted buffers." + ;; See `mm-uu-verbatim-marks-extract'. + :version "23.0" ;; No Gnus + :group 'gnus-article-mime) + +(defun mm-uu-copy-to-buffer (&optional from to properties) "Copy the contents of the current buffer to a fresh buffer. -Return that buffer." +Return that buffer. + +If PROPERTIES is non-nil, PROPERTIES are applied to the buffer, +see `set-text-properties'. If PROPERTIES equals t, this means to +apply the face `mm-uu-extract'." (let ((obuf (current-buffer)) (coding-system ;; Might not exist in non-MULE XEmacs @@ -212,6 +279,11 @@ Return that buffer." (with-current-buffer (generate-new-buffer " *mm-uu*") (setq buffer-file-coding-system coding-system) (insert-buffer-substring obuf from to) + (cond ((eq properties t) + (set-text-properties (point-min) (point-max) + '(face mm-uu-extract))) + (properties + (set-text-properties (point-min) (point-max) properties))) (current-buffer)))) (defun mm-uu-configure-p (key val) @@ -267,6 +339,35 @@ Return that buffer." (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) '("application/postscript"))) +(defun mm-uu-verbatim-marks-extract (start-offset end-offset + &optional + start-hide + end-hide) + (let ((start (or (and mm-uu-hide-markers + start-hide) + start-offset + 1)) + (end (or (and mm-uu-hide-markers + end-hide) + end-offset + -1))) + (mm-make-handle + (mm-uu-copy-to-buffer + (progn (goto-char start-point) + (forward-line start) + (point)) + (progn (goto-char end-point) + (forward-line end) + (point)) + t) + '("text/x-verbatim" (charset . gnus-decoded))))) + +(defun mm-uu-latex-extract () + (mm-make-handle + (mm-uu-copy-to-buffer start-point end-point t) + ;; application/x-tex? + '("text/x-verbatim" (charset . gnus-decoded)))) + (defun mm-uu-emacs-sources-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) '("application/emacs-lisp" (charset . gnus-decoded)) @@ -292,6 +393,11 @@ Return that buffer." mm-uu-diff-groups-regexp (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name))) +(defun mm-uu-latex-test () + (and gnus-newsgroup-name + mm-uu-tex-groups-regexp + (string-match mm-uu-tex-groups-regexp gnus-newsgroup-name))) + (defun mm-uu-forward-extract () (mm-make-handle (mm-uu-copy-to-buffer (progn (goto-char start-point) (forward-line) (point)) @@ -369,30 +475,16 @@ Return that buffer." (progn (mml2015-clean-buffer) (let ((coding-system-for-write (or gnus-newsgroup-charset - 'iso-8859-1))) + 'iso-8859-1)) + (coding-system-for-read (or gnus-newsgroup-charset + 'iso-8859-1))) (funcall (mml2015-clear-verify-function)))) (when (and mml2015-use (null (mml2015-clear-verify-function))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details - (format "Clear verification not supported by `%s'.\n" mml2015-use)))) - (goto-char (point-min)) - (forward-line) - ;; We need to be careful not to strip beyond the armor headers. - ;; Previously, an attacker could replace the text inside our - ;; markup with trailing garbage by injecting whitespace into the - ;; message. - (while (looking-at "Hash:") ; The only header allowed in cleartext - (forward-line)) ; signatures according to RFC2440. - (when (looking-at "[\t ]*$") - (forward-line)) - (delete-region (point-min) (point)) - (if (re-search-forward mm-uu-pgp-beginning-signature nil t) - (delete-region (match-beginning 0) (point-max))) - (goto-char (point-min)) - (while (re-search-forward "^- " nil t) - (replace-match "" t t) - (forward-line 1))) - (list (mm-make-handle buf mm-uu-text-plain-type)))) + (format "Clear verification not supported by `%s'.\n" mml2015-use))) + (mml2015-extract-cleartext-signature)) + (list (mm-make-handle buf mm-uu-text-plain-type))))) (defun mm-uu-pgp-signed-extract () (let ((mm-security-handle (list (format "multipart/signed")))) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index c8a672928c0..ffaf0ed68ba 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -30,15 +30,14 @@ (require 'mailcap) (require 'mm-bodies) (require 'mm-decode) +(require 'smime) (eval-and-compile (autoload 'gnus-article-prepare-display "gnus-art") (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") (autoload 'fill-flowed "flow-fill") - (autoload 'html2text "html2text" nil t) - (unless (fboundp 'diff-mode) - (autoload 'diff-mode "diff-mode" "" t nil))) + (autoload 'html2text "html2text" nil t)) (defvar gnus-article-mime-handles) (defvar gnus-newsgroup-charset) @@ -73,7 +72,7 @@ "The attributes of washer types for text/html.") (defcustom mm-fill-flowed t - "If non-nil an format=flowed article will be displayed flowed." + "If non-nil a format=flowed article will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) @@ -140,26 +139,26 @@ (charset (mail-content-type-get (mm-handle-type handle) 'charset))) (save-excursion - (insert text) + (insert (if charset (mm-decode-string text charset) text)) (save-restriction (narrow-to-region b (point)) - (goto-char (point-min)) - (if (or (and (boundp 'w3-meta-content-type-charset-regexp) - (re-search-forward - w3-meta-content-type-charset-regexp nil t)) - (and (boundp 'w3-meta-charset-content-type-regexp) - (re-search-forward - w3-meta-charset-content-type-regexp nil t))) + (unless charset + (goto-char (point-min)) + (when (or (and (boundp 'w3-meta-content-type-charset-regexp) + (re-search-forward + w3-meta-content-type-charset-regexp nil t)) + (and (boundp 'w3-meta-charset-content-type-regexp) + (re-search-forward + w3-meta-charset-content-type-regexp nil t))) (setq charset - (or (let ((bsubstr (buffer-substring-no-properties - (match-beginning 2) - (match-end 2)))) - (if (fboundp 'w3-coding-system-for-mime-charset) - (w3-coding-system-for-mime-charset bsubstr) - (mm-charset-to-coding-system bsubstr))) - charset))) - (delete-region (point-min) (point-max)) - (insert (mm-decode-string text charset)) + (let ((bsubstr (buffer-substring-no-properties + (match-beginning 2) + (match-end 2)))) + (if (fboundp 'w3-coding-system-for-mime-charset) + (w3-coding-system-for-mime-charset bsubstr) + (mm-charset-to-coding-system bsubstr)))) + (delete-region (point-min) (point-max)) + (insert (mm-decode-string text charset)))) (save-window-excursion (save-restriction (let ((w3-strict-width width) @@ -189,12 +188,12 @@ handle `(lambda () (let (buffer-read-only) - (if (functionp 'remove-specifier) - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) - (current-buffer))) - '(background background-pixmap foreground))) + ,@(if (functionp 'remove-specifier) + '((mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) + (current-buffer))) + '(background background-pixmap foreground)))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) @@ -263,13 +262,7 @@ (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) - (if (functionp 'remove-specifier) - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) - (current-buffer))) - '(background background-pixmap foreground))) + (let ((inhibit-read-only t)) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) @@ -428,7 +421,8 @@ (save-restriction (narrow-to-region b (point)) (goto-char b) - (fill-flowed) + (fill-flowed nil (equal (cdr (assoc 'delsp (mm-handle-type handle))) + "yes")) (goto-char (point-max)))) (save-restriction (narrow-to-region b (point)) @@ -448,6 +442,8 @@ "Insert TEXT inline from HANDLE." (let ((b (point))) (insert text) + (unless (bolp) + (insert "\n")) (mm-handle-set-undisplayer handle `(lambda () @@ -530,38 +526,55 @@ (delete-region ,(point-min-marker) ,(point-max-marker))))))))) (defun mm-display-inline-fontify (handle mode) - (let (text) + (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset)) + text coding-system) + (unless (eq charset 'gnus-decoded) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (mm-decompress-buffer + (or (mail-content-type-get (mm-handle-disposition handle) 'name) + (mail-content-type-get (mm-handle-disposition handle) 'filename)) + t t) + (unless charset + (setq coding-system (mm-find-buffer-file-coding-system))) + (setq text (buffer-string)))) ;; XEmacs @#$@ version of font-lock refuses to fully turn itself ;; on for buffers whose name begins with " ". That's why we use - ;; save-current-buffer/get-buffer-create rather than - ;; with-temp-buffer. - (save-current-buffer - (set-buffer (generate-new-buffer "*fontification*")) - (unwind-protect - (progn - (buffer-disable-undo) - (mm-insert-part handle) - (require 'font-lock) - (let ((font-lock-maximum-size nil) - ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. - (font-lock-mode-hook nil) - (font-lock-support-mode nil) - ;; I find font-lock a bit too verbose. - (font-lock-verbose nil)) - (funcall mode) - ;; The mode function might have already turned on font-lock. - (unless (symbol-value 'font-lock-mode) - (font-lock-fontify-buffer))) - ;; By default, XEmacs font-lock uses non-duplicable text - ;; properties. This code forces all the text properties - ;; to be copied along with the text. - (when (fboundp 'extent-list) - (map-extents (lambda (ext ignored) - (set-extent-property ext 'duplicable t) - nil) - nil nil nil nil nil 'text-prop)) - (setq text (buffer-string))) - (kill-buffer (current-buffer)))) + ;; `with-current-buffer'/`generate-new-buffer' rather than + ;; `with-temp-buffer'. + (with-current-buffer (generate-new-buffer "*fontification*") + (buffer-disable-undo) + (mm-enable-multibyte) + (insert (cond ((eq charset 'gnus-decoded) + (with-current-buffer (mm-handle-buffer handle) + (buffer-string))) + (coding-system + (mm-decode-coding-string text coding-system)) + (charset + (mm-decode-string text charset)) + (t + text))) + (require 'font-lock) + (let ((font-lock-maximum-size nil) + ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. + (font-lock-mode-hook nil) + (font-lock-support-mode nil) + ;; I find font-lock a bit too verbose. + (font-lock-verbose nil)) + (funcall mode) + ;; The mode function might have already turned on font-lock. + (unless (symbol-value 'font-lock-mode) + (font-lock-fontify-buffer))) + ;; By default, XEmacs font-lock uses non-duplicable text + ;; properties. This code forces all the text properties + ;; to be copied along with the text. + (when (fboundp 'extent-list) + (map-extents (lambda (ext ignored) + (set-extent-property ext 'duplicable t) + nil) + nil nil nil nil nil 'text-prop)) + (setq text (buffer-string)) + (kill-buffer (current-buffer))) (mm-insert-inline handle text))) ;; Shouldn't these functions check whether the user even wants to use @@ -575,27 +588,28 @@ (defun mm-display-elisp-inline (handle) (mm-display-inline-fontify handle 'emacs-lisp-mode)) +(defun mm-display-dns-inline (handle) + (mm-display-inline-fontify handle 'dns-mode)) + ;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 } (defvar mm-pkcs7-signed-magic (mm-string-as-unibyte - (apply 'concat - (mapcar 'char-to-string - (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c - ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e - ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 - ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02))))) + (mapconcat 'char-to-string + (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c + ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e + ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 + ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02) ""))) ;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 } (defvar mm-pkcs7-enveloped-magic (mm-string-as-unibyte - (apply 'concat - (mapcar 'char-to-string - (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c - ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e - ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 - ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03))))) + (mapconcat 'char-to-string + (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c + ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e + ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 + ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03) ""))) (defun mm-view-pkcs7-get-type (handle) (mm-with-unibyte-buffer @@ -614,23 +628,26 @@ (otherwise (error "Unknown or unimplemented PKCS#7 type")))) (defun mm-view-pkcs7-verify (handle) - ;; A bogus implementation of PKCS#7. FIXME:: - (mm-insert-part handle) - (goto-char (point-min)) - (if (search-forward "Content-Type: " nil t) - (delete-region (point-min) (match-beginning 0))) - (goto-char (point-max)) - (if (re-search-backward "--\r?\n?" nil t) - (delete-region (match-end 0) (point-max))) + (let ((verified nil)) + (with-temp-buffer + (insert "MIME-Version: 1.0\n") + (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") + (insert-buffer-substring (mm-handle-buffer handle)) + (setq verified (smime-verify-region (point-min) (point-max)))) + (goto-char (point-min)) + (mm-insert-part handle) + (if (search-forward "Content-Type: " nil t) + (delete-region (point-min) (match-beginning 0))) + (goto-char (point-max)) + (if (re-search-backward "--\r?\n?" nil t) + (delete-region (match-end 0) (point-max))) + (unless verified + (insert-buffer-substring smime-details-buffer))) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n")) - (message "Verify signed PKCS#7 message is unimplemented.") - (sit-for 1) t) -(autoload 'gnus-completing-read-maybe-default "gnus-util" nil nil 'macro) - (defun mm-view-pkcs7-decrypt (handle) (insert-buffer-substring (mm-handle-buffer handle)) (goto-char (point-min)) @@ -641,10 +658,9 @@ (if (= (length smime-keys) 1) (cadar smime-keys) (smime-get-key-by-email - (gnus-completing-read-maybe-default + (completing-read (concat "Decipher using key" - (if smime-keys - (concat " (default " (caar smime-keys) "): ") + (if smime-keys (concat "(default " (caar smime-keys) "): ") ": ")) smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) (goto-char (point-min)) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 68df6b64c4b..29bc0d41a1b 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -26,14 +26,20 @@ ;;; Code: -(require 'mml-smime) (eval-when-compile (require 'cl)) +(require 'password) (autoload 'mml2015-sign "mml2015") (autoload 'mml2015-encrypt "mml2015") (autoload 'mml1991-sign "mml1991") (autoload 'mml1991-encrypt "mml1991") (autoload 'message-goto-body "message") (autoload 'mml-insert-tag "mml") +(autoload 'mml-smime-sign "mml-smime") +(autoload 'mml-smime-encrypt "mml-smime") +(autoload 'mml-smime-sign-query "mml-smime") +(autoload 'mml-smime-encrypt-query "mml-smime") +(autoload 'mml-smime-verify "mml-smime") +(autoload 'mml-smime-verify-test "mml-smime") (defvar mml-sign-alist '(("smime" mml-smime-sign-buffer mml-smime-sign-query) @@ -96,6 +102,23 @@ details." (choice (const :tag "Separate" separate) (const :tag "Combined" combined))))) +(defcustom mml-secure-verbose nil + "If non-nil, ask the user about the current operation more verbosely." + :group 'message + :type 'boolean) + +(defcustom mml-secure-cache-passphrase password-cache + "If t, cache passphrase." + :group 'message + :type 'boolean) + +(defcustom mml-secure-passphrase-cache-expiry password-cache-expiry + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`mml-secure-cache-passphrase'." + :group 'message + :type 'integer) + ;;; Configuration/helper functions (defun mml-signencrypt-style (method &optional style) @@ -249,6 +272,13 @@ Use METHOD if given. Else use `mml-secure-method' or ;; defuns that add the proper <#secure ...> tag to the top of the message body (defun mml-secure-message (method &optional modesym) (let ((mode (prin1-to-string modesym)) + (tags (append + (if (or (eq modesym 'sign) + (eq modesym 'signencrypt)) + (funcall (nth 2 (assoc method mml-sign-alist)))) + (if (or (eq modesym 'encrypt) + (eq modesym 'signencrypt)) + (funcall (nth 2 (assoc method mml-encrypt-alist)))))) insert-loc) (mml-unsecure-message) (save-excursion @@ -257,8 +287,8 @@ Use METHOD if given. Else use `mml-secure-method' or (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (goto-char (setq insert-loc (match-end 0))) (unless (looking-at "<#secure") - (mml-insert-tag - 'secure 'method method 'mode mode))) + (apply 'mml-insert-tag + 'secure 'method method 'mode mode tags))) (t (error "The message is corrupted. No mail header separator")))) (when (eql insert-loc (point)) diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 3762c2303b3..c00ac416b8b 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -31,10 +31,82 @@ (require 'smime) (require 'mm-decode) +(require 'mml-sec) (autoload 'message-narrow-to-headers "message") (autoload 'message-fetch-field "message") +(defvar mml-smime-use 'openssl) + +(defvar mml-smime-function-alist + '((openssl mml-smime-openssl-sign + mml-smime-openssl-encrypt + mml-smime-openssl-sign-query + mml-smime-openssl-encrypt-query + mml-smime-openssl-verify + mml-smime-openssl-verify-test) + (epg mml-smime-epg-sign + mml-smime-epg-encrypt + nil + nil + mml-smime-epg-verify + mml-smime-epg-verify-test))) + +(defcustom mml-smime-verbose mml-secure-verbose + "If non-nil, ask the user about the current operation more verbosely." + :group 'mime-security + :type 'boolean) + +(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase + "If t, cache passphrase." + :group 'mime-security + :type 'boolean) + +(defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`mml-smime-cache-passphrase'." + :group 'mime-security + :type 'integer) + +(defcustom mml-smime-signers nil + "A list of your own key ID which will be used to sign a message." + :group 'mime-security + :type '(repeat (string :tag "Key ID"))) + (defun mml-smime-sign (cont) + (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func cont) + (error "Cannot find sign function")))) + +(defun mml-smime-encrypt (cont) + (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func cont) + (error "Cannot find encrypt function")))) + +(defun mml-smime-sign-query () + (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func)))) + +(defun mml-smime-encrypt-query () + (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func)))) + +(defun mml-smime-verify (handle ctl) + (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func handle ctl) + handle))) + +(defun mml-smime-verify-test (handle ctl) + (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist)))) + (if func + (funcall func handle ctl)))) + +(defun mml-smime-openssl-sign (cont) (when (null smime-keys) (customize-variable 'smime-keys) (error "No S/MIME keys configured, use customize to add your key")) @@ -44,7 +116,7 @@ (replace-match "\n" t t)) (goto-char (point-max))) -(defun mml-smime-encrypt (cont) +(defun mml-smime-openssl-encrypt (cont) (let (certnames certfiles tmp file tmpfiles) ;; xxx tmp files are always an security issue (while (setq tmp (pop cont)) @@ -70,7 +142,7 @@ nil)) (goto-char (point-max))) -(defun mml-smime-sign-query () +(defun mml-smime-openssl-sign-query () ;; query information (what certificate) from user when MML tag is ;; added, for use later by the signing process (when (null smime-keys) @@ -123,22 +195,42 @@ (quit)) result)) -(defun mml-smime-encrypt-query () - ;; todo: add ldap support (xemacs ldap api?) +(defun mml-smime-get-ldap-cert () + ;; todo: deal with comma separated multiple recipients + (let (result who bad cert) + (condition-case () + (while (not result) + (setq who (read-from-minibuffer + (format "%sLookup certificate for: " (or bad "")) + (cadr (funcall gnus-extract-address-components + (or (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "to"))) + ""))))) + (if (setq cert (smime-cert-by-ldap who)) + (setq result (list 'certfile (buffer-name cert))) + (setq bad (format "`%s' not found. " who)))) + (quit)) + result)) + +(defun mml-smime-openssl-encrypt-query () ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) (ecase (read (gnus-completing-read-with-default - "dns" "Fetch certificate from" - '(("dns") ("file")) nil t)) + "ldap" "Fetch certificate from" + '(("dns") ("ldap") ("file")) nil t)) (dns (setq certs (append certs (mml-smime-get-dns-cert)))) + (ldap (setq certs (append certs + (mml-smime-get-ldap-cert)))) (file (setq certs (append certs (mml-smime-get-file-cert))))) (setq done (not (y-or-n-p "Add more recipients? ")))) certs)) -(defun mml-smime-verify (handle ctl) +(defun mml-smime-openssl-verify (handle ctl) (with-temp-buffer (insert-buffer-substring (mm-handle-multipart-original-buffer ctl)) (goto-char (point-min)) @@ -203,9 +295,249 @@ (buffer-string) "\n"))))) handle) -(defun mml-smime-verify-test (handle ctl) +(defun mml-smime-openssl-verify-test (handle ctl) smime-openssl-program) +(eval-and-compile + (autoload 'epg-make-context "epg")) + +(eval-when-compile + (defvar epg-user-id-alist) + (defvar epg-digest-algorithm-alist) + (defvar inhibit-redisplay) + (autoload 'epg-context-set-armor "epg") + (autoload 'epg-context-set-signers "epg") + (autoload 'epg-context-result-for "epg") + (autoload 'epg-new-signature-digest-algorithm "epg") + (autoload 'epg-verify-result-to-string "epg") + (autoload 'epg-list-keys "epg") + (autoload 'epg-decrypt-string "epg") + (autoload 'epg-verify-string "epg") + (autoload 'epg-sign-string "epg") + (autoload 'epg-encrypt-string "epg") + (autoload 'epg-passphrase-callback-function "epg") + (autoload 'epg-context-set-passphrase-callback "epg") + (autoload 'epg-configuration "epg-config") + (autoload 'epg-expand-group "epg-config") + (autoload 'epa-select-keys "epa")) + +(eval-when-compile + (defvar password-cache-expiry) + (autoload 'password-read "password") + (autoload 'password-cache-add "password") + (autoload 'password-cache-remove "password")) + +(defvar mml-smime-epg-secret-key-id-list nil) + +(defun mml-smime-epg-passphrase-callback (context key-id ignore) + (if (eq key-id 'SYM) + (epg-passphrase-callback-function context key-id nil) + (let* (entry + (passphrase + (password-read + (if (eq key-id 'PIN) + "Passphrase for PIN: " + (if (setq entry (assoc key-id epg-user-id-alist)) + (format "Passphrase for %s %s: " key-id (cdr entry)) + (format "Passphrase for %s: " key-id))) + (if (eq key-id 'PIN) + "PIN" + key-id)))) + (when passphrase + (let ((password-cache-expiry mml-smime-passphrase-cache-expiry)) + (password-cache-add key-id passphrase)) + (setq mml-smime-epg-secret-key-id-list + (cons key-id mml-smime-epg-secret-key-id-list)) + (copy-sequence passphrase))))) + +(defun mml-smime-epg-find-usable-key (keys usage) + (catch 'found + (while keys + (let ((pointer (epg-key-sub-key-list (car keys)))) + (while pointer + (if (and (memq usage (epg-sub-key-capability (car pointer))) + (not (memq (epg-sub-key-validity (car pointer)) + '(revoked expired)))) + (throw 'found (car keys))) + (setq pointer (cdr pointer)))) + (setq keys (cdr keys))))) + +(defun mml-smime-epg-sign (cont) + (let* ((inhibit-redisplay t) + (context (epg-make-context 'CMS)) + (boundary (mml-compute-boundary cont)) + signer-key + (signers + (or (message-options-get 'mml-smime-epg-signers) + (message-options-set + 'mml-smime-epg-signers + (if mml-smime-verbose + (epa-select-keys context "\ +Select keys for signing. +If no one is selected, default secret key is used. " + mml-smime-signers t) + (if mml-smime-signers + (mapcar + (lambda (signer) + (setq signer-key (mml-smime-epg-find-usable-key + (epg-list-keys context signer t) + 'sign)) + (unless (or signer-key + (y-or-n-p + (format "No secret key for %s; skip it? " + signer))) + (error "No secret key for %s" signer)) + signer-key) + mml-smime-signers)))))) + signature micalg) + (epg-context-set-signers context signers) + (if mml-smime-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml-smime-epg-passphrase-callback)) + (condition-case error + (setq signature (epg-sign-string context + (mm-replace-in-string (buffer-string) + "\n" "\r\n") + t) + mml-smime-epg-secret-key-id-list nil) + (error + (while mml-smime-epg-secret-key-id-list + (password-cache-remove (car mml-smime-epg-secret-key-id-list)) + (setq mml-smime-epg-secret-key-id-list + (cdr mml-smime-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (if (epg-context-result-for context 'sign) + (setq micalg (epg-new-signature-digest-algorithm + (car (epg-context-result-for context 'sign))))) + (goto-char (point-min)) + (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" + boundary)) + (if micalg + (insert (format "\tmicalg=%s; " + (downcase + (cdr (assq micalg + epg-digest-algorithm-alist)))))) + (insert "protocol=\"application/pkcs7-signature\"\n") + (insert (format "\n--%s\n" boundary)) + (goto-char (point-max)) + (insert (format "\n--%s\n" boundary)) + (insert "Content-Type: application/pkcs7-signature; name=smime.p7s +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=smime.p7s + +") + (insert (base64-encode-string signature) "\n") + (goto-char (point-max)) + (insert (format "--%s--\n" boundary)) + (goto-char (point-max)))) + +(defun mml-smime-epg-encrypt (cont) + (let ((inhibit-redisplay t) + (context (epg-make-context 'CMS)) + (config (epg-configuration)) + (recipients (message-options-get 'mml-smime-epg-recipients)) + cipher signers + (boundary (mml-compute-boundary cont)) + recipient-key) + (unless recipients + (setq recipients + (apply #'nconc + (mapcar + (lambda (recipient) + (or (epg-expand-group config recipient) + (list recipient))) + (split-string + (or (message-options-get 'message-recipients) + (message-options-set 'message-recipients + (read-string "Recipients: "))) + "[ \f\t\n\r\v,]+")))) + (if mml-smime-verbose + (setq recipients + (epa-select-keys context "\ +Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. " + recipients)) + (setq recipients + (mapcar + (lambda (recipient) + (setq recipient-key (mml-smime-epg-find-usable-key + (epg-list-keys context recipient) + 'encrypt)) + (unless (or recipient-key + (y-or-n-p + (format "No public key for %s; skip it? " + recipient))) + (error "No public key for %s" recipient)) + recipient-key) + recipients)) + (unless recipients + (error "No recipient specified"))) + (message-options-set 'mml-smime-epg-recipients recipients)) + (if mml-smime-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml-smime-epg-passphrase-callback)) + (condition-case error + (setq cipher + (epg-encrypt-string context (buffer-string) recipients) + mml-smime-epg-secret-key-id-list nil) + (error + (while mml-smime-epg-secret-key-id-list + (password-cache-remove (car mml-smime-epg-secret-key-id-list)) + (setq mml-smime-epg-secret-key-id-list + (cdr mml-smime-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert "\ +Content-Type: application/pkcs7-mime; + smime-type=enveloped-data; + name=smime.p7m +Content-Transfer-Encoding: base64 +Content-Disposition: attachment; filename=smime.p7m + +") + (insert (base64-encode-string cipher)) + (goto-char (point-max)))) + +(defun mml-smime-epg-verify (handle ctl) + (catch 'error + (let ((inhibit-redisplay t) + context plain signature-file part signature) + (when (or (null (setq part (mm-find-raw-part-by-type + ctl (or (mm-handle-multipart-ctl-parameter + ctl 'protocol) + "application/pkcs7-signature") + t))) + (null (setq signature (mm-find-part-by-type + (cdr handle) + "application/pkcs7-signature" + nil t)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (setq part (mm-replace-in-string part "\n" "\r\n" t) + context (epg-make-context 'CMS)) + (condition-case error + (setq plain (epg-verify-string context (mm-get-part signature) part)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (format "%S" error))) + (throw 'error handle))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (epg-verify-result-to-string (epg-context-result-for context 'verify))) + handle))) + +(defun mml-smime-epg-verify-test (handle ctl) + t) + (provide 'mml-smime) ;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 2fb88f5e551..7fbc8bb3209 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -35,9 +35,9 @@ (eval-and-compile (autoload 'message-make-message-id "message") (autoload 'gnus-setup-posting-charset "gnus-msg") - (autoload 'gnus-add-minor-mode "gnus-ems") (autoload 'gnus-make-local-hook "gnus-util") (autoload 'message-fetch-field "message") + (autoload 'message-mark-active-p "message") (autoload 'message-info "message") (autoload 'fill-flowed-encode "flow-fill") (autoload 'message-posting-charset "message") @@ -70,6 +70,46 @@ These parameters are generated in Content-Disposition header if exists." :type '(repeat (symbol :tag "Parameter")) :group 'message) +(defcustom mml-content-disposition-alist + '((text (rtf . "attachment") (t . "inline")) + (t . "attachment")) + "Alist of MIME types or regexps matching file names and default dispositions. +Each element should be one of the following three forms: + + (REGEXP . DISPOSITION) + (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...) + (TYPE . DISPOSITION) + +Where REGEXP is a string which matches the file name (if any) of an +attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a +MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME +type (e.g., text/plain) respectively, and DISPOSITION should be either +the string \"attachment\" or the string \"inline\". The value t for +SUPERTYPE, SUBTYPE or TYPE matches any of those types. The first +match found will be used." + :version "23.0" ;; No Gnus + :type (let ((dispositions '(radio :format "DISPOSITION: %v" + :value "attachment" + (const :format "%v " "attachment") + (const :format "%v\n" "inline")))) + `(repeat + :offset 0 + (choice :format "%[Value Menu%]%v" + (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4 + (regexp :tag "REGEXP" :value ".*") + ,dispositions) + (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)" + :indent 0 + (symbol :tag " SUPERTYPE" :value text) + (repeat :format "%v%i\n" :offset 0 :extra-offset 4 + (cons :format "%v" :extra-offset 5 + (symbol :tag "SUBTYPE" :value t) + ,dispositions))) + (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4 + (symbol :tag "TYPE" :value t) + ,dispositions)))) + :group 'message) + (defcustom mml-insert-mime-headers-always nil "If non-nil, always put Content-Type: text/plain at top of empty parts. It is necessary to work against a bug in certain clients." @@ -154,19 +194,15 @@ part. This is for the internal use, you should never modify the value.") (defun mml-destroy-buffers () (let (kill-buffer-hook) - (mapcar 'kill-buffer mml-buffer-list) + (mapc 'kill-buffer mml-buffer-list) (setq mml-buffer-list nil))) (defun mml-parse () "Parse the current buffer as an MML document." (save-excursion (goto-char (point-min)) - (let ((table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table mml-syntax-table) - (mml-parse-1)) - (set-syntax-table table))))) + (with-syntax-table mml-syntax-table + (mml-parse-1)))) (defun mml-parse-1 () "Parse the current buffer as an MML document." @@ -181,6 +217,8 @@ part. This is for the internal use, you should never modify the value.") ;; included in the message (let* (secure-mode (taginfo (mml-read-tag)) + (keyfile (cdr (assq 'keyfile taginfo))) + (certfile (cdr (assq 'certfile taginfo))) (recipients (cdr (assq 'recipients taginfo))) (sender (cdr (assq 'sender taginfo))) (location (cdr (assq 'tag-location taginfo))) @@ -188,9 +226,8 @@ part. This is for the internal use, you should never modify the value.") (method (cdr (assq 'method taginfo))) tags) (save-excursion - (if - (re-search-forward - "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) + (if (re-search-forward + "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t) (setq secure-mode "multipart") (setq secure-mode "part"))) (save-excursion @@ -205,6 +242,10 @@ part. This is for the internal use, you should never modify the value.") (setq tags (list "sign" method "encrypt" method)))) (eval `(mml-insert-tag ,secure-mode ,@tags + ,(if keyfile "keyfile") + ,keyfile + ,(if certfile "certfile") + ,certfile ,(if recipients "recipients") ,recipients ,(if sender "sender") @@ -426,21 +467,24 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (or (mm-default-file-encoding filename) "application/octet-stream") "text/plain"))) - coded encoding charset flowed) + (charset (cdr (assq 'charset cont))) + (coding (mm-charset-to-coding-system charset)) + encoding flowed coded) + (cond ((eq coding 'ascii) + (setq charset nil + coding nil)) + (charset + (setq charset (intern (downcase charset))))) (if (and (not raw) (member (car (split-string type "/")) '("text" "message"))) (progn (with-temp-buffer - (setq charset (mm-charset-to-coding-system - (cdr (assq 'charset cont)))) - (when (eq charset 'ascii) - (setq charset nil)) (cond ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) ((and filename (not (equal (cdr (assq 'nofile cont)) "yes"))) - (let ((coding-system-for-read charset)) + (let ((coding-system-for-read coding)) (mm-insert-file-contents filename))) ((eq 'mml (car cont)) (insert (cdr (assq 'contents cont)))) @@ -490,7 +534,13 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; insert a "; format=flowed" string unless the ;; user has already specified it. (setq flowed (null (assq 'format cont))))) - (setq charset (mm-encode-body charset)) + ;; Prefer `utf-8' for text/calendar parts. + (if (or charset + (not (string= type "text/calendar"))) + (setq charset (mm-encode-body charset)) + (let ((mm-coding-system-priorities + (cons 'utf-8 mm-coding-system-priorities))) + (setq charset (mm-encode-body)))) (setq encoding (mm-body-encoding charset (cdr (assq 'encoding cont)))))) (setq coded (buffer-string))) @@ -506,7 +556,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ((and filename (not (equal (cdr (assq 'nofile cont)) "yes"))) (let ((coding-system-for-read mm-binary-coding-system)) - (mm-insert-file-contents filename nil nil nil nil t))) + (mm-insert-file-contents filename nil nil nil nil t)) + (unless charset + (setq charset (mm-coding-system-to-mime-charset + (mm-find-buffer-file-coding-system + filename))))) (t (let ((contents (cdr (assq 'contents cont)))) (if (if (featurep 'xemacs) @@ -516,7 +570,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mm-enable-multibyte) (insert contents) (unless raw - (setq charset (mm-encode-body)))) + (setq charset (mm-encode-body charset)))) (insert contents))))) (setq encoding (mm-encode-buffer type) coded (mm-string-as-multibyte (buffer-string)))) @@ -647,7 +701,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (incf mml-multipart-number))) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) - (mapcar 'mml-compute-boundary-1 (cddr cont)))) + (mapc 'mml-compute-boundary-1 (cddr cont)))) t)) (defun mml-make-boundary (number) @@ -657,6 +711,30 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "") mml-base-boundary)) +(defun mml-content-disposition (type &optional filename) + "Return a default disposition name suitable to TYPE or FILENAME." + (let ((defs mml-content-disposition-alist) + disposition def types) + (while (and (not disposition) defs) + (setq def (pop defs)) + (cond ((stringp (car def)) + (when (and filename + (string-match (car def) filename)) + (setq disposition (cdr def)))) + ((consp (cdr def)) + (when (string= (car (setq types (split-string type "/"))) + (car def)) + (setq type (cadr types) + types (cdr def)) + (while (and (not disposition) types) + (setq def (pop types)) + (when (or (eq (car def) t) (string= type (car def))) + (setq disposition (cdr def)))))) + (t + (when (or (eq (car def) t) (string= type (car def))) + (setq disposition (cdr def)))))) + (or disposition "attachment"))) + (defun mml-insert-mime-headers (cont type charset encoding flowed) (let (parameters id disposition description) (setq parameters @@ -687,7 +765,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." cont mml-content-disposition-parameters)) (when (or (setq disposition (cdr (assq 'disposition cont))) parameters) - (insert "Content-Disposition: " (or disposition "inline")) + (insert "Content-Disposition: " + (or disposition + (mml-content-disposition type (cdr (assq 'filename cont))))) (when parameters (mml-insert-parameter-string cont mml-content-disposition-parameters)) @@ -808,7 +888,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (goto-char (point-max)) (insert "<#/mml>\n")) ((stringp (car handle)) - (mapcar 'mml-insert-mime (cdr handle)) + (mapc 'mml-insert-mime (cdr handle)) (insert "<#/multipart>\n")) (textp (let ((charset (mail-content-type-get @@ -1003,9 +1083,18 @@ See Info node `(emacs-mime)Composing'. ;;; inserting stuff to the buffer. ;;; +(defcustom mml-default-directory mm-default-directory + "The default directory where mml will find files. +If not set, `default-directory' will be used." + :type '(choice directory (const :tag "Default" nil)) + :version "23.0" ;; No Gnus + :group 'message) + (defun mml-minibuffer-read-file (prompt) (let* ((completion-ignored-extensions nil) - (file (read-file-name prompt nil nil t))) + (file (read-file-name prompt + (or mml-default-directory default-directory) + nil t))) ;; Prevent some common errors. This is inspired by similar code in ;; VM. (when (file-directory-p file) @@ -1037,16 +1126,13 @@ See Info node `(emacs-mime)Composing'. (setq description nil)) description)) -(defun mml-minibuffer-read-disposition (type &optional default) - (unless default (setq default - (if (and (string-match "\\`text/" type) - (not (string-match "\\`text/rtf\\'" type))) - "inline" - "attachment"))) +(defun mml-minibuffer-read-disposition (type &optional default filename) + (unless default + (setq default (mml-content-disposition type filename))) (let ((disposition (completing-read - (format "Disposition (default %s): " default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) + (format "Disposition (default %s): " default) + '(("attachment") ("inline") ("")) + nil t nil nil default))) (if (not (equal disposition "")) disposition default))) @@ -1138,7 +1224,7 @@ body) or \"attachment\" (separate from the body)." (let* ((file (mml-minibuffer-read-file "Attach file: ")) (type (mml-minibuffer-read-type file)) (description (mml-minibuffer-read-description)) - (disposition (mml-minibuffer-read-disposition type))) + (disposition (mml-minibuffer-read-disposition type nil file))) (list file type description disposition))) (save-excursion (unless (message-in-body-p) (goto-char (point-max))) @@ -1169,7 +1255,7 @@ Ask for type, description or disposition according to (when (memq 'description mml-dnd-attach-options) (setq description (mml-minibuffer-read-description))) (when (memq 'disposition mml-dnd-attach-options) - (setq disposition (mml-minibuffer-read-disposition type))) + (setq disposition (mml-minibuffer-read-disposition type nil file))) (mml-attach-file file type description disposition))))) (defun mml-attach-buffer (buffer &optional type description) @@ -1226,10 +1312,20 @@ Should be adopted if code in `message-send-mail' is changed." (message-position-on-field "Mail-Followup-To" "X-Draft-From") (insert (message-make-mail-followup-to)))) +(defvar mml-preview-buffer nil) + (defun mml-preview (&optional raw) "Display current buffer with Gnus, in a new buffer. -If RAW, display a raw encoded MIME message." +If RAW, display a raw encoded MIME message. + +The window layout for the preview buffer is controled by the variables +`special-display-buffer-names', `special-display-regexps', or +`gnus-buffer-configuration' (the first match made will be used), +or the `pop-to-buffer' function." (interactive "P") + (setq mml-preview-buffer (generate-new-buffer + (concat (if raw "*Raw MIME preview of " + "*MIME preview of ") (buffer-name)))) (save-excursion (let* ((buf (current-buffer)) (message-options message-options) @@ -1241,13 +1337,13 @@ If RAW, display a raw encoded MIME message." (message-fetch-field "Newsgroups"))) message-posting-charset))) (message-options-set-recipient) - (pop-to-buffer (generate-new-buffer - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) (when (boundp 'gnus-buffers) - (push (current-buffer) gnus-buffers)) - (erase-buffer) - (insert-buffer-substring buf) + (push mml-preview-buffer gnus-buffers)) + (save-restriction + (widen) + (set-buffer mml-preview-buffer) + (erase-buffer) + (insert-buffer-substring buf)) (mml-preview-insert-mail-followup-to) (let ((message-deletable-headers (if (message-news-p) nil @@ -1260,6 +1356,7 @@ If RAW, display a raw encoded MIME message." (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (replace-match "\n")) (let ((mail-header-separator ""));; mail-header-separator is removed. + (message-sort-headers) (mml-to-mime)) (if raw (when (fboundp 'set-buffer-multibyte) @@ -1292,7 +1389,15 @@ If RAW, display a raw encoded MIME message." (lambda (event) (interactive "@e") (widget-button-press (widget-event-point event) event))) - (goto-char (point-min))))) + ;; FIXME: Buffer is in article mode, but most tool bar commands won't + ;; work. Maybe only keep the following icons: search, print, quit + (goto-char (point-min)))) + (if (and (not (mm-special-display-p (buffer-name mml-preview-buffer))) + (boundp 'gnus-buffer-configuration) + (assq 'mml-preview gnus-buffer-configuration)) + (let ((gnus-message-buffer (current-buffer))) + (gnus-configure-windows 'mml-preview)) + (pop-to-buffer mml-preview-buffer))) (defun mml-validate () "Validate the current MML document." diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index 104fb9cfaa3..f6d2dcc7ad5 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007 Free Software Foundation, Inc. -;; Author: Sascha Lüdecke <sascha@meta-x.de>, +;; Author: Sascha Ldecke <sascha@meta-x.de>, ;; Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue) ;; Keywords PGP @@ -32,6 +32,8 @@ (require 'cl) (require 'mm-util)) +(require 'mml-sec) + (defvar mc-pgp-always-sign) (autoload 'quoted-printable-decode-region "qp") @@ -46,9 +48,28 @@ (gpg mml1991-gpg-sign mml1991-gpg-encrypt) (pgg mml1991-pgg-sign - mml1991-pgg-encrypt)) + mml1991-pgg-encrypt) + (epg mml1991-epg-sign + mml1991-epg-encrypt)) "Alist of PGP functions.") +(defvar mml1991-verbose mml-secure-verbose + "If non-nil, ask the user about the current operation more verbosely.") + +(defvar mml1991-cache-passphrase mml-secure-cache-passphrase + "If t, cache passphrase.") + +(defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`mml1991-cache-passphrase'.") + +(defvar mml1991-signers nil + "A list of your own key ID which will be used to sign a message.") + +(defvar mml1991-encrypt-to-self nil + "If t, add your own key ID to recipient list when encryption.") + ;;; mailcrypt wrapper (eval-and-compile @@ -290,6 +311,183 @@ (insert-buffer-substring pgg-output-buffer) t) +;; epg wrapper + +(eval-and-compile + (autoload 'epg-make-context "epg")) + +(eval-when-compile + (defvar epg-user-id-alist) + (autoload 'epg-passphrase-callback-function "epg") + (autoload 'epa-select-keys "epa") + (autoload 'epg-list-keys "epg") + (autoload 'epg-context-set-armor "epg") + (autoload 'epg-context-set-textmode "epg") + (autoload 'epg-context-set-signers "epg") + (autoload 'epg-context-set-passphrase-callback "epg") + (autoload 'epg-sign-string "epg") + (autoload 'epg-encrypt-string "epg") + (autoload 'epg-configuration "epg-config") + (autoload 'epg-expand-group "epg-config")) + +(eval-when-compile + (defvar password-cache-expiry) + (autoload 'password-read "password") + (autoload 'password-cache-add "password") + (autoload 'password-cache-remove "password")) + +(defvar mml1991-epg-secret-key-id-list nil) + +(defun mml1991-epg-passphrase-callback (context key-id ignore) + (if (eq key-id 'SYM) + (epg-passphrase-callback-function context key-id nil) + (let* ((entry (assoc key-id epg-user-id-alist)) + (passphrase + (password-read + (format "GnuPG passphrase for %s: " + (if entry + (cdr entry) + key-id)) + (if (eq key-id 'PIN) + "PIN" + key-id)))) + (when passphrase + (let ((password-cache-expiry mml1991-passphrase-cache-expiry)) + (password-cache-add key-id passphrase)) + (setq mml1991-epg-secret-key-id-list + (cons key-id mml1991-epg-secret-key-id-list)) + (copy-sequence passphrase))))) + +(defun mml1991-epg-sign (cont) + (let ((context (epg-make-context)) + headers cte signers signature) + (if mml1991-verbose + (setq signers (epa-select-keys context "Select keys for signing. +If no one is selected, default secret key is used. " + mml1991-signers t)) + (if mml1991-signers + (setq signers (mapcar (lambda (name) + (car (epg-list-keys context name t))) + mml1991-signers)))) + (epg-context-set-armor context t) + (epg-context-set-textmode context t) + (epg-context-set-signers context signers) + (if mml1991-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml1991-epg-passphrase-callback)) + ;; Don't sign headers. + (goto-char (point-min)) + (when (re-search-forward "^$" nil t) + (setq headers (buffer-substring (point-min) (point))) + (save-restriction + (narrow-to-region (point-min) (point)) + (setq cte (mail-fetch-field "content-transfer-encoding"))) + (forward-line 1) + (delete-region (point-min) (point)) + (when cte + (setq cte (intern (downcase cte))) + (mm-decode-content-transfer-encoding cte))) + (condition-case error + (setq signature (epg-sign-string context (buffer-string) 'clear) + mml1991-epg-secret-key-id-list nil) + (error + (while mml1991-epg-secret-key-id-list + (password-cache-remove (car mml1991-epg-secret-key-id-list)) + (setq mml1991-epg-secret-key-id-list + (cdr mml1991-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (delete-region (point-min) (point-max)) + (mm-with-unibyte-current-buffer + (insert signature) + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) + (when cte + (mm-encode-content-transfer-encoding cte)) + (goto-char (point-min)) + (when headers + (insert headers)) + (insert "\n")) + t)) + +(defun mml1991-epg-encrypt (cont &optional sign) + (goto-char (point-min)) + (when (re-search-forward "^$" nil t) + (let ((cte (save-restriction + (narrow-to-region (point-min) (point)) + (mail-fetch-field "content-transfer-encoding")))) + ;; Strip MIME headers since it will be ASCII armoured. + (forward-line 1) + (delete-region (point-min) (point)) + (when cte + (mm-decode-content-transfer-encoding (intern (downcase cte)))))) + (let ((context (epg-make-context)) + (recipients + (if (message-options-get 'message-recipients) + (split-string + (message-options-get 'message-recipients) + "[ \f\t\n\r\v,]+"))) + cipher signers config) + ;; We should remove this check if epg-0.0.6 is released. + (if (and (condition-case nil + (require 'epg-config) + (error)) + (functionp #'epg-expand-group)) + (setq config (epg-configuration) + recipients + (apply #'nconc + (mapcar (lambda (recipient) + (or (epg-expand-group config recipient) + (list recipient))) + recipients)))) + (if mml1991-verbose + (setq recipients + (epa-select-keys context "Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. " + recipients)) + (setq recipients + (delq nil (mapcar (lambda (name) + (car (epg-list-keys context name))) + recipients)))) + (if mml1991-encrypt-to-self + (if mml1991-signers + (setq recipients + (nconc recipients + (mapcar (lambda (name) + (car (epg-list-keys context name))) + mml1991-signers))) + (error "mml1991-signers not set"))) + (when sign + (if mml1991-verbose + (setq signers (epa-select-keys context "Select keys for signing. +If no one is selected, default secret key is used. " + mml1991-signers t)) + (if mml1991-signers + (setq signers (mapcar (lambda (name) + (car (epg-list-keys context name t))) + mml1991-signers)))) + (epg-context-set-signers context signers)) + (epg-context-set-armor context t) + (epg-context-set-textmode context t) + (if mml1991-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml1991-epg-passphrase-callback)) + (condition-case error + (setq cipher + (epg-encrypt-string context (buffer-string) recipients sign) + mml1991-epg-secret-key-id-list nil) + (error + (while mml1991-epg-secret-key-id-list + (password-cache-remove (car mml1991-epg-secret-key-id-list)) + (setq mml1991-epg-secret-key-id-list + (cdr mml1991-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (delete-region (point-min) (point-max)) + (insert "\n" cipher)) + t) + ;;;###autoload (defun mml1991-encrypt (cont &optional sign) (let ((func (nth 2 (assq mml1991-use mml1991-function-alist)))) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 4edf595faae..1760e4615ce 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -34,13 +34,23 @@ (require 'mm-decode) (require 'mm-util) (require 'mml) +(require 'mml-sec) (defvar mc-pgp-always-sign) (defvar mml2015-use (or + (condition-case nil + (progn + (require 'epg-config) + (epg-check-configuration (epg-configuration)) + 'epg) + (error)) (progn (ignore-errors - (require 'pgg)) + ;; Avoid the "Recursive load suspected" error + ;; in Emacs 21.1. + (let ((recursive-load-depth-limit 100)) + (require 'pgg))) (and (fboundp 'pgg-sign-region) 'pgg)) (progn @@ -54,7 +64,8 @@ (fboundp 'mc-sign-generic) (fboundp 'mc-cleanup-recipient-headers) 'mailcrypt))) - "The package used for PGP/MIME.") + "The package used for PGP/MIME. +Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") ;; Something is not RFC2015. (defvar mml2015-function-alist @@ -75,7 +86,13 @@ mml2015-pgg-verify mml2015-pgg-decrypt mml2015-pgg-clear-verify - mml2015-pgg-clear-decrypt)) + mml2015-pgg-clear-decrypt) + (epg mml2015-epg-sign + mml2015-epg-encrypt + mml2015-epg-verify + mml2015-epg-decrypt + mml2015-epg-clear-verify + mml2015-epg-clear-decrypt)) "Alist of PGP/MIME functions.") (defvar mml2015-result-buffer nil) @@ -92,6 +109,60 @@ :type '(repeat (cons (regexp :tag "GnuPG output regexp") (boolean :tag "Trust key")))) +(defcustom mml2015-verbose mml-secure-verbose + "If non-nil, ask the user about the current operation more verbosely." + :group 'mime-security + :type 'boolean) + +(defcustom mml2015-cache-passphrase mml-secure-cache-passphrase + "If t, cache passphrase." + :group 'mime-security + :type 'boolean) + +(defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`mml2015-cache-passphrase'." + :group 'mime-security + :type 'integer) + +(defcustom mml2015-signers nil + "A list of your own key ID which will be used to sign a message." + :group 'mime-security + :type '(repeat (string :tag "Key ID"))) + +(defcustom mml2015-encrypt-to-self nil + "If t, add your own key ID to recipient list when encryption." + :group 'mime-security + :type 'boolean) + +(defcustom mml2015-always-trust t + "If t, GnuPG skip key validation on encryption." + :group 'mime-security + :type 'boolean) + +;; Extract plaintext from cleartext signature. IMO, this kind of task +;; should be done by GnuPG rather than Elisp, but older PGP backends +;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG. +(defun mml2015-extract-cleartext-signature () + (goto-char (point-min)) + (forward-line) + ;; We need to be careful not to strip beyond the armor headers. + ;; Previously, an attacker could replace the text inside our + ;; markup with trailing garbage by injecting whitespace into the + ;; message. + (while (looking-at "Hash:") ; The only header allowed in cleartext + (forward-line)) ; signatures according to RFC2440. + (when (looking-at "[\t ]*$") + (forward-line)) + (delete-region (point-min) (point)) + (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t) + (delete-region (match-beginning 0) (point-max))) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (replace-match "" t t) + (forward-line 1))) + ;;; mailcrypt wrapper (eval-and-compile @@ -278,7 +349,8 @@ (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")))) + mm-security-handle 'gnus-info "Failed"))) + (mml2015-extract-cleartext-signature)) (defun mml2015-mailcrypt-sign (cont) (mc-sign-generic (message-options-get 'message-sender) @@ -475,9 +547,8 @@ (with-temp-buffer (setq message (current-buffer)) (insert part) - ;; Convert <LF> to <CR><LF> in verify mode. Sign and - ;; clearsign use --textmode. The conversion is not necessary. - ;; In clearverify, the conversion is not necessary either. + ;; Convert <LF> to <CR><LF> in signed text. If --textmode is + ;; specified when signing, the conversion is not necessary. (goto-char (point-min)) (end-of-line) (while (not (eobp)) @@ -545,7 +616,8 @@ (with-current-buffer mml2015-result-buffer (mml2015-gpg-extract-signature-details))) (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed"))) + mm-security-handle 'gnus-info "Failed")) + (mml2015-extract-cleartext-signature)) (defun mml2015-gpg-sign (cont) (let ((boundary (mml-compute-boundary cont)) @@ -734,9 +806,8 @@ handle) (with-temp-buffer (insert part) - ;; Convert <LF> to <CR><LF> in verify mode. Sign and - ;; clearsign use --textmode. The conversion is not necessary. - ;; In clearverify, the conversion is not necessary either. + ;; Convert <LF> to <CR><LF> in signed text. If --textmode is + ;; specified when signing, the conversion is not necessary. (goto-char (point-min)) (end-of-line) (while (not (eobp)) @@ -809,7 +880,8 @@ (with-current-buffer pgg-errors-buffer (mml2015-gpg-extract-signature-details))) (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")))) + mm-security-handle 'gnus-info "Failed"))) + (mml2015-extract-cleartext-signature)) (defun mml2015-pgg-sign (cont) (let ((pgg-errors-buffer mml2015-result-buffer) @@ -871,6 +943,397 @@ (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) +;;; epg wrapper + +(eval-and-compile + (autoload 'epg-make-context "epg")) + +(eval-when-compile + (defvar epg-user-id-alist) + (defvar epg-digest-algorithm-alist) + (defvar inhibit-redisplay) + (autoload 'epg-context-set-armor "epg") + (autoload 'epg-context-set-textmode "epg") + (autoload 'epg-context-set-signers "epg") + (autoload 'epg-context-result-for "epg") + (autoload 'epg-new-signature-digest-algorithm "epg") + (autoload 'epg-verify-result-to-string "epg") + (autoload 'epg-list-keys "epg") + (autoload 'epg-decrypt-string "epg") + (autoload 'epg-verify-string "epg") + (autoload 'epg-sign-string "epg") + (autoload 'epg-encrypt-string "epg") + (autoload 'epg-passphrase-callback-function "epg") + (autoload 'epg-context-set-passphrase-callback "epg") + (autoload 'epg-key-sub-key-list "epg") + (autoload 'epg-sub-key-capability "epg") + (autoload 'epg-sub-key-validity "epg") + (autoload 'epg-configuration "epg-config") + (autoload 'epg-expand-group "epg-config") + (autoload 'epa-select-keys "epa")) + +(eval-when-compile + (defvar password-cache-expiry) + (autoload 'password-read "password") + (autoload 'password-cache-add "password") + (autoload 'password-cache-remove "password")) + +(defvar mml2015-epg-secret-key-id-list nil) + +(defun mml2015-epg-passphrase-callback (context key-id ignore) + (if (eq key-id 'SYM) + (epg-passphrase-callback-function context key-id nil) + (let* (entry + (passphrase + (password-read + (if (eq key-id 'PIN) + "Passphrase for PIN: " + (if (setq entry (assoc key-id epg-user-id-alist)) + (format "Passphrase for %s %s: " key-id (cdr entry)) + (format "Passphrase for %s: " key-id))) + (if (eq key-id 'PIN) + "PIN" + key-id)))) + (when passphrase + (let ((password-cache-expiry mml2015-passphrase-cache-expiry)) + (password-cache-add key-id passphrase)) + (setq mml2015-epg-secret-key-id-list + (cons key-id mml2015-epg-secret-key-id-list)) + (copy-sequence passphrase))))) + +(defun mml2015-epg-find-usable-key (keys usage) + (catch 'found + (while keys + (let ((pointer (epg-key-sub-key-list (car keys)))) + (while pointer + (if (and (memq usage (epg-sub-key-capability (car pointer))) + (not (memq (epg-sub-key-validity (car pointer)) + '(revoked expired)))) + (throw 'found (car keys))) + (setq pointer (cdr pointer)))) + (setq keys (cdr keys))))) + +(defun mml2015-epg-decrypt (handle ctl) + (catch 'error + (let ((inhibit-redisplay t) + context plain child handles result decrypt-status) + (unless (setq child (mm-find-part-by-type + (cdr handle) + "application/octet-stream" nil t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (setq context (epg-make-context)) + (if mml2015-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml2015-epg-passphrase-callback)) + (condition-case error + (setq plain (epg-decrypt-string context (mm-get-part child)) + mml2015-epg-secret-key-id-list nil) + (error + (while mml2015-epg-secret-key-id-list + (password-cache-remove (car mml2015-epg-secret-key-id-list)) + (setq mml2015-epg-secret-key-id-list + (cdr mml2015-epg-secret-key-id-list))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))) + (throw 'error handle))) + (with-temp-buffer + (insert plain) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" t t)) + (setq handles (mm-dissect-buffer t)) + (mm-destroy-parts handle) + (if (epg-context-result-for context 'verify) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (concat "OK\n" + (epg-verify-result-to-string + (epg-context-result-for context 'verify)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK")) + (if (stringp (car handles)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (mm-handle-multipart-ctl-parameter handles 'gnus-details)))) + (if (listp (car handles)) + handles + (list handles))))) + +(defun mml2015-epg-clear-decrypt () + (let ((inhibit-redisplay t) + (context (epg-make-context)) + plain) + (if mml2015-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml2015-epg-passphrase-callback)) + (condition-case error + (setq plain (epg-decrypt-string context (buffer-string)) + mml2015-epg-secret-key-id-list nil) + (error + (while mml2015-epg-secret-key-id-list + (password-cache-remove (car mml2015-epg-secret-key-id-list)) + (setq mml2015-epg-secret-key-id-list + (cdr mml2015-epg-secret-key-id-list))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))))) + (when plain + (erase-buffer) + ;; Treat data which epg returns as a unibyte string. + (mm-disable-multibyte) + (insert plain) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" t t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (if (epg-context-result-for context 'verify) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (epg-verify-result-to-string + (epg-context-result-for context 'verify))))))) + +(defun mml2015-epg-verify (handle ctl) + (catch 'error + (let ((inhibit-redisplay t) + context plain signature-file part signature) + (when (or (null (setq part (mm-find-raw-part-by-type + ctl (or (mm-handle-multipart-ctl-parameter + ctl 'protocol) + "application/pgp-signature") + t))) + (null (setq signature (mm-find-part-by-type + (cdr handle) "application/pgp-signature" + nil t)))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (setq part (mm-replace-in-string part "\n" "\r\n" t) + signature (mm-get-part signature) + context (epg-make-context)) + (condition-case error + (setq plain (epg-verify-string context signature part)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))) + (throw 'error handle))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (epg-verify-result-to-string (epg-context-result-for context 'verify))) + handle))) + +(defun mml2015-epg-clear-verify () + (let ((inhibit-redisplay t) + (context (epg-make-context)) + (signature (mm-encode-coding-string (buffer-string) + coding-system-for-write)) + plain) + (condition-case error + (setq plain (epg-verify-string context signature)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (if (eq (car error) 'quit) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error error))))) + (if plain + (progn + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (epg-verify-result-to-string + (epg-context-result-for context 'verify))) + (delete-region (point-min) (point-max)) + (insert (mm-decode-coding-string plain coding-system-for-read))) + (mml2015-extract-cleartext-signature)))) + +(defun mml2015-epg-sign (cont) + (let* ((inhibit-redisplay t) + (context (epg-make-context)) + (boundary (mml-compute-boundary cont)) + signer-key + (signers + (or (message-options-get 'mml2015-epg-signers) + (message-options-set + 'mml2015-epg-signers + (if mml2015-verbose + (epa-select-keys context "\ +Select keys for signing. +If no one is selected, default secret key is used. " + mml2015-signers t) + (if mml2015-signers + (mapcar + (lambda (signer) + (setq signer-key (mml2015-epg-find-usable-key + (epg-list-keys context signer t) + 'sign)) + (unless (or signer-key + (y-or-n-p + (format "No secret key for %s; skip it? " + signer))) + (error "No secret key for %s" signer)) + signer-key) + mml2015-signers)))))) + signature micalg) + (epg-context-set-armor context t) + (epg-context-set-textmode context t) + (epg-context-set-signers context signers) + (if mml2015-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml2015-epg-passphrase-callback)) + (condition-case error + (setq signature (epg-sign-string context (buffer-string) t) + mml2015-epg-secret-key-id-list nil) + (error + (while mml2015-epg-secret-key-id-list + (password-cache-remove (car mml2015-epg-secret-key-id-list)) + (setq mml2015-epg-secret-key-id-list + (cdr mml2015-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (if (epg-context-result-for context 'sign) + (setq micalg (epg-new-signature-digest-algorithm + (car (epg-context-result-for context 'sign))))) + (goto-char (point-min)) + (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" + boundary)) + (if micalg + (insert (format "\tmicalg=pgp-%s; " + (downcase + (cdr (assq micalg + epg-digest-algorithm-alist)))))) + (insert "protocol=\"application/pgp-signature\"\n") + (insert (format "\n--%s\n" boundary)) + (goto-char (point-max)) + (insert (format "\n--%s\n" boundary)) + (insert "Content-Type: application/pgp-signature\n\n") + (insert signature) + (goto-char (point-max)) + (insert (format "--%s--\n" boundary)) + (goto-char (point-max)))) + +(defun mml2015-epg-encrypt (cont &optional sign) + (let ((inhibit-redisplay t) + (context (epg-make-context)) + (config (epg-configuration)) + (recipients (message-options-get 'mml2015-epg-recipients)) + cipher signers + (boundary (mml-compute-boundary cont)) + recipient-key signer-key) + (unless recipients + (setq recipients + (apply #'nconc + (mapcar + (lambda (recipient) + (or (epg-expand-group config recipient) + (list (concat "<" recipient ">")))) + (split-string + (or (message-options-get 'message-recipients) + (message-options-set 'message-recipients + (read-string "Recipients: "))) + "[ \f\t\n\r\v,]+")))) + (when mml2015-encrypt-to-self + (unless mml2015-signers + (error "mml2015-signers not set")) + (setq recipients (nconc recipients mml2015-signers))) + (if mml2015-verbose + (setq recipients + (epa-select-keys context "\ +Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. " + recipients)) + (setq recipients + (mapcar + (lambda (recipient) + (setq recipient-key (mml2015-epg-find-usable-key + (epg-list-keys context recipient) + 'encrypt)) + (unless (or recipient-key + (y-or-n-p + (format "No public key for %s; skip it? " + recipient))) + (error "No public key for %s" recipient)) + recipient-key) + recipients)) + (unless recipients + (error "No recipient specified"))) + (message-options-set 'mml2015-epg-recipients recipients)) + (when sign + (setq signers + (or (message-options-get 'mml2015-epg-signers) + (message-options-set + 'mml2015-epg-signers + (if mml2015-verbose + (epa-select-keys context "\ +Select keys for signing. +If no one is selected, default secret key is used. " + mml2015-signers t) + (if mml2015-signers + (mapcar + (lambda (signer) + (setq signer-key (mml2015-epg-find-usable-key + (epg-list-keys context signer t) + 'sign)) + (unless (or signer-key + (y-or-n-p + (format + "No secret key for %s; skip it? " + signer))) + (error "No secret key for %s" signer)) + signer-key) + mml2015-signers)))))) + (epg-context-set-signers context signers)) + (epg-context-set-armor context t) + (epg-context-set-textmode context t) + (if mml2015-cache-passphrase + (epg-context-set-passphrase-callback + context + #'mml2015-epg-passphrase-callback)) + (condition-case error + (setq cipher + (epg-encrypt-string context (buffer-string) recipients sign + mml2015-always-trust) + mml2015-epg-secret-key-id-list nil) + (error + (while mml2015-epg-secret-key-id-list + (password-cache-remove (car mml2015-epg-secret-key-id-list)) + (setq mml2015-epg-secret-key-id-list + (cdr mml2015-epg-secret-key-id-list))) + (signal (car error) (cdr error)))) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" + boundary)) + (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") + (insert (format "--%s\n" boundary)) + (insert "Content-Type: application/pgp-encrypted\n\n") + (insert "Version: 1\n\n") + (insert (format "--%s\n" boundary)) + (insert "Content-Type: application/octet-stream\n\n") + (insert cipher) + (goto-char (point-max)) + (insert (format "--%s--\n" boundary)) + (goto-char (point-max)))) + ;;; General wrapper (defun mml2015-clean-buffer () @@ -879,7 +1342,7 @@ (erase-buffer) t) (setq mml2015-result-buffer - (gnus-get-buffer-create "*MML2015 Result*")) + (gnus-get-buffer-create " *MML2015 Result*")) nil)) (defsubst mml2015-clear-decrypt-function () diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el index 7d11329f81f..0c1dbc6817e 100644 --- a/lisp/gnus/nnagent.el +++ b/lisp/gnus/nnagent.el @@ -121,7 +121,7 @@ (gnus-request-accept-article "nndraft:queue" nil t t)) (deffoo nnagent-request-set-mark (group action server) - (with-temp-buffer + (mm-with-unibyte-buffer (insert "(gnus-agent-synchronize-group-flags \"" group "\" '") @@ -130,7 +130,17 @@ (gnus-method-to-server gnus-command-method) "\"") (insert ")\n") - (append-to-file (point-min) (point-max) (gnus-agent-lib-file "flags"))) + (let ((coding-system-for-write nnheader-file-coding-system)) + (write-region (point-min) (point-max) (gnus-agent-lib-file "flags") + t 'silent))) + ;; Also set the marks for the original back end that keeps marks in + ;; the local system. + (let ((gnus-agent nil)) + (when (and (memq (car gnus-command-method) '(nntp)) + (gnus-check-backend-function 'request-set-mark + (car gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-set-mark) + group action server))) nil) (deffoo nnagent-retrieve-headers (articles &optional group server fetch-old) @@ -148,7 +158,8 @@ (pop arts))) (set-buffer nntp-server-buffer) (erase-buffer) - (nnheader-insert-nov-file file (car articles)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (nnheader-insert-nov-file file (car articles))) (goto-char (point-min)) (gnus-parse-without-error (while (and arts (not (eobp))) @@ -214,10 +225,10 @@ (list (nnagent-server server)))) (deffoo nnagent-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (nnoo-parent-function 'nnagent 'nnml-request-move-article (list article group (nnagent-server server) - accept-form last))) + accept-form last move-is-internal))) (deffoo nnagent-request-rename-group (group new-name &optional server) (nnoo-parent-function 'nnagent 'nnml-request-rename-group diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 3f0631c152d..38d4a7227c2 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -70,9 +70,6 @@ (defvoo nnbabyl-previous-buffer-mode nil) -(eval-and-compile - (autoload 'gnus-set-text-properties "gnus-ems")) - ;;; Interface functions @@ -271,7 +268,7 @@ (save-excursion (set-buffer nnbabyl-mbox-buffer) - (gnus-set-text-properties (point-min) (point-max) nil) + (set-text-properties (point-min) (point-max) nil) (while (and articles is-old) (goto-char (point-min)) (when (search-forward (nnbabyl-article-string (car articles)) nil t) @@ -308,7 +305,7 @@ (nconc rest articles)))) (deffoo nnbabyl-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnbabyl move*")) result) (and diff --git a/lisp/gnus/nndb.el b/lisp/gnus/nndb.el index e8421cb2074..70d395ba986 100644 --- a/lisp/gnus/nndb.el +++ b/lisp/gnus/nndb.el @@ -241,7 +241,7 @@ expiry mechanism." (nndb-request-expire-articles-local articles group server force))) (deffoo nndb-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) "Move ARTICLE (a number) from GROUP on SERVER. Evals ACCEPT-FORM in current buffer, where the article is. Optional LAST is ignored." diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index eaa425239d2..015c0643893 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -606,7 +606,7 @@ all. This may very well take some time.") (nconc rest articles))) (deffoo nndiary-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nndiary move*")) result) (nndiary-possibly-change-directory group server) @@ -875,7 +875,7 @@ all. This may very well take some time.") (search-forward id nil t)) ; We find the ID. ;; And the id is in the fourth field. (if (not (and (search-backward "\t" nil t 4) - (not (search-backward"\t" (gnus-point-at-bol) t)))) + (not (search-backward"\t" (point-at-bol) t)))) (forward-line 1) (beginning-of-line) (setq found t) @@ -1096,9 +1096,7 @@ all. This may very well take some time.") (push (list group (cons (or (caar files) (1+ last)) (max last - (or (let ((f files)) - (while (cdr f) (setq f (cdr f))) - (caar f)) + (or (caar (last files)) 0)))) nndiary-group-alist))) @@ -1577,13 +1575,11 @@ all. This may very well take some time.") ;; The end... =============================================================== -(mapcar - (lambda (elt) - (let ((header (intern (format "X-Diary-%s" (car elt))))) - ;; Required for building NOV databases and some other stuff - (add-to-list 'gnus-extra-headers header) - (add-to-list 'nnmail-extra-headers header))) - nndiary-headers) +(dolist (header nndiary-headers) + (setq header (intern (format "X-Diary-%s" (car header)))) + ;; Required for building NOV databases and some other stuff. + (add-to-list 'gnus-extra-headers header) + (add-to-list 'nnmail-extra-headers header)) (unless (assoc "nndiary" gnus-valid-select-methods) (gnus-declare-backend "nndiary" 'post-mail 'respool 'address)) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index ea32a8f4183..1de9a2083b0 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -122,7 +122,7 @@ from the document.") (subtype digest guess)) (lanl-gov-announce (article-begin . "^\\\\\\\\\n") - (head-begin . "^Paper.*:") + (head-begin . "^\\(Paper.*:\\|arXiv:\\)") (head-end . "\\(^\\\\\\\\.*\n\\|-----------------\\)") (body-begin . "") (body-end . "\\(-------------------------------------------------\\|%-%-%-%-%-%-%-%-%-%-%-%-%-%-\\|%%--%%--%%--%%--%%--%%--%%--%%--\\|%%%---%%%---%%%---%%%---\\)") @@ -624,25 +624,28 @@ from the document.") (defun nndoc-lanl-gov-announce-type-p () (when (let ((case-fold-search nil)) - (re-search-forward "^\\\\\\\\\nPaper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+" nil t)) + (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t)) t)) (defun nndoc-transform-lanl-gov-announce (article) - (goto-char (point-max)) - (when (re-search-backward "^\\\\\\\\ +( *\\([^ ]*\\) , *\\([^ ]*\\))" nil t) - (replace-match "\n\nGet it at \\1 (\\2)" t nil)) - (goto-char (point-min)) - (while (re-search-forward "^\\\\\\\\$" nil t) - (replace-match "" t nil)) - (goto-char (point-min)) - (when (re-search-forward "^replaced with revised version +\\(.*[^ ]\\) +" nil t) - (replace-match "Date: \\1 (revised) " t nil)) - (goto-char (point-min)) - (unless (re-search-forward "^From" nil t) + (let ((case-fold-search nil)) + (goto-char (point-max)) + (when (re-search-backward "^\\\\\\\\ +( *\\([^ ]*\\) , *\\([^ ]*\\))" nil t) + (replace-match "\n\nGet it at \\1 (\\2)" t nil)) (goto-char (point-min)) - (when (re-search-forward "^Authors?: \\(.*\\)" nil t) + (while (re-search-forward "^\\\\\\\\$" nil t) + (replace-match "" t nil)) + (goto-char (point-min)) + (when (re-search-forward "^replaced with revised version +\\(.*[^ ]\\) +" nil t) + (replace-match "Date: \\1 (revised) " t nil)) + (goto-char (point-min)) + (unless (re-search-forward "^From" nil t) (goto-char (point-min)) - (insert "From: " (match-string 1) "\n")))) + (when (re-search-forward "^Authors?: \\(.*\\)" nil t) + (goto-char (point-min)) + (insert "From: " (match-string 1) "\n"))) + (when (re-search-forward "^arXiv:" nil t) + (replace-match "Paper: arXiv:" t nil)))) (defun nndoc-generate-lanl-gov-head (article) (let ((entry (cdr (assq article nndoc-dissection-alist))) @@ -653,8 +656,8 @@ from the document.") (save-restriction (narrow-to-region (car entry) (nth 1 entry)) (goto-char (point-min)) - (when (looking-at "^Paper.*: \\([a-zA-Z-\\.]+/[0-9]+\\)") - (setq subject (concat " (" (match-string 1) ")")) + (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z-\\./]+\\)") + (setq subject (concat " (" (match-string 2) ")")) (when (re-search-forward "^From: \\(.*\\)" nil t) (setq from (concat "<" (cadr (funcall gnus-extract-address-components diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 37bd3c1aa96..7fc0993a520 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -42,6 +42,11 @@ "Where nndraft will store its files." nnmh-directory) +(defvar nndraft-required-headers '(Date) + "*Headers to be generated when saving a draft message. +The headers in this variable and the ones in `message-required-headers' +are generated if and only if they are also in `message-draft-headers'.") + (defvoo nndraft-current-group "" nil nnmh-current-group) @@ -156,7 +161,7 @@ (save-excursion (message-generate-headers (message-headers-to-generate - message-required-headers message-draft-headers nil)))) + nndraft-required-headers message-draft-headers nil)))) (deffoo nndraft-request-associate-buffer (group) "Associate the current buffer with some article in the draft group." @@ -199,8 +204,8 @@ 'nnmh-request-group (list group server dont-check))) -(deffoo nndraft-request-move-article (article group server - accept-form &optional last) +(deffoo nndraft-request-move-article (article group server accept-form + &optional last move-is-internal) (nndraft-possibly-change-group group) (let ((buf (get-buffer-create " *nndraft move*")) result) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 8d1fa98d81f..143ddcfdf62 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -423,7 +423,7 @@ included.") (if (numberp article) (if (setq fname (cadr (assq article nneething-map))) (expand-file-name fname dir) - (mm-make-temp-file (expand-file-name "nneething" dir))) + (make-temp-name (expand-file-name "nneething" dir))) (expand-file-name article dir)))) (provide 'nneething) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 4127f11463e..bf82791fea6 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -203,7 +203,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (goto-char (match-end 0)) (setq num (string-to-number (buffer-substring - (point) (gnus-point-at-eol)))) + (point) (point-at-eol)))) (goto-char start) (< num article))) ;; Check that we are before an article with a @@ -213,7 +213,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (progn (setq num (string-to-number (buffer-substring - (point) (gnus-point-at-eol)))) + (point) (point-at-eol)))) (> num article)) ;; Discard any article numbers before the one we're ;; now looking at. @@ -287,31 +287,36 @@ the group. Then the marks file will be regenerated properly by Gnus.") (if (search-forward (concat "\n" nnfolder-article-marker) nil t) (string-to-number (buffer-substring - (point) (gnus-point-at-eol))) + (point) (point-at-eol))) -1)))))))) (deffoo nnfolder-request-group (group &optional server dont-check) (nnfolder-possibly-change-group group server t) (save-excursion - (if (not (assoc group nnfolder-group-alist)) - (nnheader-report 'nnfolder "No such group: %s" group) - (if dont-check - (progn - (nnheader-report 'nnfolder "Selected group %s" group) - t) - (let* ((active (assoc group nnfolder-group-alist)) - (group (car active)) - (range (cadr active))) - (cond - ((null active) - (nnheader-report 'nnfolder "No such group: %s" group)) - ((null nnfolder-current-group) - (nnheader-report 'nnfolder "Empty group: %s" group)) - (t - (nnheader-report 'nnfolder "Selected group %s" group) - (nnheader-insert "211 %d %d %d %s\n" - (1+ (- (cdr range) (car range))) - (car range) (cdr range) group)))))))) + (cond ((not (assoc group nnfolder-group-alist)) + (nnheader-report 'nnfolder "No such group: %s" group)) + ((file-directory-p (nnfolder-group-pathname group)) + (nnheader-report 'nnfolder "%s is a directory" + (file-name-as-directory + (let ((nnmail-pathname-coding-system nil)) + (nnfolder-group-pathname group))))) + (dont-check + (nnheader-report 'nnfolder "Selected group %s" group) + t) + (t + (let* ((active (assoc group nnfolder-group-alist)) + (group (car active)) + (range (cadr active))) + (cond + ((null active) + (nnheader-report 'nnfolder "No such group: %s" group)) + ((null nnfolder-current-group) + (nnheader-report 'nnfolder "Empty group: %s" group)) + (t + (nnheader-report 'nnfolder "Selected group %s" group) + (nnheader-insert "211 %d %d %d %s\n" + (1+ (- (cdr range) (car range))) + (car range) (cdr range) group)))))))) (deffoo nnfolder-request-scan (&optional group server) (nnfolder-possibly-change-group nil server) @@ -371,13 +376,21 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-create-group (group &optional server args) (nnfolder-possibly-change-group nil server) (nnmail-activate 'nnfolder) - (when (and group - (not (assoc group nnfolder-group-alist))) - (push (list group (cons 1 0)) nnfolder-group-alist) - (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) - (save-current-buffer - (nnfolder-read-folder group))) - t) + (cond ((zerop (length group)) + (nnheader-report 'nnfolder "Invalid (empty) group name")) + ((file-directory-p (nnfolder-group-pathname group)) + (nnheader-report 'nnfolder "%s is a directory" + (file-name-as-directory + (let ((nnmail-pathname-coding-system nil)) + (nnfolder-group-pathname group))))) + ((assoc group nnfolder-group-alist) + t) + (t + (push (list group (cons 1 0)) nnfolder-group-alist) + (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) + (save-current-buffer + (nnfolder-read-folder group)) + t))) (deffoo nnfolder-request-list (&optional server) (nnfolder-possibly-change-group nil server) @@ -416,16 +429,17 @@ the group. Then the marks file will be regenerated properly by Gnus.") ;; The article numbers are increasing, so this result is sorted. (nreverse numbers))))) -(deffoo nnfolder-request-expire-articles - (articles newsgroup &optional server force) +(deffoo nnfolder-request-expire-articles (articles newsgroup + &optional server force) (nnfolder-possibly-change-group newsgroup server) - (let* ((is-old t) - ;; The articles we have deleted so far. - (deleted-articles nil) - ;; The articles that really exist and will - ;; be expired if they are old enough. - (maybe-expirable - (gnus-sorted-intersection articles (nnfolder-existing-articles)))) + (let ((is-old t) + ;; The articles we have deleted so far. + (deleted-articles nil) + ;; The articles that really exist and will + ;; be expired if they are old enough. + (maybe-expirable + (gnus-sorted-intersection articles (nnfolder-existing-articles))) + target) (nnmail-activate 'nnfolder) (save-excursion @@ -445,21 +459,28 @@ the group. Then the marks file will be regenerated properly by Gnus.") (buffer-substring (point) (progn (end-of-line) (point))) force nnfolder-inhibit-expiry)) - (unless (eq nnmail-expiry-target 'delete) + (setq target nnmail-expiry-target) + (unless (eq target 'delete) (with-temp-buffer (nnfolder-request-article (car maybe-expirable) newsgroup server (current-buffer)) (let ((nnfolder-current-directory nil)) - (nnmail-expiry-target-group - nnmail-expiry-target newsgroup))) + (when (functionp target) + (setq target (funcall target newsgroup))) + (if (and target + (or (gnus-request-group target) + (gnus-request-create-group target))) + (nnmail-expiry-target-group target newsgroup) + (setq target nil)))) (nnfolder-possibly-change-group newsgroup server)) - (nnheader-message 5 "Deleting article %d in %s..." - (car maybe-expirable) newsgroup) - (nnfolder-delete-mail) - (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) - (nnfolder-nov-delete-article newsgroup (car maybe-expirable))) - ;; Must remember which articles were actually deleted - (push (car maybe-expirable) deleted-articles))) + (when target + (nnheader-message 5 "Deleting article %d in %s..." + (car maybe-expirable) newsgroup) + (nnfolder-delete-mail) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (nnfolder-nov-delete-article newsgroup (car maybe-expirable))) + ;; Must remember which articles were actually deleted + (push (car maybe-expirable) deleted-articles)))) (setq maybe-expirable (cdr maybe-expirable))) (unless nnfolder-inhibit-expiry (nnheader-message 5 "Deleting articles...done")) @@ -468,8 +489,8 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) (gnus-sorted-difference articles (nreverse deleted-articles))))) -(deffoo nnfolder-request-move-article (article group server - accept-form &optional last) +(deffoo nnfolder-request-move-article (article group server accept-form + &optional last move-is-internal) (save-excursion (let ((buf (get-buffer-create " *nnfolder move*")) result) @@ -1029,9 +1050,7 @@ This command does not work if you use short group names." (when (not (message-mail-file-mbox-p file)) (ignore-errors (delete-file file))))) - (let ((files (directory-files nnfolder-directory)) - file) - (while (setq file (pop files)) + (dolist (file (directory-files nnfolder-directory)) (when (and (not (backup-file-name-p file)) (message-mail-file-mbox-p (nnheader-concat nnfolder-directory file))) @@ -1046,7 +1065,7 @@ This command does not work if you use short group names." (nnfolder-possibly-change-folder file) (nnfolder-possibly-change-group file) (nnfolder-close-group file)))) - (nnheader-message 5 ""))) + (nnheader-message 5 "")) (defun nnfolder-group-pathname (group) "Make file name for GROUP." @@ -1073,7 +1092,8 @@ This command does not work if you use short group names." (gnus-make-directory (file-name-directory (buffer-file-name))) (let ((coding-system-for-write (or nnfolder-file-coding-system-for-write - nnfolder-file-coding-system))) + nnfolder-file-coding-system)) + (copyright-update nil)) (save-buffer))) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) (nnfolder-save-nov))) @@ -1197,16 +1217,16 @@ This command does not work if you use short group names." (nnheader-message 8 "Updating marks for %s..." group) (nnfolder-open-marks group server) ;; Update info using `nnfolder-marks'. - (mapcar (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnfolder-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) + (mapc (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nnfolder-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) (let ((seen (cdr (assq 'read nnfolder-marks)))) (gnus-info-set-read info (if (and (integerp (car seen)) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index aa19967b412..031d2c3d0fb 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -115,7 +115,6 @@ on your system, you could say something like: (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") (autoload 'message-remove-header "message") - (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-buffer-live-p "gnus-util")) ;;; Header access macros. @@ -209,9 +208,9 @@ on your system, you could say something like: "Return the extra headers in HEADER." `(aref ,header 9)) -(defmacro mail-header-set-extra (header extra) +(defun mail-header-set-extra (header extra) "Set the extra headers in HEADER to EXTRA." - `(aset ,header 9 ',extra)) + (aset header 9 extra)) (defsubst make-mail-header (&optional init) "Create a new mail header structure initialized with INIT." @@ -227,12 +226,16 @@ on your system, you could say something like: (defvar nnheader-fake-message-id 1) -(defsubst nnheader-generate-fake-message-id () - (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id)))) +(defsubst nnheader-generate-fake-message-id (&optional number) + (if (numberp number) + (format "fake+none+%s+%d" gnus-newsgroup-name number) + (format "fake+none+%s+%s" + gnus-newsgroup-name + (int-to-string (incf nnheader-fake-message-id))))) (defsubst nnheader-fake-message-id-p (id) (save-match-data ; regular message-id's are <.*> - (string-match "\\`fake\\+none\\+[0-9]+\\'" id))) + (string-match "\\`fake\\+none\\+.*\\+[0-9]+\\'" id))) ;; Parsing headers and NOV lines. @@ -243,7 +246,7 @@ on your system, you could say something like: (defsubst nnheader-header-value () (skip-chars-forward " \t") - (buffer-substring (point) (gnus-point-at-eol))) + (buffer-substring (point) (point-at-eol))) (defun nnheader-parse-naked-head (&optional number) ;; This function unfolds continuation lines in this buffer @@ -289,12 +292,12 @@ on your system, you could say something like: (goto-char p) (if (search-forward "\nmessage-id:" nil t) (buffer-substring - (1- (or (search-forward "<" (gnus-point-at-eol) t) + (1- (or (search-forward "<" (point-at-eol) t) (point))) - (or (search-forward ">" (gnus-point-at-eol) t) (point))) + (or (search-forward ">" (point-at-eol) t) (point))) ;; If there was no message-id, we just fake one to make ;; subsequent routines simpler. - (nnheader-generate-fake-message-id))) + (nnheader-generate-fake-message-id number))) ;; References. (progn (goto-char p) @@ -392,20 +395,29 @@ on your system, you could say something like: out))) out)) -(defmacro nnheader-nov-read-message-id () - '(let ((id (nnheader-nov-field))) +(eval-and-compile + (defvar nnheader-uniquify-message-id nil)) + +(defmacro nnheader-nov-read-message-id (&optional number) + `(let ((id (nnheader-nov-field))) (if (string-match "^<[^>]+>$" id) - id - (nnheader-generate-fake-message-id)))) + ,(if nnheader-uniquify-message-id + `(if (string-match "__[^@]+@" id) + (concat (substring id 0 (match-beginning 0)) + (substring id (1- (match-end 0)))) + id) + 'id) + (nnheader-generate-fake-message-id ,number)))) (defun nnheader-parse-nov () - (let ((eol (gnus-point-at-eol))) + (let ((eol (point-at-eol)) + (number (nnheader-nov-read-integer))) (vector - (nnheader-nov-read-integer) ; number + number ; number (nnheader-nov-field) ; subject (nnheader-nov-field) ; from (nnheader-nov-field) ; date - (nnheader-nov-read-message-id) ; id + (nnheader-nov-read-message-id number) ; id (nnheader-nov-field) ; refs (nnheader-nov-read-integer) ; chars (nnheader-nov-read-integer) ; lines @@ -628,7 +640,7 @@ the line could be found." ;; This is invalid, but not all articles have Message-IDs. () (mail-position-on-field "References") - (let ((begin (gnus-point-at-bol)) + (let ((begin (point-at-bol)) (fill-column 78) (fill-prefix "\t")) (when references @@ -662,6 +674,14 @@ the line could be found." (point-max))) (goto-char (point-min))) +(defun nnheader-get-lines-and-char () + "Return the number of lines and chars in the article body." + (goto-char (point-min)) + (if (not (re-search-forward "\n\r?\n" nil t)) + (list 0 0) + (list (count-lines (point) (point-max)) + (- (point-max) (point))))) + (defun nnheader-remove-body () "Remove the body from an article in this current buffer." (goto-char (point-min)) @@ -701,8 +721,7 @@ the line could be found." (defvar nnheader-directory-files-is-safe (or (eq system-type 'windows-nt) - (and (not (featurep 'xemacs)) - (> emacs-major-version 20))) + (not (featurep 'xemacs))) "If non-nil, Gnus believes `directory-files' is safe. It has been reported numerous times that `directory-files' fails with an alarming frequency on NFS mounted file systems. If it is nil, @@ -848,7 +867,9 @@ without formatting." "Message if the Gnus backends are talkative." (if (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends)) - (apply 'message args) + (if gnus-add-timestamp-to-message + (apply 'gnus-message-with-timestamp args) + (apply 'message args)) (apply 'format args))) (defun nnheader-be-verbose (level) @@ -972,6 +993,7 @@ See `find-file-noselect' for the arguments." (after-insert-file-functions nil) (enable-local-eval nil) (coding-system-for-read nnheader-file-coding-system) + (version-control 'never) (ffh (if (boundp 'find-file-hook) 'find-file-hook 'find-file-hooks)) @@ -1033,7 +1055,6 @@ See `find-file-noselect' for the arguments." "Strip all \r's from the current buffer." (nnheader-skeleton-replace "\r")) -(defalias 'nnheader-run-at-time 'run-at-time) (defalias 'nnheader-cancel-timer 'cancel-timer) (defalias 'nnheader-cancel-function-timers 'cancel-function-timers) (defalias 'nnheader-string-as-multibyte 'string-as-multibyte) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index ba23280658a..28938e4c0a6 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -250,10 +250,15 @@ it O(n). If p is small, then the default is probably faster." :type 'boolean :group 'nnimap) -(defvoo nnimap-need-unselect-to-notice-new-mail nil +(defvoo nnimap-need-unselect-to-notice-new-mail t "Unselect mailboxes before looking for new mail in them. Some servers seem to need this under some circumstances.") +(defvoo nnimap-logout-timeout nil + "Close server immediately if it can't logout in this number of seconds. +If it is nil, never close server until logout completes. This variable +overrides `imap-logout-timeout' on a per-server basis.") + ;; Authorization / Privacy variables (defvoo nnimap-auth-method nil @@ -417,6 +422,43 @@ just like \"ticked\" articles, in other IMAP clients.") If this is 'imap-mailbox-lsub, then use a server-side subscription list to restrict visible folders.") +(defcustom nnimap-id nil + "Plist with client identity to send to server upon login. +Nil means no information is sent, symbol `no' to disable ID query +alltogheter, or plist with identifier-value pairs to send to +server. RFC 2971 describes the list as follows: + + Any string may be sent as a field, but the following are defined to + describe certain values that might be sent. Implementations are free + to send none, any, or all of these. Strings are not case-sensitive. + Field strings MUST NOT be longer than 30 octets. Value strings MUST + NOT be longer than 1024 octets. Implementations MUST NOT send more + than 30 field-value pairs. + + name Name of the program + version Version number of the program + os Name of the operating system + os-version Version of the operating system + vendor Vendor of the client/server + support-url URL to contact for support + address Postal address of contact/vendor + date Date program was released, specified as a date-time + in IMAP4rev1 + command Command used to start the program + arguments Arguments supplied on the command line, if any + if any + environment Description of environment, i.e., UNIX environment + variables or Windows registry settings + + Implementations MUST NOT send the same field name more than once. + +An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number +\"os\" system-configuration \"vendor\" \"GNU\")." + :group 'nnimap + :type '(choice (const :tag "No information" nil) + (const :tag "Disable ID query" no) + (plist :key-type string :value-type string))) + (defcustom nnimap-debug nil "If non-nil, random debug spews are placed in *nnimap-debug* buffer. Note that username, passwords and other privacy sensitive @@ -451,6 +493,14 @@ variable unless you are comfortable with that." "Return buffer for SERVER, if nil use current server." (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist))) +(defun nnimap-remove-server-from-buffer-alist (server list) + "Remove SERVER from LIST." + (let (l) + (dolist (e list) + (unless (equal server (car-safe e)) + (push e l))) + l)) + (defun nnimap-possibly-change-server (server) "Return buffer for SERVER, changing the current server as a side-effect. If SERVER is nil, uses the current server." @@ -569,7 +619,7 @@ If EXAMINE is non-nil the group is selected read-only." (with-temp-buffer (buffer-disable-undo) (insert headers) - (let ((head (nnheader-parse-naked-head))) + (let ((head (nnheader-parse-naked-head uid))) (mail-header-set-number head uid) (mail-header-set-chars head chars) (mail-header-set-lines head lines) @@ -730,6 +780,8 @@ If EXAMINE is non-nil the group is selected read-only." 'nov))) (defun nnimap-open-connection (server) + ;; Note: `nnimap-open-server' that calls this function binds + ;; `imap-logout-timeout' to `nnimap-logout-timeout'. (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream nnimap-authenticator nnimap-server-buffer)) (nnheader-report 'nnimap "Can't open connection to server %s" server) @@ -739,26 +791,35 @@ If EXAMINE is non-nil the group is selected read-only." (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server)) (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'." nnimap-authinfo-file) - (gnus-parse-netrc nnimap-authinfo-file))) - (port (if nnimap-server-port - (int-to-string nnimap-server-port) - "imap")) - (alist (or (gnus-netrc-machine list server port "imap") - (gnus-netrc-machine list server port "imaps") - (gnus-netrc-machine list - (or nnimap-server-address - nnimap-address) - port "imap") - (gnus-netrc-machine list - (or nnimap-server-address - nnimap-address) - port "imaps"))) - (user (gnus-netrc-get alist "login")) - (passwd (gnus-netrc-get alist "password"))) + (netrc-parse nnimap-authinfo-file))) + (port (if nnimap-server-port + (int-to-string nnimap-server-port) + "imap")) + (user (netrc-machine-user-or-password + "login" + list + (list server + (or nnimap-server-address + nnimap-address)) + (list port) + (list "imap" "imaps"))) + (passwd (netrc-machine-user-or-password + "password" + list + (list server + (or nnimap-server-address + nnimap-address)) + (list port) + (list "imap" "imaps")))) (if (imap-authenticate user passwd nnimap-server-buffer) - (prog1 + (prog2 + (setq nnimap-server-buffer-alist + (nnimap-remove-server-from-buffer-alist + server + nnimap-server-buffer-alist)) (push (list server nnimap-server-buffer) nnimap-server-buffer-alist) + (imap-id nnimap-id nnimap-server-buffer) (nnimap-possibly-change-server server)) (imap-close nnimap-server-buffer) (kill-buffer nnimap-server-buffer) @@ -782,14 +843,15 @@ If EXAMINE is non-nil the group is selected read-only." (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs)))) (with-current-buffer (get-buffer-create nnimap-server-buffer) (nnoo-change-server 'nnimap server defs)) - (or (and nnimap-server-buffer - (imap-opened nnimap-server-buffer) - (if (with-current-buffer nnimap-server-buffer - (memq imap-state '(auth select examine))) - t - (imap-close nnimap-server-buffer) - (nnimap-open-connection server))) - (nnimap-open-connection server)))) + (let ((imap-logout-timeout nnimap-logout-timeout)) + (or (and nnimap-server-buffer + (imap-opened nnimap-server-buffer) + (if (with-current-buffer nnimap-server-buffer + (memq imap-state '(auth selected examine))) + t + (imap-close nnimap-server-buffer) + (nnimap-open-connection server))) + (nnimap-open-connection server))))) (deffoo nnimap-server-opened (&optional server) "Whether SERVER is opened. @@ -804,7 +866,8 @@ SERVER is nil, it is treated as the current server." (deffoo nnimap-close-server (&optional server) "Close connection to server and free all resources connected to it. Return nil if the server couldn't be closed for some reason." - (let ((server (or server nnimap-current-server))) + (let ((server (or server nnimap-current-server)) + (imap-logout-timeout nnimap-logout-timeout)) (when (or (nnimap-server-opened server) (imap-opened (nnimap-get-server-buffer server))) (imap-close (nnimap-get-server-buffer server)) @@ -812,7 +875,9 @@ Return nil if the server couldn't be closed for some reason." (setq nnimap-server-buffer nil nnimap-current-server nil nnimap-server-buffer-alist - (delq server nnimap-server-buffer-alist))) + (nnimap-remove-server-from-buffer-alist + server + nnimap-server-buffer-alist))) (nnoo-close-server 'nnimap server))) (deffoo nnimap-request-close () @@ -820,8 +885,8 @@ Return nil if the server couldn't be closed for some reason." All buffers that have been created by that backend should be killed. (Not the nntp-server-buffer, though.) This function is generally only called when Gnus is shutting down." - (mapcar (lambda (server) (nnimap-close-server (car server))) - nnimap-server-buffer-alist) + (mapc (lambda (server) (nnimap-close-server (car server))) + nnimap-server-buffer-alist) (setq nnimap-server-buffer-alist nil)) (deffoo nnimap-status-message (&optional server) @@ -1142,20 +1207,19 @@ function is generally only called when Gnus is shutting down." seen)) (gnus-info-set-read info seen))) - (mapcar (lambda (pred) - (when (or (eq (cdr pred) 'recent) - (and (nnimap-mark-permanent-p (cdr pred)) - (member (nnimap-mark-to-flag (cdr pred)) - (imap-mailbox-get 'flags)))) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (gnus-compress-sequence - (imap-search (nnimap-mark-to-predicate (cdr pred)))) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) + (dolist (pred gnus-article-mark-lists) + (when (or (eq (cdr pred) 'recent) + (and (nnimap-mark-permanent-p (cdr pred)) + (member (nnimap-mark-to-flag (cdr pred)) + (imap-mailbox-get 'flags)))) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (gnus-compress-sequence + (imap-search (nnimap-mark-to-predicate (cdr pred)))) + (gnus-info-marks info)) + t))) (when nnimap-importantize-dormant ;; nnimap mark dormant article as ticked too (for other clients) @@ -1207,11 +1271,11 @@ function is generally only called when Gnus is shutting down." (if (memq 'dormant cmdmarks) (setq cmdmarks (cons 'tick cmdmarks)))) ;; remove stuff we are forbidden to store - (mapcar (lambda (mark) - (if (imap-message-flag-permanent-p - (nnimap-mark-to-flag mark)) - (setq marks (cons mark marks)))) - cmdmarks) + (mapc (lambda (mark) + (if (imap-message-flag-permanent-p + (nnimap-mark-to-flag mark)) + (setq marks (cons mark marks)))) + cmdmarks) (when (and range marks) (cond ((eq what 'del) (imap-message-flags-del @@ -1472,8 +1536,8 @@ function is generally only called when Gnus is shutting down." ;; return articles not deleted articles) -(deffoo nnimap-request-move-article (article group server - accept-form &optional last) +(deffoo nnimap-request-move-article (article group server accept-form + &optional last move-is-internal) (when (nnimap-possibly-change-server server) (save-excursion (let ((buf (get-buffer-create " *nnimap move*")) @@ -1481,7 +1545,13 @@ function is generally only called when Gnus is shutting down." (nnimap-current-move-group group) (nnimap-current-move-server nnimap-current-server) result) - (and (nnimap-request-article article group server) + (gnus-message 10 "nnimap-request-move-article: this is an %s move" + (if move-is-internal + "internal" + "external")) + ;; request the article only when the move is NOT internal + (and (or move-is-internal + (nnimap-request-article article group server)) (save-excursion (set-buffer buf) (buffer-disable-undo (current-buffer)) @@ -1558,21 +1628,21 @@ function is generally only called when Gnus is shutting down." (error "Your server does not support ACL editing")) (with-current-buffer nnimap-server-buffer ;; delete all removed identifiers - (mapcar (lambda (old-acl) - (unless (assoc (car old-acl) new-acls) - (or (imap-mailbox-acl-delete (car old-acl) mailbox) - (error "Can't delete ACL for %s" (car old-acl))))) - old-acls) + (mapc (lambda (old-acl) + (unless (assoc (car old-acl) new-acls) + (or (imap-mailbox-acl-delete (car old-acl) mailbox) + (error "Can't delete ACL for %s" (car old-acl))))) + old-acls) ;; set all changed acl's - (mapcar (lambda (new-acl) - (let ((new-rights (cdr new-acl)) - (old-rights (cdr (assoc (car new-acl) old-acls)))) - (unless (and old-rights new-rights - (string= old-rights new-rights)) - (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox) - (error "Can't set ACL for %s to %s" (car new-acl) - new-rights))))) - new-acls) + (mapc (lambda (new-acl) + (let ((new-rights (cdr new-acl)) + (old-rights (cdr (assoc (car new-acl) old-acls)))) + (unless (and old-rights new-rights + (string= old-rights new-rights)) + (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox) + (error "Can't set ACL for %s to %s" (car new-acl) + new-rights))))) + new-acls) t))) @@ -1651,64 +1721,64 @@ be used in a STORE FLAGS command." (when nnimap-debug (require 'trace) (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) - (mapcar (lambda (f) (trace-function-background f nnimap-debug-buffer)) - '( - nnimap-possibly-change-server - nnimap-verify-uidvalidity - nnimap-find-minmax-uid - nnimap-before-find-minmax-bugworkaround - nnimap-possibly-change-group - ;;nnimap-replace-whitespace - nnimap-retrieve-headers-progress - nnimap-retrieve-which-headers - nnimap-group-overview-filename - nnimap-retrieve-headers-from-file - nnimap-retrieve-headers-from-server - nnimap-retrieve-headers - nnimap-open-connection - nnimap-open-server - nnimap-server-opened - nnimap-close-server - nnimap-request-close - nnimap-status-message - ;;nnimap-demule - nnimap-request-article-part - nnimap-request-article - nnimap-request-head - nnimap-request-body - nnimap-request-group - nnimap-close-group - nnimap-pattern-to-list-arguments - nnimap-request-list - nnimap-request-post - nnimap-retrieve-groups - nnimap-request-update-info-internal - nnimap-request-type - nnimap-request-set-mark - nnimap-split-to-groups - nnimap-split-find-rule - nnimap-split-find-inbox - nnimap-split-articles - nnimap-request-scan - nnimap-request-newgroups - nnimap-request-create-group - nnimap-time-substract - nnimap-date-days-ago - nnimap-request-expire-articles-progress - nnimap-request-expire-articles - nnimap-request-move-article - nnimap-request-accept-article - nnimap-request-delete-group - nnimap-request-rename-group - gnus-group-nnimap-expunge - gnus-group-nnimap-edit-acl - gnus-group-nnimap-edit-acl-done - nnimap-group-mode-hook - nnimap-mark-to-predicate - nnimap-mark-to-flag-1 - nnimap-mark-to-flag - nnimap-mark-permanent-p - ))) + (mapc (lambda (f) (trace-function-background f nnimap-debug-buffer)) + '( + nnimap-possibly-change-server + nnimap-verify-uidvalidity + nnimap-find-minmax-uid + nnimap-before-find-minmax-bugworkaround + nnimap-possibly-change-group + ;;nnimap-replace-whitespace + nnimap-retrieve-headers-progress + nnimap-retrieve-which-headers + nnimap-group-overview-filename + nnimap-retrieve-headers-from-file + nnimap-retrieve-headers-from-server + nnimap-retrieve-headers + nnimap-open-connection + nnimap-open-server + nnimap-server-opened + nnimap-close-server + nnimap-request-close + nnimap-status-message + ;;nnimap-demule + nnimap-request-article-part + nnimap-request-article + nnimap-request-head + nnimap-request-body + nnimap-request-group + nnimap-close-group + nnimap-pattern-to-list-arguments + nnimap-request-list + nnimap-request-post + nnimap-retrieve-groups + nnimap-request-update-info-internal + nnimap-request-type + nnimap-request-set-mark + nnimap-split-to-groups + nnimap-split-find-rule + nnimap-split-find-inbox + nnimap-split-articles + nnimap-request-scan + nnimap-request-newgroups + nnimap-request-create-group + nnimap-time-substract + nnimap-date-days-ago + nnimap-request-expire-articles-progress + nnimap-request-expire-articles + nnimap-request-move-article + nnimap-request-accept-article + nnimap-request-delete-group + nnimap-request-rename-group + gnus-group-nnimap-expunge + gnus-group-nnimap-edit-acl + gnus-group-nnimap-edit-acl-done + nnimap-group-mode-hook + nnimap-mark-to-predicate + nnimap-mark-to-flag-1 + nnimap-mark-to-flag + nnimap-mark-permanent-p + ))) (provide 'nnimap) diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el index 7c7fb5a54ab..78e35c410bb 100644 --- a/lisp/gnus/nnkiboze.el +++ b/lisp/gnus/nnkiboze.el @@ -227,7 +227,7 @@ Finds out what articles are to be part of the nnkiboze groups." "." gnus-score-file-suffix)))))) (defun nnkiboze-generate-group (group &optional inhibit-list-groups) - (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) + (let* ((info (gnus-get-info group)) (newsrc-file (concat nnkiboze-directory (nnheader-translate-file-chars (concat group ".newsrc")))) @@ -269,8 +269,7 @@ Finds out what articles are to be part of the nnkiboze groups." (numberp (car (symbol-value group))) ; It is active (or (> nnkiboze-level 7) (and (setq glevel - (nth 1 (nth 2 (gnus-gethash - gname gnus-newsrc-hashtb)))) + (gnus-info-level (gnus-get-info gname))) (>= nnkiboze-level glevel))) (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes (push (cons gname (1- (car (symbol-value group)))) @@ -282,8 +281,7 @@ Finds out what articles are to be part of the nnkiboze groups." ;; number that has been kibozed in GROUP in this kiboze group. (setq newsrc nnkiboze-newsrc) (while newsrc - (if (not (setq active (gnus-gethash - (caar newsrc) gnus-active-hashtb))) + (if (not (setq active (gnus-active (caar newsrc)))) ;; This group isn't active after all, so we remove it from ;; the list of component groups. (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) @@ -294,8 +292,7 @@ Finds out what articles are to be part of the nnkiboze groups." (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) (setq ginfo (gnus-get-info (gnus-group-group-name)) orig-info (gnus-copy-sequence ginfo) - num-unread (car (gnus-gethash (caar newsrc) - gnus-newsrc-hashtb))) + num-unread (gnus-group-unread (caar newsrc))) (unwind-protect (progn ;; We set all list of article marks to nil. Since we operate @@ -338,8 +335,7 @@ Finds out what articles are to be part of the nnkiboze groups." ;; Restore the proper info. (when ginfo (setcdr ginfo (cdr orig-info))) - (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) - num-unread))) + (setcar (gnus-group-entry (caar newsrc)) num-unread))) (setcdr (car newsrc) (cdr active)) (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) (setq newsrc (cdr newsrc))))) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 35f5476f9b4..7608660f019 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -32,7 +32,6 @@ (require 'gnus) ; for macro gnus-kill-buffer, at least (require 'nnheader) (require 'message) -(require 'custom) (require 'gnus-util) (require 'mail-source) (require 'mm-util) @@ -298,7 +297,10 @@ Eg. \(add-hook 'nnmail-read-incoming-hook (lambda () (call-process \"/local/bin/mailsend\" nil nil nil - \"read\" nnmail-spool-file))) + \"read\" + ;; The incoming mail box file. + (expand-file-name (user-login-name) + rmail-spool-directory)))) If you have xwatch running, this will alert it that mail has been read. @@ -412,13 +414,13 @@ This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." (const :format "" &) (editable-list :inline t nnmail-split-fancy)) (list :tag "Function with fixed arguments (:)" - :value (: nil) + :value (:) (const :format "" :value :) function (editable-list :inline t (sexp :tag "Arg")) ) (list :tag "Function with split arguments (!)" - :value (! nil) + :value (!) (const :format "" !) function (editable-list :inline t nnmail-split-fancy)) @@ -476,7 +478,7 @@ FIELD must match a complete field name. VALUE must match a complete word according to the `nnmail-split-fancy-syntax-table' syntax table. You can use \".*\" in the regexps to match partial field names or words. -FIELD and VALUE can also be lisp symbols, in that case they are expanded +FIELD and VALUE can also be Lisp symbols, in that case they are expanded as specified in `nnmail-split-abbrev-alist'. GROUP can contain \\& and \\N which will substitute from matching @@ -660,9 +662,7 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)." (expand-file-name group dir) ;; If not, we translate dots into slashes. (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string group ?. ?/) - nnmail-pathname-coding-system) + (nnheader-replace-chars-in-string group ?. ?/) dir)))) (or file ""))) @@ -687,7 +687,7 @@ nn*-request-list should have been called before calling this function." (while (not (eobp)) (condition-case err (progn - (narrow-to-region (point) (gnus-point-at-eol)) + (narrow-to-region (point) (point-at-eol)) (setq group (read buffer)) (unless (stringp group) (setq group (symbol-name group))) @@ -1047,6 +1047,9 @@ If SOURCE is a directory spec, try to return the group name component." (nnmail-check-duplication message-id func artnum-func)) 1)) +(defvar nnmail-group-names-not-encoded-p nil + "Non-nil means group names are not encoded.") + (defun nnmail-split-incoming (incoming func &optional exit-func group artnum-func) "Go through the entire INCOMING file and pick out each individual mail. @@ -1056,7 +1059,8 @@ FUNC will be called with the buffer narrowed to each mail." (nnmail-split-methods (if (and group (not nnmail-resplit-incoming)) (list (list group "")) - nnmail-split-methods))) + nnmail-split-methods)) + (nnmail-group-names-not-encoded-p t)) (save-excursion ;; Insert the incoming file. (set-buffer (get-buffer-create nnmail-article-buffer)) @@ -1125,7 +1129,7 @@ FUNC will be called with the group name to determine the article number." (while (not (eobp)) (unless (< (move-to-column nnmail-split-header-length-limit) nnmail-split-header-length-limit) - (delete-region (point) (gnus-point-at-eol))) + (delete-region (point) (point-at-eol))) (forward-line 1)) ;; Allow washing. (goto-char (point-min)) @@ -1247,11 +1251,11 @@ Return the number of characters in the body." (progn (forward-line 1) (point)))) (insert (format "Xref: %s" (system-name))) (while group-alist - (insert (format " %s:%d" - (mm-encode-coding-string - (caar group-alist) - nnmail-pathname-coding-system) - (cdar group-alist))) + (insert (if (mm-multibyte-p) + (mm-string-as-multibyte + (format " %s:%d" (caar group-alist) (cdar group-alist))) + (mm-string-as-unibyte + (format " %s:%d" (caar group-alist) (cdar group-alist))))) (setq group-alist (cdr group-alist))) (insert "\n"))) @@ -1285,10 +1289,20 @@ Return the number of characters in the body." "Translate TAB characters into SPACE characters." (subst-char-in-region (point-min) (point-max) ?\t ? t)) -(defun nnmail-fix-eudora-headers () - "Eudora has a broken References line, but an OK In-Reply-To." +(defcustom nnmail-broken-references-mailers + "^X-Mailer:.*\\(Eudora\\|Pegasus\\)" + "Header line matching mailer producing bogus References lines. +See `nnmail-ignore-broken-references'." + :group 'nnmail-prepare + :version "23.0" ;; No Gnus + :type 'regexp) + +(defun nnmail-ignore-broken-references () + "Ignore the References line and use In-Reply-To + +Eudora has a broken References line, but an OK In-Reply-To." (goto-char (point-min)) - (when (re-search-forward "^X-Mailer:.*Eudora" nil t) + (when (re-search-forward nnmail-broken-references-mailers nil t) (goto-char (point-min)) (when (re-search-forward "^References:" nil t) (beginning-of-line) @@ -1297,8 +1311,11 @@ Return the number of characters in the body." (when (re-search-forward "^\\(In-Reply-To:[^\n]+\\)\n[ \t]+" nil t) (replace-match "\\1" t)))) +(defalias 'nnmail-fix-eudora-headers 'nnmail-ignore-broken-references) +(make-obsolete 'nnmail-fix-eudora-headers 'nnmail-ignore-broken-references) + (custom-add-option 'nnmail-prepare-incoming-header-hook - 'nnmail-fix-eudora-headers) + 'nnmail-ignore-broken-references) ;;; Utility functions @@ -1327,12 +1344,8 @@ to actually put the message in the right group." (defun nnmail-split-fancy () "Fancy splitting method. See the documentation for the variable `nnmail-split-fancy' for details." - (let ((syntab (syntax-table))) - (unwind-protect - (progn - (set-syntax-table nnmail-split-fancy-syntax-table) - (nnmail-split-it nnmail-split-fancy)) - (set-syntax-table syntab)))) + (with-syntax-table nnmail-split-fancy-syntax-table + (nnmail-split-it nnmail-split-fancy))) (defvar nnmail-split-cache nil) ;; Alist of split expressions their equivalent regexps. @@ -1644,7 +1657,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." (skip-chars-forward "^\n\r\t") (unless (looking-at "[\r\n]") (forward-char 1) - (buffer-substring (point) (gnus-point-at-eol))))))) + (buffer-substring (point) (point-at-eol))))))) ;; Function for nnmail-split-fancy: look up all references in the ;; cache and if a match is found, return that group. @@ -1672,12 +1685,11 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (setq references (nreverse (gnus-split-references refstr))) (unless (gnus-buffer-live-p nnmail-cache-buffer) (nnmail-cache-open)) - (mapcar (lambda (x) - (setq res (or (nnmail-cache-fetch-group x) res)) - (when (or (member res '("delayed" "drafts" "queue")) - (and regexp res (string-match regexp res))) - (setq res nil))) - references) + (dolist (x references) + (setq res (or (nnmail-cache-fetch-group x) res)) + (when (or (member res '("delayed" "drafts" "queue")) + (and regexp res (string-match regexp res))) + (setq res nil))) res))) (defun nnmail-cache-id-exists-p (id) @@ -1902,7 +1914,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (or (string-match (cadr regexp-target-pair) from) (and (string-match (cadr regexp-target-pair) to) (let ((rmail-dont-reply-to-names - message-dont-reply-to-names)) + (message-dont-reply-to-names))) (equal (rmail-dont-reply-to from) ""))))) (setq target (format-time-string (caddr regexp-target-pair) date))) ((and (not (equal header 'to-from)) @@ -1995,14 +2007,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (with-output-to-temp-buffer "*nnmail split history*" (with-current-buffer standard-output (fundamental-mode)) ; for Emacs 20.4+ - (let ((history nnmail-split-history) - elem) - (while (setq elem (pop history)) + (dolist (elem nnmail-split-history) (princ (mapconcat (lambda (ga) (concat (car ga) ":" (int-to-string (cdr ga)))) elem ", ")) - (princ "\n"))))) + (princ "\n")))) (defun nnmail-purge-split-history (group) "Remove all instances of GROUP from `nnmail-split-history'." diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 6769c902e2b..04b6af72aed 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -41,6 +41,8 @@ ;; copying, restoring, etc. ;; ;; Todo: +;; * When moving an article for expiry, copy all the marks except 'expire +;; from the original article. ;; * Add a hook for when moving messages from new/ to cur/, to support ;; nnmail's duplicate detection. ;; * Improve generated Xrefs, so crossposts are detectable. @@ -54,6 +56,7 @@ (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0) + (put 'nnmaildir--condcase 'lisp-indent-function 2) ) ] @@ -229,7 +232,6 @@ by nnmaildir-request-article.") (defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov")) (defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks")) (defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num")) -(defmacro nnmaildir--num-file (dir) `(concat ,dir ":")) (defmacro nnmaildir--unlink (file-arg) `(let ((file ,file-arg)) @@ -237,20 +239,36 @@ by nnmaildir-request-article.") (defun nnmaildir--mkdir (dir) (or (file-exists-p (file-name-as-directory dir)) (make-directory-internal (directory-file-name dir)))) +(defun nnmaildir--mkfile (file) + (write-region "" nil file nil 'no-message)) (defun nnmaildir--delete-dir-files (dir ls) (when (file-attributes dir) - (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) + (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) (delete-directory dir))) (defun nnmaildir--group-maxnum (server group) - (if (zerop (nnmaildir--grp-count group)) 0 - (let ((x (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server) - (nnmaildir--grp-name group)))) - (setq x (nnmaildir--nndir x) - x (nnmaildir--num-dir x) - x (nnmaildir--num-file x) - x (file-attributes x)) - (if x (1- (nth 1 x)) 0)))) + (catch 'return + (if (zerop (nnmaildir--grp-count group)) (throw 'return 0)) + (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server) + (nnmaildir--grp-name group))) + (number-opened 1) + attr ino-opened nlink number-linked) + (setq dir (nnmaildir--nndir dir) + dir (nnmaildir--num-dir dir)) + (while t + (setq attr (file-attributes + (concat dir (number-to-string number-opened)))) + (or attr (throw 'return (1- number-opened))) + (setq ino-opened (nth 10 attr) + nlink (nth 1 attr) + number-linked (+ number-opened nlink)) + (if (or (< nlink 1) (< number-linked nlink)) + (signal 'error '("Arithmetic overflow"))) + (setq attr (file-attributes + (concat dir (number-to-string number-linked)))) + (or attr (throw 'return (1- number-linked))) + (if (/= ino-opened (nth 10 attr)) + (setq number-opened number-linked)))))) ;; Make the given server, if non-nil, be the current server. Then make the ;; given group, if non-nil, be the current group of the current server. Then @@ -287,6 +305,64 @@ by nnmaildir-request-article.") (setq pos (match-end 0)))) string) +(defmacro nnmaildir--condcase (errsym body &rest handler) + `(condition-case ,errsym + (let ((system-messages-locale "C")) ,body) + (error . ,handler))) + +(defun nnmaildir--emlink-p (err) + (and (eq (car err) 'file-error) + (string= (downcase (caddr err)) "too many links"))) + +(defun nnmaildir--enoent-p (err) + (and (eq (car err) 'file-error) + (string= (downcase (caddr err)) "no such file or directory"))) + +(defun nnmaildir--eexist-p (err) + (eq (car err) 'file-already-exists)) + +(defun nnmaildir--new-number (nndir) + "Allocate a new article number by atomically creating a file under NNDIR." + (let ((numdir (nnmaildir--num-dir nndir)) + (make-new-file t) + (number-open 1) + number-link previous-number-link path-open path-link ino-open) + (nnmaildir--mkdir numdir) + (catch 'return + (while t + (setq path-open (concat numdir (number-to-string number-open))) + (if (not make-new-file) + (setq previous-number-link number-link) + (nnmaildir--mkfile path-open) + ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here. + (setq make-new-file nil + previous-number-link 0)) + (let* ((attr (file-attributes path-open)) + (nlink (nth 1 attr))) + (setq ino-open (nth 10 attr) + number-link (+ number-open nlink)) + (if (or (< nlink 1) (< number-link nlink)) + (signal 'error '("Arithmetic overflow")))) + (if (= number-link previous-number-link) + ;; We've already tried this number, in the previous loop iteration, + ;; and failed. + (signal 'error `("Corrupt internal nnmaildir data" ,path-open))) + (setq path-link (concat numdir (number-to-string number-link))) + (nnmaildir--condcase err + (progn + (add-name-to-file path-open path-link) + (throw 'return number-link)) + (cond + ((nnmaildir--emlink-p err) + (setq make-new-file t + number-open number-link)) + ((nnmaildir--eexist-p err) + (let ((attr (file-attributes path-link))) + (if (/= (nth 10 attr) ino-open) + (setq number-open number-link + number-link 0)))) + (t (signal (car err) (cdr err))))))))) + (defun nnmaildir--update-nov (server group article) (let ((nnheader-file-coding-system 'binary) (srv-dir (nnmaildir--srv-dir server)) @@ -398,30 +474,7 @@ by nnmaildir-request-article.") nnmaildir--extra) num (nnmaildir--art-num article)) (unless num - ;; Allocate a new article number. - (erase-buffer) - (setq numdir (nnmaildir--num-dir dir) - file (nnmaildir--num-file numdir) - num -1) - (nnmaildir--mkdir numdir) - (write-region "" nil file nil 'no-message) - (while file - ;; Get the number of links to file. - (setq attr (nth 1 (file-attributes file))) - (if (= attr num) - ;; We've already tried this number, in the previous loop - ;; iteration, and failed. - (signal 'error `("Corrupt internal nnmaildir data" ,numdir))) - ;; If attr is 123, try to link file to "123". This atomically - ;; increases the link count and creates the "123" link, failing - ;; if that link was already created by another Gnus, just after - ;; we stat()ed file. - (condition-case nil - (progn - (add-name-to-file file (concat numdir (format "%x" attr))) - (setq file nil)) ;; Stop looping. - (file-already-exists nil)) - (setq num attr)) + (setq num (nnmaildir--new-number dir)) (setf (nnmaildir--art-num article) num)) ;; Store this new NOV data in a file (erase-buffer) @@ -683,8 +736,7 @@ by nnmaildir-request-article.") group (make-nnmaildir--grp :name gname :index 0)) (nnmaildir--mkdir nndir) (nnmaildir--mkdir (nnmaildir--nov-dir nndir)) - (nnmaildir--mkdir (nnmaildir--marks-dir nndir)) - (write-region "" nil (concat nndir "markfile") nil 'no-message)) + (nnmaildir--mkdir (nnmaildir--marks-dir nndir))) (setq read-only (nnmaildir--param pgname 'read-only) ls (or (nnmaildir--param pgname 'directory-files) srv-ls)) (unless read-only @@ -693,12 +745,10 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Maildir spans filesystems: " absdir)) (throw 'return nil)) - (mapcar - (lambda (file) - (setq x (file-attributes file)) - (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) - (delete-file file))) - (funcall ls tdir 'full "\\`[^.]" 'nosort))) + (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort)) + (setq x (file-attributes file)) + (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) + (delete-file file)))) (or scan-msgs isnew (throw 'return t)) @@ -707,12 +757,10 @@ by nnmaildir-request-article.") (setq nattr nil)) (if read-only (setq dir (and (or isnew nattr) ndir)) (when (or isnew nattr) - (mapcar - (lambda (file) - (let ((path (concat ndir file))) - (and (time-less-p (nth 5 (file-attributes path)) (current-time)) - (rename-file path (concat cdir file ":2,"))))) - (funcall ls ndir nil "\\`[^.]" 'nosort)) + (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) + (setq x (concat ndir file)) + (and (time-less-p (nth 5 (file-attributes x)) (current-time)) + (rename-file x (concat cdir file ":2,")))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) (if (equal cattr (nnmaildir--grp-cur group)) @@ -737,13 +785,11 @@ by nnmaildir-request-article.") cdir (nnmaildir--marks-dir nndir) ndir (nnmaildir--subdir cdir "tick") cdir (nnmaildir--subdir cdir "read")) - (mapcar - (lambda (file) - (setq file (car file)) - (if (or (not (file-exists-p (concat cdir file))) - (file-exists-p (concat ndir file))) - (setq num (1+ num)))) - files)) + (dolist (file files) + (setq file (car file)) + (if (or (not (file-exists-p (concat cdir file))) + (file-exists-p (concat ndir file))) + (setq num (1+ num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) (set (intern gname groups) group)) @@ -757,12 +803,10 @@ by nnmaildir-request-article.") files (delq nil files) files (mapcar 'nnmaildir--parse-filename files) files (sort files 'nnmaildir--sort-files)) - (mapcar - (lambda (file) - (setq file (if (consp file) file (aref file 3)) - x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) - (nnmaildir--grp-add-art nnmaildir--cur-server group x)) - files) + (dolist (file files) + (setq file (if (consp file) file (aref file 3)) + x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) + (nnmaildir--grp-add-art nnmaildir--cur-server group x)) (if read-only (setf (nnmaildir--grp-new group) nattr) (setf (nnmaildir--grp-cur group) cattr))) t)) @@ -809,19 +853,18 @@ by nnmaildir-request-article.") dirs)) seen (nnmaildir--up2-1 (length dirs)) seen (make-vector seen 0)) - (mapcar - (lambda (grp-dir) - (if (nnmaildir--scan grp-dir scan-group groups method srv-dir - srv-ls) - (intern grp-dir seen))) - dirs) + (dolist (grp-dir dirs) + (if (nnmaildir--scan grp-dir scan-group groups method srv-dir + srv-ls) + (intern grp-dir seen))) (setq x nil) (mapatoms (lambda (group) (setq group (symbol-name group)) (unless (intern-soft group seen) (setq x (cons group x)))) groups) - (mapcar (lambda (grp) (unintern grp groups)) x) + (dolist (grp x) + (unintern grp groups)) (setf (nnmaildir--srv-mtime nnmaildir--cur-server) (nth 5 (file-attributes srv-dir)))) (and scan-group @@ -857,19 +900,17 @@ by nnmaildir-request-article.") (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) - (mapcar - (lambda (gname) - (setq group (nnmaildir--prepare nil gname)) - (if (null group) (insert "411 no such news group\n") - (insert "211 ") - (princ (nnmaildir--grp-count group) nntp-server-buffer) - (insert " ") - (princ (nnmaildir--grp-min group) nntp-server-buffer) - (insert " ") - (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) - nntp-server-buffer) - (insert " " gname "\n"))) - groups))) + (dolist (gname groups) + (setq group (nnmaildir--prepare nil gname)) + (if (null group) (insert "411 no such news group\n") + (insert "211 ") + (princ (nnmaildir--grp-count group) nntp-server-buffer) + (insert " ") + (princ (nnmaildir--grp-min group) nntp-server-buffer) + (insert " ") + (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) + nntp-server-buffer) + (insert " " gname "\n"))))) 'group) (defun nnmaildir-request-update-info (gname info &optional server) @@ -909,33 +950,29 @@ by nnmaildir-request-article.") new-mmth (nnmaildir--up2-1 (length markdirs)) new-mmth (make-vector new-mmth 0) old-mmth (nnmaildir--grp-mmth group)) - (mapcar - (lambda (mark) - (setq markdir (nnmaildir--subdir dir mark) - mark-sym (intern mark) - ranges nil) - (catch 'got-ranges - (if (memq mark-sym never-marks) (throw 'got-ranges nil)) - (when (memq mark-sym always-marks) - (setq ranges existing) - (throw 'got-ranges nil)) - (setq mtime (nth 5 (file-attributes markdir))) - (set (intern mark new-mmth) mtime) - (when (equal mtime (symbol-value (intern-soft mark old-mmth))) - (setq ranges (assq mark-sym old-marks)) - (if ranges (setq ranges (cdr ranges))) - (throw 'got-ranges nil)) - (mapcar - (lambda (prefix) - (setq article (nnmaildir--flist-art flist prefix)) - (if article - (setq ranges - (gnus-add-to-range ranges - `(,(nnmaildir--art-num article)))))) - (funcall ls markdir nil "\\`[^.]" 'nosort))) - (if (eq mark-sym 'read) (setq read ranges) - (if ranges (setq marks (cons (cons mark-sym ranges) marks))))) - markdirs) + (dolist (mark markdirs) + (setq markdir (nnmaildir--subdir dir mark) + mark-sym (intern mark) + ranges nil) + (catch 'got-ranges + (if (memq mark-sym never-marks) (throw 'got-ranges nil)) + (when (memq mark-sym always-marks) + (setq ranges existing) + (throw 'got-ranges nil)) + (setq mtime (nth 5 (file-attributes markdir))) + (set (intern mark new-mmth) mtime) + (when (equal mtime (symbol-value (intern-soft mark old-mmth))) + (setq ranges (assq mark-sym old-marks)) + (if ranges (setq ranges (cdr ranges))) + (throw 'got-ranges nil)) + (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort)) + (setq article (nnmaildir--flist-art flist prefix)) + (if article + (setq ranges + (gnus-add-to-range ranges + `(,(nnmaildir--art-num article))))))) + (if (eq mark-sym 'read) (setq read ranges) + (if ranges (setq marks (cons (cons mark-sym ranges) marks))))) (gnus-info-set-read info (gnus-range-add read missing)) (gnus-info-set-marks info marks 'extend) (setf (nnmaildir--grp-mmth group) new-mmth) @@ -1087,10 +1124,10 @@ by nnmaildir-request-article.") (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls) (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls)) (setq dir (nnmaildir--nndir grp-dir)) - (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls)) - `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) - ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" - 'nosort))) + (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) + ,@(funcall ls (nnmaildir--marks-dir dir) + 'full "\\`[^.]" 'nosort))) + (nnmaildir--delete-dir-files subdir ls)) (setq dir (nnmaildir--nndir grp-dir)) (nnmaildir--unlink (concat dir "markfile")) (nnmaildir--unlink (concat dir "markfile{new}")) @@ -1144,11 +1181,9 @@ by nnmaildir-request-article.") (nnmaildir--nlist-iterate nlist 'all insert-nov)) ((null articles)) ((stringp (car articles)) - (mapcar - (lambda (msgid) - (setq article (nnmaildir--mlist-art mlist msgid)) - (if article (funcall insert-nov article))) - articles)) + (dolist (msgid articles) + (setq article (nnmaildir--mlist-art mlist msgid)) + (if article (funcall insert-nov article)))) (t (if fetch-old ;; Assume the article range list is sorted ascending @@ -1254,7 +1289,7 @@ by nnmaildir-request-article.") t))) (defun nnmaildir-request-move-article (article gname server accept-form - &optional last) + &optional last move-is-internal) (let ((group (nnmaildir--prepare server gname)) pgname suffix result nnmaildir--file deactivate-mark) (catch 'return @@ -1339,8 +1374,7 @@ by nnmaildir-request-article.") nnmaildir--cur-server) "24-hour timer expired") (throw 'return nil)))) - (condition-case nil - (add-name-to-file nnmaildir--file tmpfile) + (condition-case nil (add-name-to-file nnmaildir--file tmpfile) (error (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil 'excl) @@ -1470,7 +1504,12 @@ by nnmaildir-request-article.") (not (string-equal target pgname))) ;; Move it. (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) - (gnus-request-accept-article target nil nil 'no-encode)) + (let ((group-art (gnus-request-accept-article + target nil nil 'no-encode))) + (when (consp group-art) + ;; Maybe also copy: dormant forward reply save tick + ;; (gnus-add-mark? gnus-request-set-mark?) + (gnus-group-mark-article-read target (cdr group-art))))) (if (equal target pgname) ;; Leave it here. (setq didnt (cons (nnmaildir--art-num article) didnt)) @@ -1484,8 +1523,8 @@ by nnmaildir-request-article.") (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) - del-mark del-action add-action set-action marksdir markfile nlist - ranges begin end article all-marks todo-marks did-marks mdir mfile + del-mark del-action add-action set-action marksdir nlist + ranges begin end article all-marks todo-marks mdir mfile pgname ls permarkfile deactivate-mark) (setq del-mark (lambda (mark) @@ -1500,17 +1539,19 @@ by nnmaildir-request-article.") (setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) permarkfile (concat mdir ":") mfile (concat mdir (nnmaildir--art-prefix article))) - (unless (memq mark did-marks) - (setq did-marks (cons mark did-marks)) - (nnmaildir--mkdir mdir) - (unless (file-attributes permarkfile) - (condition-case nil - (add-name-to-file markfile permarkfile) - (file-error - ;; AFS can't make hard links in separate directories - (write-region "" nil permarkfile nil 'no-message))))) - (unless (file-exists-p mfile) - (add-name-to-file permarkfile mfile))) + (nnmaildir--condcase err (add-name-to-file permarkfile mfile) + (cond + ((nnmaildir--eexist-p err)) + ((nnmaildir--enoent-p err) + (nnmaildir--mkdir mdir) + (nnmaildir--mkfile permarkfile) + (add-name-to-file permarkfile mfile)) + ((nnmaildir--emlink-p err) + (let ((permarkfilenew (concat permarkfile "{new}"))) + (nnmaildir--mkfile permarkfilenew) + (rename-file permarkfilenew permarkfile 'replace) + (add-name-to-file permarkfile mfile))) + (t (signal (car err) (cdr err)))))) todo-marks)) set-action (lambda (article) (funcall add-action) @@ -1522,32 +1563,29 @@ by nnmaildir-request-article.") (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) - (mapcar (lambda (action) - (setq ranges (gnus-range-add ranges (car action)))) - actions) + (dolist (action actions) + (setq ranges (gnus-range-add ranges (car action)))) (throw 'return ranges)) (setq nlist (nnmaildir--grp-nlist group) marksdir (nnmaildir--srv-dir nnmaildir--cur-server) marksdir (nnmaildir--srvgrp-dir marksdir gname) marksdir (nnmaildir--nndir marksdir) - markfile (concat marksdir "markfile") marksdir (nnmaildir--marks-dir marksdir) gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort) all-marks (mapcar 'intern all-marks)) - (mapcar - (lambda (action) - (setq ranges (car action) - todo-marks (caddr action)) - (mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks) - (if (numberp (cdr ranges)) (setq ranges (list ranges))) - (nnmaildir--nlist-iterate nlist ranges - (cond ((eq 'del (cadr action)) del-action) - ((eq 'add (cadr action)) add-action) - (t set-action)))) - actions) + (dolist (action actions) + (setq ranges (car action) + todo-marks (caddr action)) + (dolist (mark todo-marks) + (add-to-list 'all-marks mark)) + (if (numberp (cdr ranges)) (setq ranges (list ranges))) + (nnmaildir--nlist-iterate nlist ranges + (cond ((eq 'del (cadr action)) del-action) + ((eq 'add (cadr action)) add-action) + (t set-action)))) nil))) (defun nnmaildir-close-group (gname &optional server) @@ -1576,22 +1614,16 @@ by nnmaildir-request-article.") flist (nnmaildir--up2-1 (length files)) flist (make-vector flist 0)) (save-match-data - (mapcar - (lambda (file) - (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (intern (match-string 1 file) flist)) - files)) - (mapcar - (lambda (dir) - (setq files (cdr dir) - dir (file-name-as-directory (car dir))) - (mapcar - (lambda (file) - (unless (or (intern-soft file flist) (string= file ":")) - (setq file (concat dir file)) - (delete-file file))) - files)) - dirs) + (dolist (file files) + (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) + (intern (match-string 1 file) flist))) + (dolist (dir dirs) + (setq files (cdr dir) + dir (file-name-as-directory (car dir))) + (dolist (file files) + (unless (or (intern-soft file flist) (string= file ":")) + (setq file (concat dir file)) + (delete-file file)))) t))) (defun nnmaildir-close-server (&optional server) @@ -1608,7 +1640,7 @@ by nnmaildir-request-article.") (mapatoms (lambda (server) (setq servers (cons (symbol-name server) servers))) nnmaildir--servers) - (mapcar 'nnmaildir-close-server servers) + (mapc 'nnmaildir-close-server servers) (setq buffer (get-buffer " *nnmaildir work*")) (if buffer (kill-buffer buffer)) (setq buffer (get-buffer " *nnmaildir nov*")) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index fd8ec27d225..d7dddc96362 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -284,7 +284,7 @@ (nconc rest articles)))) (deffoo nnmbox-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmbox move*")) result) (and diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 3eeea7487dc..a7735edc513 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -176,7 +176,7 @@ as unread by Gnus.") (nnheader-re-read-dir pathname) (setq dir (sort - (mapcar (lambda (name) (string-to-number name)) + (mapcar 'string-to-number (directory-files pathname nil "^[0-9]+$" t)) '<)) (cond @@ -211,7 +211,6 @@ as unread by Gnus.") (setq dir (expand-file-name dir)) ;; Recurse down all directories. (let ((dirs (and (file-readable-p dir) - (> (nth 1 (file-attributes (file-chase-links dir))) 2) (nnheader-directory-files dir t nil t))) rdir) ;; Recurse down directories. @@ -223,9 +222,8 @@ as unread by Gnus.") (nnmh-request-list-1 rdir)))) ;; For each directory, generate an active file line. (unless (string= (expand-file-name nnmh-toplev) dir) - (let ((files (mapcar - (lambda (name) (string-to-number name)) - (directory-files dir nil "^[0-9]+$" t)))) + (let ((files (mapcar 'string-to-number + (directory-files dir nil "^[0-9]+$" t)))) (when files (save-excursion (set-buffer nntp-server-buffer) @@ -290,8 +288,8 @@ as unread by Gnus.") (deffoo nnmh-close-group (group &optional server) t) -(deffoo nnmh-request-move-article (article group server - accept-form &optional last) +(deffoo nnmh-request-move-article (article group server accept-form + &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmh move*")) result) (and @@ -356,11 +354,9 @@ as unread by Gnus.") nnmh-group-alist) (nnmh-possibly-create-directory group) (nnmh-possibly-change-directory group server) - (let ((articles (mapcar - (lambda (file) - (string-to-number file)) - (directory-files - nnmh-current-directory nil "^[0-9]+$")))) + (let ((articles (mapcar 'string-to-number + (directory-files + nnmh-current-directory nil "^[0-9]+$")))) (when articles (setcar active (apply 'min articles)) (setcdr active (apply 'max articles)))))) @@ -484,10 +480,8 @@ as unread by Gnus.") (gnus-make-directory dir)) ;; Find the highest number in the group. (let ((files (sort - (mapcar - (lambda (f) - (string-to-number f)) - (directory-files dir nil "^[0-9]+$")) + (mapcar 'string-to-number + (directory-files dir nil "^[0-9]+$")) '>))) (when files (setcdr active (car files))))) @@ -509,7 +503,7 @@ as unread by Gnus.") ;; articles in this folder. The articles that are "new" will be ;; marked as unread by Gnus. (let* ((dir nnmh-current-directory) - (files (sort (mapcar (function (lambda (name) (string-to-number name))) + (files (sort (mapcar 'string-to-number (directory-files nnmh-current-directory nil "^[0-9]+$" t)) '<)) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 8396c174a3f..0f159181026 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -3,8 +3,9 @@ ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. -;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS) -;; Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Authors: Didier Verna <didier@xemacs.org> (adding compaction) +;; Simon Josefsson <simon@josefsson.org> (adding MARKS) +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail @@ -40,7 +41,8 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'gnus-article-unpropagatable-p "gnus-sum")) + (autoload 'gnus-article-unpropagatable-p "gnus-sum") + (autoload 'gnus-backlog-remove-article "gnus-bcklg")) (nnoo-declare nnml) @@ -83,7 +85,18 @@ marks file will be regenerated properly by Gnus.") "If non-nil, inhibit expiry.") (defvoo nnml-use-compressed-files nil - "If non-nil, allow using compressed message files.") + "If non-nil, allow using compressed message files. + +If it is a string, use it as the file extension which specifies +the compression program. You can set it to \".bz2\" if your Emacs +supports auto-compression using the bzip2 program. A value of t +is equivalent to \".gz\".") + +(defvoo nnml-compressed-files-size-threshold 1000 + "Default size threshold for compressed message files. +Message files with bodies larger than that many characters will +be automatically compressed if `nnml-use-compressed-files' is +non-nil.") @@ -116,6 +129,37 @@ marks file will be regenerated properly by Gnus.") (nnoo-define-basics nnml) +(eval-when-compile + (defsubst nnml-group-name-charset (group server-or-method) + (gnus-group-name-charset + (if (stringp server-or-method) + (gnus-server-to-method + (if (string-match "\\+" server-or-method) + (concat (substring server-or-method 0 (match-beginning 0)) + ":" (substring server-or-method (match-end 0))) + (concat "nnml:" server-or-method))) + (or server-or-method gnus-command-method '(nnml ""))) + group))) + +(defun nnml-decoded-group-name (group &optional server-or-method) + "Return a decoded group name of GROUP on SERVER-OR-METHOD." + (if nnmail-group-names-not-encoded-p + group + (mm-decode-coding-string + group + (nnml-group-name-charset group server-or-method)))) + +(defun nnml-encoded-group-name (group &optional server-or-method) + "Return an encoded group name of GROUP on SERVER-OR-METHOD." + (mm-encode-coding-string + group + (nnml-group-name-charset group server-or-method))) + +(defun nnml-group-pathname (group &optional file server) + "Return an absolute file name of FILE for GROUP on SERVER." + (nnmail-group-pathname (inline (nnml-decoded-group-name group server)) + nnml-directory file)) + (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) (when (nnml-possibly-change-directory group server) (save-excursion @@ -188,14 +232,12 @@ marks file will be regenerated properly by Gnus.") (file-name-coding-system nnmail-pathname-coding-system) path gpath group-num) (if (stringp id) - (when (and (setq group-num (nnml-find-group-number id)) + (when (and (setq group-num (nnml-find-group-number id server)) (cdr (assq (cdr group-num) (nnheader-article-to-file-alist - (setq gpath - (nnmail-group-pathname - (car group-num) - nnml-directory)))))) + (setq gpath (nnml-group-pathname (car group-num) + nil server)))))) (setq path (concat gpath (int-to-string (cdr group-num))))) (setq path (nnml-article-to-file id))) (cond @@ -252,19 +294,23 @@ marks file will be regenerated properly by Gnus.") (nnml-possibly-change-directory nil server) (nnmail-activate 'nnml) (cond + ((let ((file (directory-file-name (nnml-group-pathname group nil server))) + (file-name-coding-system nnmail-pathname-coding-system)) + (and (file-exists-p file) + (not (file-directory-p file)))) + (nnheader-report 'nnml "%s is a file" + (directory-file-name (nnml-group-pathname group + nil server)))) ((assoc group nnml-group-alist) t) - ((and (file-exists-p (nnmail-group-pathname group nnml-directory)) - (not (file-directory-p (nnmail-group-pathname group nnml-directory)))) - (nnheader-report 'nnml "%s is a file" - (nnmail-group-pathname group nnml-directory))) (t (let (active) (push (list group (setq active (cons 1 0))) nnml-group-alist) - (nnml-possibly-create-directory group) + (nnml-possibly-create-directory group server) (nnml-possibly-change-directory group server) - (let ((articles (nnml-directory-articles nnml-current-directory))) + (let* ((file-name-coding-system nnmail-pathname-coding-system) + (articles (nnml-directory-articles nnml-current-directory))) (when articles (setcar active (apply 'min articles)) (setcdr active (apply 'max articles)))) @@ -288,10 +334,12 @@ marks file will be regenerated properly by Gnus.") (deffoo nnml-request-expire-articles (articles group &optional server force) (nnml-possibly-change-directory group server) - (let ((active-articles - (nnml-directory-articles nnml-current-directory)) - (is-old t) - article rest mod-time number) + (let* ((file-name-coding-system nnmail-pathname-coding-system) + (active-articles + (nnml-directory-articles nnml-current-directory)) + (is-old t) + (decoded (nnml-decoded-group-name group server)) + article rest mod-time number target) (nnmail-activate 'nnml) (setq active-articles (sort active-articles '<)) @@ -308,23 +356,33 @@ marks file will be regenerated properly by Gnus.") nnml-inhibit-expiry))) (progn ;; Allow a special target group. - (unless (eq nnmail-expiry-target 'delete) + (setq target nnmail-expiry-target) + (unless (eq target 'delete) (with-temp-buffer (nnml-request-article number group server (current-buffer)) (let (nnml-current-directory nnml-current-group nnml-article-file-alist) - (nnmail-expiry-target-group nnmail-expiry-target group))) + (when (functionp target) + (setq target (funcall target group))) + (if (and target + (or (gnus-request-group target) + (gnus-request-create-group target))) + (nnmail-expiry-target-group target group) + (setq target nil)))) ;; Maybe directory is changed during nnmail-expiry-target-group. (nnml-possibly-change-directory group server)) - (nnheader-message 5 "Deleting article %s in %s" - number group) - (condition-case () - (funcall nnmail-delete-file-function article) - (file-error - (push number rest))) - (setq active-articles (delq number active-articles)) - (nnml-nov-delete-article group number)) + (if target + (progn + (nnheader-message 5 "Deleting article %s in %s" + number decoded) + (condition-case () + (funcall nnmail-delete-file-function article) + (file-error + (push number rest))) + (setq active-articles (delq number active-articles)) + (nnml-nov-delete-article group number)) + (push number rest))) (push number rest))) (let ((active (nth 1 (assoc group nnml-group-alist)))) (when active @@ -336,8 +394,9 @@ marks file will be regenerated properly by Gnus.") (nconc rest articles))) (deffoo nnml-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnml move*")) + (file-name-coding-system nnmail-pathname-coding-system) result) (nnml-possibly-change-directory group server) (nnml-update-file-alist) @@ -370,7 +429,7 @@ marks file will be regenerated properly by Gnus.") (nnmail-check-syntax) (let (result) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -378,16 +437,20 @@ marks file will be regenerated properly by Gnus.") (and (nnmail-activate 'nnml) (setq result (car (nnml-save-mail - (list (cons group (nnml-active-number group)))))) + (list (cons group (nnml-active-number group + server))) + server))) (progn (nnmail-save-active nnml-group-alist nnml-active-file) (and last (nnml-save-nov)))) (and (nnmail-activate 'nnml) - (if (and (not (setq result (nnmail-article-group 'nnml-active-number))) + (if (and (not (setq result (nnmail-article-group + `(lambda (group) + (nnml-active-number group ,server))))) (yes-or-no-p "Moved to `junk' group; delete article? ")) (setq result 'junk) - (setq result (car (nnml-save-mail result)))) + (setq result (car (nnml-save-mail result server)))) (when last (nnmail-save-active nnml-group-alist nnml-active-file) (when nnmail-cache-accepted-message-ids @@ -439,47 +502,55 @@ marks file will be regenerated properly by Gnus.") (deffoo nnml-request-delete-group (group &optional force server) (nnml-possibly-change-directory group server) - (when force - ;; Delete all articles in GROUP. - (let ((articles - (directory-files - nnml-current-directory t - (concat nnheader-numerical-short-files - "\\|" (regexp-quote nnml-nov-file-name) "$" - "\\|" (regexp-quote nnml-marks-file-name) "$"))) - article) - (while articles - (setq article (pop articles)) - (when (file-writable-p article) - (nnheader-message 5 "Deleting article %s in %s..." article group) - (funcall nnmail-delete-file-function article)))) - ;; Try to delete the directory itself. - (ignore-errors (delete-directory nnml-current-directory))) - ;; Remove the group from all structures. - (setq nnml-group-alist - (delq (assoc group nnml-group-alist) nnml-group-alist) - nnml-current-group nil - nnml-current-directory nil) - ;; Save the active file. - (nnmail-save-active nnml-group-alist nnml-active-file) + (let ((file (directory-file-name nnml-current-directory)) + (file-name-coding-system nnmail-pathname-coding-system)) + (if (file-exists-p file) + (if (file-directory-p file) + (progn + (when force + ;; Delete all articles in GROUP. + (let ((articles + (directory-files + nnml-current-directory t + (concat + nnheader-numerical-short-files + "\\|" (regexp-quote nnml-nov-file-name) "$" + "\\|" (regexp-quote nnml-marks-file-name) "$"))) + (decoded (nnml-decoded-group-name group server))) + (dolist (article articles) + (when (file-writable-p article) + (nnheader-message 5 "Deleting article %s in %s..." + (file-name-nondirectory article) + decoded) + (funcall nnmail-delete-file-function article)))) + ;; Try to delete the directory itself. + (ignore-errors (delete-directory nnml-current-directory)))) + (nnheader-report 'nnml "%s is not a directory" file)) + (nnheader-report 'nnml "No such directory: %s/" file)) + ;; Remove the group from all structures. + (setq nnml-group-alist + (delq (assoc group nnml-group-alist) nnml-group-alist) + nnml-current-group nil + nnml-current-directory nil) + ;; Save the active file. + (nnmail-save-active nnml-group-alist nnml-active-file)) t) (deffoo nnml-request-rename-group (group new-name &optional server) (nnml-possibly-change-directory group server) - (let ((new-dir (nnmail-group-pathname new-name nnml-directory)) - (old-dir (nnmail-group-pathname group nnml-directory))) + (let ((new-dir (nnml-group-pathname new-name nil server)) + (old-dir (nnml-group-pathname group nil server)) + (file-name-coding-system nnmail-pathname-coding-system)) (when (ignore-errors (make-directory new-dir t) t) ;; We move the articles file by file instead of renaming ;; the directory -- there may be subgroups in this group. ;; One might be more clever, I guess. - (let ((files (nnheader-article-to-file-alist old-dir))) - (while files - (rename-file - (concat old-dir (cdar files)) - (concat new-dir (cdar files))) - (pop files))) + (dolist (file (nnheader-article-to-file-alist old-dir)) + (rename-file + (concat old-dir (cdr file)) + (concat new-dir (cdr file)))) ;; Move .overview file. (let ((overview (concat old-dir nnml-nov-file-name))) (when (file-exists-p overview) @@ -534,7 +605,8 @@ marks file will be regenerated properly by Gnus.") (defun nnml-deletable-article-p (group article) "Say whether ARTICLE in GROUP can be deleted." - (let (path) + (let ((file-name-coding-system nnmail-pathname-coding-system) + path) (when (setq path (nnml-article-to-file article)) (when (file-writable-p path) (or (not nnmail-keep-last-article) @@ -542,7 +614,7 @@ marks file will be regenerated properly by Gnus.") article))))))) ;; Find an article number in the current group given the Message-ID. -(defun nnml-find-group-number (id) +(defun nnml-find-group-number (id server) (save-excursion (set-buffer (get-buffer-create " *nnml id*")) (let ((alist nnml-group-alist) @@ -550,22 +622,21 @@ marks file will be regenerated properly by Gnus.") ;; We want to look through all .overview files, but we want to ;; start with the one in the current directory. It seems most ;; likely that the article we are looking for is in that group. - (if (setq number (nnml-find-id nnml-current-group id)) + (if (setq number (nnml-find-id nnml-current-group id server)) (cons nnml-current-group number) ;; It wasn't there, so we look through the other groups as well. (while (and (not number) alist) (or (string= (caar alist) nnml-current-group) - (setq number (nnml-find-id (caar alist) id))) + (setq number (nnml-find-id (caar alist) id server))) (or number (setq alist (cdr alist)))) (and number (cons (caar alist) number)))))) -(defun nnml-find-id (group id) +(defun nnml-find-id (group id server) (erase-buffer) - (let ((nov (expand-file-name nnml-nov-file-name - (nnmail-group-pathname group nnml-directory))) + (let ((nov (nnml-group-pathname group nnml-nov-file-name server)) number found) (when (file-exists-p nov) (nnheader-insert-file-contents nov) @@ -573,7 +644,7 @@ marks file will be regenerated properly by Gnus.") (search-forward id nil t)) ; We find the ID. ;; And the id is in the fourth field. (if (not (and (search-backward "\t" nil t 4) - (not (search-backward"\t" (gnus-point-at-bol) t)))) + (not (search-backward "\t" (point-at-bol) t)))) (forward-line 1) (beginning-of-line) (setq found t) @@ -606,7 +677,7 @@ marks file will be regenerated properly by Gnus.") (nnml-open-server server)) (if (not group) t - (let ((pathname (nnmail-group-pathname group nnml-directory)) + (let ((pathname (nnml-group-pathname group nil server)) (file-name-coding-system nnmail-pathname-coding-system)) (when (not (equal pathname nnml-current-directory)) (setq nnml-current-directory pathname @@ -614,20 +685,32 @@ marks file will be regenerated properly by Gnus.") nnml-article-file-alist nil)) (file-exists-p nnml-current-directory)))) -(defun nnml-possibly-create-directory (group) - (let ((dir (nnmail-group-pathname group nnml-directory))) +(defun nnml-possibly-create-directory (group &optional server) + (let ((dir (nnml-group-pathname group nil server)) + (file-name-coding-system nnmail-pathname-coding-system)) (unless (file-exists-p dir) (make-directory (directory-file-name dir) t) (nnheader-message 5 "Creating mail directory %s" dir)))) -(defun nnml-save-mail (group-art) - "Called narrowed to an article." - (let (chars headers extension) - (setq chars (nnmail-insert-lines)) - (setq extension - (and nnml-use-compressed-files - (> chars 1000) - ".gz")) +(defun nnml-save-mail (group-art &optional server) + "Save a mail into the groups GROUP-ART in the nnml server SERVER. +GROUP-ART is a list that each element is a cons of a group name and an +article number. This function is called narrowed to an article." + (let* ((chars (nnmail-insert-lines)) + (extension (and nnml-use-compressed-files + (> chars nnml-compressed-files-size-threshold) + (if (stringp nnml-use-compressed-files) + nnml-use-compressed-files + ".gz"))) + decoded dec file first headers) + (when nnmail-group-names-not-encoded-p + (dolist (ga (prog1 group-art (setq group-art nil))) + (setq group-art (nconc group-art + (list (cons (nnml-encoded-group-name (car ga) + server) + (cdr ga)))) + decoded (nconc decoded (list (car ga))))) + (setq dec decoded)) (nnmail-insert-xref group-art) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnml-prepare-save-mail-hook) @@ -636,43 +719,50 @@ marks file will be regenerated properly by Gnus.") (replace-match "X-From-Line: ") (forward-line 1)) ;; We save the article in all the groups it belongs in. - (let ((ga group-art) - first) - (while ga - (nnml-possibly-create-directory (caar ga)) - (let ((file (concat (nnmail-group-pathname - (caar ga) nnml-directory) - (int-to-string (cdar ga)) - extension))) - (if first - ;; It was already saved, so we just make a hard link. - (funcall nnmail-crosspost-link-function first file t) - ;; Save the article. - (nnmail-write-region (point-min) (point-max) file nil - (if (nnheader-be-verbose 5) nil 'nomesg)) - (setq first file))) - (setq ga (cdr ga)))) + (dolist (ga group-art) + (if nnmail-group-names-not-encoded-p + (progn + (nnml-possibly-create-directory (car decoded) server) + (setq file (nnmail-group-pathname + (pop decoded) nnml-directory + (concat (number-to-string (cdr ga)) extension)))) + (nnml-possibly-create-directory (car ga) server) + (setq file (nnml-group-pathname + (car ga) (concat (number-to-string (cdr ga)) extension) + server))) + (if first + ;; It was already saved, so we just make a hard link. + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (funcall nnmail-crosspost-link-function first file t)) + ;; Save the article. + (nnmail-write-region (point-min) (point-max) file nil + (if (nnheader-be-verbose 5) nil 'nomesg)) + (setq first file))) ;; Generate a nov line for this article. We generate the nov ;; line after saving, because nov generation destroys the ;; header. (setq headers (nnml-parse-head chars)) ;; Output the nov line to all nov databases that should have it. - (let ((ga group-art)) - (while ga - (nnml-add-nov (caar ga) (cdar ga) headers) - (setq ga (cdr ga)))) - group-art)) - -(defun nnml-active-number (group) - "Compute the next article number in GROUP." - (let ((active (cadr (assoc group nnml-group-alist)))) + (if nnmail-group-names-not-encoded-p + (dolist (ga group-art) + (nnml-add-nov (pop dec) (cdr ga) headers)) + (dolist (ga group-art) + (nnml-add-nov (car ga) (cdr ga) headers)))) + group-art) + +(defun nnml-active-number (group &optional server) + "Compute the next article number in GROUP on SERVER." + (let ((active (cadr (assoc (if nnmail-group-names-not-encoded-p + (nnml-encoded-group-name group server) + group) + nnml-group-alist)))) ;; The group wasn't known to nnml, so we just create an active ;; entry for it. (unless active ;; Perhaps the active file was corrupt? See whether ;; there are any articles in this group. - (nnml-possibly-create-directory group) - (nnml-possibly-change-directory group) + (nnml-possibly-create-directory group server) + (nnml-possibly-change-directory group server) (unless nnml-article-file-alist (setq nnml-article-file-alist (sort @@ -686,8 +776,7 @@ marks file will be regenerated properly by Gnus.") (push (list group active) nnml-group-alist)) (setcdr active (1+ (cdr active))) (while (file-exists-p - (expand-file-name (int-to-string (cdr active)) - (nnmail-group-pathname group nnml-directory))) + (nnml-group-pathname group (int-to-string (cdr active)) server)) (setcdr active (1+ (cdr active)))) (cdr active))) @@ -700,7 +789,7 @@ marks file will be regenerated properly by Gnus.") (nnheader-insert-nov headers))) (defsubst nnml-header-value () - (buffer-substring (match-end 0) (gnus-point-at-eol))) + (buffer-substring (match-end 0) (point-at-eol))) (defun nnml-parse-head (chars &optional number) "Parse the head of the current buffer." @@ -718,13 +807,13 @@ marks file will be regenerated properly by Gnus.") headers)))) (defun nnml-get-nov-buffer (group) - (let ((buffer (get-buffer-create (format " *nnml overview %s*" group)))) + (let* ((decoded (nnml-decoded-group-name group)) + (buffer (get-buffer-create (format " *nnml overview %s*" decoded))) + (file-name-coding-system nnmail-pathname-coding-system)) (save-excursion (set-buffer buffer) (set (make-local-variable 'nnml-nov-buffer-file-name) - (expand-file-name - nnml-nov-file-name - (nnmail-group-pathname group nnml-directory))) + (nnmail-group-pathname decoded nnml-directory nnml-nov-file-name)) (erase-buffer) (when (file-exists-p nnml-nov-buffer-file-name) (nnheader-insert-file-contents nnml-nov-buffer-file-name))) @@ -759,53 +848,57 @@ marks file will be regenerated properly by Gnus.") (nnml-open-server server)) (setq nnml-directory (expand-file-name nnml-directory)) ;; Recurse down the directories. - (nnml-generate-nov-databases-1 nnml-directory nil t) + (nnml-generate-nov-databases-directory nnml-directory nil t) ;; Save the active file. (nnmail-save-active nnml-group-alist nnml-active-file)) -(defun nnml-generate-nov-databases-1 (dir &optional seen no-active) - "Regenerate the NOV database in DIR." - (interactive "DRegenerate NOV in: ") +(defun nnml-generate-nov-databases-directory (dir &optional seen no-active) + "Regenerate the NOV database in DIR. + +Unless no-active is non-nil, update the active file too." + (interactive (list (let ((file-name-coding-system + nnmail-pathname-coding-system)) + (read-directory-name "Regenerate NOV in: " + nnml-directory nil t)))) (setq dir (file-name-as-directory dir)) - ;; Only scan this sub-tree if we haven't been here yet. - (unless (member (file-truename dir) seen) - (push (file-truename dir) seen) - ;; We descend recursively - (let ((dirs (directory-files dir t nil t)) - dir) - (while (setq dir (pop dirs)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + ;; Only scan this sub-tree if we haven't been here yet. + (unless (member (file-truename dir) seen) + (push (file-truename dir) seen) + ;; We descend recursively + (dolist (dir (directory-files dir t nil t)) (when (and (not (string-match "^\\." (file-name-nondirectory dir))) (file-directory-p dir)) - (nnml-generate-nov-databases-1 dir seen)))) - ;; Do this directory. - (let ((files (sort (nnheader-article-to-file-alist dir) - 'car-less-than-car))) - (if (not files) - (let* ((group (nnheader-file-to-group - (directory-file-name dir) nnml-directory)) - (info (cadr (assoc group nnml-group-alist)))) - (when info - (setcar info (1+ (cdr info))))) - (funcall nnml-generate-active-function dir) - ;; Generate the nov file. - (nnml-generate-nov-file dir files) - (unless no-active - (nnmail-save-active nnml-group-alist nnml-active-file)))))) + (nnml-generate-nov-databases-directory dir seen))) + ;; Do this directory. + (let ((files (sort (nnheader-article-to-file-alist dir) + 'car-less-than-car))) + (if (not files) + (let* ((group (nnheader-file-to-group + (directory-file-name dir) nnml-directory)) + (info (cadr (assoc group nnml-group-alist)))) + (when info + (setcar info (1+ (cdr info))))) + (funcall nnml-generate-active-function dir) + ;; Generate the nov file. + (nnml-generate-nov-file dir files) + (unless no-active + (nnmail-save-active nnml-group-alist nnml-active-file))))))) (eval-when-compile (defvar files)) (defun nnml-generate-active-info (dir) ;; Update the active info for this group. - (let* ((group (nnheader-file-to-group - (directory-file-name dir) nnml-directory)) - (entry (assoc group nnml-group-alist)) - (last (or (caadr entry) 0))) - (setq nnml-group-alist (delq entry nnml-group-alist)) + (let ((group (directory-file-name dir)) + entry last) + (setq group (nnheader-file-to-group (nnml-encoded-group-name group) + nnml-directory) + entry (assoc group nnml-group-alist) + last (or (caadr entry) 0) + nnml-group-alist (delq entry nnml-group-alist)) (push (list group (cons (or (caar files) (1+ last)) (max last - (or (let ((f files)) - (while (cdr f) (setq f (cdr f))) - (caar f)) + (or (caar (last files)) 0)))) nnml-group-alist))) @@ -938,20 +1031,20 @@ Use the nov database for the current group if available." (deffoo nnml-request-update-info (group info &optional server) (nnml-possibly-change-directory group server) - (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group)) + (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group server)) (nnheader-message 8 "Updating marks for %s..." group) (nnml-open-marks group server) ;; Update info using `nnml-marks'. - (mapcar (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnml-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) + (mapc (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nnml-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) (let ((seen (cdr (assq 'read nnml-marks)))) (gnus-info-set-read info (if (and (integerp (car seen)) @@ -961,9 +1054,8 @@ Use the nov database for the current group if available." (nnheader-message 8 "Updating marks for %s...done" group)) info) -(defun nnml-marks-changed-p (group) - (let ((file (expand-file-name nnml-marks-file-name - (nnmail-group-pathname group nnml-directory)))) +(defun nnml-marks-changed-p (group server) + (let ((file (nnml-group-pathname group nnml-marks-file-name server))) (if (null (gnus-gethash file nnml-marks-modtime)) t ;; never looked at marks file, assume it has changed (not (equal (gnus-gethash file nnml-marks-modtime) @@ -971,11 +1063,10 @@ Use the nov database for the current group if available." (defun nnml-save-marks (group server) (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (expand-file-name nnml-marks-file-name - (nnmail-group-pathname group nnml-directory)))) + (file (nnml-group-pathname group nnml-marks-file-name server))) (condition-case err (progn - (nnml-possibly-create-directory group) + (nnml-possibly-create-directory group server) (with-temp-file file (erase-buffer) (gnus-prin1 nnml-marks) @@ -988,9 +1079,10 @@ Use the nov database for the current group if available." (error "Cannot write to %s (%s)" file err)))))) (defun nnml-open-marks (group server) - (let ((file (expand-file-name - nnml-marks-file-name - (nnmail-group-pathname group nnml-directory)))) + (let* ((decoded (nnml-decoded-group-name group server)) + (file (nnmail-group-pathname decoded nnml-directory + nnml-marks-file-name)) + (file-name-coding-system nnmail-pathname-coding-system)) (if (file-exists-p file) (condition-case err (with-temp-buffer @@ -1008,14 +1100,211 @@ Use the nov database for the current group if available." (let ((info (gnus-get-info (gnus-group-prefixed-name group - (gnus-server-to-method (format "nnml:%s" server)))))) - (nnheader-message 7 "Bootstrapping marks for %s..." group) + (gnus-server-to-method + (format "nnml:%s" (or server ""))))))) + (setq decoded (if (member server '(nil "")) + (concat "nnml:" decoded) + (format "nnml+%s:%s" server decoded))) + (nnheader-message 7 "Bootstrapping marks for %s..." decoded) (setq nnml-marks (gnus-info-marks info)) (push (cons 'read (gnus-info-read info)) nnml-marks) (dolist (el gnus-article-unpropagated-mark-lists) (setq nnml-marks (gnus-remassoc el nnml-marks))) (nnml-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) + (nnheader-message 7 "Bootstrapping marks for %s...done" decoded))))) + + +;;; +;;; Group and server compaction. -- dvl +;;; + +;; #### FIXME: this function handles self Xref: entry correctly, but I don't +;; #### know how to handle external cross-references. I actually don't know if +;; #### this is handled correctly elsewhere. For instance, what happens if you +;; #### move all articles to a new group (that's what people do for manual +;; #### compaction) ? + +;; #### NOTE: the function below handles the article backlog. This is +;; #### conceptually the wrong place to do it because the backend is at a +;; #### lower level. However, this is the only place where we have the needed +;; #### information to do the job. Ideally, this function should not handle +;; #### the backlog by itself, but return a list of moved groups / articles to +;; #### the caller. This will become important to avoid code duplication when +;; #### other backends get a compaction feature. Also, note that invalidating +;; #### the "original article buffer" is already done at an upper level. + +;; Shouldn't `nnml-request-compact-group' be interactive? --rsteib + +(defun nnml-request-compact-group (group &optional server save) + (nnml-possibly-change-directory group server) + (unless nnml-article-file-alist + (setq nnml-article-file-alist + (sort (nnml-current-group-article-to-file-alist) + 'car-less-than-car))) + (if (not nnml-article-file-alist) + ;; The group is empty: do nothing but return t + t + ;; The group is not empty: + (let* ((group-full-name + (gnus-group-prefixed-name + group + (gnus-server-to-method (format "nnml:%s" server)))) + (info (gnus-get-info group-full-name)) + (new-number 1) + compacted) + (let ((articles nnml-article-file-alist) + article) + (while (setq article (pop articles)) + (let ((old-number (car article))) + (when (> old-number new-number) + ;; There is a gap here: + (let ((old-number-string (int-to-string old-number)) + (new-number-string (int-to-string new-number))) + (setq compacted t) + ;; #### NOTE: `nnml-article-to-file' calls + ;; #### `nnml-update-file-alist' (which in turn calls + ;; #### `nnml-current-group-article-to-file-alist', which + ;; #### might use the NOV database). This might turn out to be + ;; #### inefficient. In that case, we will do the work + ;; #### manually. + ;; 1/ Move the article to a new file: + (let* ((oldfile (nnml-article-to-file old-number)) + (newfile + (gnus-replace-in-string + oldfile + ;; nnml-use-compressed-files might be any string, but + ;; probably it's sufficient to take into account only + ;; "\\.[a-z0-9]+". Note that we can't only use the + ;; value of nnml-use-compressed-files because old + ;; articles might have been saved with a different + ;; value. + (concat + "\\(" old-number-string "\\)\\(\\(\\.[a-z0-9]+\\)?\\)$") + (concat new-number-string "\\2")))) + (with-current-buffer nntp-server-buffer + (nnmail-find-file oldfile) + ;; Update the Xref header in the article itself: + (when (and (re-search-forward "^Xref: [^ ]+ " nil t) + (re-search-forward + (concat "\\<" + (regexp-quote + (concat group ":" old-number-string)) + "\\>") + (point-at-eol) t)) + (replace-match + (concat group ":" new-number-string))) + ;; Save to the new file: + (nnmail-write-region (point-min) (point-max) newfile)) + (funcall nnmail-delete-file-function oldfile)) + ;; 2/ Update all marks for this article: + ;; #### NOTE: it is possible that the new article number + ;; #### already belongs to a range, whereas the corresponding + ;; #### article doesn't exist (for example, if you delete an + ;; #### article). For that reason, it is important to update + ;; #### the ranges (meaning remove inexistant articles) before + ;; #### doing anything on them. + ;; 2 a/ read articles: + (let ((read (gnus-info-read info))) + (setq read (gnus-remove-from-range read (list new-number))) + (when (gnus-member-of-range old-number read) + (setq read (gnus-remove-from-range read (list old-number))) + (setq read (gnus-add-to-range read (list new-number)))) + (gnus-info-set-read info read)) + ;; 2 b/ marked articles: + (let ((oldmarks (gnus-info-marks info)) + mark newmarks) + (while (setq mark (pop oldmarks)) + (setcdr mark (gnus-remove-from-range (cdr mark) + (list new-number))) + (when (gnus-member-of-range old-number (cdr mark)) + (setcdr mark (gnus-remove-from-range (cdr mark) + (list old-number))) + (setcdr mark (gnus-add-to-range (cdr mark) + (list new-number)))) + (push mark newmarks)) + (gnus-info-set-marks info newmarks)) + ;; 3/ Update the NOV entry for this article: + (unless nnml-nov-is-evil + (save-excursion + (set-buffer (nnml-open-nov group)) + (when (nnheader-find-nov-line old-number) + ;; Replace the article number: + (looking-at old-number-string) + (replace-match new-number-string nil t) + ;; Update the Xref header: + (when (re-search-forward + (concat "\\(Xref:[^\t\n]* \\)\\<" + (regexp-quote + (concat group ":" old-number-string)) + "\\>") + (point-at-eol) t) + (replace-match + (concat "\\1" group ":" new-number-string)))))) + ;; 4/ Possibly remove the article from the backlog: + (when gnus-keep-backlog + ;; #### NOTE: instead of removing the article, we could + ;; #### modify the backlog to reflect the numbering change, + ;; #### but I don't think it's worth it. + (gnus-backlog-remove-article group-full-name old-number) + (gnus-backlog-remove-article group-full-name new-number)))) + (setq new-number (1+ new-number))))) + (if (not compacted) + ;; No compaction had to be done: + t + ;; Some articles have actually been renamed: + ;; 1/ Rebuild active information: + (let ((entry (assoc group nnml-group-alist)) + (active (cons 1 (1- new-number)))) + (setq nnml-group-alist (delq entry nnml-group-alist)) + (push (list group active) nnml-group-alist) + ;; Update the active hashtable to let the *Group* buffer display + ;; up-to-date lines. I don't think that either gnus-newsrc-hashtb or + ;; gnus-newwrc-alist are out of date, since all we did is to modify + ;; the info of the group internally. + (gnus-set-active group-full-name active)) + ;; 1 bis/ + ;; #### NOTE: normally, we should save the overview (NOV) file + ;; #### here, just like we save the marks file. However, there is no + ;; #### such function as nnml-save-nov for a single group. Only for + ;; #### all groups. Gnus inconsistency is getting worse every day... + ;; 2/ Rebuild marks file: + (unless nnml-marks-is-evil + ;; #### NOTE: this constant use of global variables everywhere is + ;; #### truly disgusting. Gnus really needs a *major* cleanup. + (setq nnml-marks (gnus-info-marks info)) + (push (cons 'read (gnus-info-read info)) nnml-marks) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nnml-marks (gnus-remassoc el nnml-marks))) + (nnml-save-marks group server)) + ;; 3/ Save everything if this was not part of a bigger operation: + (if (not save) + ;; Nothing to save (yet): + t + ;; Something to save: + ;; a/ Save the NOV databases: + ;; #### NOTE: this should be done directory per directory in 1bis + ;; #### above. See comment there. + (nnml-save-nov) + ;; b/ Save the active file: + (nnmail-save-active nnml-group-alist nnml-active-file) + t))))) + +(defun nnml-request-compact (&optional server) + "Request compaction of all SERVER nnml groups." + (interactive (list (or (nnoo-current-server 'nnml) ""))) + (nnmail-activate 'nnml) + (unless (nnml-server-opened server) + (nnml-open-server server)) + (setq nnml-directory (expand-file-name nnml-directory)) + (let* ((groups (gnus-groups-from-server + (gnus-server-to-method (format "nnml:%s" server)))) + (first (pop groups)) + group) + (when first + (while (setq group (pop groups)) + (nnml-request-compact-group (gnus-group-real-name group) server)) + (nnml-request-compact-group (gnus-group-real-name first) server t)))) + (provide 'nnml) diff --git a/lisp/gnus/nnnil.el b/lisp/gnus/nnnil.el index 3508a7dd94f..926553365d3 100644 --- a/lisp/gnus/nnnil.el +++ b/lisp/gnus/nnnil.el @@ -32,8 +32,7 @@ (defvar nnnil-status-string "") (defun nnnil-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer)) 'nov) @@ -69,8 +68,7 @@ t) (defun nnnil-request-list (&optional server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer)) t) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index af2a3e2ea62..5241f9d80e6 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -50,6 +50,15 @@ (defvoo nnrss-directory (nnheader-concat gnus-directory "rss/") "Where nnrss will save its files.") +(defvoo nnrss-ignore-article-fields '(slash:comments) + "*List of fields that should be ignored when comparing RSS articles. +Some RSS feeds update article fields during their lives, e.g. to +indicate the number of comments or the number of times the +articles have been seen. However, if there is a difference +between the local article and the distant one, the latter is +considered to be new. To avoid this and discard some fields, set +this variable to the list of fields to be ignored.") + ;; (group max rss-url) (defvoo nnrss-server-data nil) @@ -58,7 +67,7 @@ (defvoo nnrss-group-max 0) (defvoo nnrss-group-min 1) (defvoo nnrss-group nil) -(defvoo nnrss-group-hashtb nil) +(defvoo nnrss-group-hashtb (make-hash-table :test 'equal)) (defvoo nnrss-status-string "") (defconst nnrss-version "nnrss 1.0") @@ -83,7 +92,13 @@ ENTRY is the record of the current headline. GROUP is the group name. ARTICLE is the article number of the current headline.") (defvar nnrss-file-coding-system mm-universal-coding-system - "Coding system used when reading and writing files.") + "*Coding system used when reading and writing files. +If you run Gnus with various versions of Emacsen, the value of this +variable should be the coding system that all those Emacsen support. +Note that you have to regenerate all the nnrss groups if you change +the value. Moreover, you should be patient even if you are made to +read the same articles twice, that arises for the difference of the +versions of xml.el.") (defvar nnrss-compatible-encoding-alist (delq nil (mapcar (lambda (elem) @@ -365,7 +380,8 @@ used to render text. If it is nil, text will simply be folded.") (delq (assoc group nnrss-server-data) nnrss-server-data)) (nnrss-save-server-data server) (ignore-errors - (delete-file (nnrss-make-filename group server))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (delete-file (nnrss-make-filename group server)))) t) (deffoo nnrss-request-list-newsgroups (&optional server) @@ -391,10 +407,10 @@ return `utf-8' which is the default encoding for xml if it is available, otherwise return nil." (goto-char (point-min)) (if (re-search-forward - "<\\?[^>]*encoding=\\(\"\\([^\">]+\\)\"\\|'\\([^'>]+\\)'\\)" + "<\\?[^>]*encoding=\\(?:\"\\([^\">]+\\)\"\\|'\\([^'>]+\\)'\\)" nil t) - (let ((encoding (intern (downcase (or (match-string 2) - (match-string 3)))))) + (let ((encoding (intern (downcase (or (match-string 1) + (match-string 2)))))) (or (mm-coding-system-p (cdr (assq encoding nnrss-compatible-encoding-alist))) @@ -462,8 +478,7 @@ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s" (defun nnrss-generate-active () (when (y-or-n-p "Fetch extra categories? ") - (dolist (func nnrss-extra-categories) - (funcall func))) + (mapc 'funcall nnrss-extra-categories)) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) @@ -500,37 +515,37 @@ which RSS 2.0 allows." (concat ;; 1. year "\\(199[0-9]\\|20[0-9][0-9]\\)" - "\\(-" - ;; 3. month + "\\(?:-" + ;; 2. month "\\([01][0-9]\\)" - "\\(-" - ;; 5. day + "\\(?:-" + ;; 3. day "\\([0-3][0-9]\\)" - "\\)?\\)?\\(T" - ;; 7. hh:mm + "\\)?\\)?\\(?:T" + ;; 4. hh:mm "\\([012][0-9]:[0-5][0-9]\\)" - "\\(" - ;; 9. :ss + "\\(?:" + ;; 5. :ss "\\(:[0-5][0-9]\\)" - "\\(\\.[0-9]+\\)?\\)?\\)?" - ;; 13+14,15,16. zone - "\\(\\(\\([+-][012][0-9]\\):\\([0-5][0-9]\\)\\)" + "\\(?:\\.[0-9]+\\)?\\)?\\)?" + ;; 6+7,8,9. zone + "\\(?:\\(?:\\([+-][012][0-9]\\):\\([0-5][0-9]\\)\\)" "\\|\\([+-][012][0-9][0-5][0-9]\\)" "\\|\\(Z\\)\\)?")) date) (setq year (string-to-number (match-string 1 date)) - month (string-to-number (or (match-string 3 date) "1")) - day (string-to-number (or (match-string 5 date) "1")) - time (if (match-beginning 9) - (substring date (match-beginning 7) (match-end 9)) - (concat (or (match-string 7 date) "00:00") ":00")) - zone (cond ((match-beginning 13) - (concat (match-string 13 date) - (match-string 14 date))) - ((match-beginning 16) ;; Z + month (string-to-number (or (match-string 2 date) "1")) + day (string-to-number (or (match-string 3 date) "1")) + time (if (match-beginning 5) + (substring date (match-beginning 4) (match-end 5)) + (concat (or (match-string 4 date) "00:00") ":00")) + zone (cond ((match-beginning 6) + (concat (match-string 6 date) + (match-string 7 date))) + ((match-beginning 9) ;; Z "+0000") (t ;; nil if zone is not provided. - (match-string 15 date)))))) + (match-string 8 date)))))) (if month (progn (setq cts (current-time-string (encode-time 0 0 0 day month year))) @@ -545,13 +560,13 @@ which RSS 2.0 allows." (defun nnrss-read-server-data (server) (setq nnrss-server-data nil) - (let ((file (nnrss-make-filename "nnrss" server))) + (let ((file (nnrss-make-filename "nnrss" server)) + (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII ;; file names. So, we use `insert-file-contents' instead. (mm-with-multibyte-buffer - (let ((coding-system-for-read nnrss-file-coding-system) - (file-name-coding-system nnmail-pathname-coding-system)) + (let ((coding-system-for-read nnrss-file-coding-system)) (insert-file-contents file) (eval-region (point-min) (point-max))))))) @@ -568,21 +583,23 @@ which RSS 2.0 allows." (defun nnrss-read-group-data (group server) (setq nnrss-group-data nil) - (setq nnrss-group-hashtb (gnus-make-hashtable)) + (if (hash-table-p nnrss-group-hashtb) + (clrhash nnrss-group-hashtb) + (setq nnrss-group-hashtb (make-hash-table :test 'equal))) (let ((pair (assoc group nnrss-server-data))) (setq nnrss-group-max (or (cadr pair) 0)) (setq nnrss-group-min (+ nnrss-group-max 1))) - (let ((file (nnrss-make-filename group server))) + (let ((file (nnrss-make-filename group server)) + (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII ;; file names. So, we use `insert-file-contents' instead. (mm-with-multibyte-buffer - (let ((coding-system-for-read nnrss-file-coding-system) - (file-name-coding-system nnmail-pathname-coding-system)) + (let ((coding-system-for-read nnrss-file-coding-system)) (insert-file-contents file) (eval-region (point-min) (point-max)))) (dolist (e nnrss-group-data) - (gnus-sethash (or (nth 2 e) (nth 6 e)) t nnrss-group-hashtb) + (puthash (nth 9 e) t nnrss-group-hashtb) (when (and (car e) (> nnrss-group-min (car e))) (setq nnrss-group-min (car e))) (when (and (car e) (< nnrss-group-max (car e))) @@ -662,9 +679,20 @@ which RSS 2.0 allows." ;;; Snarf functions +(defun nnrss-make-hash-index (item) + (setq item (gnus-remove-if + (lambda (field) + (when (listp field) + (memq (car field) nnrss-ignore-article-fields))) + item)) + (md5 (gnus-prin1-to-string item) + nil nil + nnrss-file-coding-system)) + (defun nnrss-check-group (group server) (let (file xml subject url extra changed author date feed-subject - enclosure comments rss-ns rdf-ns content-ns dc-ns) + enclosure comments rss-ns rdf-ns content-ns dc-ns + hash-index) (if (and nnrss-use-local (file-exists-p (setq file (expand-file-name (nnrss-translate-file-chars @@ -696,15 +724,12 @@ which RSS 2.0 allows." (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml))) (when (and (listp item) (string= (concat rss-ns "item") (car item)) - (if (setq url (nnrss-decode-entities-string - (nnrss-node-text rss-ns 'link (cddr item)))) - (not (gnus-gethash url nnrss-group-hashtb)) - (setq extra (or (nnrss-node-text content-ns 'encoded item) - (nnrss-node-text rss-ns 'description item))) - (not (gnus-gethash extra nnrss-group-hashtb)))) + (progn (setq hash-index (nnrss-make-hash-index item)) + (not (gethash hash-index nnrss-group-hashtb)))) (setq subject (nnrss-node-text rss-ns 'title item)) - (setq extra (or extra - (nnrss-node-text content-ns 'encoded item) + (setq url (nnrss-decode-entities-string + (nnrss-node-text rss-ns 'link (cddr item)))) + (setq extra (or (nnrss-node-text content-ns 'encoded item) (nnrss-node-text rss-ns 'description item))) (if (setq feed-subject (nnrss-node-text dc-ns 'subject item)) (setq extra (concat feed-subject "<br /><br />" extra))) @@ -746,9 +771,10 @@ which RSS 2.0 allows." date (and extra (nnrss-decode-entities-string extra)) enclosure - comments) + comments + hash-index) nnrss-group-data) - (gnus-sethash (or url extra) t nnrss-group-hashtb) + (puthash hash-index t nnrss-group-hashtb) (setq changed t)) (setq extra nil)) (when changed @@ -947,7 +973,7 @@ whether they are `offsite' or `onsite'." (let (rss-onsite-end rdf-onsite-end xml-onsite-end rss-onsite-in rdf-onsite-in xml-onsite-in rss-offsite-end rdf-offsite-end xml-offsite-end - rss-offsite-in rdf-offsite-in xml-offsite-in) + rss-offsite-in rdf-offsite-in xml-offsite-in) (dolist (href hrefs) (cond ((null href)) ((string-match "\\.rss$" href) diff --git a/lisp/gnus/nnslashdot.el b/lisp/gnus/nnslashdot.el index ee97f7085c8..04e998c76ba 100644 --- a/lisp/gnus/nnslashdot.el +++ b/lisp/gnus/nnslashdot.el @@ -459,11 +459,9 @@ (insert-file-contents file) (goto-char (point-min)) (setq nnslashdot-groups (read (current-buffer)))) - (if (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5)) - (let ((groups nnslashdot-groups)) - (while groups - (nnslashdot-make-tuple (car groups) 5) - (setq groups (cdr groups)))))))) + (when (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5)) + (dolist (group nnslashdot-groups) + (nnslashdot-make-tuple group 5)))))) (defun nnslashdot-write-groups () (with-temp-file (expand-file-name "groups" nnslashdot-directory) diff --git a/lisp/gnus/nnsoup.el b/lisp/gnus/nnsoup.el index 8167ba2bf4e..1053ecc413c 100644 --- a/lisp/gnus/nnsoup.el +++ b/lisp/gnus/nnsoup.el @@ -371,9 +371,7 @@ backend for the messages.") entry e min max) (while (setq e (cdr (setq entry (pop alist)))) (setq min (caaar e)) - (while (cdr e) - (setq e (cdr e))) - (setq max (cdar (car e))) + (setq max (cdar (car (last e)))) (setcdr entry (cons (cons min max) (cdr entry))))) (setq nnsoup-group-alist-touched t)) nnsoup-group-alist)) @@ -558,9 +556,8 @@ backend for the messages.") (defun nnsoup-unpack-packets () "Unpack all packets in `nnsoup-packet-directory'." (let ((packets (directory-files - nnsoup-packet-directory t nnsoup-packet-regexp)) - packet) - (while (setq packet (pop packets)) + nnsoup-packet-directory t nnsoup-packet-regexp))) + (dolist (packet packets) (nnheader-message 5 "nnsoup: unpacking %s..." packet) (if (not (gnus-soup-unpack-packet nnsoup-tmp-directory nnsoup-unpacker packet)) @@ -759,20 +756,18 @@ backend for the messages.") (string-to-number (match-string 1 f2))))))) active group lines ident elem min) (set-buffer (get-buffer-create " *nnsoup work*")) - (while files - (nnheader-message 5 "Doing %s..." (car files)) + (dolist (file files) + (nnheader-message 5 "Doing %s..." file) (erase-buffer) - (nnheader-insert-file-contents (car files)) + (nnheader-insert-file-contents file) (goto-char (point-min)) (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t)) (setq group "unknown") (setq group (match-string 2))) (setq lines (count-lines (point-min) (point-max))) (setq ident (progn (string-match - "/\\([0-9]+\\)\\." (car files)) - (substring - (car files) (match-beginning 1) - (match-end 1)))) + "/\\([0-9]+\\)\\." file) + (match-string 1 file))) (if (not (setq elem (assoc group active))) (push (list group (cons 1 lines) (list (cons 1 lines) @@ -783,8 +778,7 @@ backend for the messages.") (list (cons (1+ (setq min (cdadr elem))) (+ min lines)) (vector ident group "ucm" "" lines)))) - (setcdr (cadr elem) (+ min lines))) - (setq files (cdr files))) + (setcdr (cadr elem) (+ min lines)))) (nnheader-message 5 "") (setq nnsoup-group-alist active) (nnsoup-write-active-file t))) @@ -801,9 +795,9 @@ backend for the messages.") nnsoup-group-alist))) (regexp "\\.MSG$\\|\\.IDX$") (files (directory-files nnsoup-directory nil regexp)) - non-files file) + non-files) ;; Find all files that aren't known by nnsoup. - (while (setq file (pop files)) + (dolist (file files) (string-match regexp file) (unless (member (substring file 0 (match-beginning 0)) known) (push file non-files))) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 39fa1874d3b..0861f5c85a3 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -246,13 +246,11 @@ there.") ;; Yes, completely empty spool directories *are* possible. ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu> (when (setq dir (directory-files pathname nil "^[0-9]+$" t)) - (setq dir - (sort (mapcar (lambda (name) (string-to-number name)) dir) '<))) + (setq dir (sort (mapcar 'string-to-number dir) '<))) (if dir (nnheader-insert "211 %d %d %d %s\n" (length dir) (car dir) - (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) - group) + (car (last dir)) group) (nnheader-report 'nnspool "Empty group %s" group) (nnheader-insert "211 0 0 0 %s\n" group)))))) @@ -311,9 +309,8 @@ there.") groups) (zerop (forward-line -1)))) (erase-buffer) - (while groups - (insert (car groups) " 0 0 y\n") - (setq groups (cdr groups)))) + (dolist (group groups) + (insert group " 0 0 y\n"))) t) nil)) @@ -400,8 +397,7 @@ there.") (<= last (car arts))) (pop arts)) ;; The articles in `arts' are missing from the buffer. - (while arts - (nnspool-insert-nov-head (pop arts))) + (mapc 'nnspool-insert-nov-head arts) t)))))))))) (defun nnspool-insert-nov-head (article) @@ -421,8 +417,7 @@ there.") (defun nnspool-sift-nov-with-sed (articles file) (let ((first (car articles)) - (last (progn (while (cdr articles) (setq articles (cdr articles))) - (car articles)))) + (last (car (last articles)))) (call-process "awk" nil t nil (format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}" (1- first) (1+ last)) @@ -431,16 +426,12 @@ there.") ;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle). ;; Find out what group an article identified by a Message-ID is in. (defun nnspool-find-id (id) - (save-excursion - (set-buffer (get-buffer-create " *nnspool work*")) - (erase-buffer) + (with-temp-buffer (ignore-errors (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file)) (goto-char (point-min)) - (prog1 - (when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]") - (cons (match-string 1) (string-to-number (match-string 2)))) - (kill-buffer (current-buffer))))) + (when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]") + (cons (match-string 1) (string-to-number (match-string 2)))))) (defun nnspool-find-file (file) "Insert FILE in server buffer safely." diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 2623df58e4d..c8c14da4df7 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -31,6 +31,8 @@ (require 'nnheader) (require 'nnoo) (require 'gnus-util) +(require 'gnus) +(require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) @@ -86,6 +88,7 @@ Direct connections: Indirect connections: - `nntp-open-via-rlogin-and-telnet', +- `nntp-open-via-rlogin-and-netcat', - `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-never-echoes-commands nil @@ -109,20 +112,22 @@ This is where you would put \"runsocks\" or stuff like that.") (defvoo nntp-telnet-command "telnet" "*Telnet command used to connect to the nntp server. -This command is used by the various nntp-open-via-* methods.") +This command is used by the methods `nntp-open-telnet-stream', +`nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-telnet-switches '("-8") "*Switches given to the telnet command `nntp-telnet-command'.") (defvoo nntp-end-of-line "\r\n" "*String to use on the end of lines when talking to the NNTP server. -This is \"\\r\\n\" by default, but should be \"\\n\" when -using an indirect connection method (nntp-open-via-*).") +This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect +connection method (nntp-open-via-*).") (defvoo nntp-via-rlogin-command "rsh" "*Rlogin command used to connect to an intermediate host. -This command is used by the `nntp-open-via-rlogin-and-telnet' method. -The default is \"rsh\", but \"ssh\" is a popular alternative.") +This command is used by the methods `nntp-open-via-rlogin-and-telnet' +and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\" +is a popular alternative.") (defvoo nntp-via-rlogin-command-switches nil "*Switches given to the rlogin command `nntp-via-rlogin-command'. @@ -138,9 +143,16 @@ This command is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-telnet-switches '("-8") "*Switches given to the telnet command `nntp-via-telnet-command'.") +(defvoo nntp-via-netcat-command "nc" + "*Netcat command used to connect to the nntp server. +This command is used by the `nntp-open-via-rlogin-and-netcat' method.") + +(defvoo nntp-via-netcat-switches nil + "*Switches given to the netcat command `nntp-via-netcat-command'.") + (defvoo nntp-via-user-name nil "*User name to log in on an intermediate host with. -This variable is used by the `nntp-open-via-telnet-and-telnet' method.") +This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-user-password nil "*Password to use to log in on an intermediate host with. @@ -148,8 +160,7 @@ This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-address nil "*Address of an intermediate host to connect to. -This variable is used by the `nntp-open-via-rlogin-and-telnet' and -`nntp-open-via-telnet-and-telnet' methods.") +This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-envuser nil "*Whether both telnet client and server support the ENVIRON option. @@ -206,6 +217,21 @@ server there that you can connect to. See also (defvoo nntp-coding-system-for-write 'binary "*Coding system to write to NNTP.") +;; Marks +(defvoo nntp-marks-is-evil nil + "*If non-nil, Gnus will never generate and use marks file for nntp groups. +See `nnml-marks-is-evil' for more information.") + +(defvoo nntp-marks-file-name ".marks") +(defvoo nntp-marks nil) +(defvar nntp-marks-modtime (gnus-make-hashtable)) + +(defcustom nntp-marks-directory + (nnheader-concat gnus-directory "marks/") + "*The directory where marks for nntp groups will be stored." + :group 'nntp + :type 'directory) + (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :group 'nntp @@ -252,6 +278,7 @@ to insert Cancel-Lock headers.") (defvoo nntp-last-command nil) (defvoo nntp-authinfo-password nil) (defvoo nntp-authinfo-user nil) +(defvoo nntp-authinfo-force nil) (defvar nntp-connection-list nil) @@ -339,14 +366,16 @@ be restored and the command retried." (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." + (save-excursion (set-buffer (process-buffer process)) (goto-char (point-min)) + (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) (looking-at "48[02]")) (memq (process-status process) '(open run))) (cond ((looking-at "480") - (nntp-handle-authinfo process)) + (nntp-handle-authinfo process)) ((looking-at "482") (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message)) (signal 'nntp-authinfo-rejected nil)) @@ -394,6 +423,11 @@ be restored and the command retried." (kill-buffer buffer) (nnheader-init-server-buffer))) +(defun nntp-erase-buffer (buffer) + "Erase contents of BUFFER." + (with-current-buffer buffer + (erase-buffer))) + (defsubst nntp-find-connection (buffer) "Find the connection delivering to BUFFER." (let ((alist nntp-connection-alist) @@ -428,9 +462,7 @@ be restored and the command retried." (if process (progn (unless (or nntp-inhibit-erase nnheader-callback-function) - (save-excursion - (set-buffer (process-buffer process)) - (erase-buffer))) + (nntp-erase-buffer (process-buffer process))) (condition-case err (progn (when command @@ -459,9 +491,7 @@ be restored and the command retried." "Send STRINGS to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))) + (nntp-erase-buffer nntp-server-buffer)) (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) @@ -488,8 +518,7 @@ be restored and the command retried." (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) - (gnus-point-at-bol)))) - ))) + (point-at-bol))))))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) @@ -513,7 +542,7 @@ be restored and the command retried." (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) - (gnus-point-at-bol))))))) + (point-at-bol))))))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) @@ -521,9 +550,7 @@ be restored and the command retried." "Send STRINGS to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))) + (nntp-erase-buffer nntp-server-buffer)) (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) @@ -538,11 +565,11 @@ be restored and the command retried." (unless wait-for (nntp-accept-response) (save-excursion - (set-buffer buffer) - (goto-char pos) - (if (looking-at (regexp-quote command)) - (delete-region pos (progn (forward-line 1) (gnus-point-at-bol)))) - ))) + (set-buffer buffer) + (goto-char pos) + (if (looking-at (regexp-quote command)) + (delete-region pos (progn (forward-line 1) (point-at-bol)))) + ))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) @@ -551,9 +578,8 @@ be restored and the command retried." "Send the current buffer to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) - (save-excursion - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - (erase-buffer))) + (nntp-erase-buffer + (nntp-find-connection-buffer nntp-server-buffer))) (nntp-encode-text) (mm-with-unibyte-current-buffer ;; Some encoded unicode text contains character 0x80-0x9f e.g. Euro. @@ -575,7 +601,12 @@ be restored and the command retried." ;; a line with only a "." on it. ((eq (char-after) ?2) (if (re-search-forward "\n\\.\r?\n" nil t) - t + (progn + ;; Some broken news servers add another dot at the end. + ;; Protect against inflooping there. + (while (looking-at "^\\.\r?\n") + (forward-line 1)) + t) nil)) ;; A result that starts with a 3xx or 4xx code is terminated ;; by a newline. @@ -615,7 +646,7 @@ command whose response triggered the error." (let ((timer (and nntp-connection-timeout - (nnheader-run-at-time + (run-at-time nntp-connection-timeout nil '(lambda () (let ((process (nntp-find-connection @@ -637,7 +668,8 @@ command whose response triggered the error." (condition-case nil (progn ,@forms) (quit - (nntp-close-server) + (unless debug-on-quit + (nntp-close-server)) (signal 'quit nil)))) (when timer (nnheader-cancel-timer timer))) @@ -717,8 +749,7 @@ command whose response triggered the error." (catch 'done (save-excursion ;; Erase nntp-server-buffer before nntp-inhibit-erase. - (set-buffer nntp-server-buffer) - (erase-buffer) + (nntp-erase-buffer nntp-server-buffer) (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) ;; The first time this is run, this variable is `try'. So we ;; try. @@ -1046,6 +1077,54 @@ command whose response triggered the error." (deffoo nntp-asynchronous-p () t) +(deffoo nntp-request-set-mark (group actions &optional server) + (unless nntp-marks-is-evil + (nntp-possibly-create-directory group server) + (nntp-open-marks group server) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (assert (or (eq what 'add) (eq what 'del)) nil + "Unknown request-set-mark action: %s" what) + (dolist (mark marks) + (setq nntp-marks (gnus-update-alist-soft + mark + (funcall (if (eq what 'add) 'gnus-range-add + 'gnus-remove-from-range) + (cdr (assoc mark nntp-marks)) range) + nntp-marks))))) + (nntp-save-marks group server)) + nil) + +(deffoo nntp-request-update-info (group info &optional server) + (unless nntp-marks-is-evil + (nntp-possibly-create-directory group server) + (when (nntp-marks-changed-p group server) + (nnheader-message 8 "Updating marks for %s..." group) + (nntp-open-marks group server) + ;; Update info using `nntp-marks'. + (mapc (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nntp-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) + (let ((seen (cdr (assq 'read nntp-marks)))) + (gnus-info-set-read info + (if (and (integerp (car seen)) + (null (cdr seen))) + (list (cons (car seen) (car seen))) + seen))) + (nnheader-message 8 "Updating marks for %s...done" group))) + nil) + + + ;;; Hooky functions. (defun nntp-send-mode-reader () @@ -1063,11 +1142,11 @@ and a password. If SEND-IF-FORCE, only send authinfo to the server if the .authinfo file has the FORCE token." - (let* ((list (gnus-parse-netrc nntp-authinfo-file)) - (alist (gnus-netrc-machine list nntp-address "nntp")) - (force (gnus-netrc-get alist "force")) - (user (or (gnus-netrc-get alist "login") nntp-authinfo-user)) - (passwd (gnus-netrc-get alist "password"))) + (let* ((list (netrc-parse nntp-authinfo-file)) + (alist (netrc-machine list nntp-address "nntp")) + (force (or (netrc-get alist "force") nntp-authinfo-force)) + (user (or (netrc-get alist "login") nntp-authinfo-user)) + (passwd (netrc-get alist "password"))) (when (or (not send-if-force) force) (unless user @@ -1106,7 +1185,7 @@ password contained in '~/.nntp-authinfo'." (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" - (buffer-substring (point) (gnus-point-at-eol)))))) + (buffer-substring (point) (point-at-eol)))))) ;;; Internal functions. @@ -1116,9 +1195,7 @@ password contained in '~/.nntp-authinfo'." (funcall nntp-authinfo-function) ;; We have to re-send the function that was interrupted by ;; the authinfo request. - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) + (nntp-erase-buffer nntp-server-buffer) (nntp-send-string process last))) (defun nntp-make-process-buffer (buffer) @@ -1144,7 +1221,7 @@ password contained in '~/.nntp-authinfo'." (let* ((pbuffer (nntp-make-process-buffer buffer)) (timer (and nntp-connection-timeout - (nnheader-run-at-time + (run-at-time nntp-connection-timeout nil `(lambda () (nntp-kill-buffer ,pbuffer))))) @@ -1155,7 +1232,7 @@ password contained in '~/.nntp-authinfo'." (funcall nntp-open-connection-function pbuffer)) (error nil) (quit - (message "Quit opening connection") + (message "Quit opening connection to %s" nntp-address) (nntp-kill-buffer pbuffer) (signal 'quit nil) nil)))) @@ -1223,12 +1300,9 @@ password contained in '~/.nntp-authinfo'." "Find out what the name of the server we have connected to is." ;; Wait for the status string to arrive. (setq nntp-server-type (buffer-string)) - (let ((alist nntp-server-action-alist) - (case-fold-search t) - entry) + (let ((case-fold-search t)) ;; Run server-specific commands. - (while alist - (setq entry (pop alist)) + (dolist (entry nntp-server-action-alist) (when (string-match (car entry) nntp-server-type) (if (and (listp (cadr entry)) (not (eq 'lambda (caadr entry)))) @@ -1254,7 +1328,7 @@ password contained in '~/.nntp-authinfo'." ;; doesn't trigger after-change-functions. (unless nntp-async-timer (setq nntp-async-timer - (nnheader-run-at-time 1 1 'nntp-async-timer-handler))) + (run-at-time 1 1 'nntp-async-timer-handler))) (add-to-list 'nntp-async-process-list process)) (defun nntp-async-timer-handler () @@ -1340,22 +1414,22 @@ password contained in '~/.nntp-authinfo'." (defun nntp-accept-process-output (process) "Wait for output from PROCESS and message some dots." - (save-excursion - (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer) - nntp-server-buffer)) + (with-current-buffer (or (nntp-find-connection-buffer nntp-server-buffer) + nntp-server-buffer) (let ((len (/ (buffer-size) 1024)) message-log-max) (unless (< len 10) (setq nntp-have-messaged t) (nnheader-message 7 "nntp read: %dk" len))) - (nnheader-accept-process-output process) - ;; accept-process-output may update status of process to indicate - ;; that the server has closed the connection. This MUST be - ;; handled here as the buffer restored by the save-excursion may - ;; be the process's former output buffer (i.e. now killed) - (or (and process - (memq (process-status process) '(open run))) - (nntp-report "Server closed connection")))) + (prog1 + (nnheader-accept-process-output process) + ;; accept-process-output may update status of process to indicate + ;; that the server has closed the connection. This MUST be + ;; handled here as the buffer restored by the save-excursion may + ;; be the process's former output buffer (i.e. now killed) + (or (and process + (memq (process-status process) '(open run))) + (nntp-report "Server closed connection"))))) (defun nntp-accept-response () "Wait for output from the process that outputs to BUFFER." @@ -1382,9 +1456,7 @@ password contained in '~/.nntp-authinfo'." (nntp-send-command "^[245].*\n" "GROUP" group) (setcar (cddr entry) group) (erase-buffer) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)))))))) + (nntp-erase-buffer nntp-server-buffer))))))) (defun nntp-decode-text (&optional cr-only) "Decode the text in the current buffer." @@ -1594,10 +1666,8 @@ password contained in '~/.nntp-authinfo'." (setq commands (cdr commands))) ;; If none of the commands worked, we disable XOVER. (when (eq nntp-server-xover 'try) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq nntp-server-xover nil))) + (nntp-erase-buffer nntp-server-buffer) + (setq nntp-server-xover nil)) nntp-server-xover)))) (defun nntp-find-group-and-number (&optional group) @@ -1847,6 +1917,36 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc)) +(defun nntp-open-via-rlogin-and-netcat (buffer) + "Open a connection to an nntp server through an intermediate host. +First rlogin to the remote host, and then connect to the real news +server from there using the netcat command. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-via-rlogin-command', +- `nntp-via-rlogin-command-switches', +- `nntp-via-user-name', +- `nntp-via-address', +- `nntp-via-netcat-command', +- `nntp-via-netcat-switches', +- `nntp-address', +- `nntp-port-number', +- `nntp-end-of-line'." + (let ((command `(,@(when nntp-pre-command + (list nntp-pre-command)) + ,nntp-via-rlogin-command + ,@(when nntp-via-rlogin-command-switches + nntp-via-rlogin-command-switches) + ,@(when nntp-via-user-name + (list "-l" nntp-via-user-name)) + ,nntp-via-address + ,nntp-via-netcat-command + ,@nntp-via-netcat-switches + ,nntp-address + ,nntp-port-number))) + (apply 'start-process "nntpd" buffer command))) + (defun nntp-open-via-telnet-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. First telnet the remote host, and then telnet the real news server @@ -1922,6 +2022,96 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc))) +;; Marks handling + +(defun nntp-marks-directory (server) + (expand-file-name server nntp-marks-directory)) + +(defvar nntp-server-to-method-cache nil + "Alist of servers and select methods.") + +(defun nntp-group-pathname (server group &optional file) + "Return an absolute file name of FILE for GROUP on SERVER." + (let ((method (cdr (assoc server nntp-server-to-method-cache)))) + (unless method + (push (cons server (setq method (or (gnus-server-to-method server) + (gnus-find-method-for-group group)))) + nntp-server-to-method-cache)) + (nnmail-group-pathname + (mm-decode-coding-string group + (inline (gnus-group-name-charset method group))) + (nntp-marks-directory server) + file))) + +(defun nntp-possibly-create-directory (group server) + (let ((dir (nntp-group-pathname server group)) + (file-name-coding-system nnmail-pathname-coding-system)) + (unless (file-exists-p dir) + (make-directory (directory-file-name dir) t) + (nnheader-message 5 "Creating nntp marks directory %s" dir)))) + +(eval-and-compile + (autoload 'time-less-p "time-date")) + +(defun nntp-marks-changed-p (group server) + (let ((file (nntp-group-pathname server group nntp-marks-file-name)) + (file-name-coding-system nnmail-pathname-coding-system)) + (if (null (gnus-gethash file nntp-marks-modtime)) + t ;; never looked at marks file, assume it has changed + (time-less-p (gnus-gethash file nntp-marks-modtime) + (nth 5 (file-attributes file)))))) + +(defun nntp-save-marks (group server) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (file (nntp-group-pathname server group nntp-marks-file-name))) + (condition-case err + (progn + (nntp-possibly-create-directory group server) + (with-temp-file file + (erase-buffer) + (gnus-prin1 nntp-marks) + (insert "\n")) + (gnus-sethash file + (nth 5 (file-attributes file)) + nntp-marks-modtime)) + (error (or (gnus-yes-or-no-p + (format "Could not write to %s (%s). Continue? " file err)) + (error "Cannot write to %s (%s)" file err)))))) + +(defun nntp-open-marks (group server) + (let ((file (nntp-group-pathname server group nntp-marks-file-name)) + (file-name-coding-system nnmail-pathname-coding-system)) + (if (file-exists-p file) + (condition-case err + (with-temp-buffer + (gnus-sethash file (nth 5 (file-attributes file)) + nntp-marks-modtime) + (nnheader-insert-file-contents file) + (setq nntp-marks (read (current-buffer))) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nntp-marks (gnus-remassoc el nntp-marks)))) + (error (or (gnus-yes-or-no-p + (format "Error reading nntp marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) + (error "Cannot read nntp marks file %s (%s)" file err)))) + ;; User didn't have a .marks file. Probably first time + ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. + (let ((info (gnus-get-info + (gnus-group-prefixed-name + group + (gnus-server-to-method (format "nntp:%s" server))))) + (decoded-name (mm-decode-coding-string + group + (gnus-group-name-charset + (gnus-server-to-method server) group)))) + (nnheader-message 7 "Bootstrapping marks for %s..." decoded-name) + (setq nntp-marks (gnus-info-marks info)) + (push (cons 'read (gnus-info-read info)) nntp-marks) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nntp-marks (gnus-remassoc el nntp-marks))) + (nntp-save-marks group server) + (nnheader-message 7 "Bootstrapping marks for %s...done" + decoded-name))))) + (provide 'nntp) ;;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271 diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index fc2500df2f5..4905e7631b3 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -339,9 +339,9 @@ component group will show up when you enter the virtual group.") (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups)) (gnus-expert-user t)) ;; Make sure all groups are activated. - (mapcar + (mapc (lambda (g) - (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb)))) + (when (not (numberp (gnus-group-unread g))) (gnus-activate-group g))) nnvirtual-component-groups) (save-excursion @@ -384,14 +384,11 @@ component group will show up when you enter the virtual group.") (defun nnvirtual-convert-headers () "Convert HEAD headers into NOV headers." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (let* ((dependencies (make-vector 100 0)) - (headers (gnus-get-newsgroup-headers dependencies)) - header) + (headers (gnus-get-newsgroup-headers dependencies))) (erase-buffer) - (while (setq header (pop headers)) - (nnheader-insert-nov header))))) + (mapc 'nnheader-insert-nov headers)))) (defun nnvirtual-update-xref-header (group article prefix system-name) @@ -401,7 +398,7 @@ component group will show up when you enter the virtual group.") (looking-at "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") (goto-char (match-end 0)) - (unless (search-forward "\t" (gnus-point-at-eol) 'move) + (unless (search-forward "\t" (point-at-eol) 'move) (insert "\t")) ;; Remove any spaces at the beginning of the Xref field. @@ -417,8 +414,8 @@ component group will show up when you enter the virtual group.") ;; component server prefix. (save-restriction (narrow-to-region (point) - (or (search-forward "\t" (gnus-point-at-eol) t) - (gnus-point-at-eol))) + (or (search-forward "\t" (point-at-eol) t) + (point-at-eol))) (goto-char (point-min)) (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t) (replace-match "" t t)) @@ -465,7 +462,7 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." (nnvirtual-partition-sequence (cdr ml))))) (gnus-info-marks (gnus-get-info (nnvirtual-current-group)))))) - mark type groups carticles info entry) + type groups info) ;; Ok, atomically move all of the (un)read info, clear any old ;; marks, and move all of the current marks. This way if someone @@ -474,13 +471,12 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." ;; move (un)read ;; bind for workaround guns-update-read-articles (let ((gnus-newsgroup-active nil)) - (while (setq entry (pop unreads)) + (dolist (entry unreads) (gnus-update-read-articles (car entry) (cdr entry)))) ;; clear all existing marks on the component groups - (setq groups nnvirtual-component-groups) - (while groups - (when (and (setq info (gnus-get-info (pop groups))) + (dolist (group nnvirtual-component-groups) + (when (and (setq info (gnus-get-info group)) (gnus-info-marks info)) (gnus-info-set-marks info @@ -491,18 +487,17 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." ;; Ok, currently type-marks is an assq list with keys of a mark type, ;; with data of an assq list with keys of component group names ;; and the articles which correspond to that key/group pair. - (while (setq mark (pop type-marks)) + (dolist (mark type-marks) (setq type (car mark)) (setq groups (cdr mark)) - (while (setq carticles (pop groups)) + (dolist (carticles groups) (gnus-add-marked-articles (car carticles) type (cdr carticles) nil t)))) ;; possibly update the display, it is really slow (when update-p - (setq groups nnvirtual-component-groups) - (while groups - (gnus-group-update-group (pop groups) t)))))) + (dolist (group nnvirtual-component-groups) + (gnus-group-update-group group t)))))) (defun nnvirtual-current-group () @@ -664,8 +659,7 @@ numbers has no corresponding component article, then it is left out of the result." (when (numberp (cdr-safe articles)) (setq articles (list articles))) - (let ((carticles (mapcar (lambda (g) (list g)) - nnvirtual-component-groups)) + (let ((carticles (mapcar 'list nnvirtual-component-groups)) a i j article entry) (while (setq a (pop articles)) (if (atom a) @@ -678,8 +672,8 @@ the result." (setq entry (assoc (car article) carticles)) (setcdr entry (cons (cdr article) (cdr entry)))) (setq i (1+ i)))) - (mapcar (lambda (x) (setcdr x (nreverse (cdr x)))) - carticles) + (mapc (lambda (x) (setcdr x (nreverse (cdr x)))) + carticles) carticles)) @@ -701,29 +695,29 @@ based on the marks on the component groups." ;; Into all-unreads we put (g unreads). ;; Into all-marks we put (g marks). ;; We also increment cnt and tot here, and compute M (max of sizes). - (mapcar (lambda (g) - (setq active (gnus-activate-group g) - min (car active) - max (cdr active)) - (when (and active (>= max min) (not (zerop max))) - ;; store active information - (push (list g (- max min -1) max) actives) - ;; collect unread/mark info for later - (setq unreads (gnus-list-of-unread-articles g)) - (setq marks (gnus-info-marks (gnus-get-info g))) - (when gnus-use-cache - (push (cons 'cache - (gnus-cache-articles-in-group g)) - marks)) - (push (cons g unreads) all-unreads) - (push (cons g marks) all-marks) - ;; count groups, total #articles, and max size - (setq size (- max min -1)) - (setq cnt (1+ cnt) - tot (+ tot size) - M (max M size)))) - nnvirtual-component-groups) - + (mapc (lambda (g) + (setq active (gnus-activate-group g) + min (car active) + max (cdr active)) + (when (and active (>= max min) (not (zerop max))) + ;; store active information + (push (list g (- max min -1) max) actives) + ;; collect unread/mark info for later + (setq unreads (gnus-list-of-unread-articles g)) + (setq marks (gnus-info-marks (gnus-get-info g))) + (when gnus-use-cache + (push (cons 'cache + (gnus-cache-articles-in-group g)) + marks)) + (push (cons g unreads) all-unreads) + (push (cons g marks) all-marks) + ;; count groups, total #articles, and max size + (setq size (- max min -1)) + (setq cnt (1+ cnt) + tot (+ tot size) + M (max M size)))) + nnvirtual-component-groups) + ;; Number of articles in the virtual group. (setq nnvirtual-mapping-len tot) @@ -785,10 +779,9 @@ based on the marks on the component groups." ;; Remove any empty marks lists, and store. (setq nnvirtual-mapping-marks nil) - (while marks - (if (cdr (car marks)) - (push (car marks) nnvirtual-mapping-marks)) - (setq marks (cdr marks))) + (dolist (mark marks) + (when (cdr mark) + (push mark nnvirtual-mapping-marks))) ;; We need to convert the unreads to reads. We compress the ;; sequence as we go, otherwise it could be huge. diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 0d1fb193082..4729e7216be 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -523,7 +523,9 @@ Valid types include `google', `dejanews', and `gmane'.") "?" (mm-url-encode-www-form-urlencoded `(("query" . ,search) - ("HITSPERPAGE" . ,(number-to-string nnweb-max-hits)))))) + ("HITSPERPAGE" . ,(number-to-string nnweb-max-hits)) + ;;("TOPDOC" . "1000") + )))) (setq buffer-file-name nil) (set-buffer-multibyte t) (mm-decode-coding-region (point-min) (point-max) 'utf-8) @@ -554,7 +556,7 @@ Valid types include `google', `dejanews', and `gmane'.") (nth 1 parse) " ")) (insert ">\n") - (mapcar 'nnweb-insert-html (nth 2 parse)) + (mapc 'nnweb-insert-html (nth 2 parse)) (insert "</" (symbol-name (car parse)) ">\n"))) (defun nnweb-parse-find (type parse &optional maxdepth) diff --git a/lisp/gnus/ntlm.el b/lisp/gnus/ntlm.el new file mode 100644 index 00000000000..edea2c3048a --- /dev/null +++ b/lisp/gnus/ntlm.el @@ -0,0 +1,537 @@ +;;; ntlm.el --- NTLM (NT LanManager) authentication support + +;; Copyright (C) 2001 Taro Kawagishi +;; Author: Taro Kawagishi <tarok@transpulse.org> +;; Keywords: NTLM, SASL +;; Version: 1.00 +;; Created: February 2001 + +;; This program 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 3, or (at your option) +;; any later version. +;; +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This library is a direct translation of the Samba release 2.2.0 +;; implementation of Windows NT and LanManager compatible password +;; encryption. +;; +;; Interface functions: +;; +;; ntlm-build-auth-request +;; This will return a binary string, which should be used in the +;; base64 encoded form and it is the caller's responsibility to encode +;; the returned string with base64. +;; +;; ntlm-build-auth-response +;; It is the caller's responsibility to pass a base64 decoded string +;; (which will be a binary string) as the first argument and to +;; encode the returned string with base64. The second argument user +;; should be given in user@domain format. +;; +;; ntlm-get-password-hashes +;; +;; +;; NTLM authentication procedure example: +;; +;; 1. Open a network connection to the Exchange server at the IMAP port (143) +;; 2. Receive an opening message such as: +;; "* OK Microsoft Exchange IMAP4rev1 server version 5.5.2653.7 (XXXX) ready" +;; 3. Ask for IMAP server capability by sending "NNN capability" +;; 4. Receive a capability message such as: +;; "* CAPABILITY IMAP4 IMAP4rev1 IDLE LITERAL+ LOGIN-REFERRALS MAILBOX-REFERRALS NAMESPACE AUTH=NTLM" +;; 5. Ask for NTLM authentication by sending a string +;; "NNN authenticate ntlm" +;; 6. Receive continuation acknowledgment "+" +;; 7. Send NTLM authentication request generated by 'ntlm-build-auth-request +;; 8. Receive NTLM challenge string following acknowledgment "+" +;; 9. Generate response to challenge by 'ntlm-build-auth-response +;; (here two hash function values of the user password are encrypted) +;; 10. Receive authentication completion message such as +;; "NNN OK AUTHENTICATE NTLM completed." + +;;; Code: + +(require 'md4) + +;;; +;;; NTLM authentication interface functions + +(defun ntlm-build-auth-request (user &optional domain) + "Return the NTLM authentication request string for USER and DOMAIN. +USER is a string representing a user name to be authenticated and +DOMAIN is a NT domain. USER can include a NT domain part as in +user@domain where the string after @ is used as the domain if DOMAIN +is not given." + (interactive) + (let ((request-ident (concat "NTLMSSP" (make-string 1 0))) + (request-msgType (concat (make-string 1 1) (make-string 3 0))) + ;0x01 0x00 0x00 0x00 + (request-flags (concat (make-string 1 7) (make-string 1 178) + (make-string 2 0))) + ;0x07 0xb2 0x00 0x00 + lu ld off-d off-u) + (when (string-match "@" user) + (unless domain + (setq domain (substring user (1+ (match-beginning 0))))) + (setq user (substring user 0 (match-beginning 0)))) + ;; set fields offsets within the request struct + (setq lu (length user)) + (setq ld (length domain)) + (setq off-u 32) ;offset to the string 'user + (setq off-d (+ 32 lu)) ;offset to the string 'domain + ;; pack the request struct in a string + (concat request-ident ;8 bytes + request-msgType ;4 bytes + request-flags ;4 bytes + (md4-pack-int16 lu) ;user field, count field + (md4-pack-int16 lu) ;user field, max count field + (md4-pack-int32 (cons 0 off-u)) ;user field, offset field + (md4-pack-int16 ld) ;domain field, count field + (md4-pack-int16 ld) ;domain field, max count field + (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field + user ;bufer field + domain ;bufer field + ))) + +(eval-when-compile + (defmacro ntlm-string-as-unibyte (string) + (if (fboundp 'string-as-unibyte) + `(string-as-unibyte ,string) + string))) + +(defun ntlm-build-auth-response (challenge user password-hashes) + "Return the response string to a challenge string CHALLENGE given by +the NTLM based server for the user USER and the password hash list +PASSWORD-HASHES. NTLM uses two hash values which are represented +by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of + (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))" + (let* ((rchallenge (ntlm-string-as-unibyte challenge)) + ;; get fields within challenge struct + ;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes + ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes + (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes + (flags (substring rchallenge 20 24)) ;flags, 4 bytes + (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes + uDomain-len uDomain-offs + ;; response struct and its fields + lmRespData ;lmRespData, 24 bytes + ntRespData ;ntRespData, 24 bytes + domain ;ascii domain string + lu ld off-lm off-nt off-d off-u off-w off-s) + ;; extract domain string from challenge string + (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) + (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) + (setq domain + (ntlm-unicode2ascii (substring challenge + (cdr uDomain-offs) + (+ (cdr uDomain-offs) uDomain-len)) + (/ uDomain-len 2))) + ;; overwrite domain in case user is given in <user>@<domain> format + (when (string-match "@" user) + (setq domain (substring user (1+ (match-beginning 0)))) + (setq user (substring user 0 (match-beginning 0)))) + + ;; generate response data + (setq lmRespData + (ntlm-smb-owf-encrypt (car password-hashes) challengeData)) + (setq ntRespData + (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData)) + + ;; get offsets to fields to pack the response struct in a string + (setq lu (length user)) + (setq ld (length domain)) + (setq off-lm 64) ;offset to string 'lmResponse + (setq off-nt (+ 64 24)) ;offset to string 'ntResponse + (setq off-d (+ 64 48)) ;offset to string 'uDomain + (setq off-u (+ 64 48 (* 2 ld))) ;offset to string 'uUser + (setq off-w (+ 64 48 (* 2 (+ ld lu)))) ;offset to string 'uWks + (setq off-s (+ 64 48 (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey + ;; pack the response struct in a string + (concat "NTLMSSP\0" ;response ident field, 8 bytes + (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes + + ;; lmResponse field, 8 bytes + ;;AddBytes(response,lmResponse,lmRespData,24); + (md4-pack-int16 24) ;len field + (md4-pack-int16 24) ;maxlen field + (md4-pack-int32 (cons 0 off-lm)) ;field offset + + ;; ntResponse field, 8 bytes + ;;AddBytes(response,ntResponse,ntRespData,24); + (md4-pack-int16 24) ;len field + (md4-pack-int16 24) ;maxlen field + (md4-pack-int32 (cons 0 off-nt)) ;field offset + + ;; uDomain field, 8 bytes + ;;AddUnicodeString(response,uDomain,domain); + ;;AddBytes(response, uDomain, udomain, 2*ld); + (md4-pack-int16 (* 2 ld)) ;len field + (md4-pack-int16 (* 2 ld)) ;maxlen field + (md4-pack-int32 (cons 0 off-d)) ;field offset + + ;; uUser field, 8 bytes + ;;AddUnicodeString(response,uUser,u); + ;;AddBytes(response, uUser, uuser, 2*lu); + (md4-pack-int16 (* 2 lu)) ;len field + (md4-pack-int16 (* 2 lu)) ;maxlen field + (md4-pack-int32 (cons 0 off-u)) ;field offset + + ;; uWks field, 8 bytes + ;;AddUnicodeString(response,uWks,u); + (md4-pack-int16 (* 2 lu)) ;len field + (md4-pack-int16 (* 2 lu)) ;maxlen field + (md4-pack-int32 (cons 0 off-w)) ;field offset + + ;; sessionKey field, 8 bytes + ;;AddString(response,sessionKey,NULL); + (md4-pack-int16 0) ;len field + (md4-pack-int16 0) ;maxlen field + (md4-pack-int32 (cons 0 (- off-s off-lm))) ;field offset + + ;; flags field, 4 bytes + flags ; + + ;; buffer field + lmRespData ;lmResponse, 24 bytes + ntRespData ;ntResponse, 24 bytes + (ntlm-ascii2unicode domain ;unicode domain string, 2*ld bytes + (length domain)) ; + (ntlm-ascii2unicode user ;unicode user string, 2*lu bytes + (length user)) ; + (ntlm-ascii2unicode user ;unicode user string, 2*lu bytes + (length user)) ; + ))) + +(defun ntlm-get-password-hashes (password) + "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD" + (list (ntlm-smb-passwd-hash password) + (ntlm-md4hash password))) + +(defun ntlm-ascii2unicode (str len) + "Convert an ASCII string into a NT Unicode string, which is +little-endian utf16." + (let ((utf (make-string (* 2 len) 0)) (i 0) val) + (while (and (< i len) + (not (zerop (setq val (aref str i))))) + (aset utf (* 2 i) val) + (aset utf (1+ (* 2 i)) 0) + (setq i (1+ i))) + utf)) + +(defun ntlm-unicode2ascii (str len) + "Extract 7 bits ASCII part of a little endian utf16 string STR of length LEN." + (let ((buf (make-string len 0)) (i 0) (j 0)) + (while (< i len) + (aset buf i (logand (aref str j) 127)) ;(string-to-number "7f" 16) + (setq i (1+ i) + j (+ 2 j))) + buf)) + +(defun ntlm-smb-passwd-hash (passwd) + "Return the SMB password hash string of 16 bytes long for the given password +string PASSWD. PASSWD is truncated to 14 bytes if longer." + (let ((len (min (length passwd) 14))) + (ntlm-smb-des-e-p16 + (concat (substring (upcase passwd) 0 len) ;fill top 14 bytes with passwd + (make-string (- 15 len) 0))))) + +(defun ntlm-smb-owf-encrypt (passwd c8) + "Return the response string of 24 bytes long for the given password +string PASSWD based on the DES encryption. PASSWD is of at most 14 +bytes long and the challenge string C8 of 8 bytes long." + (let ((len (min (length passwd) 16)) p22) + (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd + (make-string (- 22 len) 0))) + (ntlm-smb-des-e-p24 p22 c8))) + +(defun ntlm-smb-des-e-p24 (p22 c8) + "Return a 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes +string C8." + (concat (ntlm-smb-hash c8 p22 t) ;hash first 8 bytes of p22 + (ntlm-smb-hash c8 (substring p22 7) t) + (ntlm-smb-hash c8 (substring p22 14) t))) + +(defconst ntlm-smb-sp8 [75 71 83 33 64 35 36 37]) + +(defun ntlm-smb-des-e-p16 (p15) + "Return a 16 bytes hashed string for a 15 bytes string P15." + (concat (ntlm-smb-hash ntlm-smb-sp8 p15 t) ;hash of first 8 bytes of p15 + (ntlm-smb-hash ntlm-smb-sp8 ;hash of last 8 bytes of p15 + (substring p15 7) t))) + +(defun ntlm-smb-hash (in key forw) + "Return the hash string of length 8 for a string IN of length 8 and +a string KEY of length 8. FORW is t or nil." + (let ((out (make-string 8 0)) + outb ;string of length 64 + (inb (make-string 64 0)) + (keyb (make-string 64 0)) + (key2 (ntlm-smb-str-to-key key)) + (i 0) aa) + (while (< i 64) + (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (aset inb i 1)) + (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (aset keyb i 1)) + (setq i (1+ i))) + (setq outb (ntlm-smb-dohash inb keyb forw)) + (setq i 0) + (while (< i 64) + (unless (zerop (aref outb i)) + (setq aa (aref out (/ i 8))) + (aset out (/ i 8) + (logior aa (lsh 1 (- 7 (% i 8)))))) + (setq i (1+ i))) + out)) + +(defun ntlm-smb-str-to-key (str) + "Return a string of length 8 for the given string STR of length 7." + (let ((key (make-string 8 0)) + (i 7)) + (aset key 0 (lsh (aref str 0) -1)) + (aset key 1 (logior + (lsh (logand (aref str 0) 1) 6) + (lsh (aref str 1) -2))) + (aset key 2 (logior + (lsh (logand (aref str 1) 3) 5) + (lsh (aref str 2) -3))) + (aset key 3 (logior + (lsh (logand (aref str 2) 7) 4) + (lsh (aref str 3) -4))) + (aset key 4 (logior + (lsh (logand (aref str 3) 15) 3) + (lsh (aref str 4) -5))) + (aset key 5 (logior + (lsh (logand (aref str 4) 31) 2) + (lsh (aref str 5) -6))) + (aset key 6 (logior + (lsh (logand (aref str 5) 63) 1) + (lsh (aref str 6) -7))) + (aset key 7 (logand (aref str 6) 127)) + (while (>= i 0) + (aset key i (lsh (aref key i) 1)) + (setq i (1- i))) + key)) + +(defconst ntlm-smb-perm1 [57 49 41 33 25 17 9 + 1 58 50 42 34 26 18 + 10 2 59 51 43 35 27 + 19 11 3 60 52 44 36 + 63 55 47 39 31 23 15 + 7 62 54 46 38 30 22 + 14 6 61 53 45 37 29 + 21 13 5 28 20 12 4]) + +(defconst ntlm-smb-perm2 [14 17 11 24 1 5 + 3 28 15 6 21 10 + 23 19 12 4 26 8 + 16 7 27 20 13 2 + 41 52 31 37 47 55 + 30 40 51 45 33 48 + 44 49 39 56 34 53 + 46 42 50 36 29 32]) + +(defconst ntlm-smb-perm3 [58 50 42 34 26 18 10 2 + 60 52 44 36 28 20 12 4 + 62 54 46 38 30 22 14 6 + 64 56 48 40 32 24 16 8 + 57 49 41 33 25 17 9 1 + 59 51 43 35 27 19 11 3 + 61 53 45 37 29 21 13 5 + 63 55 47 39 31 23 15 7]) + +(defconst ntlm-smb-perm4 [32 1 2 3 4 5 + 4 5 6 7 8 9 + 8 9 10 11 12 13 + 12 13 14 15 16 17 + 16 17 18 19 20 21 + 20 21 22 23 24 25 + 24 25 26 27 28 29 + 28 29 30 31 32 1]) + +(defconst ntlm-smb-perm5 [16 7 20 21 + 29 12 28 17 + 1 15 23 26 + 5 18 31 10 + 2 8 24 14 + 32 27 3 9 + 19 13 30 6 + 22 11 4 25]) + +(defconst ntlm-smb-perm6 [40 8 48 16 56 24 64 32 + 39 7 47 15 55 23 63 31 + 38 6 46 14 54 22 62 30 + 37 5 45 13 53 21 61 29 + 36 4 44 12 52 20 60 28 + 35 3 43 11 51 19 59 27 + 34 2 42 10 50 18 58 26 + 33 1 41 9 49 17 57 25]) + +(defconst ntlm-smb-sc [1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1]) + +(defconst ntlm-smb-sbox [[[14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7] + [ 0 15 7 4 14 2 13 1 10 6 12 11 9 5 3 8] + [ 4 1 14 8 13 6 2 11 15 12 9 7 3 10 5 0] + [15 12 8 2 4 9 1 7 5 11 3 14 10 0 6 13]] + [[15 1 8 14 6 11 3 4 9 7 2 13 12 0 5 10] + [ 3 13 4 7 15 2 8 14 12 0 1 10 6 9 11 5] + [ 0 14 7 11 10 4 13 1 5 8 12 6 9 3 2 15] + [13 8 10 1 3 15 4 2 11 6 7 12 0 5 14 9]] + [[10 0 9 14 6 3 15 5 1 13 12 7 11 4 2 8] + [13 7 0 9 3 4 6 10 2 8 5 14 12 11 15 1] + [13 6 4 9 8 15 3 0 11 1 2 12 5 10 14 7] + [ 1 10 13 0 6 9 8 7 4 15 14 3 11 5 2 12]] + [[ 7 13 14 3 0 6 9 10 1 2 8 5 11 12 4 15] + [13 8 11 5 6 15 0 3 4 7 2 12 1 10 14 9] + [10 6 9 0 12 11 7 13 15 1 3 14 5 2 8 4] + [ 3 15 0 6 10 1 13 8 9 4 5 11 12 7 2 14]] + [[ 2 12 4 1 7 10 11 6 8 5 3 15 13 0 14 9] + [14 11 2 12 4 7 13 1 5 0 15 10 3 9 8 6] + [ 4 2 1 11 10 13 7 8 15 9 12 5 6 3 0 14] + [11 8 12 7 1 14 2 13 6 15 0 9 10 4 5 3]] + [[12 1 10 15 9 2 6 8 0 13 3 4 14 7 5 11] + [10 15 4 2 7 12 9 5 6 1 13 14 0 11 3 8] + [ 9 14 15 5 2 8 12 3 7 0 4 10 1 13 11 6] + [ 4 3 2 12 9 5 15 10 11 14 1 7 6 0 8 13]] + [[ 4 11 2 14 15 0 8 13 3 12 9 7 5 10 6 1] + [13 0 11 7 4 9 1 10 14 3 5 12 2 15 8 6] + [ 1 4 11 13 12 3 7 14 10 15 6 8 0 5 9 2] + [ 6 11 13 8 1 4 10 7 9 5 0 15 14 2 3 12]] + [[13 2 8 4 6 15 11 1 10 9 3 14 5 0 12 7] + [ 1 15 13 8 10 3 7 4 12 5 6 11 0 14 9 2] + [ 7 11 4 1 9 12 14 2 0 6 10 13 15 3 5 8] + [ 2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11]]]) + +(defsubst ntlm-string-permute (in perm n) + "Return a string of length N for a string IN and a permutation vector +PERM of size N. The length of IN should be height of PERM." + (let ((i 0) (out (make-string n 0))) + (while (< i n) + (aset out i (aref in (- (aref perm i) 1))) + (setq i (1+ i))) + out)) + +(defsubst ntlm-string-lshift (str count len) + "Return a string by circularly shifting a string STR by COUNT to the left. +length of STR is LEN." + (let ((c (% count len))) + (concat (substring str c len) (substring str 0 c)))) + +(defsubst ntlm-string-xor (in1 in2 n) + "Return exclusive-or of sequences in1 and in2" + (let ((w (make-string n 0)) (i 0)) + (while (< i n) + (aset w i (logxor (aref in1 i) (aref in2 i))) + (setq i (1+ i))) + w)) + +(defun ntlm-smb-dohash (in key forw) + "Return the hash value for a string IN and a string KEY. +Length of IN and KEY are 64. FORW non nill means forward, nil means +backward." + (let (pk1 ;string of length 56 + c ;string of length 28 + d ;string of length 28 + cd ;string of length 56 + (ki (make-vector 16 0)) ;vector of string of length 48 + pd1 ;string of length 64 + l ;string of length 32 + r ;string of length 32 + rl ;string of length 64 + (i 0) (j 0) (k 0)) + (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) + (setq c (substring pk1 0 28)) + (setq d (substring pk1 28 56)) + + (setq i 0) + (while (< i 16) + (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28)) + (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28)) + (setq cd (concat (substring c 0 28) (substring d 0 28))) + (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48)) + (setq i (1+ i))) + + (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64)) + + (setq l (substring pd1 0 32)) + (setq r (substring pd1 32 64)) + + (setq i 0) + (let (er ;string of length 48 + erk ;string of length 48 + (b (make-vector 8 0)) ;vector of strings of length 6 + cb ;string of length 32 + pcb ;string of length 32 + r2 ;string of length 32 + jj m n bj sbox-jmn) + (while (< i 16) + (setq er (ntlm-string-permute r ntlm-smb-perm4 48)) + (setq erk (ntlm-string-xor er + (aref ki (if forw i (- 15 i))) + 48)) + (setq j 0) + (while (< j 8) + (setq jj (* 6 j)) + (aset b j (substring erk jj (+ jj 6))) + (setq j (1+ j))) + (setq j 0) + (while (< j 8) + (setq bj (aref b j)) + (setq m (logior (lsh (aref bj 0) 1) (aref bj 5))) + (setq n (logior (lsh (aref bj 1) 3) + (lsh (aref bj 2) 2) + (lsh (aref bj 3) 1) + (aref bj 4))) + (setq k 0) + (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n)) + (while (< k 4) + (aset bj k + (if (zerop (logand sbox-jmn (lsh 1 (- 3 k)))) + 0 1)) + (setq k (1+ k))) + (setq j (1+ j))) + + (setq j 0) + (setq cb nil) + (while (< j 8) + (setq cb (concat cb (substring (aref b j) 0 4))) + (setq j (1+ j))) + + (setq pcb (ntlm-string-permute cb ntlm-smb-perm5 32)) + (setq r2 (ntlm-string-xor l pcb 32)) + (setq l r) + (setq r r2) + (setq i (1+ i)))) + (setq rl (concat r l)) + (ntlm-string-permute rl ntlm-smb-perm6 64))) + +(defun ntlm-md4hash (passwd) + "Return the 16 bytes MD4 hash of a string PASSWD after converting it +into a Unicode string. PASSWD is truncated to 128 bytes if longer." + (let (len wpwd) + ;; Password cannot be longer than 128 characters + (setq len (length passwd)) + (if (> len 128) + (setq len 128)) + ;; Password must be converted to NT unicode + (setq wpwd (ntlm-ascii2unicode passwd len)) + ;; Calculate length in bytes + (setq len (* len 2)) + (md4 wpwd len))) + +(provide 'ntlm) + +;;; arch-tag: 348ace18-f8e2-4176-8fe9-d9ab4e96f296 +;;; ntlm.el ends here diff --git a/lisp/gnus/password.el b/lisp/gnus/password.el new file mode 100644 index 00000000000..32ab76052d9 --- /dev/null +++ b/lisp/gnus/password.el @@ -0,0 +1,140 @@ +;;; password.el --- Read passwords from user, possibly using a password cache. + +;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Created: 2003-12-21 +;; Keywords: password cache passphrase key + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Greatly influenced by pgg.el written by Daiki Ueno, with timer +;; fixes for XEmacs by Katsumi Yamaoka. In fact, this is mostly just +;; a rip-off. +;; +;; (password-read "Password? " "test") +;; ;; Minibuffer prompt for password. +;; => "foo" +;; +;; (password-cache-add "test" "foo") +;; => nil + +;; Note the previous two can be replaced with: +;; (password-read-and-add "Password? " "test") +;; ;; Minibuffer prompt for password. +;; => "foo" +;; ;; "foo" is now cached with key "test" + + +;; (password-read "Password? " "test") +;; ;; No minibuffer prompt +;; => "foo" +;; +;; (password-read "Password? " "test") +;; ;; No minibuffer prompt +;; => "foo" +;; +;; ;; Wait `password-cache-expiry' seconds. +;; +;; (password-read "Password? " "test") +;; ;; Minibuffer prompt for password is back. +;; => "foo" + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defcustom password-cache t + "Whether to cache passwords." + :group 'password + :type 'boolean) + +(defcustom password-cache-expiry 16 + "How many seconds passwords are cached, or nil to disable expiring. +Whether passwords are cached at all is controlled by `password-cache'." + :group 'password + :type '(choice (const :tag "Never" nil) + (integer :tag "Seconds"))) + +(defvar password-data (make-vector 7 0)) + +(defun password-read-from-cache (key) + "Obtain passphrase for KEY from time-limited passphrase cache. +Custom variables `password-cache' and `password-cache-expiry' +regulate cache behavior." + (and password-cache + key + (symbol-value (intern-soft key password-data)))) + +(defun password-read (prompt &optional key) + "Read password, for use with KEY, from user, or from cache if wanted. +KEY indicate the purpose of the password, so the cache can +separate passwords. The cache is not used if KEY is nil. It is +typically a string. +The variable `password-cache' control whether the cache is used." + (or (password-read-from-cache key) + (read-passwd prompt))) + +(defun password-read-and-add (prompt &optional key) + "Read password, for use with KEY, from user, or from cache if wanted. +Then store the password in the cache. Uses `password-read' and +`password-cache-add'. +Custom variables `password-cache' and `password-cache-expiry' +regulate cache behavior." + (let ((password (password-read prompt key))) + (when (and password key) + (password-cache-add key password)) + password)) + +(defun password-cache-remove (key) + "Remove password indexed by KEY from password cache. +This is typically run be a timer setup from `password-cache-add', +but can be invoked at any time to forcefully remove passwords +from the cache. This may be useful when it has been detected +that a password is invalid, so that `password-read' query the +user again." + (let ((password (symbol-value (intern-soft key password-data)))) + (when password + (if (fboundp 'clear-string) + (clear-string password) + (fillarray password ?_)) + (unintern key password-data)))) + +(defun password-cache-add (key password) + "Add password to cache. +The password is removed by a timer after `password-cache-expiry' +seconds." + (when (and password-cache-expiry (null (intern-soft key password-data))) + (run-at-time password-cache-expiry nil + #'password-cache-remove + key)) + (set (intern key password-data) password) + nil) + +(defun password-reset () + "Clear the password cache." + (interactive) + (fillarray password-data 0)) + +(provide 'password) + +;;; arch-tag: ab160494-16c8-4c68-a4a1-73eebf6686e5 +;;; password.el ends here diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el index 97d6af02cde..c8e309d8c14 100644 --- a/lisp/gnus/pop3.el +++ b/lisp/gnus/pop3.el @@ -201,6 +201,23 @@ to %s might not give the result you'd expect." pop3-leave-mail-on-server) (pop3-quit process) message-count)) +(autoload 'open-tls-stream "tls") +(autoload 'starttls-open-stream "starttls") +(autoload 'starttls-negotiate "starttls") ; avoid warning + +(defcustom pop3-stream-type nil + "*Transport security type for POP3 connexions. +This may be either nil (plain connexion), `ssl' (use an +SSL/TSL-secured stream) or `starttls' (use the starttls mechanism +to turn on TLS security after opening the stream). However, if +this is nil, `ssl' is assumed for connexions to port +995 (pop3s)." + :version "23.0" ;; No Gnus + :group 'pop3 + :type '(choice (const :tag "Plain" nil) + (const :tag "SSL/TLS" ssl) + (const starttls))) + (defun pop3-open-server (mailhost port) "Open TCP connection to MAILHOST on PORT. Returns the process associated with the connection." @@ -212,7 +229,44 @@ Returns the process associated with the connection." mailhost))) (erase-buffer) (setq pop3-read-point (point-min)) - (setq process (open-network-stream "POP" (current-buffer) mailhost port)) + (setq process + (cond + ((or (eq pop3-stream-type 'ssl) + (and (not pop3-stream-type) (member port '(995 "pop3s")))) + ;; gnutls-cli, openssl don't accept service names + (if (or (equal port "pop3s") + (null port)) + (setq port 995)) + (let ((process (open-tls-stream "POP" (current-buffer) + mailhost port))) + (when process + ;; There's a load of info printed that needs deleting. + (while (when (memq (process-status process) '(open run)) + (pop3-accept-process-output process) + (goto-char (point-max)) + (forward-line -1) + (if (looking-at "\\+OK") + (progn + (delete-region (point-min) (point)) + nil) + (pop3-quit process) + (error "POP SSL connexion failed")))) + process))) + ((eq pop3-stream-type 'starttls) + ;; gnutls-cli, openssl don't accept service names + (if (equal port "pop3") + (setq port 110)) + (let ((process (starttls-open-stream "POP" (current-buffer) + mailhost (or port 110)))) + (pop3-send-command process "STLS") + (let ((response (pop3-read-response process t))) + (if (and response (string-match "+OK" response)) + (starttls-negotiate process) + (pop3-quit process) + (error "POP server doesn't support starttls"))) + process)) + (t + (open-network-stream "POP" (current-buffer) mailhost port)))) (let ((response (pop3-read-response process t))) (setq pop3-timestamp (substring response (or (string-match "<" response) 0) @@ -357,37 +411,6 @@ If NOW, use that time instead." ;; AUTHORIZATION STATE -(eval-when-compile - (if (not (fboundp 'md5)) ;; Emacs 20 - (defalias 'md5 'ignore))) - -(eval-and-compile - (if (and (fboundp 'md5) - ;; There might be an incompatible implementation. - (condition-case nil - (md5 "Check whether the 4th argument is allowed" - nil nil 'binary) - (error nil))) - (defun pop3-md5 (string) - (md5 string nil nil 'binary)) - (defvar pop3-md5-program "md5" - "*Program to encode its input in MD5. -\"openssl\" is a popular alternative; set `pop3-md5-program-args' to -'(\"md5\") if you use it.") - (defvar pop3-md5-program-args nil - "*List of arguments passed to `pop3-md5-program'.") - (defun pop3-md5 (string) - (let ((default-enable-multibyte-characters t) - (coding-system-for-write 'binary)) - (with-temp-buffer - (insert string) - (apply 'call-process-region (point-min) (point-max) - pop3-md5-program t (current-buffer) nil - pop3-md5-program-args) - ;; The meaningful output is the first 32 characters. - ;; Don't return the newline that follows them! - (buffer-substring (point-min) (+ 32 (point-min)))))))) - (defun pop3-user (process user) "Send USER information to POP3 server." (pop3-send-command process (format "USER %s" user)) @@ -409,7 +432,7 @@ If NOW, use that time instead." (setq pass (read-passwd (format "Password for %s: " pop3-maildrop)))) (if pass - (let ((hash (pop3-md5 (concat pop3-timestamp pass)))) + (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) (pop3-send-command process (format "APOP %s %s" user hash)) (let ((response (pop3-read-response process t))) (if (not (and response (string-match "+OK" response))) @@ -520,6 +543,13 @@ and close the connection." ;; -ERR [invalid password] ;; -ERR [unable to lock maildrop] +;; STLS (RFC 2595) +;; Arguments: none +;; Restrictions: Only permitted in AUTHORIZATION state. +;; Possible responses: +;; +OK +;; -ERR + ;;; TRANSACTION STATE ;; STAT diff --git a/lisp/gnus/qp.el b/lisp/gnus/qp.el index 17cc7ef2cf6..5689a70f3ac 100644 --- a/lisp/gnus/qp.el +++ b/lisp/gnus/qp.el @@ -70,8 +70,8 @@ them into characters should be done separately." (delete-char 2)) ((looking-at "=[0-9A-F][0-9A-F]") (let ((byte (string-to-number (buffer-substring (1+ (point)) - (+ 3 (point))) - 16))) + (+ 3 (point))) + 16))) (mm-insert-byte byte 1) (delete-char 3))) (t @@ -82,7 +82,7 @@ them into characters should be done separately." (defun quoted-printable-decode-string (string &optional coding-system) "Decode the quoted-printable encoded STRING and return the result. -If CODING-SYSTEM is non-nil, decode the region with coding-system. +If CODING-SYSTEM is non-nil, decode the string with coding-system. Use of CODING-SYSTEM is deprecated; this function should deal with raw bytes, and coding conversion should be done separately." (mm-with-unibyte-buffer diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el index 4ae41b8e9a5..b789061853f 100644 --- a/lisp/gnus/rfc2047.el +++ b/lisp/gnus/rfc2047.el @@ -31,24 +31,7 @@ (eval-when-compile (require 'cl) - (defvar message-posting-charset) - (unless (fboundp 'with-syntax-table) ; not in Emacs 20 - (defmacro with-syntax-table (table &rest body) - "Evaluate BODY with syntax table of current buffer set to TABLE. -The syntax table of the current buffer is saved, BODY is evaluated, and the -saved table is restored, even in case of an abnormal exit. -Value is what BODY returns." - (let ((old-table (make-symbol "table")) - (old-buffer (make-symbol "buffer"))) - `(let ((,old-table (syntax-table)) - (,old-buffer (current-buffer))) - (unwind-protect - (progn - (set-syntax-table ,table) - ,@body) - (save-current-buffer - (set-buffer ,old-buffer) - (set-syntax-table ,old-table)))))))) + (defvar message-posting-charset)) (require 'qp) (require 'mm-util) @@ -58,18 +41,6 @@ Value is what BODY returns." (require 'rfc2045) ;; rfc2045-encode-string (autoload 'mm-body-7-or-8 "mm-bodies") -(eval-and-compile - ;; Avoid gnus-util for mm- code. - (defalias 'rfc2047-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - - (defalias 'rfc2047-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) - (defvar rfc2047-header-encoding-alist '(("Newsgroups" . nil) ("Followup-To" . nil) @@ -161,7 +132,7 @@ This is either `base64' or `quoted-printable'." (progn (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) - (rfc2047-point-at-bol) + (point-at-bol) (point-max)))) (goto-char (point-min))) @@ -177,37 +148,50 @@ This is either `base64' or `quoted-printable'." encodable-regexp) "Quote special characters with `\\'s in quoted strings. Quoting will not be done in a quoted string if it contains characters -matching ENCODABLE-REGEXP." +matching ENCODABLE-REGEXP or it is within parentheses." (goto-char (point-min)) (let ((tspecials (concat "[" ietf-drums-tspecials "]")) + (start (point)) beg end) (with-syntax-table (standard-syntax-table) - (while (search-forward "\"" nil t) - (setq beg (match-beginning 0)) - (unless (eq (char-before beg) ?\\) - (goto-char beg) - (setq beg (1+ beg)) - (condition-case nil - (progn - (forward-sexp) - (setq end (1- (point))) - (goto-char beg) - (if (and encodable-regexp - (re-search-forward encodable-regexp end t)) - (goto-char (1+ end)) - (save-restriction - (narrow-to-region beg end) - (while (re-search-forward tspecials nil 'move) - (if (eq (char-before) ?\\) - (if (looking-at tspecials) ;; Already quoted. - (forward-char) - (insert "\\")) - (goto-char (match-beginning 0)) - (insert "\\") - (forward-char)))) - (forward-char))) - (error - (goto-char beg)))))))) + (while (not (eobp)) + (if (ignore-errors + (forward-list 1) + (eq (char-before) ?\))) + (forward-list -1) + (goto-char (point-max))) + (save-restriction + (narrow-to-region start (point)) + (goto-char start) + (while (search-forward "\"" nil t) + (setq beg (match-beginning 0)) + (unless (eq (char-before beg) ?\\) + (goto-char beg) + (setq beg (1+ beg)) + (condition-case nil + (progn + (forward-sexp) + (setq end (1- (point))) + (goto-char beg) + (if (and encodable-regexp + (re-search-forward encodable-regexp end t)) + (goto-char (1+ end)) + (save-restriction + (narrow-to-region beg end) + (while (re-search-forward tspecials nil 'move) + (if (eq (char-before) ?\\) + (if (looking-at tspecials) ;; Already quoted. + (forward-char) + (insert "\\")) + (goto-char (match-beginning 0)) + (insert "\\") + (forward-char)))) + (forward-char))) + (error + (goto-char beg))))) + (goto-char (point-max))) + (forward-list 1) + (setq start (point)))))) (defvar rfc2047-encoding-type 'address-mime "The type of encoding done by `rfc2047-encode-region'. @@ -292,9 +276,10 @@ Should be called narrowed to the head of the message." ;;; (rfc2047-encode-region (point-min) (point-max)) ;;; (error "Cannot send unencoded text"))) ((mm-coding-system-p method) - (if (and (featurep 'mule) - (if (boundp 'default-enable-multibyte-characters) - default-enable-multibyte-characters)) + (if (or (and (featurep 'mule) + (if (boundp 'default-enable-multibyte-characters) + default-enable-multibyte-characters)) + (featurep 'file-coding)) (mm-encode-coding-region (point) (point-max) method))) ;; Hm. (t))) @@ -658,14 +643,14 @@ Point moves to the end of the region." (goto-char b) (setq b (point-marker) e (set-marker (make-marker) e)) - (rfc2047-fold-region (rfc2047-point-at-bol) b) + (rfc2047-fold-region (point-at-bol) b) (goto-char b) (skip-chars-backward "^ \t\n") (unless (= 0 (skip-chars-backward " \t")) ;; `crest' may contain whitespace and an open parenthesis. (setq crest (buffer-substring-no-properties (point) b))) (setq eword (rfc2047-encode-1 - (- b (rfc2047-point-at-bol)) + (- b (point-at-bol)) (mm-replace-in-string (buffer-substring-no-properties b e) "\n\\([ \t]?\\)" "\\1") @@ -712,7 +697,7 @@ Point moves to the end of the region." (first t) (bol (save-restriction (widen) - (rfc2047-point-at-bol)))) + (point-at-bol)))) (while (not (eobp)) (when (and (or break qword-break) (> (- (point) bol) 76)) @@ -784,18 +769,18 @@ Point moves to the end of the region." (goto-char (point-min)) (let ((bol (save-restriction (widen) - (rfc2047-point-at-bol))) - (eol (rfc2047-point-at-eol))) + (point-at-bol))) + (eol (point-at-eol))) (forward-line 1) (while (not (eobp)) (if (and (looking-at "[ \t]") - (< (- (rfc2047-point-at-eol) bol) 76)) + (< (- (point-at-eol) bol) 76)) (delete-region eol (progn (goto-char eol) (skip-chars-forward "\r\n") (point))) - (setq bol (rfc2047-point-at-bol))) - (setq eol (rfc2047-point-at-eol)) + (setq bol (point-at-bol))) + (setq eol (point-at-eol)) (forward-line 1))))) (defun rfc2047-b-encode-string (string) @@ -844,7 +829,7 @@ it, put the following line in your ~/.gnus.el file: (eval-and-compile (defconst rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(\\*[^?]+\\)?\ + "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\ \\?\\(B\\|Q\\)\\?\\([!->@-~ ]*\\)\\?=")) (defvar rfc2047-quote-decoded-words-containing-tspecials nil @@ -983,8 +968,8 @@ other than `\"' and `\\' in quoted strings." words nil) (while match (push (list (match-string 2) ;; charset - (char-after (match-beginning 4)) ;; encoding - (match-string 5) ;; encoded-text + (char-after (match-beginning 3)) ;; encoding + (match-string 4) ;; encoded-text (match-string 1)) ;; encoded-word words) ;; Look for the subsequent encoded-words. diff --git a/lisp/gnus/rfc2231.el b/lisp/gnus/rfc2231.el index 51d7523a648..6e9963c5321 100644 --- a/lisp/gnus/rfc2231.el +++ b/lisp/gnus/rfc2231.el @@ -53,8 +53,7 @@ must never cause a Lisp error." (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token)) (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) (ntoken (ietf-drums-token-to-list "0-9")) - c type attribute encoded number prev-attribute vals - prev-encoded parameters value) + c type attribute encoded number parameters value) (ietf-drums-init (condition-case nil (mail-header-remove-whitespace @@ -81,8 +80,8 @@ must never cause a Lisp error." ;; Finally, attempt to extract only type. (if (string-match (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+" - "\\(/[^" ietf-drums-tspecials - "\t\n ]+\\)?\\)\\([\t\n ;]\\|\\'\\)") + "\\(?:/[^" ietf-drums-tspecials + "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)") string) (match-string 1 string) "")))))) @@ -142,19 +141,6 @@ must never cause a Lisp error." (setq c (char-after))))) (setq number nil encoded nil)) - ;; See if we have any previous continuations. - (when (and prev-attribute - (not (eq prev-attribute attribute))) - (setq vals - (mapconcat 'cdr (sort vals 'car-less-than-car) "")) - (push (cons prev-attribute - (if prev-encoded - (rfc2231-decode-encoded-string vals) - vals)) - parameters) - (setq prev-attribute nil - vals nil - prev-encoded nil)) (unless (eq c ?=) (error "Invalid header: %s" string)) (forward-char 1) @@ -187,33 +173,33 @@ must never cause a Lisp error." (point))))) (t (error "Invalid header: %s" string))) - (if number - (progn - (push (cons number value) vals) - (setq prev-attribute attribute - prev-encoded encoded)) - (push (cons attribute - (if encoded - (rfc2231-decode-encoded-string value) - value)) - parameters)))) - - ;; Take care of any final continuations. - (when prev-attribute - (setq vals (mapconcat 'cdr (sort vals 'car-less-than-car) "")) - (push (cons prev-attribute - (if prev-encoded - (rfc2231-decode-encoded-string vals) - vals)) - parameters))) + (push (list attribute value number encoded) + parameters)))) (error (setq parameters nil) - (if signal-error - (signal (car err) (cdr err)) - ;;(message "%s" (error-message-string err)) - ))) + (when signal-error + (signal (car err) (cdr err))))) - (cons type (nreverse parameters)))))) + ;; Now collect and concatenate continuation parameters. + (let ((cparams nil) + elem) + (loop for (attribute value part encoded) + in (sort parameters (lambda (e1 e2) + (< (or (caddr e1) 0) + (or (caddr e2) 0)))) + do (if (or (not (setq elem (assq attribute cparams))) + (and (numberp part) + (zerop part))) + (push (list attribute value encoded) cparams) + (setcar (cdr elem) (concat (cadr elem) value)))) + ;; Finally decode encoded values. + (cons type (mapcar + (lambda (elem) + (cons (car elem) + (if (nth 2 elem) + (rfc2231-decode-encoded-string (nth 1 elem)) + (nth 1 elem)))) + (nreverse cparams)))))))) (defun rfc2231-decode-encoded-string (string) "Decode an RFC2231-encoded string. @@ -223,10 +209,10 @@ These look like: \"'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\", \"''This%20is%20%2A%2A%2Afun%2A%2A%2A\", or \"This is ***fun***\"." - (string-match "\\`\\(\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string) - (let ((coding-system (mm-charset-to-coding-system (match-string 2 string))) - ;;(language (match-string 3 string)) - (value (match-string 4 string))) + (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string) + (let ((coding-system (mm-charset-to-coding-system (match-string 1 string))) + ;;(language (match-string 2 string)) + (value (match-string 3 string))) (mm-with-unibyte-buffer (insert value) (goto-char (point-min)) diff --git a/lisp/gnus/sasl-cram.el b/lisp/gnus/sasl-cram.el new file mode 100644 index 00000000000..b8b1ced82ac --- /dev/null +++ b/lisp/gnus/sasl-cram.el @@ -0,0 +1,52 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Kenichi OKADA <okada@opaopa.org> +;; Keywords: SASL, CRAM-MD5 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program 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 3, or (at +;; your option) any later version. + +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defconst sasl-cram-md5-steps + '(ignore ;no initial response + sasl-cram-md5-response)) + +(defun sasl-cram-md5-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "CRAM-MD5 passphrase for %s: " + (sasl-client-name client))))) + (unwind-protect + (concat (sasl-client-name client) " " + (encode-hex-string + (hmac-md5 (sasl-step-data step) passphrase))) + (fillarray passphrase 0)))) + +(put 'sasl-cram 'sasl-mechanism + (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) + +(provide 'sasl-cram) + +;;; arch-tag: 46cb281b-975a-4fe0-a39f-3018691b1b05 +;;; sasl-cram.el ends here diff --git a/lisp/gnus/sasl-digest.el b/lisp/gnus/sasl-digest.el new file mode 100644 index 00000000000..c290c7524c8 --- /dev/null +++ b/lisp/gnus/sasl-digest.el @@ -0,0 +1,157 @@ +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Kenichi OKADA <okada@opaopa.org> +;; Keywords: SASL, DIGEST-MD5 + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program 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 3, or (at +;; your option) any later version. + +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;; This program is implemented from draft-leach-digest-sasl-05.txt. +;; +;; It is caller's responsibility to base64-decode challenges and +;; base64-encode responses in IMAP4 AUTHENTICATE command. +;; +;; Passphrase should be longer than 16 bytes. (See RFC 2195) + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defvar sasl-digest-md5-nonce-count 1) +(defvar sasl-digest-md5-unique-id-function + sasl-unique-id-function) + +(defvar sasl-digest-md5-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?, "." table) + table) + "A syntax table for parsing digest-challenge attributes.") + +(defconst sasl-digest-md5-steps + '(ignore ;no initial response + sasl-digest-md5-response + ignore)) ;"" + +(defun sasl-digest-md5-parse-string (string) + "Parse STRING and return a property list. +The value is a cons cell of the form \(realm nonce qop-options stale maxbuf +charset algorithm cipher-opts auth-param)." + (with-temp-buffer + (set-syntax-table sasl-digest-md5-syntax-table) + (save-excursion + (insert string) + (goto-char (point-min)) + (insert "(") + (while (progn (forward-sexp) (not (eobp))) + (delete-char 1) + (insert " ")) + (insert ")") + (read (point-min-marker))))) + +(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name) + (concat serv-type "/" host + (if (and serv-name + (not (string= host serv-name))) + (concat "/" serv-name)))) + +(defun sasl-digest-md5-cnonce () + (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function)) + (sasl-unique-id))) + +(defun sasl-digest-md5-response-value (username + realm + nonce + cnonce + nonce-count + qop + digest-uri + authzid) + (let ((passphrase + (sasl-read-passphrase + (format "DIGEST-MD5 passphrase for %s: " + username)))) + (unwind-protect + (encode-hex-string + (md5-binary + (concat + (encode-hex-string + (md5-binary (concat (md5-binary + (concat username ":" realm ":" passphrase)) + ":" nonce ":" cnonce + (if authzid + (concat ":" authzid))))) + ":" nonce + ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" digest-uri + (if (member qop '("auth-int" "auth-conf")) + ":00000000000000000000000000000000"))))))) + (fillarray passphrase 0)))) + +(defun sasl-digest-md5-response (client step) + (let* ((plist + (sasl-digest-md5-parse-string (sasl-step-data step))) + (realm + (or (sasl-client-property client 'realm) + (plist-get plist 'realm))) ;need to check + (nonce-count + (or (sasl-client-property client 'nonce-count) + sasl-digest-md5-nonce-count)) + (qop + (or (sasl-client-property client 'qop) + "auth")) + (digest-uri + (sasl-digest-md5-digest-uri + (sasl-client-service client)(sasl-client-server client))) + (cnonce + (or (sasl-client-property client 'cnonce) + (sasl-digest-md5-cnonce)))) + (sasl-client-set-property client 'nonce-count (1+ nonce-count)) + (unless (string= qop "auth") + (sasl-error (format "Unsupported \"qop-value\": %s" qop))) + (concat + "username=\"" (sasl-client-name client) "\"," + "realm=\"" realm "\"," + "nonce=\"" (plist-get plist 'nonce) "\"," + "cnonce=\"" cnonce "\"," + (format "nc=%08x," nonce-count) + "digest-uri=\"" digest-uri "\"," + "qop=" qop "," + "response=" + (sasl-digest-md5-response-value + (sasl-client-name client) + realm + (plist-get plist 'nonce) + cnonce + nonce-count + qop + digest-uri + (plist-get plist 'authzid))))) + +(put 'sasl-digest 'sasl-mechanism + (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps)) + +(provide 'sasl-digest) + +;;; arch-tag: 786e02ed-1bc4-4b3c-bf34-96c27e31084d +;;; sasl-digest.el ends here diff --git a/lisp/gnus/sasl-ntlm.el b/lisp/gnus/sasl-ntlm.el new file mode 100644 index 00000000000..784b373c056 --- /dev/null +++ b/lisp/gnus/sasl-ntlm.el @@ -0,0 +1,66 @@ +;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Taro Kawagishi <tarok@transpulse.org> +;; Keywords: SASL, NTLM +;; Version: 1.00 +;; Created: February 2001 + +;; This program 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 3, or (at your option) +;; any later version. +;; +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This is a SASL interface layer for NTLM authentication message +;; generation by ntlm.el + +;;; Code: + +(require 'sasl) +(require 'ntlm) + +(defconst sasl-ntlm-steps + '(ignore ;nothing to do before making + sasl-ntlm-request ;authentication request + sasl-ntlm-response) ;response to challenge + "A list of functions to be called in sequnece for the NTLM +authentication steps. Ther are called by 'sasl-next-step.") + +(defun sasl-ntlm-request (client step) + "SASL step function to generate a NTLM authentication request to the server. +Called from 'sasl-next-step. +CLIENT is a vector [mechanism user service server sasl-client-properties] +STEP is a vector [<previous step function> <result of previous step function>]" + (let ((user (sasl-client-name client))) + (ntlm-build-auth-request user))) + +(defun sasl-ntlm-response (client step) + "SASL step function to generate a NTLM response against the server +challenge stored in the 2nd element of STEP. Called from 'sasl-next-step." + (let* ((user (sasl-client-name client)) + (passphrase + (sasl-read-passphrase (format "NTLM passphrase for %s: " user))) + (challenge (sasl-step-data step))) + (ntlm-build-auth-response challenge user + (ntlm-get-password-hashes passphrase)))) + +(put 'sasl-ntlm 'sasl-mechanism + (sasl-make-mechanism "NTLM" sasl-ntlm-steps)) + +(provide 'sasl-ntlm) + +;;; arch-tag: 1d9164c1-1df0-418f-b7ab-360157fd05dc +;;; sasl-ntlm.el ends here diff --git a/lisp/gnus/sasl.el b/lisp/gnus/sasl.el new file mode 100644 index 00000000000..d730dddcb20 --- /dev/null +++ b/lisp/gnus/sasl.el @@ -0,0 +1,273 @@ +;;; sasl.el --- SASL client framework + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Keywords: SASL + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; This program 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 3, or (at +;; your option) any later version. + +;; This program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This module provides common interface functions to share several +;; SASL mechanism drivers. The toplevel is designed to be mostly +;; compatible with [Java-SASL]. +;; +;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", +;; RFC 2222, October 1997. +;; +;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program +;; Interface", draft-weltman-java-sasl-03.txt, March 2000. + +;;; Code: + +(defvar sasl-mechanisms + '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" + "NTLM" "SCRAM-MD5")) + +(defvar sasl-mechanism-alist + '(("CRAM-MD5" sasl-cram) + ("DIGEST-MD5" sasl-digest) + ("PLAIN" sasl-plain) + ("LOGIN" sasl-login) + ("ANONYMOUS" sasl-anonymous) + ("NTLM" sasl-ntlm) + ("SCRAM-MD5" sasl-scram))) + +(defvar sasl-unique-id-function #'sasl-unique-id-function) + +(put 'sasl-error 'error-message "SASL error") +(put 'sasl-error 'error-conditions '(sasl-error error)) + +(defun sasl-error (datum) + (signal 'sasl-error (list datum))) + +;;; @ SASL client +;;; + +(defun sasl-make-client (mechanism name service server) + "Return a newly allocated SASL client. +NAME is name of the authorization. SERVICE is name of the service desired. +SERVER is the fully qualified host name of the server to authenticate to." + (vector mechanism name service server (make-symbol "sasl-client-properties"))) + +(defun sasl-client-mechanism (client) + "Return the authentication mechanism driver of CLIENT." + (aref client 0)) + +(defun sasl-client-name (client) + "Return the authorization name of CLIENT, a string." + (aref client 1)) + +(defun sasl-client-service (client) + "Return the service name of CLIENT, a string." + (aref client 2)) + +(defun sasl-client-server (client) + "Return the server name of CLIENT, a string." + (aref client 3)) + +(defun sasl-client-set-properties (client plist) + "Destructively set the properties of CLIENT. +The second argument PLIST is the new property list." + (setplist (aref client 4) plist)) + +(defun sasl-client-set-property (client property value) + "Add the given property/value to CLIENT." + (put (aref client 4) property value)) + +(defun sasl-client-property (client property) + "Return the value of the PROPERTY of CLIENT." + (get (aref client 4) property)) + +(defun sasl-client-properties (client) + "Return the properties of CLIENT." + (symbol-plist (aref client 4))) + +;;; @ SASL mechanism +;;; + +(defun sasl-make-mechanism (name steps) + "Make an authentication mechanism. +NAME is a IANA registered SASL mechanism name. +STEPS is list of continuation function." + (vector name + (mapcar + (lambda (step) + (let ((symbol (make-symbol (symbol-name step)))) + (fset symbol (symbol-function step)) + symbol)) + steps))) + +(defun sasl-mechanism-name (mechanism) + "Return name of MECHANISM, a string." + (aref mechanism 0)) + +(defun sasl-mechanism-steps (mechanism) + "Return the authentication steps of MECHANISM, a list of functions." + (aref mechanism 1)) + +(defun sasl-find-mechanism (mechanisms) + "Retrieve an apropriate mechanism object from MECHANISMS hints." + (let* ((sasl-mechanisms sasl-mechanisms) + (mechanism + (catch 'done + (while sasl-mechanisms + (if (member (car sasl-mechanisms) mechanisms) + (throw 'done (nth 1 (assoc (car sasl-mechanisms) + sasl-mechanism-alist)))) + (setq sasl-mechanisms (cdr sasl-mechanisms)))))) + (if mechanism + (require mechanism)) + (get mechanism 'sasl-mechanism))) + +;;; @ SASL authentication step +;;; + +(defun sasl-step-data (step) + "Return the data which STEP holds, a string." + (aref step 1)) + +(defun sasl-step-set-data (step data) + "Store DATA string to STEP." + (aset step 1 data)) + +(defun sasl-next-step (client step) + "Evaluate the challenge and prepare an appropriate next response. +The data type of the value and optional 2nd argument STEP is nil or +opaque authentication step which holds the reference to the next action +and the current challenge. At the first time STEP should be set to nil." + (let* ((steps + (sasl-mechanism-steps + (sasl-client-mechanism client))) + (function + (if (vectorp step) + (nth 1 (memq (aref step 0) steps)) + (car steps)))) + (if function + (vector function (funcall function client step))))) + +(defvar sasl-read-passphrase nil) +(defun sasl-read-passphrase (prompt) + (if (not sasl-read-passphrase) + (if (functionp 'read-passwd) + (setq sasl-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq sasl-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) + (funcall sasl-read-passphrase prompt)) + +(defun sasl-unique-id () + "Compute a data string which must be different each time. +It contain at least 64 bits of entropy." + (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) + +(defvar sasl-unique-id-char nil) + +;; stolen (and renamed) from message.el +(defun sasl-unique-id-function () + ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Instead we use this randomly inited counter. + (setq sasl-unique-id-char + (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) + ;; (current-time) returns 16-bit ints, + ;; and 2^16*25 just fits into 4 digits i base 36. + (* 25 25))) + (let ((tm (current-time))) + (concat + (sasl-unique-id-number-base36 + (+ (car tm) + (lsh (% sasl-unique-id-char 25) 16)) 4) + (sasl-unique-id-number-base36 + (+ (nth 1 tm) + (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + +(defun sasl-unique-id-number-base36 (num len) + (if (if (< len 0) + (<= num 0) + (= len 0)) + "" + (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) + (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" + (% num 36)))))) + +;;; PLAIN (RFC2595 Section 6) +(defconst sasl-plain-steps + '(sasl-plain-response)) + +(defun sasl-plain-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "PLAIN passphrase for %s: " (sasl-client-name client)))) + (authenticator-name + (sasl-client-property + client 'authenticator-name)) + (name (sasl-client-name client))) + (unwind-protect + (if (and authenticator-name + (not (string= authenticator-name name))) + (concat authenticator-name "\0" name "\0" passphrase) + (concat "\0" name "\0" passphrase)) + (fillarray passphrase 0)))) + +(put 'sasl-plain 'sasl-mechanism + (sasl-make-mechanism "PLAIN" sasl-plain-steps)) + +(provide 'sasl-plain) + +;;; LOGIN (No specification exists) +(defconst sasl-login-steps + '(ignore ;no initial response + sasl-login-response-1 + sasl-login-response-2)) + +(defun sasl-login-response-1 (client step) +;;; (unless (string-match "^Username:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-client-name client)) + +(defun sasl-login-response-2 (client step) +;;; (unless (string-match "^Password:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " (sasl-client-name client)))) + +(put 'sasl-login 'sasl-mechanism + (sasl-make-mechanism "LOGIN" sasl-login-steps)) + +(provide 'sasl-login) + +;;; ANONYMOUS (RFC2245) +(defconst sasl-anonymous-steps + '(ignore ;no initial response + sasl-anonymous-response)) + +(defun sasl-anonymous-response (client step) + (or (sasl-client-property client 'trace) + (sasl-client-name client))) + +(put 'sasl-anonymous 'sasl-mechanism + (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) + +(provide 'sasl-anonymous) + +(provide 'sasl) + +;;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887 +;;; sasl.el ends here diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 33cdfe55944..c71ef32f22c 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -31,6 +31,9 @@ (require 'mm-util) ; for mm-universal-coding-system (require 'gnus-util) ; for gnus-pp, gnus-run-mode-hooks +(defvar gnus-score-edit-done-hook nil + "*Hook run at the end of closing the score buffer.") + (defvar gnus-score-mode-hook nil "*Hook run in score mode buffers.") diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index 2f0e54a234b..d8bd965718d 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -27,7 +27,10 @@ ;; This library provides an elisp API for the managesieve network ;; protocol. ;; -;; Currently only the CRAM-MD5 authentication mechanism is supported. +;; It uses the SASL library for authentication, which means it +;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN +;; methods. STARTTLS is not well tested, but should be easy to get to +;; work if someone wants. ;; ;; The API should be fairly obvious for anyone familiar with the ;; managesieve protocol, interface functions include: @@ -69,15 +72,17 @@ ;; ;; 2001-10-31 Committed to Oort Gnus. ;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd. +;; 2002-08-03 Use SASL library. ;;; Code: -(require 'rfc2104) -(or (fboundp 'md5) - (require 'md5)) +(require 'password) +(eval-when-compile + (require 'sasl) + (require 'starttls)) (eval-and-compile - (autoload 'starttls-open-stream "starttls") - (autoload 'starttls-negotiate "starttls")) + (autoload 'sasl-find-mechanism "sasl") + (autoload 'starttls-open-stream "starttls")) ;; User customizable variables: @@ -123,13 +128,22 @@ server support the stream and OPEN is a function for opening the stream." :group 'sieve-manage) -(defcustom sieve-manage-authenticators '(cram-md5 plain) +(defcustom sieve-manage-authenticators '(digest-md5 + cram-md5 + scram-md5 + ntlm + plain + login) "Priority of authenticators to consider when authenticating to server." :group 'sieve-manage) (defcustom sieve-manage-authenticator-alist '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth) - (plain sieve-manage-plain-p sieve-manage-plain-auth)) + (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth) + (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth) + (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth) + (plain sieve-manage-plain-p sieve-manage-plain-auth) + (login sieve-manage-login-p sieve-manage-login-auth)) "Definition of authenticators. \(NAME CHECK AUTHENTICATE) @@ -188,38 +202,45 @@ Returns t if login was successful, nil otherwise." (with-current-buffer buffer (make-local-variable 'sieve-manage-username) (make-local-variable 'sieve-manage-password) - (let (user passwd ret reason) - ;; (condition-case () - (while (or (not user) (not passwd)) - (setq user (or sieve-manage-username - (read-from-minibuffer - (concat "Managesieve username for " - sieve-manage-server ": ") - (or user sieve-manage-default-user)))) - (setq passwd (or sieve-manage-password - (read-passwd - (concat "Managesieve password for " user "@" - sieve-manage-server ": ")))) - (when (and user passwd) - (if (funcall loginfunc user passwd) - (progn - (setq ret t - sieve-manage-username user) - (if (and (not sieve-manage-password) - (y-or-n-p "Store password for this session? ")) - (setq sieve-manage-password passwd))) - (if reason - (message "Login failed (reason given: %s)..." reason) - (message "Login failed...")) - (setq reason nil) - (setq passwd nil) - (sit-for 1)))) - ;; (quit (with-current-buffer buffer - ;; (setq user nil - ;; passwd nil))) - ;; (error (with-current-buffer buffer - ;; (setq user nil - ;; passwd nil)))) + (let (user passwd ret reason passwd-key) + (condition-case () + (while (or (not user) (not passwd)) + (setq user (or sieve-manage-username + (read-from-minibuffer + (concat "Managesieve username for " + sieve-manage-server ": ") + (or user sieve-manage-default-user))) + passwd-key (concat "managesieve:" user "@" sieve-manage-server + ":" sieve-manage-port) + passwd (or sieve-manage-password + (password-read (concat "Managesieve password for " + user "@" sieve-manage-server + ": ") + passwd-key))) + (when (y-or-n-p "Store password for this session? ") + (password-cache-add passwd-key (copy-sequence passwd))) + (when (and user passwd) + (if (funcall loginfunc user passwd) + (setq ret t + sieve-manage-username user) + (if reason + (message "Login failed (reason given: %s)..." reason) + (message "Login failed...")) + (password-cache-remove passwd-key) + (setq sieve-manage-password nil) + (setq passwd nil) + (setq reason nil) + (sit-for 1)))) + (quit (with-current-buffer buffer + (password-cache-remove passwd-key) + (setq user nil + passwd nil + sieve-manage-password nil))) + (error (with-current-buffer buffer + (password-cache-remove passwd-key) + (setq user nil + passwd nil + sieve-manage-password nil)))) ret))) (defun sieve-manage-erase (&optional p buffer) @@ -304,60 +325,111 @@ Returns t if login was successful, nil otherwise." ;; Authenticators +(defun sieve-sasl-auth (buffer mech) + "Login to server using the SASL MECH method." + (message "sieve: Authenticating using %s..." mech) + (if (sieve-manage-interactive-login + buffer + (lambda (user passwd) + (let (client step tag data rsp) + (setq client (sasl-make-client (sasl-find-mechanism (list mech)) + user "sieve" sieve-manage-server)) + (setq sasl-read-passphrase (function (lambda (prompt) passwd))) + (setq step (sasl-next-step client nil)) + (setq tag + (sieve-manage-send + (concat + "AUTHENTICATE \"" + mech + "\"" + (and (sasl-step-data step) + (concat + " \"" + (base64-encode-string + (sasl-step-data step) + 'no-line-break) + "\""))))) + (catch 'done + (while t + (setq rsp nil) + (goto-char (point-min)) + (while (null (or (progn + (setq rsp (sieve-manage-is-string)) + (if (not (and rsp (looking-at + sieve-manage-server-eol))) + (setq rsp nil) + (goto-char (match-end 0)) + rsp)) + (setq rsp (sieve-manage-is-okno)))) + (accept-process-output sieve-manage-process 1) + (goto-char (point-min))) + (sieve-manage-erase) + (when (sieve-manage-ok-p rsp) + (when (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)) + (sasl-step-set-data + step (base64-decode-string (match-string 1 (cadr rsp))))) + (if (and (setq step (sasl-next-step client step)) + (setq data (sasl-step-data step))) + ;; We got data for server but it's finished + (error "Server not ready for SASL data: %s" data) + ;; The authentication process is finished. + (throw 'done t))) + (unless (stringp rsp) + (apply 'error "Server aborted SASL authentication: %s %s %s" + rsp)) + (sasl-step-set-data step (base64-decode-string rsp)) + (setq step (sasl-next-step client step)) + (sieve-manage-send + (if (sasl-step-data step) + (concat "\"" + (base64-encode-string (sasl-step-data step) + 'no-line-break) + "\"") + ""))))))) + (message "sieve: Authenticating using %s...done" mech) + (message "sieve: Authenticating using %s...failed" mech))) + +(defun sieve-manage-cram-md5-p (buffer) + (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) + +(defun sieve-manage-cram-md5-auth (buffer) + "Login to managesieve server using the CRAM-MD5 SASL method." + (sieve-sasl-auth buffer "CRAM-MD5")) + +(defun sieve-manage-digest-md5-p (buffer) + (sieve-manage-capability "SASL" "DIGEST-MD5" buffer)) + +(defun sieve-manage-digest-md5-auth (buffer) + "Login to managesieve server using the DIGEST-MD5 SASL method." + (sieve-sasl-auth buffer "DIGEST-MD5")) + +(defun sieve-manage-scram-md5-p (buffer) + (sieve-manage-capability "SASL" "SCRAM-MD5" buffer)) + +(defun sieve-manage-scram-md5-auth (buffer) + "Login to managesieve server using the SCRAM-MD5 SASL method." + (sieve-sasl-auth buffer "SCRAM-MD5")) + +(defun sieve-manage-ntlm-p (buffer) + (sieve-manage-capability "SASL" "NTLM" buffer)) + +(defun sieve-manage-ntlm-auth (buffer) + "Login to managesieve server using the NTLM SASL method." + (sieve-sasl-auth buffer "NTLM")) + (defun sieve-manage-plain-p (buffer) (sieve-manage-capability "SASL" "PLAIN" buffer)) (defun sieve-manage-plain-auth (buffer) "Login to managesieve server using the PLAIN SASL method." - (let* ((done (sieve-manage-interactive-login - buffer - (lambda (user passwd) - (sieve-manage-send (concat "AUTHENTICATE \"PLAIN\" \"" - (base64-encode-string - (concat (char-to-string 0) - user - (char-to-string 0) - passwd)) - "\"")) - (let ((rsp (sieve-manage-parse-okno))) - (if (sieve-manage-ok-p rsp) - t - (setq reason (cdr-safe rsp)) - nil)))))) - (if done - (message "sieve: Authenticating using PLAIN...done") - (message "sieve: Authenticating using PLAIN...failed")))) + (sieve-sasl-auth buffer "PLAIN")) -(defun sieve-manage-cram-md5-p (buffer) - (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) +(defun sieve-manage-login-p (buffer) + (sieve-manage-capability "SASL" "LOGIN" buffer)) -(defun sieve-manage-cram-md5-auth (buffer) - "Login to managesieve server using the CRAM-MD5 SASL method." - (message "sieve: Authenticating using CRAM-MD5...") - (let* ((done (sieve-manage-interactive-login - buffer - (lambda (user passwd) - (sieve-manage-send "AUTHENTICATE \"CRAM-MD5\"") - (sieve-manage-send - (concat - "\"" - (base64-encode-string - (concat - user " " - (rfc2104-hash 'md5 64 16 passwd - (base64-decode-string - (prog1 - (sieve-manage-parse-string) - (sieve-manage-erase)))))) - "\"")) - (let ((rsp (sieve-manage-parse-okno))) - (if (sieve-manage-ok-p rsp) - t - (setq reason (cdr-safe rsp)) - nil)))))) - (if done - (message "sieve: Authenticating using CRAM-MD5...done") - (message "sieve: Authenticating using CRAM-MD5...failed")))) +(defun sieve-manage-login-auth (buffer) + "Login to managesieve server using the LOGIN SASL method." + (sieve-sasl-auth buffer "LOGIN")) ;; Managesieve API diff --git a/lisp/gnus/sieve-mode.el b/lisp/gnus/sieve-mode.el index 694cad6e77c..d12045627fb 100644 --- a/lisp/gnus/sieve-mode.el +++ b/lisp/gnus/sieve-mode.el @@ -51,7 +51,6 @@ (autoload 'sieve-manage "sieve") (autoload 'sieve-upload "sieve") -(autoload 'c-mode "cc-mode") (require 'easymenu) (eval-when-compile (require 'font-lock)) diff --git a/lisp/gnus/sieve.el b/lisp/gnus/sieve.el index 3605da590de..2d4dfba4ee6 100644 --- a/lisp/gnus/sieve.el +++ b/lisp/gnus/sieve.el @@ -145,7 +145,7 @@ require \"fileinto\"; (setq mode-name "SIEVE") (buffer-disable-undo (current-buffer)) (setq truncate-lines t) - (easy-menu-add-item nil nil sieve-manage-mode-menu)) + (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) (put 'sieve-manage-mode 'mode-class 'special) diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index 2b13ecd7388..b0f194893b5 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -58,24 +58,65 @@ "Turn :-)'s into real images." :group 'gnus-visual) -;; Maybe this should go. -(defcustom smiley-data-directory - (nnheader-find-etc-directory "images/smilies") - "Location of the smiley faces files." +(defvar smiley-data-directory) + +(defcustom smiley-style + (if (or (and (fboundp 'face-attribute) + (>= (face-attribute 'default :height) 160)) + (and (fboundp 'face-height) + (>= (face-height 'default) 14))) + 'medium + 'low-color) + "Smiley style." + :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 + (const :tag "medium, ~10 colors" medium) ;; 16x16 + (const :tag "dull, grayscale" grayscale));; 14x14 + :set (lambda (symbol value) + (set-default symbol value) + (setq smiley-data-directory (smiley-directory)) + (smiley-update-cache)) + :initialize 'custom-initialize-default + :version "23.0" ;; No Gnus + :group 'smiley) + +;; For compatibility, honor the variable `smiley-data-directory' if the user +;; has set it. + +(defun smiley-directory (&optional style) + "Return a the location of the smiley faces files. +STYLE specifies which style to use, see `smiley-style'. If STYLE +is nil, use `smiley-style'." + (unless style (setq style smiley-style)) + (nnheader-find-etc-directory + (concat "images/smilies" + (cond ((eq smiley-style 'low-color) "") + ((eq smiley-style 'medium) "/medium") + ((eq smiley-style 'grayscale) "/grayscale"))))) + +(defcustom smiley-data-directory (smiley-directory) + "*Location of the smiley faces files." + :set (lambda (symbol value) + (set-default symbol value) + (smiley-update-cache)) + :initialize 'custom-initialize-default :type 'directory :group 'smiley) ;; The XEmacs version has a baroque, if not rococo, set of these. (defcustom smiley-regexp-alist - '(("\\(:-?)\\)\\W" 1 "smile") - ("\\(;-?)\\)\\W" 1 "blink") + '(("\\(;-?)\\)\\W" 1 "blink") ("\\(:-]\\)\\W" 1 "forced") ("\\(8-)\\)\\W" 1 "braindamaged") ("\\(:-|\\)\\W" 1 "indifferent") ("\\(:-[/\\]\\)\\W" 1 "wry") ("\\(:-(\\)\\W" 1 "sad") ("\\(X-)\\)\\W" 1 "dead") - ("\\(:-{\\)\\W" 1 "frown")) + ("\\(:-{\\)\\W" 1 "frown") + ("\\(>:-)\\)\\W" 1 "evil") + ("\\(;-(\\)\\W" 1 "cry") + ("\\(:-D\\)\\W" 1 "grin") + ;; "smile" must be come after "evil" + ("\\(\\^?:-?)\\)\\W" 1 "smile")) "*A list of regexps to map smilies to images. The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in regexp to replace with IMAGE. IMAGE is the name of an image file in diff --git a/lisp/gnus/smime-ldap.el b/lisp/gnus/smime-ldap.el new file mode 100644 index 00000000000..882f9f80c6f --- /dev/null +++ b/lisp/gnus/smime-ldap.el @@ -0,0 +1,206 @@ +;;; smime-ldap.el --- client interface to LDAP for Emacs + +;; Copyright (C) 1998, 1999, 2000, 2005 Free Software Foundation, Inc. + +;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> +;; Maintainer: Arne J,Ax(Brgensen <arne@arnested.dk> +;; Created: February 2005 +;; Keywords: comm + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file has a slightly changed implementation of Emacs 21.3's +;; ldap-search and ldap-search-internal from ldap.el. The changes are +;; made to achieve compatibility with OpenLDAP v2 and to make it +;; possible to retrieve LDAP attributes that are tagged ie ";binary". + +;; The file also adds a compatibility layer for Emacs and XEmacs. + +;;; Code: + +(require 'ldap) + +(defun smime-ldap-search (filter &optional host attributes attrsonly withdn) + "Perform an LDAP search. +FILTER is the search filter in RFC1558 syntax. +HOST is the LDAP host on which to perform the search. +ATTRIBUTES are the specific attributes to retrieve, nil means +retrieve all. +ATTRSONLY, if non-nil, retrieves the attributes only, without +the associated values. +If WITHDN is non-nil, each entry in the result will be prepended with +its distinguished name WITHDN. +Additional search parameters can be specified through +`ldap-host-parameters-alist', which see." + (interactive "sFilter:") + ;; for XEmacs + (if (fboundp 'ldap-search-entries) + (ldap-search-entries filter host attributes attrsonly) + ;; for Emacs 22 + (if (>= emacs-major-version 22) + (cdr (ldap-search filter host attributes attrsonly)) + ;; for Emacs 21.x + (or host + (setq host ldap-default-host) + (error "No LDAP host specified")) + (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) + result) + (setq result (smime-ldap-search-internal + (append host-plist + (list 'host host + 'filter filter + 'attributes attributes + 'attrsonly attrsonly + 'withdn withdn)))) + (cdr (if ldap-ignore-attribute-codings + result + (mapcar (function + (lambda (record) + (mapcar 'ldap-decode-attribute record))) + result))))))) + +(defun smime-ldap-search-internal (search-plist) + "Perform a search on a LDAP server. +SEARCH-PLIST is a property list describing the search request. +Valid keys in that list are: +`host' is a string naming one or more (blank-separated) LDAP servers to +to try to connect to. Each host name may optionally be of the form HOST:PORT. +`filter' is a filter string for the search as described in RFC 1558. +`attributes' is a list of strings indicating which attributes to retrieve +for each matching entry. If nil, return all available attributes. +`attrsonly', if non-nil, indicates that only attributes are retrieved, +not their associated values. +`base' is the base for the search as described in RFC 1779. +`scope' is one of the three symbols `sub', `base' or `one'. +`binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax). +`passwd' is the password to use for simple authentication. +`deref' is one of the symbols `never', `always', `search' or `find'. +`timelimit' is the timeout limit for the connection in seconds. +`sizelimit' is the maximum number of matches to return. +`withdn' if non-nil each entry in the result will be prepended with +its distinguished name DN. +The function returns a list of matching entries. Each entry is itself +an alist of attribute/value pairs." + (let ((buf (get-buffer-create " *ldap-search*")) + (bufval (get-buffer-create " *ldap-value*")) + (host (or (plist-get search-plist 'host) + ldap-default-host)) + (filter (plist-get search-plist 'filter)) + (attributes (plist-get search-plist 'attributes)) + (attrsonly (plist-get search-plist 'attrsonly)) + (base (or (plist-get search-plist 'base) + ldap-default-base)) + (scope (plist-get search-plist 'scope)) + (binddn (plist-get search-plist 'binddn)) + (passwd (plist-get search-plist 'passwd)) + (deref (plist-get search-plist 'deref)) + (timelimit (plist-get search-plist 'timelimit)) + (sizelimit (plist-get search-plist 'sizelimit)) + (withdn (plist-get search-plist 'withdn)) + (numres 0) + arglist dn name value record result) + (if (or (null filter) + (equal "" filter)) + (error "No search filter")) + (setq filter (cons filter attributes)) + (save-excursion + (set-buffer buf) + (erase-buffer) + (if (and host + (not (equal "" host))) + (setq arglist (nconc arglist (list (format "-h%s" host))))) + (if (and attrsonly + (not (equal "" attrsonly))) + (setq arglist (nconc arglist (list "-A")))) + (if (and base + (not (equal "" base))) + (setq arglist (nconc arglist (list (format "-b%s" base))))) + (if (and scope + (not (equal "" scope))) + (setq arglist (nconc arglist (list (format "-s%s" scope))))) + (if (and binddn + (not (equal "" binddn))) + (setq arglist (nconc arglist (list (format "-D%s" binddn))))) + (if (and passwd + (not (equal "" passwd))) + (setq arglist (nconc arglist (list (format "-w%s" passwd))))) + (if (and deref + (not (equal "" deref))) + (setq arglist (nconc arglist (list (format "-a%s" deref))))) + (if (and timelimit + (not (equal "" timelimit))) + (setq arglist (nconc arglist (list (format "-l%s" timelimit))))) + (if (and sizelimit + (not (equal "" sizelimit))) + (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) + (eval `(call-process ldap-ldapsearch-prog + nil + buf + nil + ,@arglist + "-tt" ; Write values to temp files + "-x" + "-LL" + ; ,@ldap-ldapsearch-args + ,@filter)) + (insert "\n") + (goto-char (point-min)) + + (while (re-search-forward "[\t\n\f]+ " nil t) + (replace-match "" nil nil)) + (goto-char (point-min)) + + (if (looking-at "usage") + (error "Incorrect ldapsearch invocation") + (message "Parsing results... ") + (while (progn + (skip-chars-forward " \t\n") + (not (eobp))) + (setq dn (buffer-substring (point) (save-excursion + (end-of-line) + (point)))) + (forward-line 1) + (while (looking-at (concat "^\\(\\w*\\)\\(;\\w*\\)?[=:\t ]+" + "\\(<[\t ]*file://\\)?\\(.*\\)$")) + (setq name (match-string 1) + value (match-string 4)) + (save-excursion + (set-buffer bufval) + (erase-buffer) + (insert-file-contents-literally value) + (delete-file value) + (setq value (buffer-substring (point-min) (point-max)))) + (setq record (cons (list name value) + record)) + (forward-line 1)) + (setq result (cons (if withdn + (cons dn (nreverse record)) + (nreverse record)) result)) + (setq record nil) + (skip-chars-forward " \t\n") + (message "Parsing results... %d" numres) + (1+ numres)) + (message "Parsing results... done") + (nreverse result))))) + +(provide 'smime-ldap) + +;; arch-tag: 87e6bc44-21fc-4e9b-a89b-f55f031f78f8 +;;; smime-ldap.el ends here diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index 62d1f27b4b5..ee62fd8124b 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -28,7 +28,7 @@ ;; This library perform S/MIME operations from within Emacs. ;; ;; Functions for fetching certificates from public repositories are -;; provided, currently only from DNS. LDAP support (via EUDC) is planned. +;; provided, currently from DNS and LDAP. ;; ;; It uses OpenSSL (tested with version 0.9.5a and 0.9.6) for signing, ;; encryption and decryption. @@ -117,12 +117,28 @@ ;; 2000-06-05 initial version, committed to Gnus CVS contrib/ ;; 2000-10-28 retrieve certificates via DNS CERT RRs ;; 2001-10-14 posted to gnu.emacs.sources +;; 2005-02-13 retrieve certificates via LDAP ;;; Code: (require 'dig) +(require 'smime-ldap) +(require 'password) (eval-when-compile (require 'cl)) +(eval-and-compile + (cond + ((fboundp 'replace-in-string) + (defalias 'smime-replace-in-string 'replace-in-string)) + ((fboundp 'replace-regexp-in-string) + (defun smime-replace-in-string (string regexp newtext &optional literal) + "Replace all matches for REGEXP with NEWTEXT in STRING. +If LITERAL is non-nil, insert NEWTEXT literally. Return a new +string containing the replacements. + +This is a compatibility function for different Emacsen." + (replace-regexp-in-string regexp newtext string nil literal))))) + (defgroup smime nil "S/MIME configuration." :group 'mime) @@ -218,6 +234,14 @@ If nil, use system defaults." string) :group 'smime) +(defcustom smime-ldap-host-list nil + "A list of LDAP hosts with S/MIME user certificates. +If needed search base, binddn, passwd, etc. for the LDAP host +must be set in `ldap-host-parameters-alist'." + :type '(repeat (string :tag "Host name")) + :version "23.0" ;; No Gnus + :group 'smime) + (defvar smime-details-buffer "*OpenSSL output*") ;; Use mm-util? @@ -234,11 +258,13 @@ If nil, use system defaults." ;; Password dialog function -(defun smime-ask-passphrase () - "Asks the passphrase to unlock the secret key." +(defun smime-ask-passphrase (&optional cache-key) + "Asks the passphrase to unlock the secret key. +If `cache-key' and `password-cache' is non-nil then cache the +password under `cache-key'." (let ((passphrase - (read-passwd - "Passphrase for secret key (RET for no passphrase): "))) + (password-read-and-add + "Passphrase for secret key (RET for no passphrase): " cache-key))) (if (string= passphrase "") nil passphrase))) @@ -270,11 +296,11 @@ certificates to include in its caar. If no additional certificates is included, KEYFILE may be the file containing the PEM encoded private key and certificate itself." (smime-new-details-buffer) - (let ((keyfile (or (car-safe keyfile) keyfile)) - (certfiles (and (cdr-safe keyfile) (cadr keyfile))) - (buffer (generate-new-buffer (generate-new-buffer-name " *smime*"))) - (passphrase (smime-ask-passphrase)) - (tmpfile (smime-make-temp-file "smime"))) + (let* ((certfiles (and (cdr-safe keyfile) (cadr keyfile))) + (keyfile (or (car-safe keyfile) keyfile)) + (buffer (generate-new-buffer (generate-new-buffer-name " *smime*"))) + (passphrase (smime-ask-passphrase (expand-file-name keyfile))) + (tmpfile (smime-make-temp-file "smime"))) (if passphrase (setenv "GNUS_SMIME_PASSPHRASE" passphrase)) (prog1 @@ -408,7 +434,7 @@ Any details (stderr on success, stdout and stderr on error) are left in the buffer specified by `smime-details-buffer'." (smime-new-details-buffer) (let ((buffer (generate-new-buffer (generate-new-buffer-name " *smime*"))) - CAs (passphrase (smime-ask-passphrase)) + CAs (passphrase (smime-ask-passphrase (expand-file-name keyfile))) (tmpfile (smime-make-temp-file "smime"))) (if passphrase (setenv "GNUS_SMIME_PASSPHRASE" passphrase)) @@ -521,20 +547,13 @@ A string or a list of strings is returned." (caddr curkey) (smime-get-certfiles keyfile otherkeys))))) -;; Use mm-util? -(eval-and-compile - (defalias 'smime-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) - (defun smime-buffer-as-string-region (b e) "Return each line in region between B and E as a list of strings." (save-excursion (goto-char b) (let (res) (while (< (point) e) - (let ((str (buffer-substring (point) (smime-point-at-eol)))) + (let ((str (buffer-substring (point) (point-at-eol)))) (unless (string= "" str) (push str res))) (forward-line)) @@ -548,6 +567,7 @@ A string or a list of strings is returned." mailaddr)) (defun smime-cert-by-dns (mail) + "Find certificate via DNS for address MAIL." (let* ((dig-dns-server smime-dns-server) (digbuf (dig-invoke (smime-mail-to-domain mail) "cert" nil nil "+vc")) (retbuf (generate-new-buffer (format "*certificate for %s*" mail))) @@ -568,6 +588,50 @@ A string or a list of strings is returned." (kill-buffer digbuf) retbuf)) +(defun smime-cert-by-ldap-1 (mail host) + "Get cetificate for MAIL from the ldap server at HOST." + (let ((ldapresult (smime-ldap-search (concat "mail=" mail) + host '("userCertificate") nil)) + (retbuf (generate-new-buffer (format "*certificate for %s*" mail))) + cert) + (if (and (>= (length ldapresult) 1) + (> (length (cadaar ldapresult)) 0)) + (with-current-buffer retbuf + ;; Certificates on LDAP servers _should_ be in DER format, + ;; but there are some servers out there that distributes the + ;; certificates in PEM format (with or without + ;; header/footer) so we try to handle them anyway. + (if (or (string= (substring (cadaar ldapresult) 0 27) + "-----BEGIN CERTIFICATE-----") + (string= (substring (cadaar ldapresult) 0 3) + "MII")) + (setq cert + (smime-replace-in-string + (cadaar ldapresult) + (concat "\\(\n\\|\r\\|-----BEGIN CERTIFICATE-----\\|" + "-----END CERTIFICATE-----\\)") + "" t)) + (setq cert (base64-encode-string (cadaar ldapresult) t))) + (insert "-----BEGIN CERTIFICATE-----\n") + (let ((i 0) (len (length cert))) + (while (> (- len 64) i) + (insert (substring cert i (+ i 64)) "\n") + (setq i (+ i 64))) + (insert (substring cert i len) "\n")) + (insert "-----END CERTIFICATE-----\n")) + (kill-buffer retbuf) + (setq retbuf nil)) + retbuf)) + +(defun smime-cert-by-ldap (mail) + "Find certificate via LDAP for address MAIL." + (if smime-ldap-host-list + (catch 'certbuf + (dolist (host smime-ldap-host-list) + (let ((retbuf (smime-cert-by-ldap-1 mail host))) + (when retbuf + (throw 'certbuf retbuf))))))) + ;; User interface. (defvar smime-buffer "*SMIME*") diff --git a/lisp/gnus/spam-report.el b/lisp/gnus/spam-report.el index ce891a11d49..51ad9b8649e 100644 --- a/lisp/gnus/spam-report.el +++ b/lisp/gnus/spam-report.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. -;; Author: Teodor Zlatanov <tzz@lifelogs.com> -;; Keywords: network +;; Author: Ted Zlatanov <tzz@lifelogs.com> +;; Keywords: network, spam, mail, gmane, report ;; This file is part of GNU Emacs. @@ -80,26 +80,92 @@ The function must accept the arguments `host' and `report'." :type 'file :group 'spam-report) +(defcustom spam-report-resend-to nil + "Email address that spam articles are resent to when reporting. +If not set, the user will be prompted to enter a value which will be +saved for future use." + :type 'string + :group 'spam-report) + (defvar spam-report-url-ping-temp-agent-function nil "Internal variable for `spam-report-agentize' and `spam-report-deagentize'. This variable will store the value of `spam-report-url-ping-function' from before `spam-report-agentize' was run, so that `spam-report-deagentize' can undo that change.") -(defun spam-report-gmane (&rest articles) - "Report an article as spam through Gmane" +(defun spam-report-resend (articles &optional ham) + "Report an article as spam by resending via email. +Reports is as ham when HAM is set." + (dolist (article articles) + (gnus-message 6 + "Reporting %s article %d to <%s>..." + (if ham "ham" "spam") + article spam-report-resend-to) + (unless spam-report-resend-to + (customize-set-variable + spam-report-resend-to + (read-from-minibuffer "email address to resend SPAM/HAM to? "))) + ;; This is ganked from the `gnus-summary-resend-message' function. + ;; It involves rendering the SPAM, which is undesirable, but there does + ;; not seem to be a nicer way to achieve this. + ;; select this particular article + (gnus-summary-select-article nil nil nil article) + ;; resend it to the destination address + (save-excursion + (set-buffer gnus-original-article-buffer) + (message-resend spam-report-resend-to)))) + +(defun spam-report-resend-ham (articles) + "Report an article as ham by resending via email." + (spam-report-resend articles t)) + +(defun spam-report-gmane-ham (&rest articles) + "Report ARTICLES as ham (unregister) through Gmane." + (interactive (gnus-summary-work-articles current-prefix-arg)) + (dolist (article articles) + (spam-report-gmane-internal t article))) + +(defun spam-report-gmane-spam (&rest articles) + "Report ARTICLES as spam through Gmane." + (interactive (gnus-summary-work-articles current-prefix-arg)) (dolist (article articles) - (when (and gnus-newsgroup-name - (or (null spam-report-gmane-regex) - (string-match spam-report-gmane-regex gnus-newsgroup-name))) - (gnus-message 6 "Reporting spam article %d to spam.gmane.org..." article) - (if spam-report-gmane-use-article-number - (spam-report-url-ping - "spam.gmane.org" - (format "/%s:%d" - (gnus-group-real-name gnus-newsgroup-name) - article)) + (spam-report-gmane-internal nil article))) + +;; `spam-report-gmane' was an interactive entry point, so we should provide an +;; alias. +(defalias 'spam-report-gmane 'spam-report-gmane-spam) + +(defun spam-report-gmane-internal (unspam article) + "Report ARTICLE as spam or not-spam through Gmane, depending on UNSPAM." + (when (and gnus-newsgroup-name + (or (null spam-report-gmane-regex) + (string-match spam-report-gmane-regex gnus-newsgroup-name))) + (let ((rpt-host (if unspam "unspam.gmane.org" "spam.gmane.org"))) + (gnus-message 6 "Reporting article %d to %s..." article rpt-host) + (cond + ;; Special-case nnweb groups -- these have the URL to use in + ;; the Xref headers. + ((eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnweb) + (spam-report-url-ping + rpt-host + (concat + "/" + (gnus-replace-in-string + (gnus-replace-in-string + (gnus-replace-in-string + (mail-header-xref (gnus-summary-article-header article)) + "/raw" ":silent") + "^.*article.gmane.org/" "") + "/" ":")))) + (spam-report-gmane-use-article-number + (spam-report-url-ping + rpt-host + (format "/%s:%d" + (gnus-group-real-name gnus-newsgroup-name) + article))) + (t (with-current-buffer nntp-server-buffer + (erase-buffer) (gnus-request-head article gnus-newsgroup-name) (let ((case-fold-search t) field host report url) @@ -111,25 +177,33 @@ undo that change.") ;; There might be more than one Archived-At header so we need to ;; find (and transform) the one related to Gmane. (setq field (or (gnus-fetch-field "X-Report-Spam") + (gnus-fetch-field "X-Report-Unspam") (gnus-fetch-field "Archived-At"))) - (setq host (progn - (string-match - (concat "http://\\([a-z]+\\.gmane\\.org\\)" - "\\(/[^:/]+[:/][0-9]+\\)") - field) - (match-string 1 field))) - (setq report (match-string 2 field)) - (when (string-equal "permalink.gmane.org" host) - (setq host "spam.gmane.org") - (setq report (gnus-replace-in-string - report "/\\([0-9]+\\)$" ":\\1"))) - (setq url (format "http://%s%s" host report)) + (if (not (stringp field)) + (if (and (setq field (gnus-fetch-field "Xref")) + (string-match "[^ ]+ +\\([^ ]+\\)" field)) + (setq report (concat "/" (match-string 1 field)) + host rpt-host)) + (setq host + (progn + (string-match + (concat "http://\\([a-z]+\\.gmane\\.org\\)" + "\\(/[^:/]+[:/][0-9]+\\)") + field) + (match-string 1 field))) + (setq report (match-string 2 field))) + (when host + (when (string-equal "permalink.gmane.org" host) + (setq host rpt-host) + (setq report (gnus-replace-in-string + report "/\\([0-9]+\\)$" ":\\1"))) + (setq url (format "http://%s%s" host report))) (if (not (and host report url)) (gnus-message 3 "Could not find a spam report header in article %d..." article) - (gnus-message 7 "Reporting spam through URL %s..." url) - (spam-report-url-ping host report)))))))) + (gnus-message 7 "Reporting article through URL %s..." url) + (spam-report-url-ping host report))))))))) (defun spam-report-url-ping (host report) "Ping a host through HTTP, addressing a specific GET resource using @@ -139,6 +213,24 @@ the function specified by `spam-report-url-ping-function'." ;; report: "/gmane.some.group:123456" (funcall spam-report-url-ping-function host report)) +(defcustom spam-report-user-mail-address + (and (stringp user-mail-address) + (gnus-replace-in-string user-mail-address "@" "<at>")) + "Mail address of this user used for spam reports to Gmane. +This is initialized based on `user-mail-address'." + :type '(choice string + (const :tag "Don't expose address" nil)) + :version "23.0" ;; No Gnus + :group 'spam-report) + +(defvar spam-report-user-agent + (if spam-report-user-mail-address + (format "%s (%s) %s" "spam-report.el" + spam-report-user-mail-address + (gnus-extended-version)) + (format "%s %s" "spam-report.el" + (gnus-extended-version)))) + (defun spam-report-url-ping-plain (host report) "Ping a host through HTTP, addressing a specific GET resource." (let ((tcp-connection)) @@ -153,8 +245,12 @@ the function specified by `spam-report-url-ping-function'." (set-marker (process-mark tcp-connection) (point-min)) (process-send-string tcp-connection - (format "GET %s HTTP/1.1\nUser-Agent: %s (spam-report.el)\nHost: %s\n\n" - report (gnus-extended-version) host))))) + (format "GET %s HTTP/1.1\nUser-Agent: %s\nHost: %s\n\n" + report spam-report-user-agent host)) + ;; Wait until we get something so we don't DOS the host. + (while (and (memq (process-status tcp-connection) '(open run)) + (zerop (buffer-size))) + (accept-process-output tcp-connection))))) ;;;###autoload (defun spam-report-process-queue (&optional file keep) @@ -183,7 +279,7 @@ symbol `ask', query before flushing the queue file." (goto-char (point-min)) (while (and (not (eobp)) (re-search-forward - "http://\\([^/]+\\)\\(/.*\\) *$" (gnus-point-at-eol) t)) + "http://\\([^/]+\\)\\(/.*\\) *$" (point-at-eol) t)) (funcall spam-report-url-ping-function (match-string 1) (match-string 2)) (forward-line 1)) (if (or (eq keep nil) diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el index 4a13548fcab..5b57f376cf8 100644 --- a/lisp/gnus/spam-stat.el +++ b/lisp/gnus/spam-stat.el @@ -122,6 +122,7 @@ ;;; Code: +(require 'mail-parse) (defvar gnus-original-article-buffer) @@ -163,17 +164,53 @@ This variable says how many characters this will be." :group 'spam-stat) (defcustom spam-stat-split-fancy-spam-group "mail.spam" - "Name of the group where spam should be stored, if -`spam-stat-split-fancy' is used in fancy splitting rules. Has no -effect when spam-stat is invoked through spam.el." + "Name of the group where spam should be stored. +If `spam-stat-split-fancy' is used in fancy splitting rules. Has +no effect when spam-stat is invoked through spam.el." :type 'string :group 'spam-stat) -(defcustom spam-stat-split-fancy-spam-threshhold 0.9 - "Spam score threshhold in spam-stat-split-fancy." +(defcustom spam-stat-split-fancy-spam-threshold 0.9 + "Spam score threshold in spam-stat-split-fancy." :type 'number :group 'spam-stat) +(defcustom spam-stat-washing-hook nil + "Hook applied to each message before analysis." + :type 'hook + :group 'spam-stat) + +(defcustom spam-stat-score-buffer-user-functions nil + "List of additional scoring functions. +Called one by one on the buffer. + +If all of these functions return non-nil answers, these numerical +answers are added to the computed spam stat score on the buffer. If +you defun such functions, make sure they don't return the buffer in a +narrowed state or such: use, for example, `save-excursion'. Each of +your functions is also passed the initial spam-stat score which might +aid in your scoring. + +Also be careful when defining such functions. If they take a long +time, they will slow down your mail splitting. Thus, if the buffer is +large, don't forget to use smaller regions, by wrapping your work in, +say, `with-spam-stat-max-buffer-size'." + :type '(repeat sexp) + :group 'spam-stat) + +(defcustom spam-stat-process-directory-age 90 + "Max. age of files to be processed in directory, in days. +When using `spam-stat-process-spam-directory' or +`spam-stat-process-non-spam-directory', only files that have +been touched in this many days will be considered. Without +this filter, re-training spam-stat with several thousand messages +will start to take a very long time." + :type 'number + :group 'spam-stat) + +(defvar spam-stat-last-saved-at nil + "Time stamp of last change of spam-stat-file on this run") + (defvar spam-stat-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?- "w" table) @@ -196,52 +233,24 @@ This is set by hooking into Gnus.") (defvar spam-stat-buffer-name " *spam stat buffer*" "Name of the `spam-stat-buffer'.") -;; Functions missing in Emacs 20 - -(when (memq nil (mapcar 'fboundp - '(gethash hash-table-count make-hash-table - mapc puthash))) - (require 'cl) - (unless (fboundp 'puthash) - ;; alias puthash is missing from Emacs 20 cl-extra.el - (defalias 'puthash 'cl-puthash))) - -(eval-when-compile - (unless (fboundp 'with-syntax-table) - ;; Imported from Emacs 21.2 - (defmacro with-syntax-table (table &rest body) "\ -Evaluate BODY with syntax table of current buffer set to a copy of TABLE. -The syntax table of the current buffer is saved, BODY is evaluated, and the -saved table is restored, even in case of an abnormal exit. -Value is what BODY returns." - (let ((old-table (make-symbol "table")) - (old-buffer (make-symbol "buffer"))) - `(let ((,old-table (syntax-table)) - (,old-buffer (current-buffer))) - (unwind-protect - (progn - (set-syntax-table (copy-syntax-table ,table)) - ,@body) - (save-current-buffer - (set-buffer ,old-buffer) - (set-syntax-table ,old-table)))))))) +(defvar spam-stat-coding-system + (if (mm-coding-system-p 'emacs-mule) 'emacs-mule 'raw-text) + "Coding system used for `spam-stat-file'.") ;; Hooking into Gnus (defun spam-stat-store-current-buffer () "Store a copy of the current buffer in `spam-stat-buffer'." - (save-excursion - (let ((str (buffer-string))) - (set-buffer (get-buffer-create spam-stat-buffer-name)) + (let ((buf (current-buffer))) + (with-current-buffer (get-buffer-create spam-stat-buffer-name) (erase-buffer) - (insert str) + (insert-buffer-substring buf) (setq spam-stat-buffer (current-buffer))))) (defun spam-stat-store-gnus-article-buffer () "Store a copy of the current article in `spam-stat-buffer'. This uses `gnus-article-buffer'." - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (spam-stat-store-current-buffer))) ;; Data -- not using defstruct in order to save space and time @@ -259,6 +268,9 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', (defvar spam-stat-nbad 0 "The number of bad mails in the dictionary.") +(defvar spam-stat-error-holder nil + "A holder for condition-case errors while scoring buffers.") + (defsubst spam-stat-good (entry) "Return the number of times this word belongs to good mails." (aref entry 0)) @@ -313,7 +325,7 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', ;; Parsing (defmacro with-spam-stat-max-buffer-size (&rest body) - "Narrows the buffer down to the first 4k characters, then evaluates BODY." + "Narrow the buffer down to the first 4k characters, then evaluate BODY." `(save-restriction (when (> (- (point-max) (point-min)) @@ -324,6 +336,7 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', (defun spam-stat-buffer-words () "Return a hash table of words and number of occurrences in the buffer." + (run-hooks 'spam-stat-washing-hook) (with-spam-stat-max-buffer-size (with-syntax-table spam-stat-syntax-table (goto-char (point-min)) @@ -372,7 +385,7 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', (lambda (word count) (let ((entry (gethash word spam-stat))) (if (not entry) - (error "This buffer has unknown words in it") + (gnus-message 8 "This buffer has unknown words in it") (spam-stat-set-good entry (- (spam-stat-good entry) count)) (spam-stat-set-bad entry (+ (spam-stat-bad entry) count)) (spam-stat-set-score entry (spam-stat-compute-score entry)) @@ -388,7 +401,7 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', (lambda (word count) (let ((entry (gethash word spam-stat))) (if (not entry) - (error "This buffer has unknown words in it") + (gnus-message 8 "This buffer has unknown words in it") (spam-stat-set-good entry (+ (spam-stat-good entry) count)) (spam-stat-set-bad entry (- (spam-stat-bad entry) count)) (spam-stat-set-score entry (spam-stat-compute-score entry)) @@ -403,28 +416,38 @@ Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', With a prefix argument save unconditionally." (interactive "P") (when (or force spam-stat-dirty) - (with-temp-buffer - (let ((standard-output (current-buffer)) - (font-lock-maximum-size 0)) - (insert "(setq spam-stat-ngood " - (number-to-string spam-stat-ngood) - " spam-stat-nbad " - (number-to-string spam-stat-nbad) - " spam-stat (spam-stat-to-hash-table '(") - (maphash (lambda (word entry) - (prin1 (list word - (spam-stat-good entry) - (spam-stat-bad entry)))) - spam-stat) - (insert ")))") - (write-file spam-stat-file))) - (setq spam-stat-dirty nil))) + (let ((coding-system-for-write spam-stat-coding-system)) + (with-temp-file spam-stat-file + (let ((standard-output (current-buffer)) + (font-lock-maximum-size 0)) + (insert (format ";-*- coding: %s; -*-\n" spam-stat-coding-system)) + (insert (format "(setq spam-stat-ngood %d spam-stat-nbad %d +spam-stat (spam-stat-to-hash-table '(" spam-stat-ngood spam-stat-nbad)) + (maphash (lambda (word entry) + (prin1 (list word + (spam-stat-good entry) + (spam-stat-bad entry)))) + spam-stat) + (insert ")))")))) + (message "Saved %s." spam-stat-file) + (setq spam-stat-dirty nil + spam-stat-last-saved-at (nth 5 (file-attributes spam-stat-file))))) (defun spam-stat-load () "Read the `spam-stat' hash table from disk." ;; TODO: maybe we should warn the user if spam-stat-dirty is t? - (load-file spam-stat-file) - (setq spam-stat-dirty nil)) + (let ((coding-system-for-read spam-stat-coding-system)) + (cond (spam-stat-dirty (message "Spam stat not loaded: spam-stat-dirty t")) + ((or (not (boundp 'spam-stat-last-saved-at)) + (null spam-stat-last-saved-at) + (not (equal spam-stat-last-saved-at + (nth 5 (file-attributes spam-stat-file))))) + (progn + (load-file spam-stat-file) + (setq spam-stat-dirty nil + spam-stat-last-saved-at + (nth 5 (file-attributes spam-stat-file))))) + (t (message "Spam stat file not loaded: no change in disk.."))))) (defun spam-stat-to-hash-table (entries) "Turn list ENTRIES into a hash table and store as `spam-stat'. @@ -433,7 +456,8 @@ the word string, NGOOD is the number of good mails it has appeared in, NBAD is the number of bad mails it has appeared in, GOOD is the number of times it appeared in good mails, and BAD is the number of times it has appeared in bad mails." - (let ((table (make-hash-table :test 'equal))) + (let ((table (make-hash-table :size (length entries) + :test 'equal))) (mapc (lambda (l) (puthash (car l) (spam-stat-make-entry (nth 1 l) (nth 2 l)) @@ -466,46 +490,73 @@ The default score for unknown words is stored in These are the words whose spam-stat differs the most from 0.5. The list returned contains elements of the form \(WORD SCORE DIFF), where DIFF is the difference between SCORE and 0.5." - (with-spam-stat-max-buffer-size - (with-syntax-table spam-stat-syntax-table - (let (result word score) - (maphash (lambda (word ignore) - (setq score (spam-stat-score-word word) - result (cons (list word score (abs (- score 0.5))) - result))) - (spam-stat-buffer-words)) - (setq result (sort result (lambda (a b) (< (nth 2 b) (nth 2 a))))) - (setcdr (nthcdr 14 result) nil) - result)))) + (let (result word score) + (maphash (lambda (word ignore) + (setq score (spam-stat-score-word word) + result (cons (list word score (abs (- score 0.5))) + result))) + (spam-stat-buffer-words)) + (setq result (sort result (lambda (a b) (< (nth 2 b) (nth 2 a))))) + (setcdr (nthcdr 14 result) nil) + result)) (defun spam-stat-score-buffer () - "Return a score describing the spam-probability for this buffer." + "Return a score describing the spam-probability for this buffer. +Add user supplied modifications if supplied." + (interactive) ; helps in debugging. (setq spam-stat-score-data (spam-stat-buffer-words-with-scores)) - (let* ((probs (mapcar (lambda (e) (cadr e)) spam-stat-score-data)) - (prod (apply #'* probs))) - (/ prod (+ prod (apply #'* (mapcar #'(lambda (x) (- 1 x)) - probs)))))) + (let* ((probs (mapcar 'cadr spam-stat-score-data)) + (prod (apply #'* probs)) + (score0 + (/ prod (+ prod (apply #'* (mapcar #'(lambda (x) (- 1 x)) + probs))))) + (score1s + (condition-case + spam-stat-error-holder + (spam-stat-score-buffer-user score0) + (error nil))) + (ans + (if score1s (+ score0 score1s) score0))) + (when (interactive-p) + (message "%S" ans)) + ans)) + +(defun spam-stat-score-buffer-user (&rest args) + (let* ((scores + (mapcar + (lambda (fn) + (apply fn args)) + spam-stat-score-buffer-user-functions))) + (if (memq nil scores) nil + (apply #'+ scores)))) (defun spam-stat-split-fancy () "Return the name of the spam group if the current mail is spam. Use this function on `nnmail-split-fancy'. If you are interested in the raw data used for the last run of `spam-stat-score-buffer', check the variable `spam-stat-score-data'." - (condition-case var + (condition-case spam-stat-error-holder (progn (set-buffer spam-stat-buffer) (goto-char (point-min)) - (when (> (spam-stat-score-buffer) spam-stat-split-fancy-spam-threshhold) + (when (> (spam-stat-score-buffer) spam-stat-split-fancy-spam-threshold) (when (boundp 'nnmail-split-trace) (mapc (lambda (entry) (push entry nnmail-split-trace)) spam-stat-score-data)) spam-stat-split-fancy-spam-group)) - (error (message "Error in spam-stat-split-fancy: %S" var) + (error (message "Error in spam-stat-split-fancy: %S" spam-stat-error-holder) nil))) ;; Testing +(defun spam-stat-strip-xref () + "Strip the the Xref header." + (save-restriction + (mail-narrow-to-head) + (when (re-search-forward "^Xref:.*\n" nil t) + (delete-region (match-beginning 0) (match-end 0))))) + (defun spam-stat-process-directory (dir func) "Process all the regular files in directory DIR using function FUNC." (let* ((files (directory-files dir t "^[^.]")) @@ -515,10 +566,13 @@ check the variable `spam-stat-score-data'." (dolist (f files) (when (and (file-readable-p f) (file-regular-p f) - (> (nth 7 (file-attributes f)) 0)) + (> (nth 7 (file-attributes f)) 0) + (< (time-to-number-of-days (time-since (nth 5 (file-attributes f)))) + spam-stat-process-directory-age)) (setq count (1+ count)) (message "Reading %s: %.2f%%" dir (/ count max)) - (insert-file-contents f) + (insert-file-contents-literally f) + (spam-stat-strip-xref) (funcall func) (erase-buffer)))))) @@ -537,13 +591,19 @@ check the variable `spam-stat-score-data'." (interactive) (hash-table-count spam-stat)) -(defun spam-stat-test-directory (dir) +(defun spam-stat-test-directory (dir &optional verbose) "Test all the regular files in directory DIR for spam. If the result is 1.0, then all files are considered spam. If the result is 0.0, non of the files is considered spam. -You can use this to determine error rates." - (interactive "D") +You can use this to determine error rates. + +If VERBOSE is non-nil display names of files detected as spam or +non-spam in a temporary buffer. If it is the symbol `ham', +display non-spam files; otherwise display spam files." + (interactive "DDirectory: ") (let* ((files (directory-files dir t "^[^.]")) + display-files + buffer-score (total (length files)) (score 0.0); float (max (/ total 100.0)); float @@ -554,12 +614,22 @@ You can use this to determine error rates." (file-regular-p f) (> (nth 7 (file-attributes f)) 0)) (setq count (1+ count)) - (message "Reading %.2f%%, score %.2f%%" - (/ count max) (/ score count)) - (insert-file-contents f) - (when (> (spam-stat-score-buffer) 0.9) + (message "Reading %.2f%%, score %.2f" + (/ count max) (/ score count)) + (insert-file-contents-literally f) + (setq buffer-score (spam-stat-score-buffer)) + (when (> buffer-score 0.9) (setq score (1+ score))) + (when verbose + (if (> buffer-score 0.9) + (unless (eq verbose 'ham) (push f display-files)) + (when (eq verbose 'ham) (push f display-files)))) (erase-buffer)))) + (when display-files + (with-output-to-temp-buffer "*spam-stat results*" + (dolist (file display-files) + (princ file) + (terpri)))) (message "Final score: %d / %d = %f" score total (/ score total)))) ;; Shrinking the dictionary @@ -579,7 +649,7 @@ COUNT defaults to 5" (setq spam-stat-dirty t)) (defun spam-stat-install-hooks-function () - "Install the spam-stat function hooks" + "Install the spam-stat function hooks." (interactive) (add-hook 'nnmail-prepare-incoming-message-hook 'spam-stat-store-current-buffer) @@ -590,7 +660,7 @@ COUNT defaults to 5" (spam-stat-install-hooks-function)) (defun spam-stat-unload-hook () - "Uninstall the spam-stat function hooks" + "Uninstall the spam-stat function hooks." (interactive) (remove-hook 'nnmail-prepare-incoming-message-hook 'spam-stat-store-current-buffer) diff --git a/lisp/gnus/spam-wash.el b/lisp/gnus/spam-wash.el new file mode 100644 index 00000000000..d1be1816a4f --- /dev/null +++ b/lisp/gnus/spam-wash.el @@ -0,0 +1,75 @@ +;;; spam-wash.el --- wash spam before analysis + +;; Copyright (C) 2004 Free Software Foundation, Inc. + +;; Author: Andrew Cohen <cohen@andy.bu.edu> +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; This 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 3, or (at your option) +;; any later version. + +;; This 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This library decodes MIME encodings such as base64 and +;; quoted-printable to allow for better spam analysis. +;; +;; `spam-wash' should be called in a buffer containing the message. + +;;; Code: + +(require 'gnus-art) + +(defun spam-wash () + "Treat the current buffer prior to spam analysis." + (interactive) + (run-hooks 'gnus-article-decode-hook) + (save-excursion + (save-restriction + (let* ((buffer-read-only nil) + (gnus-inhibit-treatment t) + (gnus-article-buffer (current-buffer)) + (handles (or (mm-dissect-buffer nil gnus-article-loose-mime) + (and gnus-article-emulate-mime + (mm-uu-dissect)))) + handle) + (when gnus-article-mime-handles + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handle-alist nil)) + (setq gnus-article-mime-handles handles) + (when (and handles + (or (not (stringp (car handles))) + (cdr handles))) + (article-goto-body) + (delete-region (point) (point-max)) + (spam-treat-parts handles)))))) + +(defun spam-treat-parts (handle) + (if (stringp (car handle)) + (mapcar 'spam-treat-parts (cdr handle)) + (if (bufferp (car handle)) + (save-restriction + (narrow-to-region (point) (point)) + (when (let ((case-fold-search t)) + (string-match "text" (car (mm-handle-type handle)))) + (mm-insert-part handle)) + (goto-char (point-max))) + (mapcar 'spam-treat-parts handle)))) + +(provide 'spam-wash) + +;;; arch-tag: 3c7f94a7-c96d-4c77-bb59-950df12bc85f +;;; spam-wash.el ends here diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index b19ce8cd285..4164d3f718b 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -3,7 +3,8 @@ ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: network +;; Maintainer: Ted Zlatanov <tzz@lifelogs.com> +;; Keywords: network, spam, mail, bogofilter, BBDB, dspam, dig, whitelist, blacklist, gmane, hashcash, spamassassin, bsfilter, ifile, stat, crm114, spamoracle ;; This file is part of GNU Emacs. @@ -33,12 +34,15 @@ ;;; Several TODO items are marked as such -;; TODO: spam scores, detection of spam in newsgroups, cross-server splitting, -;; remote processing, training through files +;; TODO: cross-server splitting, remote processing, training through files ;;; Code: +;;{{{ compilation directives and autoloads/requires + (eval-when-compile (require 'cl)) +(eval-when-compile (require 'spam-report)) +(eval-when-compile (require 'hashcash)) (require 'gnus-sum) @@ -50,18 +54,16 @@ ;; for nnimap-split-download-body-default (eval-when-compile (require 'nnimap)) -;; autoload executable-find -(eval-and-compile - ;; executable-find is not autoloaded in Emacs 20 - (autoload 'executable-find "executable")) - ;; autoload query-dig (eval-and-compile (autoload 'query-dig "dig")) ;; autoload spam-report (eval-and-compile - (autoload 'spam-report-gmane "spam-report")) + (autoload 'spam-report-gmane "spam-report") + (autoload 'spam-report-gmane-spam "spam-report") + (autoload 'spam-report-gmane-ham "spam-report") + (autoload 'spam-report-resend "spam-report")) ;; autoload gnus-registry (eval-and-compile @@ -74,7 +76,12 @@ (eval-and-compile (autoload 'query-dns "dns")) -;;; Main parameters. +;;}}} + +;;{{{ Main parameters. +(defvar spam-backends nil + "List of spam.el backends with all the pertinent data. +Populated by spam-install-backend-super.") (defgroup spam nil "Spam configuration." @@ -82,24 +89,23 @@ :group 'mail :group 'news) +(defcustom spam-summary-exit-behavior 'default + "Exit behavior at the time of summary exit. +Note that setting the spam-use-move or spam-use-copy backends on +a group through group/topic parameters overrides this mechanism." + :type '(choice (const 'default :tag + "Move spam out of all groups. Move ham out of spam groups.") + (const 'move-all :tag + "Move spam out of all groups. Move ham out of all groups.") + (const 'move-none :tag + "Never move spam or ham out of any groups.")) + :group 'spam) + (defcustom spam-directory (nnheader-concat gnus-directory "spam/") "Directory for spam whitelists and blacklists." :type 'directory :group 'spam) -(defcustom spam-move-spam-nonspam-groups-only t - "Whether spam should be moved in non-spam groups only. -When t, only ham and unclassified groups will have their spam moved -to the spam-process-destination. When nil, spam will also be moved from -spam groups." - :type 'boolean - :group 'spam) - -(defcustom spam-process-ham-in-nonham-groups nil - "Whether ham should be processed in non-ham groups." - :type 'boolean - :group 'spam) - (defcustom spam-mark-new-messages-in-spam-group-as-spam t "Whether new messages in a spam group should get the spam-mark." :type 'boolean @@ -123,11 +129,6 @@ Do not set this if you use `spam-split' in a fancy split :type 'boolean :group 'spam) -(defcustom spam-process-ham-in-spam-groups nil - "Whether ham should be processed in spam groups." - :type 'boolean - :group 'spam) - (defcustom spam-mark-only-unseen-as-spam t "Whether only unseen articles should be marked as spam in spam groups. When nil, all unread articles in a spam group are marked as @@ -145,9 +146,9 @@ Competition." :group 'spam) (defcustom spam-disable-spam-split-during-ham-respool nil - "Whether `spam-split' should be ignored while resplitting ham in a process -destination. This is useful to prevent ham from ending up in the same spam -group after the resplit. Don't set this to t if you have spam-split as the + "Whether `spam-split' should be ignored while resplitting ham. +This is useful to prevent ham from ending up in the same spam +group after the resplit. Don't set this to t if you have `spam-split' as the last rule in your split configuration." :type 'boolean :group 'spam) @@ -177,6 +178,11 @@ The regular expression is matched against the address." :type 'boolean :group 'spam) +(defcustom spam-use-gmane-xref nil + "Whether the Gmane spam xref should be used by `spam-split'." + :type 'boolean + :group 'spam) + (defcustom spam-use-blacklist nil "Whether the blacklist should be used by `spam-split'." :type 'boolean @@ -233,6 +239,18 @@ Enable this if you want Gnus to invoke Bogofilter on new messages." :type 'boolean :group 'spam) +(defcustom spam-use-bsfilter-headers nil + "Whether bsfilter headers should be used by `spam-split'. +Enable this if you pre-process messages with Bsfilter BEFORE Gnus sees them." + :type 'boolean + :group 'spam) + +(defcustom spam-use-bsfilter nil + "Whether bsfilter should be invoked by `spam-split'. +Enable this if you want Gnus to invoke Bsfilter on new messages." + :type 'boolean + :group 'spam) + (defcustom spam-use-BBDB nil "Whether BBDB should be used by `spam-split'." :type 'boolean @@ -260,8 +278,27 @@ considered spam." :type 'boolean :group 'spam) +(defcustom spam-use-spamassassin nil + "Whether spamassassin should be invoked by `spam-split'. +Enable this if you want Gnus to invoke SpamAssassin on new messages." + :type 'boolean + :group 'spam) + +(defcustom spam-use-spamassassin-headers nil + "Whether spamassassin headers should be checked by `spam-split'. +Enable this if you pre-process messages with SpamAssassin BEFORE Gnus sees +them." + :type 'boolean + :group 'spam) + +(defcustom spam-use-crm114 nil + "Whether the CRM114 Mailfilter should be used by `spam-split'." + :type 'boolean + :group 'spam) + (defcustom spam-install-hooks (or spam-use-dig + spam-use-gmane-xref spam-use-blacklist spam-use-whitelist spam-use-whitelist-exclusive @@ -269,13 +306,18 @@ considered spam." spam-use-hashcash spam-use-regex-headers spam-use-regex-body - spam-use-bogofilter-headers spam-use-bogofilter + spam-use-bogofilter-headers + spam-use-spamassassin + spam-use-spamassassin-headers + spam-use-bsfilter + spam-use-bsfilter-headers spam-use-BBDB spam-use-BBDB-exclusive spam-use-ifile spam-use-stat - spam-use-spamoracle) + spam-use-spamoracle + spam-use-crm114) "Whether the spam hooks should be installed. Default to t if one of the spam-use-* variables is set." :group 'spam @@ -296,14 +338,23 @@ All unmarked article in such group receive the spam mark on group entry." :type '(repeat (string :tag "Group")) :group 'spam) + +(defcustom spam-gmane-xref-spam-group "gmane.spam.detected" + "The group where spam xrefs can be found on Gmane. +Only meaningful if you enable `spam-use-gmane-xref'." + :type 'string + :group 'spam) + (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org" "dev.null.dk" "relays.visi.com") - "List of blackhole servers." + "List of blackhole servers. +Only meaningful if you enable `spam-use-blackholes'." :type '(repeat (string :tag "Server")) :group 'spam) (defcustom spam-blackhole-good-server-regex nil - "String matching IP addresses that should not be checked in the blackholes." + "String matching IP addresses that should not be checked in the blackholes. +Only meaningful if you enable `spam-use-blackholes'." :type '(radio (const nil) regexp) :group 'spam) @@ -328,25 +379,37 @@ All unmarked article in such group receive the spam mark on group entry." :group 'spam) (defcustom spam-regex-headers-spam '("^X-Spam-Flag: YES") - "Regular expression for positive header spam matches." + "Regular expression for positive header spam matches. +Only meaningful if you enable `spam-use-regex-headers'." :type '(repeat (regexp :tag "Regular expression to match spam header")) :group 'spam) (defcustom spam-regex-headers-ham '("^X-Spam-Flag: NO") - "Regular expression for positive header ham matches." + "Regular expression for positive header ham matches. +Only meaningful if you enable `spam-use-regex-headers'." :type '(repeat (regexp :tag "Regular expression to match ham header")) :group 'spam) (defcustom spam-regex-body-spam '() - "Regular expression for positive body spam matches." + "Regular expression for positive body spam matches. +Only meaningful if you enable `spam-use-regex-body'." :type '(repeat (regexp :tag "Regular expression to match spam body")) :group 'spam) (defcustom spam-regex-body-ham '() - "Regular expression for positive body ham matches." + "Regular expression for positive body ham matches. +Only meaningful if you enable `spam-use-regex-body'." :type '(repeat (regexp :tag "Regular expression to match ham body")) :group 'spam) +(defcustom spam-summary-score-preferred-header nil + "Preferred header to use for spam-summary-score." + :type '(choice :tag "Header name" + (symbol :tag "SpamAssassin etc" X-Spam-Status) + (symbol :tag "Bogofilter" X-Bogosity) + (const :tag "No preference, take best guess." nil)) + :group 'spam) + (defgroup spam-ifile nil "Spam ifile configuration." :group 'spam) @@ -398,6 +461,8 @@ your main source of newsgroup names." (const :tag "Bogofilter is not installed")) :group 'spam-bogofilter) +(defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?") + (defcustom spam-bogofilter-header "X-Bogosity" "The header that Bogofilter inserts in messages." :type 'string @@ -436,6 +501,55 @@ When nil, use the default location." (const :tag "Use the default")) :group 'spam-bogofilter) +(defgroup spam-bsfilter nil + "Spam bsfilter configuration." + :group 'spam) + +(make-obsolete-variable 'spam-bsfilter-path 'spam-bsfilter-program) +;; "22.1" ;; Gnus 5.10.9 +(defcustom spam-bsfilter-program (executable-find "bsfilter") + "Name of the Bsfilter program." + :type '(choice (file :tag "Location of bsfilter") + (const :tag "Bsfilter is not installed")) + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-header "X-Spam-Flag" + "The header inserted by Bsfilter to flag spam." + :type 'string + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-probability-header "X-Spam-Probability" + "The header that Bsfilter inserts in messages." + :type 'string + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-spam-switch "--add-spam" + "The switch that Bsfilter uses to register spam messages." + :type 'string + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-ham-switch "--add-clean" + "The switch that Bsfilter uses to register ham messages." + :type 'string + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-spam-strong-switch "--sub-spam" + "The switch that Bsfilter uses to unregister ham messages." + :type 'string + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-ham-strong-switch "--sub-clean" + "The switch that Bsfilter uses to unregister spam messages." + :type 'string + :group 'spam-bsfilter) + +(defcustom spam-bsfilter-database-directory nil + "Directory path of the Bsfilter databases." + :type '(choice (directory + :tag "Location of the Bsfilter database directory") + (const :tag "Use the default")) + :group 'spam-bsfilter) + (defgroup spam-spamoracle nil "Spam spamoracle configuration." :group 'spam) @@ -453,34 +567,184 @@ When nil, use the default spamoracle database." (const :tag "Use the default")) :group 'spam-spamoracle) +(defgroup spam-spamassassin nil + "Spam SpamAssassin configuration." + :group 'spam) + +(make-obsolete-variable 'spam-spamassassin-path + 'spam-spamassassin-program) ;; "22.1" ;; Gnus 5.10.9 +(defcustom spam-assassin-program (executable-find "spamassassin") + "Name of the spamassassin program. +Hint: set this to \"spamc\" if you have spamd running. See the spamc and +spamd man pages for more information on these programs." + :type '(choice (file :tag "Location of spamc") + (const :tag "spamassassin is not installed")) + :group 'spam-spamassassin) + +(defcustom spam-spamassassin-arguments () + "Arguments to pass to the spamassassin executable. +This must be a list. For example, `(\"-C\" \"configfile\")'." + :type '(restricted-sexp :match-alternatives (listp)) + :group 'spam-spamassassin) + +(defcustom spam-spamassassin-spam-flag-header "X-Spam-Flag" + "The header inserted by SpamAssassin to flag spam." + :type 'string + :group 'spam-spamassassin) + +(defcustom spam-spamassassin-positive-spam-flag-header "YES" + "The regex on `spam-spamassassin-spam-flag-header' for positive spam +identification" + :type 'string + :group 'spam-spamassassin) + +(defcustom spam-spamassassin-spam-status-header "X-Spam-Status" + "The header inserted by SpamAssassin, giving extended scoring information" + :type 'string + :group 'spam-spamassassin) + +(make-obsolete-variable 'spam-sa-learn-path 'spam-sa-learn-program) +;; "22.1" ;; Gnus 5.10.9 +(defcustom spam-sa-learn-program (executable-find "sa-learn") + "Name of the sa-learn program." + :type '(choice (file :tag "Location of spamassassin") + (const :tag "spamassassin is not installed")) + :group 'spam-spamassassin) + +(defcustom spam-sa-learn-rebuild t + "Whether sa-learn should rebuild the database every time it is called +Enable this if you want sa-learn to rebuild the database automatically. Doing +this will slightly increase the running time of the spam registration process. +If you choose not to do this, you will have to run \"sa-learn --rebuild\" in +order for SpamAssassin to recognize the new registered spam." + :type 'boolean + :group 'spam-spamassassin) + +(defcustom spam-sa-learn-spam-switch "--spam" + "The switch that sa-learn uses to register spam messages" + :type 'string + :group 'spam-spamassassin) + +(defcustom spam-sa-learn-ham-switch "--ham" + "The switch that sa-learn uses to register ham messages" + :type 'string + :group 'spam-spamassassin) + +(defcustom spam-sa-learn-unregister-switch "--forget" + "The switch that sa-learn uses to unregister messages messages" + :type 'string + :group 'spam-spamassassin) + +(defgroup spam-crm114 nil + "Spam CRM114 Mailfilter configuration." + :group 'spam) + +(defcustom spam-crm114-program (executable-find "mailfilter.crm") + "File path of the CRM114 Mailfilter executable program." + :type '(choice (file :tag "Location of CRM114 Mailfilter") + (const :tag "CRM114 Mailfilter is not installed")) + :group 'spam-crm114) + +(defcustom spam-crm114-header "X-CRM114-Status" + "The header that CRM114 Mailfilter inserts in messages." + :type 'string + :group 'spam-crm114) + +(defcustom spam-crm114-spam-switch "--learnspam" + "The switch that CRM114 Mailfilter uses to register spam messages." + :type 'string + :group 'spam-crm114) + +(defcustom spam-crm114-ham-switch "--learnnonspam" + "The switch that CRM114 Mailfilter uses to register ham messages." + :type 'string + :group 'spam-crm114) + +(defcustom spam-crm114-spam-strong-switch "--UNKNOWN" + "The switch that CRM114 Mailfilter uses to unregister ham messages." + :type 'string + :group 'spam-crm114) + +(defcustom spam-crm114-ham-strong-switch "--UNKNOWN" + "The switch that CRM114 Mailfilter uses to unregister spam messages." + :type 'string + :group 'spam-crm114) + +(defcustom spam-crm114-positive-spam-header "^SPAM" + "The regex on `spam-crm114-header' for positive spam identification." + :type 'regexp + :group 'spam-crm114) + +(defcustom spam-crm114-database-directory nil + "Directory path of the CRM114 Mailfilter databases." + :type '(choice (directory + :tag "Location of the CRM114 Mailfilter database directory") + (const :tag "Use the default")) + :group 'spam-crm114) + ;;; Key bindings for spam control. (gnus-define-keys gnus-summary-mode-map - "St" spam-bogofilter-score + "St" spam-generic-score "Sx" gnus-summary-mark-as-spam - "Mst" spam-bogofilter-score + "Mst" spam-generic-score "Msx" gnus-summary-mark-as-spam "\M-d" gnus-summary-mark-as-spam) -(defvar spam-old-ham-articles nil - "List of old ham articles, generated when a group is entered.") +(defvar spam-cache-lookups t + "Whether spam.el will try to cache lookups using `spam-caches'.") -(defvar spam-old-spam-articles nil - "List of old spam articles, generated when a group is entered.") +(defvar spam-caches (make-hash-table + :size 10 + :test 'equal) + "Cache of spam detection entries.") + +(defvar spam-old-articles nil + "List of old ham and spam articles, generated when a group is entered.") (defvar spam-split-disabled nil "If non-nil, `spam-split' is disabled, and always returns nil.") (defvar spam-split-last-successful-check nil - "`spam-split' will set this to nil or a spam-use-XYZ check if it - finds ham or spam.") + "Internal variable. +`spam-split' will set this to nil or a spam-use-XYZ check if it +finds ham or spam.") + +;; internal variables for backends +;; TODO: find a way to create these on the fly in spam-install-backend-super +(defvar spam-use-copy nil) +(defvar spam-use-move nil) +(defvar spam-use-gmane nil) +(defvar spam-use-resend nil) + +;;}}} + +;;{{{ convenience functions + +(defun spam-clear-cache (symbol) + "Clear the spam-caches entry for a check." + (remhash symbol spam-caches)) -;; convenience functions (defun spam-xor (a b) - "Logical exclusive `or'." + "Logical A xor B." (and (or a b) (not (and a b)))) +(defun spam-set-difference (list1 list2) + "Return a set difference of LIST1 and LIST2. +When either list is nil, the other is returned." + (if (and list1 list2) + ;; we have two non-nil lists + (progn + (dolist (item (append list1 list2)) + (when (and (memq item list1) (memq item list2)) + (setq list1 (delq item list1)) + (setq list2 (delq item list2)))) + (append list1 list2)) + ;; if either of the lists was nil, return the other one + (if list1 list1 list2))) + (defun spam-group-ham-mark-p (group mark &optional spam) + "Checks if MARK is considered a ham mark in GROUP." (when (stringp group) (let* ((marks (spam-group-ham-marks group spam)) (marks (if (symbolp mark) @@ -489,9 +753,11 @@ When nil, use the default spamoracle database." (memq mark marks)))) (defun spam-group-spam-mark-p (group mark) + "Checks if MARK is considered a spam mark in GROUP." (spam-group-ham-mark-p group mark t)) (defun spam-group-ham-marks (group &optional spam) + "In GROUP, get all the ham marks." (when (stringp group) (let* ((marks (if spam (gnus-parameter-spam-marks group) @@ -501,107 +767,594 @@ When nil, use the default spamoracle database." marks))) (defun spam-group-spam-marks (group) + "In GROUP, get all the spam marks." (spam-group-ham-marks group t)) (defun spam-group-spam-contents-p (group) - (if (stringp group) + "Is GROUP a spam group?" + (if (and (stringp group) (< 0 (length group))) (or (member group spam-junk-mailgroups) (memq 'gnus-group-spam-classification-spam (gnus-parameter-spam-contents group))) nil)) (defun spam-group-ham-contents-p (group) + "Is GROUP a ham group?" (if (stringp group) (memq 'gnus-group-spam-classification-ham (gnus-parameter-spam-contents group)) nil)) +(defun spam-classifications () + "Return list of valid classifications" + '(spam ham)) + +(defun spam-classification-valid-p (classification) + "Is CLASSIFICATION a valid spam/ham classification?" + (memq classification (spam-classifications))) + +(defun spam-backend-properties () + "Return list of valid classifications." + '(statistical mover check hrf srf huf suf)) + +(defun spam-backend-property-valid-p (property) + "Is PROPERTY a valid backend property?" + (memq property (spam-backend-properties))) + +(defun spam-backend-function-type-valid-p (type) + (or (eq type 'registration) + (eq type 'unregistration))) + +(defun spam-process-type-valid-p (process-type) + (or (eq process-type 'incoming) + (eq process-type 'process))) + +(defun spam-list-articles (articles classification) + (let ((mark-check (if (eq classification 'spam) + 'spam-group-spam-mark-p + 'spam-group-ham-mark-p)) + alist mark-cache-yes mark-cache-no) + (dolist (article articles) + (let ((mark (gnus-summary-article-mark article))) + (unless (or (memq mark mark-cache-yes) + (memq mark mark-cache-no)) + (if (funcall mark-check + gnus-newsgroup-name + mark) + (push mark mark-cache-yes) + (push mark mark-cache-no))) + (when (memq mark mark-cache-yes) + (push article alist)))) + alist)) + +;;}}} + +;;{{{ backend installation functions and procedures + +(defun spam-install-backend-super (backend &rest properties) + "Install BACKEND for spam.el. +Accepts incoming CHECK, ham registration function HRF, spam +registration function SRF, ham unregistration function HUF, spam +unregistration function SUF, and an indication whether the +backend is STATISTICAL." + + (setq spam-backends (add-to-list 'spam-backends backend)) + (while properties + (let ((property (pop properties)) + (value (pop properties))) + (if (spam-backend-property-valid-p property) + (put backend property value) + (gnus-error + 5 + "spam-install-backend-super got an invalid property %s" + property))))) + +(defun spam-backend-list (&optional type) + "Return a list of all the backend symbols, constrained by TYPE. +When TYPE is 'non-mover, only non-mover backends are returned. +When TYPE is 'mover, only mover backends are returned." + (let (list) + (dolist (backend spam-backends) + (when (or + (null type) ;either no type was requested + ;; or the type is 'mover and the backend is a mover + (and + (eq type 'mover) + (spam-backend-mover-p backend)) + ;; or the type is 'non-mover and the backend is not a mover + (and + (eq type 'non-mover) + (not (spam-backend-mover-p backend)))) + (push backend list))) + list)) + +(defun spam-backend-check (backend) + "Get the check function for BACKEND. +Each individual check may return nil, t, or a mailgroup name. +The value nil means that the check does not yield a decision, and +so, that further checks are needed. The value t means that the +message is definitely not spam, and that further spam checks +should be inhibited. Otherwise, a mailgroup name or the symbol +'spam (depending on spam-split-symbolic-return) is returned where +the mail should go, and further checks are also inhibited. The +usual mailgroup name is the value of `spam-split-group', meaning +that the message is definitely a spam." + (get backend 'check)) + +(defun spam-backend-valid-p (backend) + "Is BACKEND valid?" + (member backend (spam-backend-list))) + +(defun spam-backend-info (backend) + "Return information about BACKEND." + (if (spam-backend-valid-p backend) + (let (info) + (setq info (format "Backend %s has the following properties:\n" + backend)) + (dolist (property (spam-backend-properties)) + (setq info (format "%s%s=%s\n" + info + property + (get backend property)))) + info) + (gnus-error 5 "spam-backend-info was asked about an invalid backend %s" + backend))) + +(defun spam-backend-function (backend classification type) + "Get the BACKEND function for CLASSIFICATION and TYPE. +TYPE is 'registration or 'unregistration. +CLASSIFICATION is 'ham or 'spam." + (if (and + (spam-classification-valid-p classification) + (spam-backend-function-type-valid-p type)) + (let ((retrieval + (intern + (format "spam-backend-%s-%s-function" + classification + type)))) + (funcall retrieval backend)) + (gnus-error + 5 + "%s was passed invalid backend %s, classification %s, or type %s" + "spam-backend-function" + backend + classification + type))) + +(defun spam-backend-article-list-property (classification + &optional unregister) + "Property name of article list with CLASSIFICATION and UNREGISTER." + (let* ((r (if unregister "unregister" "register")) + (prop (format "%s-%s" classification r))) + prop)) + +(defun spam-backend-get-article-todo-list (backend + classification + &optional unregister) + "Get the articles to be processed for BACKEND and CLASSIFICATION. +With UNREGISTER, get articles to be unregistered. +This is a temporary storage function - nothing here persists." + (get + backend + (intern (spam-backend-article-list-property classification unregister)))) + +(defun spam-backend-put-article-todo-list (backend classification list &optional unregister) + "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION. +With UNREGISTER, set articles to be unregistered. +This is a temporary storage function - nothing here persists." + (put + backend + (intern (spam-backend-article-list-property classification unregister)) + list)) + +(defun spam-backend-ham-registration-function (backend) + "Get the ham registration function for BACKEND." + (get backend 'hrf)) + +(defun spam-backend-spam-registration-function (backend) + "Get the spam registration function for BACKEND." + (get backend 'srf)) + +(defun spam-backend-ham-unregistration-function (backend) + "Get the ham unregistration function for BACKEND." + (get backend 'huf)) + +(defun spam-backend-spam-unregistration-function (backend) + "Get the spam unregistration function for BACKEND." + (get backend 'suf)) + +(defun spam-backend-statistical-p (backend) + "Is BACKEND statistical?" + (get backend 'statistical)) + +(defun spam-backend-mover-p (backend) + "Is BACKEND a mover?" + (get backend 'mover)) + +(defun spam-install-backend-alias (backend alias) + "Add ALIAS to an existing BACKEND. +The previous backend settings for ALIAS are erased." + + ;; install alias with no properties at first + (spam-install-backend-super alias) + + (dolist (property (spam-backend-properties)) + (put alias property (get backend property)))) + +(defun spam-install-checkonly-backend (backend check) + "Install a BACKEND than can only CHECK for spam." + (spam-install-backend-super backend 'check check)) + +(defun spam-install-mover-backend (backend hrf srf huf suf) + "Install a BACKEND than can move articles at summary exit. +Accepts ham registration function HRF, spam registration function +SRF, ham unregistration function HUF, spam unregistration +function SUF. The backend has no incoming check and can't be +statistical." + (spam-install-backend-super + backend + 'hrf hrf 'srf srf 'huf huf 'suf suf 'mover t)) + +(defun spam-install-nocheck-backend (backend hrf srf huf suf) + "Install a BACKEND than has no check. +Accepts ham registration function HRF, spam registration function +SRF, ham unregistration function HUF, spam unregistration +function SUF. The backend has no incoming check and can't be +statistical (it could be, but in practice that doesn't happen)." + (spam-install-backend-super + backend + 'hrf hrf 'srf srf 'huf huf 'suf suf)) + +(defun spam-install-backend (backend check hrf srf huf suf) + "Install a BACKEND. +Accepts incoming CHECK, ham registration function HRF, spam +registration function SRF, ham unregistration function HUF, spam +unregistration function SUF. The backend won't be +statistical (use spam-install-statistical-backend for that)." + (spam-install-backend-super + backend + 'check check 'hrf hrf 'srf srf 'huf huf 'suf suf)) + +(defun spam-install-statistical-backend (backend check hrf srf huf suf) + "Install a BACKEND. +Accepts incoming CHECK, ham registration function HRF, spam +registration function SRF, ham unregistration function HUF, spam +unregistration function SUF. The backend will be +statistical (use spam-install-backend for non-statistical +backends)." + (spam-install-backend-super + backend + 'check check 'statistical t 'hrf hrf 'srf srf 'huf huf 'suf suf)) + +(defun spam-install-statistical-checkonly-backend (backend check) + "Install a statistical BACKEND than can only CHECK for spam." + (spam-install-backend-super + backend + 'check check 'statistical t)) + +;;}}} + +;;{{{ backend installations +(spam-install-checkonly-backend 'spam-use-blackholes + 'spam-check-blackholes) + +(spam-install-checkonly-backend 'spam-use-hashcash + 'spam-check-hashcash) + +(spam-install-checkonly-backend 'spam-use-spamassassin-headers + 'spam-check-spamassassin-headers) + +(spam-install-checkonly-backend 'spam-use-bogofilter-headers + 'spam-check-bogofilter-headers) + +(spam-install-checkonly-backend 'spam-use-bsfilter-headers + 'spam-check-bsfilter-headers) + +(spam-install-checkonly-backend 'spam-use-gmane-xref + 'spam-check-gmane-xref) + +(spam-install-checkonly-backend 'spam-use-regex-headers + 'spam-check-regex-headers) + +(spam-install-statistical-checkonly-backend 'spam-use-regex-body + 'spam-check-regex-body) + +;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy) instead +(spam-install-mover-backend 'spam-use-move + 'spam-move-ham-routine + 'spam-move-spam-routine + nil + nil) + +(spam-install-nocheck-backend 'spam-use-copy + 'spam-copy-ham-routine + 'spam-copy-spam-routine + nil + nil) + +(spam-install-nocheck-backend 'spam-use-gmane + 'spam-report-gmane-unregister-routine + 'spam-report-gmane-register-routine + 'spam-report-gmane-register-routine + 'spam-report-gmane-unregister-routine) + +(spam-install-nocheck-backend 'spam-use-resend + 'spam-report-resend-register-ham-routine + 'spam-report-resend-register-routine + nil + nil) + +(spam-install-backend 'spam-use-BBDB + 'spam-check-BBDB + 'spam-BBDB-register-routine + nil + 'spam-BBDB-unregister-routine + nil) + +(spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive) + +(spam-install-backend 'spam-use-blacklist + 'spam-check-blacklist + nil + 'spam-blacklist-register-routine + nil + 'spam-blacklist-unregister-routine) + +(spam-install-backend 'spam-use-whitelist + 'spam-check-whitelist + 'spam-whitelist-register-routine + nil + 'spam-whitelist-unregister-routine + nil) + +(spam-install-statistical-backend 'spam-use-ifile + 'spam-check-ifile + 'spam-ifile-register-ham-routine + 'spam-ifile-register-spam-routine + 'spam-ifile-unregister-ham-routine + 'spam-ifile-unregister-spam-routine) + +(spam-install-statistical-backend 'spam-use-spamoracle + 'spam-check-spamoracle + 'spam-spamoracle-learn-ham + 'spam-spamoracle-learn-spam + 'spam-spamoracle-unlearn-ham + 'spam-spamoracle-unlearn-spam) + +(spam-install-statistical-backend 'spam-use-stat + 'spam-check-stat + 'spam-stat-register-ham-routine + 'spam-stat-register-spam-routine + 'spam-stat-unregister-ham-routine + 'spam-stat-unregister-spam-routine) + +(spam-install-statistical-backend 'spam-use-spamassassin + 'spam-check-spamassassin + 'spam-spamassassin-register-ham-routine + 'spam-spamassassin-register-spam-routine + 'spam-spamassassin-unregister-ham-routine + 'spam-spamassassin-unregister-spam-routine) + +(spam-install-statistical-backend 'spam-use-bogofilter + 'spam-check-bogofilter + 'spam-bogofilter-register-ham-routine + 'spam-bogofilter-register-spam-routine + 'spam-bogofilter-unregister-ham-routine + 'spam-bogofilter-unregister-spam-routine) + +(spam-install-statistical-backend 'spam-use-bsfilter + 'spam-check-bsfilter + 'spam-bsfilter-register-ham-routine + 'spam-bsfilter-register-spam-routine + 'spam-bsfilter-unregister-ham-routine + 'spam-bsfilter-unregister-spam-routine) + +(spam-install-statistical-backend 'spam-use-crm114 + 'spam-check-crm114 + 'spam-crm114-register-ham-routine + 'spam-crm114-register-spam-routine + ;; does CRM114 Mailfilter support unregistration? + nil + nil) + +;;}}} + +;;{{{ scoring and summary formatting +(defun spam-necessary-extra-headers () + "Return the extra headers spam.el thinks are necessary." + (let (list) + (when (or spam-use-spamassassin + spam-use-spamassassin-headers + spam-use-regex-headers) + (push 'X-Spam-Status list)) + (when (or spam-use-bogofilter + spam-use-regex-headers) + (push 'X-Bogosity list)) + (when (or spam-use-crm114 + spam-use-regex-headers) + (push 'X-CRM114-Status list)) + list)) + +(defun spam-user-format-function-S (headers) + (when headers + (format "%3.2f" + (spam-summary-score headers spam-summary-score-preferred-header)))) + +(defun spam-article-sort-by-spam-status (h1 h2) + "Sort articles by score." + (let (result) + (dolist (header (spam-necessary-extra-headers)) + (let ((s1 (spam-summary-score h1 header)) + (s2 (spam-summary-score h2 header))) + (unless (= s1 s2) + (setq result (< s1 s2)) + (return)))) + result)) + +(defvar spam-spamassassin-score-regexp + ".*\\b\\(?:score\\|hits\\)=\\(-?[0-9.]+\\)" + "Regexp matching SpamAssassin score header. +The first group must match the number.") + +(defun spam-extra-header-to-number (header headers) + "Transform an extra HEADER to a number, using list of HEADERS. +Note this has to be fast." + (let ((header-content (gnus-extra-header header headers))) + (if header-content + (cond + ((eq header 'X-Spam-Status) + (string-to-number (gnus-replace-in-string + header-content + spam-spamassassin-score-regexp + "\\1"))) + ;; for CRM checking, it's probably faster to just do the string match + ((string-match "( pR: \\([0-9.-]+\\)" header-content) + (- (string-to-number (match-string 1 header-content)))) + ((eq header 'X-Bogosity) + (string-to-number (gnus-replace-in-string + (gnus-replace-in-string + header-content + ".*spamicity=" "") + ",.*" ""))) + (t nil)) + nil))) + +(defun spam-summary-score (headers &optional specific-header) + "Score an article for the summary buffer, as fast as possible. +With SPECIFIC-HEADER, returns only that header's score. +Will not return a nil score." + (let (score) + (dolist (header + (if specific-header + (list specific-header) + (spam-necessary-extra-headers))) + (setq score + (spam-extra-header-to-number header headers)) + (when score + (return))) + (or score 0))) + +(defun spam-generic-score (&optional recheck) + "Invoke whatever scoring method we can." + (interactive "P") + (cond + ((or spam-use-spamassassin spam-use-spamassassin-headers) + (spam-spamassassin-score recheck)) + ((or spam-use-bsfilter spam-use-bsfilter-headers) + (spam-bsfilter-score recheck)) + (spam-use-crm114 + (spam-crm114-score)) + (t (spam-bogofilter-score recheck)))) +;;}}} + +;;{{{ set up widening, processor checks + +;;; set up IMAP widening if it's necessary +(defun spam-setup-widening () + (when (spam-widening-needed-p) + (setq nnimap-split-download-body-default t))) + +(defun spam-widening-needed-p (&optional force-symbols) + (let (found) + (dolist (backend (spam-backend-list)) + (when (and (spam-backend-statistical-p backend) + (or (symbol-value backend) + (memq backend force-symbols))) + (setq found backend))) + found)) + (defvar spam-list-of-processors - '((gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) - (gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) + ;; note the nil processors are not defined in gnus.el + '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) + (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) (gnus-group-spam-exit-processor-stat spam spam-use-stat) (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle) + (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin) + (gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) ;; Buggy? (gnus-group-ham-exit-processor-ifile ham spam-use-ifile) (gnus-group-ham-exit-processor-bogofilter ham spam-use-bogofilter) + (gnus-group-ham-exit-processor-bsfilter ham spam-use-bsfilter) (gnus-group-ham-exit-processor-stat ham spam-use-stat) (gnus-group-ham-exit-processor-whitelist ham spam-use-whitelist) (gnus-group-ham-exit-processor-BBDB ham spam-use-BBDB) (gnus-group-ham-exit-processor-copy ham spam-use-ham-copy) + (gnus-group-ham-exit-processor-spamassassin ham spam-use-spamassassin) (gnus-group-ham-exit-processor-spamoracle ham spam-use-spamoracle)) - "The spam-list-of-processors list contains pairs associating a -ham/spam exit processor variable with a classification and a -spam-use-* variable.") - -(defun spam-group-processor-p (group processor) + "The OBSOLETE `spam-list-of-processors' list. +This list contains pairs associating the obsolete ham/spam exit +processor variables with a classification and a spam-use-* +variable. When the processor variable is nil, just the +classification and spam-use-* check variable are used. This is +superceded by the new spam backend code, so it's only consulted +for backwards compatibility.") + +(defun spam-group-processor-p (group backend &optional classification) + "Checks if GROUP has a BACKEND with CLASSIFICATION registered. +Also accepts the obsolete processors, which can be found in +gnus.el and in spam-list-of-processors. In the case of mover +backends, checks the setting of spam-summary-exit-behavior in +addition to the set values for the group." (if (and (stringp group) - (symbolp processor)) - (or (member processor (nth 0 (gnus-parameter-spam-process group))) - (spam-group-processor-multiple-p - group - (cdr-safe (assoc processor spam-list-of-processors)))) + (symbolp backend)) + (let ((old-style (assq backend spam-list-of-processors)) + (parameters (nth 0 (gnus-parameter-spam-process group))) + found) + (if old-style ; old-style processor + (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) + ;; now search for the parameter + (dolist (parameter parameters) + (when (and (null found) + (listp parameter) + (eq classification (nth 0 parameter)) + (eq backend (nth 1 parameter))) + (setq found t))) + + ;; now, if the parameter was not found, do the + ;; spam-summary-exit-behavior-logic for mover backends + (unless found + (when (spam-backend-mover-p backend) + (setq + found + (cond + ((eq spam-summary-exit-behavior 'move-all) t) + ((eq spam-summary-exit-behavior 'move-none) nil) + ((eq spam-summary-exit-behavior 'default) + (or (eq classification 'spam) ;move spam out of all groups + ;; move ham out of spam groups + (and (eq classification 'ham) + (spam-group-spam-contents-p group)))) + (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" + spam-summary-exit-behavior)))))) + + found)) nil)) -(defun spam-group-processor-multiple-p (group processor-info) - (let* ((classification (nth 0 processor-info)) - (check (nth 1 processor-info)) - (parameters (nth 0 (gnus-parameter-spam-process group))) - found) - (dolist (parameter parameters) - (when (and (null found) - (listp parameter) - (eq classification (nth 0 parameter)) - (eq check (nth 1 parameter))) - (setq found t))) - found)) - -(defun spam-group-spam-processor-report-gmane-p (group) - (spam-group-processor-p group 'gnus-group-spam-exit-processor-report-gmane)) - -(defun spam-group-spam-processor-bogofilter-p (group) - (spam-group-processor-p group 'gnus-group-spam-exit-processor-bogofilter)) - -(defun spam-group-spam-processor-blacklist-p (group) - (spam-group-processor-p group 'gnus-group-spam-exit-processor-blacklist)) - -(defun spam-group-spam-processor-ifile-p (group) - (spam-group-processor-p group 'gnus-group-spam-exit-processor-ifile)) - -(defun spam-group-ham-processor-ifile-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-ifile)) +;;}}} -(defun spam-group-spam-processor-spamoracle-p (group) - (spam-group-processor-p group 'gnus-group-spam-exit-processor-spamoracle)) +;;{{{ Summary entry and exit processing. -(defun spam-group-ham-processor-bogofilter-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-bogofilter)) - -(defun spam-group-spam-processor-stat-p (group) - (spam-group-processor-p group 'gnus-group-spam-exit-processor-stat)) - -(defun spam-group-ham-processor-stat-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-stat)) - -(defun spam-group-ham-processor-whitelist-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-whitelist)) - -(defun spam-group-ham-processor-BBDB-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-BBDB)) - -(defun spam-group-ham-processor-copy-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-copy)) - -(defun spam-group-ham-processor-spamoracle-p (group) - (spam-group-processor-p group 'gnus-group-ham-exit-processor-spamoracle)) - -;;; Summary entry and exit processing. +(defun spam-mark-junk-as-spam-routine () + ;; check the global list of group names spam-junk-mailgroups and the + ;; group parameters + (when (spam-group-spam-contents-p gnus-newsgroup-name) + (gnus-message 6 "Marking %s articles as spam" + (if spam-mark-only-unseen-as-spam + "unseen" + "unread")) + (let ((articles (if spam-mark-only-unseen-as-spam + gnus-newsgroup-unseen + gnus-newsgroup-unreads))) + (if spam-mark-new-messages-in-spam-group-as-spam + (dolist (article articles) + (gnus-summary-mark-article article gnus-spam-mark)) + (gnus-message 9 "Did not mark new messages as spam."))))) (defun spam-summary-prepare () - (setq spam-old-ham-articles - (spam-list-articles gnus-newsgroup-articles 'ham)) - (setq spam-old-spam-articles - (spam-list-articles gnus-newsgroup-articles 'spam)) + (setq spam-old-articles + (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham)) + (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam)))) (spam-mark-junk-as-spam-routine)) ;; The spam processors are invoked for any group, spam or ham or neither @@ -609,141 +1362,74 @@ spam-use-* variable.") (unless gnus-group-is-exiting-without-update-p (gnus-message 6 "Exiting summary buffer and applying spam rules") + ;; before we begin, remove any article limits +; (ignore-errors +; (gnus-summary-pop-limit t)) + ;; first of all, unregister any articles that are no longer ham or spam ;; we have to iterate over the processors, or else we'll be too slow - (dolist (classification '(spam ham)) - (let* ((old-articles (if (eq classification 'spam) - spam-old-spam-articles - spam-old-ham-articles)) + (dolist (classification (spam-classifications)) + (let* ((old-articles (cdr-safe (assq classification spam-old-articles))) (new-articles (spam-list-articles gnus-newsgroup-articles classification)) - (changed-articles (gnus-set-difference old-articles new-articles))) + (changed-articles (spam-set-difference new-articles old-articles))) ;; now that we have the changed articles, we go through the processors - (dolist (processor-param spam-list-of-processors) - (let ((processor (nth 0 processor-param)) - (processor-classification (nth 1 processor-param)) - (check (nth 2 processor-param)) - unregister-list) + (dolist (backend (spam-backend-list)) + (let (unregister-list) (dolist (article changed-articles) (let ((id (spam-fetch-field-message-id-fast article))) (when (spam-log-unregistration-needed-p - id 'process classification check) + id 'process classification backend) (push article unregister-list)))) ;; call spam-register-routine with specific articles to unregister, ;; when there are articles to unregister and the check is enabled - (when (and unregister-list (symbol-value check)) - (spam-register-routine classification check t unregister-list)))))) - - ;; find all the spam processors applicable to this group - (dolist (processor-param spam-list-of-processors) - (let ((processor (nth 0 processor-param)) - (classification (nth 1 processor-param)) - (check (nth 2 processor-param))) - (when (and (eq 'spam classification) - (spam-group-processor-p gnus-newsgroup-name processor)) - (spam-register-routine classification check)))) - - (if spam-move-spam-nonspam-groups-only - (when (not (spam-group-spam-contents-p gnus-newsgroup-name)) - (spam-mark-spam-as-expired-and-move-routine - (gnus-parameter-spam-process-destination gnus-newsgroup-name))) - (gnus-message 5 "Marking spam as expired and moving it to %s" - gnus-newsgroup-name) - (spam-mark-spam-as-expired-and-move-routine - (gnus-parameter-spam-process-destination gnus-newsgroup-name))) - - ;; now we redo spam-mark-spam-as-expired-and-move-routine to only - ;; expire spam, in case the above did not expire them - (gnus-message 5 "Marking spam as expired without moving it") - (spam-mark-spam-as-expired-and-move-routine nil) - - (when (or (spam-group-ham-contents-p gnus-newsgroup-name) - (and (spam-group-spam-contents-p gnus-newsgroup-name) - spam-process-ham-in-spam-groups) - spam-process-ham-in-nonham-groups) - ;; find all the ham processors applicable to this group - (dolist (processor-param spam-list-of-processors) - (let ((processor (nth 0 processor-param)) - (classification (nth 1 processor-param)) - (check (nth 2 processor-param))) - (when (and (eq 'ham classification) - (spam-group-processor-p gnus-newsgroup-name processor)) - (spam-register-routine classification check))))) - - (when (spam-group-ham-processor-copy-p gnus-newsgroup-name) - (gnus-message 5 "Copying ham") - (spam-ham-copy-routine - (gnus-parameter-ham-process-destination gnus-newsgroup-name))) - - ;; now move all ham articles out of spam groups - (when (spam-group-spam-contents-p gnus-newsgroup-name) - (gnus-message 5 "Moving ham messages from spam group") - (spam-ham-move-routine - (gnus-parameter-ham-process-destination gnus-newsgroup-name)))) - - (setq spam-old-ham-articles nil) - (setq spam-old-spam-articles nil)) + (when (and unregister-list (symbol-value backend)) + (spam-backend-put-article-todo-list backend + classification + unregister-list + t)))))) -(defun spam-mark-junk-as-spam-routine () - ;; check the global list of group names spam-junk-mailgroups and the - ;; group parameters - (when (spam-group-spam-contents-p gnus-newsgroup-name) - (gnus-message 6 "Marking %s articles as spam" - (if spam-mark-only-unseen-as-spam - "unseen" - "unread")) - (let ((articles (if spam-mark-only-unseen-as-spam - gnus-newsgroup-unseen - gnus-newsgroup-unreads))) - (if spam-mark-new-messages-in-spam-group-as-spam - (dolist (article articles) - (gnus-summary-mark-article article gnus-spam-mark)) - (gnus-message 9 "Did not mark new messages as spam."))))) + ;; do the non-moving backends first, then the moving ones + (dolist (backend-type '(non-mover mover)) + (dolist (classification (spam-classifications)) + (dolist (backend (spam-backend-list backend-type)) + (when (spam-group-processor-p + gnus-newsgroup-name + backend + classification) + (spam-backend-put-article-todo-list backend + classification + (spam-list-articles + gnus-newsgroup-articles + classification)))))) -(defun spam-mark-spam-as-expired-and-move-routine (&rest groups) - (if (and (car-safe groups) (listp (car-safe groups))) - (apply 'spam-mark-spam-as-expired-and-move-routine (car groups)) - (gnus-summary-kill-process-mark) - (let ((articles gnus-newsgroup-articles) - (backend-supports-deletions - (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name)) - article tomove deletep) - (dolist (article articles) - (when (eq (gnus-summary-article-mark article) gnus-spam-mark) - (gnus-summary-mark-article article gnus-expirable-mark) - (push article tomove))) - - ;; now do the actual copies - (dolist (group groups) - (when (and tomove - (stringp group)) - (dolist (article tomove) - (gnus-summary-set-process-mark article)) - (when tomove - (if (or (not backend-supports-deletions) - (> (length groups) 1)) - (progn - (gnus-summary-copy-article nil group) - (setq deletep t)) - (gnus-summary-move-article nil group))))) + (spam-resolve-registrations-routine) ; do the registrations now + + ;; we mark all the leftover spam articles as expired at the end + (dolist (article (spam-list-articles + gnus-newsgroup-articles + 'spam)) + (gnus-summary-mark-article article gnus-expirable-mark))) + + (setq spam-old-articles nil)) + +;;}}} - ;; now delete the articles, if there was a copy done, and the - ;; backend allows it - (when (and deletep backend-supports-deletions) - (dolist (article tomove) - (gnus-summary-set-process-mark article)) - (when tomove - (let ((gnus-novice-user nil)) ; don't ask me if I'm sure - (gnus-summary-delete-article nil)))) +;;{{{ spam-use-move and spam-use-copy backend support functions - (gnus-summary-yank-process-mark)))) +(defun spam-copy-or-move-routine (copy groups articles classification) -(defun spam-ham-copy-or-move-routine (copy groups) + (when (and (car-safe groups) (listp (car-safe groups))) + (setq groups (pop groups))) + + (unless (listp groups) + (setq groups (list groups))) + + ;; remove the current process mark (gnus-summary-kill-process-mark) - (let ((todo (spam-list-articles gnus-newsgroup-articles 'ham)) - (backend-supports-deletions + + (let ((backend-supports-deletions (gnus-check-backend-function 'request-move-article gnus-newsgroup-name)) (respool-method (gnus-find-method-for-group gnus-newsgroup-name)) @@ -755,69 +1441,95 @@ spam-use-* variable.") ;; now do the actual move (dolist (group groups) - (when (and todo (stringp group)) - (dolist (article todo) - (when spam-mark-ham-unread-before-move-from-spam-group - (gnus-summary-mark-article article gnus-unread-mark)) - (gnus-summary-set-process-mark article)) - - (if respool ; respooling is with a "fake" group - (let ((spam-split-disabled - (or spam-split-disabled - spam-disable-spam-split-during-ham-respool))) - (gnus-summary-respool-article nil respool-method)) - (if (or (not backend-supports-deletions) ; else, we are not respooling - (> (length groups) 1)) - (progn ; if copying, copy and set deletep - (gnus-summary-copy-article nil group) - (setq deletep t)) - (gnus-summary-move-article nil group))))) ; else move articles - - ;; now delete the articles, unless a) copy is t, and there was a copy done - ;; b) a move was done to a single group - ;; c) backend-supports-deletions is nil - (unless copy - (when (and deletep backend-supports-deletions) - (dolist (article todo) - (gnus-summary-set-process-mark article)) - (when todo - (let ((gnus-novice-user nil)) ; don't ask me if I'm sure - (gnus-summary-delete-article nil)))))) - - (gnus-summary-yank-process-mark)) - -(defun spam-ham-copy-routine (&rest groups) - (if (and (car-safe groups) (listp (car-safe groups))) - (apply 'spam-ham-copy-routine (car groups)) - (spam-ham-copy-or-move-routine t groups))) - -(defun spam-ham-move-routine (&rest groups) - (if (and (car-safe groups) (listp (car-safe groups))) - (apply 'spam-ham-move-routine (car groups)) - (spam-ham-copy-or-move-routine nil groups))) - -(eval-and-compile - (defalias 'spam-point-at-eol (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) + (when (and articles (stringp group)) + ;; first, mark the article with the process mark and, if needed, + ;; the unread or expired mark (for ham and spam respectively) + (dolist (article articles) + (when (and (eq classification 'ham) + spam-mark-ham-unread-before-move-from-spam-group) + (gnus-message 9 "Marking ham article %d unread before move" + article) + (gnus-summary-mark-article article gnus-unread-mark)) + (when (and (eq classification 'spam) + (not copy)) + (gnus-message 9 "Marking spam article %d expirable before move" + article) + (gnus-summary-mark-article article gnus-expirable-mark)) + (gnus-summary-set-process-mark article) + + (if respool ; respooling is with a "fake" group + (let ((spam-split-disabled + (or spam-split-disabled + (and (eq classification 'ham) + spam-disable-spam-split-during-ham-respool)))) + (gnus-message 9 "Respooling article %d with method %s" + article respool-method) + (gnus-summary-respool-article nil respool-method)) + (if (or (not backend-supports-deletions) ; else, we are not respooling + (> (length groups) 1)) + (progn ; if copying, copy and set deletep + (gnus-message 9 "Copying article %d to group %s" + article group) + (gnus-summary-copy-article nil group) + (setq deletep t)) + (gnus-message 9 "Moving article %d to group %s" + article group) + (gnus-summary-move-article nil group))))) ; else move articles + + ;; now delete the articles, unless a) copy is t, and there was a copy done + ;; b) a move was done to a single group + ;; c) backend-supports-deletions is nil + (unless copy + (when (and deletep backend-supports-deletions) + (dolist (article articles) + (gnus-summary-set-process-mark article) + (gnus-message 9 "Deleting article %d" article)) + (when articles + (let ((gnus-novice-user nil)) ; don't ask me if I'm sure + (gnus-summary-delete-article nil))))) + + (gnus-summary-yank-process-mark) + (length articles)))) + +(defun spam-copy-spam-routine (articles) + (spam-copy-or-move-routine + t + (gnus-parameter-spam-process-destination gnus-newsgroup-name) + articles + 'spam)) + +(defun spam-move-spam-routine (articles) + (spam-copy-or-move-routine + nil + (gnus-parameter-spam-process-destination gnus-newsgroup-name) + articles + 'spam)) + +(defun spam-copy-ham-routine (articles) + (spam-copy-or-move-routine + t + (gnus-parameter-ham-process-destination gnus-newsgroup-name) + articles + 'ham)) + +(defun spam-move-ham-routine (articles) + (spam-copy-or-move-routine + nil + (gnus-parameter-ham-process-destination gnus-newsgroup-name) + articles + 'ham)) + +;;}}} + +;;{{{ article and field retrieval code (defun spam-get-article-as-string (article) - (let ((article-buffer (spam-get-article-as-buffer article)) - article-string) - (when article-buffer - (save-window-excursion - (set-buffer article-buffer) - (setq article-string (buffer-string)))) - article-string)) - -(defun spam-get-article-as-buffer (article) - (let ((article-buffer)) - (when (numberp article) - (save-window-excursion - (gnus-summary-goto-subject article) - (gnus-summary-show-article t) - (setq article-buffer (get-buffer gnus-article-buffer)))) - article-buffer)) + (when (numberp article) + (with-temp-buffer + (gnus-request-article-this-buffer + article + gnus-newsgroup-name) + (buffer-string)))) ;; disabled for now ;; (defun spam-get-article-as-filename (article) @@ -831,72 +1543,79 @@ spam-use-* variable.") ;; article-filename ;; nil))) -(defun spam-fetch-field-from-fast (article) - "Fetch the `from' field quickly, using the internal gnus-data-list function" - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (mail-header-from - (gnus-data-header (assoc article (gnus-data-list nil)))) - nil)) - -(defun spam-fetch-field-subject-fast (article) - "Fetch the `subject' field quickly, using the internal - gnus-data-list function" - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (mail-header-subject - (gnus-data-header (assoc article (gnus-data-list nil)))) - nil)) - -(defun spam-fetch-field-message-id-fast (article) - "Fetch the `Message-ID' field quickly, using the internal - gnus-data-list function" - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (mail-header-message-id - (gnus-data-header (assoc article (gnus-data-list nil)))) - nil)) +(defun spam-fetch-field-fast (article field &optional prepared-data-header) + "Fetch a FIELD for ARTICLE quickly, using the internal gnus-data-list function. +When PREPARED-DATA-HEADER is given, don't look in the Gnus data. +When FIELD is 'number, ARTICLE can be any number (since we want +to find it out)." + (when (numberp article) + (let* ((data-header (or prepared-data-header + (spam-fetch-article-header article)))) + (if (arrayp data-header) + (cond + ((equal field 'number) + (mail-header-number data-header)) + ((equal field 'from) + (mail-header-from data-header)) + ((equal field 'message-id) + (mail-header-message-id data-header)) + ((equal field 'subject) + (mail-header-subject data-header)) + ((equal field 'references) + (mail-header-references data-header)) + ((equal field 'date) + (mail-header-date data-header)) + ((equal field 'xref) + (mail-header-xref data-header)) + ((equal field 'extra) + (mail-header-extra data-header)) + (t + (gnus-error + 5 + "spam-fetch-field-fast: unknown field %s requested" + field) + nil)) + (gnus-message 6 "Article %d has a nil data header" article))))) + +(defun spam-fetch-field-from-fast (article &optional prepared-data-header) + (spam-fetch-field-fast article 'from prepared-data-header)) + +(defun spam-fetch-field-subject-fast (article &optional prepared-data-header) + (spam-fetch-field-fast article 'subject prepared-data-header)) + +(defun spam-fetch-field-message-id-fast (article &optional prepared-data-header) + (spam-fetch-field-fast article 'message-id prepared-data-header)) + +(defun spam-generate-fake-headers (article) + (let ((dh (spam-fetch-article-header article))) + (if dh + (concat + (format + ;; 80-character limit makes for strange constructs + (concat "From: %s\nSubject: %s\nMessage-ID: %s\n" + "Date: %s\nReferences: %s\nXref: %s\n") + (spam-fetch-field-fast article 'from dh) + (spam-fetch-field-fast article 'subject dh) + (spam-fetch-field-fast article 'message-id dh) + (spam-fetch-field-fast article 'date dh) + (spam-fetch-field-fast article 'references dh) + (spam-fetch-field-fast article 'xref dh)) + (when (spam-fetch-field-fast article 'extra dh) + (format "%s\n" (spam-fetch-field-fast article 'extra dh)))) + (gnus-message + 5 + "spam-generate-fake-headers: article %d didn't have a valid header" + article)))) + +(defun spam-fetch-article-header (article) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-read-header article) + (nth 3 (assq article gnus-newsgroup-data)))) +;;}}} + +;;{{{ Spam determination. - -;;;; Spam determination. - -(defvar spam-list-of-checks - '((spam-use-blacklist . spam-check-blacklist) - (spam-use-regex-headers . spam-check-regex-headers) - (spam-use-regex-body . spam-check-regex-body) - (spam-use-whitelist . spam-check-whitelist) - (spam-use-BBDB . spam-check-BBDB) - (spam-use-ifile . spam-check-ifile) - (spam-use-spamoracle . spam-check-spamoracle) - (spam-use-stat . spam-check-stat) - (spam-use-blackholes . spam-check-blackholes) - (spam-use-hashcash . spam-check-hashcash) - (spam-use-bogofilter-headers . spam-check-bogofilter-headers) - (spam-use-bogofilter . spam-check-bogofilter)) - "The spam-list-of-checks list contains pairs associating a -parameter variable with a spam checking function. If the -parameter variable is true, then the checking function is called, -and its value decides what happens. Each individual check may -return nil, t, or a mailgroup name. The value nil means that the -check does not yield a decision, and so, that further checks are -needed. The value t means that the message is definitely not -spam, and that further spam checks should be inhibited. -Otherwise, a mailgroup name or the symbol 'spam (depending on -spam-split-symbolic-return) is returned where the mail should go, -and further checks are also inhibited. The usual mailgroup name -is the value of `spam-split-group', meaning that the message is -definitely a spam.") - -(defvar spam-list-of-statistical-checks - '(spam-use-ifile - spam-use-regex-body - spam-use-stat - spam-use-bogofilter - spam-use-spamoracle) - "The spam-list-of-statistical-checks list contains all the mail -splitters that need to have the full message body available.") - -;;;TODO: modify to invoke self with each check if invoked without specifics (defun spam-split (&rest specific-checks) "Split this message into the `spam' group if it is spam. This function can be used as an entry in the variable `nnmail-split-fancy', @@ -914,38 +1633,41 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (setq spam-split-group-choice check) (setq specific-checks (delq check specific-checks)))) - (let ((spam-split-group spam-split-group-choice)) + (let ((spam-split-group spam-split-group-choice) + (widening-needed-check (spam-widening-needed-p specific-checks))) (save-excursion (save-restriction - (dolist (check spam-list-of-statistical-checks) - (when (and (symbolp check) (symbol-value check)) - (widen) - (gnus-message 8 "spam-split: widening the buffer (%s requires it)" - (symbol-name check)) - (return))) - ;; (progn (widen) (debug (buffer-string))) - (let ((list-of-checks spam-list-of-checks) + (when widening-needed-check + (widen) + (gnus-message 8 "spam-split: widening the buffer (%s requires it)" + widening-needed-check)) + (let ((backends (spam-backend-list)) decision) - (while (and list-of-checks (not decision)) - (let ((pair (pop list-of-checks))) - (when (and (symbol-value (car pair)) - (or (null specific-checks) - (memq (car pair) specific-checks))) - (gnus-message 5 "spam-split: calling the %s function" - (symbol-name (cdr pair))) - (setq decision (funcall (cdr pair))) + (while (and backends (not decision)) + (let* ((backend (pop backends)) + (check-function (spam-backend-check backend)) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (when (or + ;; either, given specific checks, this is one of them + (memq backend specific-checks) + ;; or, given no specific checks, spam-use-CHECK is set + (and (null specific-checks) (symbol-value backend))) + (gnus-message 6 "spam-split: calling the %s function" + check-function) + (setq decision (funcall check-function)) ;; if we got a decision at all, save the current check (when decision - (setq spam-split-last-successful-check (car pair))) + (setq spam-split-last-successful-check backend)) (when (eq decision 'spam) - (if spam-split-symbolic-return - (setq decision spam-split-group) + (unless spam-split-symbolic-return (gnus-error 5 (format "spam-split got %s but %s is nil" - (symbol-name decision) - (symbol-name spam-split-symbolic-return)))))))) + decision + spam-split-symbolic-return))))))) (if (eq decision t) (if spam-split-symbolic-return-positive 'ham nil) decision)))))))) @@ -957,143 +1679,149 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (let* ((group gnus-newsgroup-name) (autodetect (gnus-parameter-spam-autodetect group)) (methods (gnus-parameter-spam-autodetect-methods group)) - (first-method (nth 0 methods))) - (when (and autodetect - (not (equal first-method 'none))) - (mapcar - (lambda (article) - (let ((id (spam-fetch-field-message-id-fast article)) - (subject (spam-fetch-field-subject-fast article)) - (sender (spam-fetch-field-from-fast article))) - (unless (and spam-log-to-registry - (spam-log-registered-p id 'incoming)) + (first-method (nth 0 methods)) + (articles (if spam-autodetect-recheck-messages + gnus-newsgroup-articles + gnus-newsgroup-unseen)) + article-cannot-be-faked) + + + (dolist (backend methods) + (when (spam-backend-statistical-p backend) + (setq article-cannot-be-faked t) + (return))) + + (when (memq 'default methods) + (setq article-cannot-be-faked t)) + + (when (and autodetect + (not (equal first-method 'none))) + (mapcar + (lambda (article) + (let ((id (spam-fetch-field-message-id-fast article)) + (subject (spam-fetch-field-subject-fast article)) + (sender (spam-fetch-field-from-fast article)) + registry-lookup) + + (unless id + (gnus-message 6 "Article %d has no message ID!" article)) + + (when (and id spam-log-to-registry) + (setq registry-lookup (spam-log-registration-type id 'incoming)) + (when registry-lookup + (gnus-message + 9 + "spam-find-spam: message %s was already registered incoming" + id))) + (let* ((spam-split-symbolic-return t) (spam-split-symbolic-return-positive t) + (fake-headers (spam-generate-fake-headers article)) (split-return - (with-temp-buffer - (gnus-request-article-this-buffer - article - group) - (if (or (null first-method) - (equal first-method 'default)) - (spam-split) - (apply 'spam-split methods))))) + (or registry-lookup + (with-temp-buffer + (if article-cannot-be-faked + (gnus-request-article-this-buffer + article + group) + ;; else, we fake the article + (when fake-headers (insert fake-headers))) + (if (or (null first-method) + (equal first-method 'default)) + (spam-split) + (apply 'spam-split methods)))))) (if (equal split-return 'spam) (gnus-summary-mark-article article gnus-spam-mark)) - - (when (and split-return spam-log-to-registry) + + (when (and id split-return spam-log-to-registry) (when (zerop (gnus-registry-group-count id)) (gnus-registry-add-group id group subject sender)) + + (unless registry-lookup + (spam-log-processing-to-registry + id + 'incoming + split-return + spam-split-last-successful-check + group)))))) + articles)))) + +;;}}} + +;;{{{ registration/unregistration functions + +(defun spam-resolve-registrations-routine () + "Go through the backends and register or unregister articles as needed." + (dolist (backend-type '(non-mover mover)) + (dolist (classification (spam-classifications)) + (dolist (backend (spam-backend-list backend-type)) + (let ((rlist (spam-backend-get-article-todo-list + backend classification)) + (ulist (spam-backend-get-article-todo-list + backend classification t)) + (delcount 0)) + + ;; clear the old lists right away + (spam-backend-put-article-todo-list backend + classification + nil + nil) + (spam-backend-put-article-todo-list backend + classification + nil + t) + + ;; eliminate duplicates + (dolist (article (copy-sequence ulist)) + (when (memq article rlist) + (incf delcount) + (setq rlist (delq article rlist)) + (setq ulist (delq article ulist)))) + + (unless (zerop delcount) + (gnus-message + 9 + "%d messages were saved the trouble of unregistering and then registering" + delcount)) + + ;; unregister articles + (unless (zerop (length ulist)) + (let ((num (spam-unregister-routine classification backend ulist))) + (when (> num 0) + (gnus-message + 6 + "%d %s messages were unregistered by backend %s." + num + classification + backend)))) + + ;; register articles + (unless (zerop (length rlist)) + (let ((num (spam-register-routine classification backend rlist))) + (when (> num 0) + (gnus-message + 6 + "%d %s messages were registered by backend %s." + num + classification + backend))))))))) - (spam-log-processing-to-registry - id - 'incoming - split-return - spam-split-last-successful-check - group)))))) - (if spam-autodetect-recheck-messages - gnus-newsgroup-articles - gnus-newsgroup-unseen))))) - -(defvar spam-registration-functions - ;; first the ham register, second the spam register function - ;; third the ham unregister, fourth the spam unregister function - '((spam-use-blacklist nil - spam-blacklist-register-routine - nil - spam-blacklist-unregister-routine) - (spam-use-whitelist spam-whitelist-register-routine - nil - spam-whitelist-unregister-routine - nil) - (spam-use-BBDB spam-BBDB-register-routine - nil - spam-BBDB-unregister-routine - nil) - (spam-use-ifile spam-ifile-register-ham-routine - spam-ifile-register-spam-routine - spam-ifile-unregister-ham-routine - spam-ifile-unregister-spam-routine) - (spam-use-spamoracle spam-spamoracle-learn-ham - spam-spamoracle-learn-spam - spam-spamoracle-unlearn-ham - spam-spamoracle-unlearn-spam) - (spam-use-stat spam-stat-register-ham-routine - spam-stat-register-spam-routine - spam-stat-unregister-ham-routine - spam-stat-unregister-spam-routine) - ;; note that spam-use-gmane is not a legitimate check - (spam-use-gmane nil - spam-report-gmane-register-routine - ;; does Gmane support unregistration? - nil - nil) - (spam-use-bogofilter spam-bogofilter-register-ham-routine - spam-bogofilter-register-spam-routine - spam-bogofilter-unregister-ham-routine - spam-bogofilter-unregister-spam-routine)) - "The spam-registration-functions list contains pairs -associating a parameter variable with the ham and spam -registration functions, and the ham and spam unregistration -functions") - -(defun spam-classification-valid-p (classification) - (or (eq classification 'spam) - (eq classification 'ham))) - -(defun spam-process-type-valid-p (process-type) - (or (eq process-type 'incoming) - (eq process-type 'process))) - -(defun spam-registration-check-valid-p (check) - (assoc check spam-registration-functions)) - -(defun spam-unregistration-check-valid-p (check) - (assoc check spam-registration-functions)) - -(defun spam-registration-function (classification check) - (let ((flist (cdr-safe (assoc check spam-registration-functions)))) - (if (eq classification 'spam) - (nth 1 flist) - (nth 0 flist)))) - -(defun spam-unregistration-function (classification check) - (let ((flist (cdr-safe (assoc check spam-registration-functions)))) - (if (eq classification 'spam) - (nth 3 flist) - (nth 2 flist)))) - -(defun spam-list-articles (articles classification) - (let ((mark-check (if (eq classification 'spam) - 'spam-group-spam-mark-p - 'spam-group-ham-mark-p)) - list mark-cache-yes mark-cache-no) - (dolist (article articles) - (let ((mark (gnus-summary-article-mark article))) - (unless (memq mark mark-cache-no) - (if (memq mark mark-cache-yes) - (push article list) - ;; else, we have to actually check the mark - (if (funcall mark-check - gnus-newsgroup-name - mark) - (progn - (push article list) - (push mark mark-cache-yes)) - (push mark mark-cache-no)))))) - list)) +(defun spam-unregister-routine (classification + backend + specific-articles) + (spam-register-routine classification backend specific-articles t)) (defun spam-register-routine (classification - check - &optional unregister - specific-articles) + backend + specific-articles + &optional unregister) (when (and (spam-classification-valid-p classification) - (spam-registration-check-valid-p check)) + (spam-backend-valid-p backend)) (let* ((register-function - (spam-registration-function classification check)) + (spam-backend-function backend classification 'registration)) (unregister-function - (spam-unregistration-function classification check)) + (spam-backend-function backend classification 'unregistration)) (run-function (if unregister unregister-function register-function)) @@ -1109,40 +1837,46 @@ functions") gnus-newsgroup-articles classification))) ;; process them - (gnus-message 5 "%s %d %s articles with classification %s, check %s" - (if unregister "Unregistering" "Registering") - (length articles) - (if specific-articles "specific" "") - (symbol-name classification) - (symbol-name check)) - (funcall run-function articles) - ;; now log all the registrations (or undo them, depending on unregister) - (dolist (article articles) - (funcall log-function - (spam-fetch-field-message-id-fast article) - 'process - classification - check - gnus-newsgroup-name)))))) + (when (> (length articles) 0) + (gnus-message 5 "%s %d %s articles as %s using backend %s" + (if unregister "Unregistering" "Registering") + (length articles) + (if specific-articles "specific" "") + classification + backend) + (funcall run-function articles) + ;; now log all the registrations (or undo them, depending on + ;; unregister) + (dolist (article articles) + (funcall log-function + (spam-fetch-field-message-id-fast article) + 'process + classification + backend + gnus-newsgroup-name)))) + ;; return the number of articles processed + (length articles)))) ;;; log a ham- or spam-processor invocation to the registry -(defun spam-log-processing-to-registry (id type classification check group) +(defun spam-log-processing-to-registry (id type classification backend group) (when spam-log-to-registry (if (and (stringp id) (stringp group) (spam-process-type-valid-p type) (spam-classification-valid-p classification) - (spam-registration-check-valid-p check)) + (spam-backend-valid-p backend)) (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) - (cell (list classification check group))) + (cell (list classification backend group))) (push cell cell-list) (gnus-registry-store-extra-entry id type cell-list)) - (gnus-message 5 (format "%s called with bad ID, type, classification, check, or group" - "spam-log-processing-to-registry"))))) + (gnus-error + 7 + (format "%s call with bad ID, type, classification, spam-backend, or group" + "spam-log-processing-to-registry"))))) ;;; check if a ham- or spam-processor registration has been done (defun spam-log-registered-p (id type) @@ -1151,76 +1885,104 @@ functions") (spam-process-type-valid-p type)) (cdr-safe (gnus-registry-fetch-extra id type)) (progn - (gnus-message 5 (format "%s called with bad ID, type, classification, or check" - "spam-log-registered-p")) + (gnus-error + 7 + (format "%s called with bad ID, type, classification, or spam-backend" + "spam-log-registered-p")) nil)))) +;;; check what a ham- or spam-processor registration says +;;; returns nil if conflicting registrations are found +(defun spam-log-registration-type (id type) + (let ((count 0) + decision) + (dolist (reg (spam-log-registered-p id type)) + (let ((classification (nth 0 reg))) + (when (spam-classification-valid-p classification) + (when (and decision + (not (eq classification decision))) + (setq count (+ 1 count))) + (setq decision classification)))) + (if (< 0 count) + nil + decision))) + + ;;; check if a ham- or spam-processor registration needs to be undone -(defun spam-log-unregistration-needed-p (id type classification check) +(defun spam-log-unregistration-needed-p (id type classification backend) (when spam-log-to-registry (if (and (stringp id) (spam-process-type-valid-p type) (spam-classification-valid-p classification) - (spam-registration-check-valid-p check)) + (spam-backend-valid-p backend)) (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) found) (dolist (cell cell-list) (unless found (when (and (eq classification (nth 0 cell)) - (eq check (nth 1 cell))) + (eq backend (nth 1 cell))) (setq found t)))) found) (progn - (gnus-message 5 (format "%s called with bad ID, type, classification, or check" - "spam-log-unregistration-needed-p")) + (gnus-error + 7 + (format "%s called with bad ID, type, classification, or spam-backend" + "spam-log-unregistration-needed-p")) nil)))) ;;; undo a ham- or spam-processor registration (the group is not used) -(defun spam-log-undo-registration (id type classification check &optional group) +(defun spam-log-undo-registration (id type classification backend &optional group) (when (and spam-log-to-registry - (spam-log-unregistration-needed-p id type classification check)) + (spam-log-unregistration-needed-p id type classification backend)) (if (and (stringp id) (spam-process-type-valid-p type) (spam-classification-valid-p classification) - (spam-registration-check-valid-p check)) + (spam-backend-valid-p backend)) (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) new-cell-list found) (dolist (cell cell-list) (unless (and (eq classification (nth 0 cell)) - (eq check (nth 1 cell))) + (eq backend (nth 1 cell))) (push cell new-cell-list))) (gnus-registry-store-extra-entry id type new-cell-list)) (progn - (gnus-message 5 (format "%s called with bad ID, type, check, or group" - "spam-log-undo-registration")) + (gnus-error 7 (format "%s call with bad ID, type, spam-backend, or group" + "spam-log-undo-registration")) nil)))) -;;; set up IMAP widening if it's necessary -(defun spam-setup-widening () - (dolist (check spam-list-of-statistical-checks) - (when (symbol-value check) - (setq nnimap-split-download-body-default t)))) +;;}}} + +;;{{{ backend functions - -;;;; Regex body +;;{{{ Gmane xrefs +(defun spam-check-gmane-xref () + (let ((header (or + (message-fetch-field "Xref") + (message-fetch-field "Newsgroups")))) + (when header ; return nil when no header + (when (string-match spam-gmane-xref-spam-group + header) + spam-split-group)))) + +;;}}} + +;;{{{ Regex body (defun spam-check-regex-body () (let ((spam-regex-headers-ham spam-regex-body-ham) (spam-regex-headers-spam spam-regex-body-spam)) (spam-check-regex-headers t))) - -;;;; Regex headers +;;}}} + +;;{{{ Regex headers (defun spam-check-regex-headers (&optional body) (let ((type (if body "body" "header")) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group)) ret found) (dolist (h-regex spam-regex-headers-ham) (unless found @@ -1237,8 +1999,9 @@ functions") (setq ret spam-split-group)))) ret)) - -;;;; Blackholes. +;;}}} + +;;{{{ Blackholes. (defun spam-reverse-ip-string (ip) (when (stringp ip) @@ -1248,16 +2011,13 @@ functions") (defun spam-check-blackholes () "Check the Received headers for blackholed relays." - (let ((headers (nnmail-fetch-field "received")) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group)) + (let ((headers (message-fetch-field "received")) ips matches) (when headers (with-temp-buffer (insert headers) (goto-char (point-min)) - (gnus-message 5 "Checking headers for relay addresses") + (gnus-message 6 "Checking headers for relay addresses") (while (re-search-forward "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) (gnus-message 9 "Blackhole search found host IP %s." (match-string 1)) @@ -1275,34 +2035,28 @@ functions") (if spam-use-dig (let ((query-result (query-dig query-string))) (when query-result - (gnus-message 5 "(DIG): positive blackhole check '%s'" + (gnus-message 6 "(DIG): positive blackhole check '%s'" query-result) (push (list ip server query-result) matches))) ;; else, if not using dig.el (when (query-dns query-string) - (gnus-message 5 "positive blackhole check") + (gnus-message 6 "positive blackhole check") (push (list ip server (query-dns query-string 'TXT)) matches))))))))) (when matches spam-split-group))) - -;;;; Hashcash. +;;}}} -(eval-when-compile - (autoload 'mail-check-payment "hashcash")) +;;{{{ Hashcash. -(condition-case nil - (progn - (require 'hashcash) +(defun spam-check-hashcash () + "Check the headers for hashcash payments." + (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean - (defun spam-check-hashcash () - "Check the headers for hashcash payments." - (mail-check-payment))) ;mail-check-payment returns a boolean +;;}}} - (file-error)) - -;;;; BBDB +;;{{{ BBDB ;;; original idea for spam-check-BBDB from Alexander Kotelnikov ;;; <sacha@giotto.sj.ru> @@ -1320,10 +2074,19 @@ functions") (require 'bbdb) (require 'bbdb-com)) (file-error + ;; `bbdb-records' should not be bound as an autoload function + ;; before loading bbdb because of `bbdb-hashtable-size'. + (defalias 'bbdb-records 'ignore) (defalias 'spam-BBDB-register-routine 'ignore) (defalias 'spam-enter-ham-BBDB 'ignore) nil)) + ;; when the BBDB changes, we want to clear out our cache + (defun spam-clear-cache-BBDB (&rest immaterial) + (spam-clear-cache 'spam-use-BBDB)) + + (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB) + (defun spam-enter-ham-BBDB (addresses &optional remove) "Enter an address into the BBDB; implies ham (non-spam) sender" (dolist (from addresses) @@ -1337,7 +2100,7 @@ functions") (record (and net-address (bbdb-search-simple nil net-address)))) (when net-address - (gnus-message 5 "%s address %s %s BBDB" + (gnus-message 6 "%s address %s %s BBDB" (if remove "Deleting" "Adding") from (if remove "from" "to")) @@ -1359,20 +2122,37 @@ functions") (defun spam-check-BBDB () "Mail from people in the BBDB is classified as ham or non-spam" - (let ((who (nnmail-fetch-field "from")) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group))) + (let ((who (message-fetch-field "from")) + bbdb-cache bbdb-hashtable) + (when spam-cache-lookups + (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches)) + (unless bbdb-cache + (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value + ;; this is based on the expanded (bbdb-hashtable) macro + ;; without the debugging support + (with-current-buffer (bbdb-buffer) + (save-excursion + (save-window-excursion + (bbdb-records nil t) + (mapatoms + (lambda (symbol) + (intern (downcase (symbol-name symbol)) bbdb-cache)) + bbdb-hashtable)))) + (puthash 'spam-use-BBDB bbdb-cache spam-caches))) (when who (setq who (nth 1 (gnus-extract-address-components who))) - (if (bbdb-search-simple nil who) + (if + (if spam-cache-lookups + (intern-soft (downcase who) bbdb-cache) + (bbdb-search-simple nil who)) t (if spam-use-BBDB-exclusive spam-split-group nil))))))) - -;;;; ifile +;;}}} + +;;{{{ ifile ;;; check the ifile backend; return nil if the mail was NOT classified ;;; as spam @@ -1388,9 +2168,6 @@ See `spam-ifile-database'." (defun spam-check-ifile () "Check the ifile backend for the classification of this message." (let ((article-buffer-name (buffer-name)) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group)) category return) (with-temp-buffer (let ((temp-buffer-name (buffer-name)) @@ -1404,7 +2181,7 @@ See `spam-ifile-database'." ;; check the return now (we're back in the temp buffer) (goto-char (point-min)) (if (not (eobp)) - (setq category (buffer-substring (point) (spam-point-at-eol)))) + (setq category (buffer-substring (point) (point-at-eol)))) (when (not (zerop (length category))) ; we need a category here (if spam-ifile-all-categories (setq return category) @@ -1443,8 +2220,9 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (defun spam-ifile-unregister-ham-routine (articles) (spam-ifile-register-ham-routine articles t)) - -;;;; spam-stat +;;}}} + +;;{{{ spam-stat (eval-when-compile (autoload 'spam-stat-buffer-change-to-non-spam "spam-stat") @@ -1466,10 +2244,7 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (defun spam-check-stat () "Check the spam-stat backend for the classification of this message" - (let ((spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group)) - (spam-stat-split-fancy-spam-group spam-split-group) ; override + (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override (spam-stat-buffer (buffer-name)) ; stat the current buffer category return) (spam-stat-split-fancy))) @@ -1504,9 +2279,9 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (defun spam-maybe-spam-stat-save () (when spam-use-stat (spam-stat-save))))) - +;;}}} -;;;; Blacklists and whitelists. +;;{{{ Blacklists and whitelists. (defvar spam-whitelist-cache nil) (defvar spam-blacklist-cache nil) @@ -1522,7 +2297,8 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." With a non-nil REMOVE, remove them." (interactive "sAddress: ") (spam-enter-list address spam-whitelist remove) - (setq spam-whitelist-cache nil)) + (setq spam-whitelist-cache nil) + (spam-clear-cache 'spam-use-whitelist)) ;;; address can be a list, too (defun spam-enter-blacklist (address &optional remove) @@ -1530,7 +2306,8 @@ With a non-nil REMOVE, remove them." With a non-nil REMOVE, remove them." (interactive "sAddress: ") (spam-enter-list address spam-blacklist remove) - (setq spam-blacklist-cache nil)) + (setq spam-blacklist-cache nil) + (spam-clear-cache 'spam-use-whitelist)) (defun spam-enter-list (addresses file &optional remove) "Enter ADDRESSES into the given FILE. @@ -1559,29 +2336,50 @@ REMOVE not nil, remove the ADDRESSES." (insert a "\n"))))) (save-buffer)))) +(defun spam-filelist-build-cache (type) + (let ((cache (if (eq type 'spam-use-blacklist) + spam-blacklist-cache + spam-whitelist-cache)) + parsed-cache) + (unless (gethash type spam-caches) + (while cache + (let ((address (pop cache))) + (unless (zerop (length address)) ; 0 for a nil address too + (setq address (regexp-quote address)) + ;; fix regexp-quote's treatment of user-intended regexes + (while (string-match "\\\\\\*" address) + (setq address (replace-match ".*" t t address)))) + (push address parsed-cache))) + (puthash type parsed-cache spam-caches)))) + +(defun spam-filelist-check-cache (type from) + (when (stringp from) + (spam-filelist-build-cache type) + (let (found) + (dolist (address (gethash type spam-caches)) + (when (and address (string-match address from)) + (setq found t) + (return))) + found))) + ;;; returns t if the sender is in the whitelist, nil or ;;; spam-split-group otherwise (defun spam-check-whitelist () ;; FIXME! Should it detect when file timestamps change? - (let ((spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group))) - (unless spam-whitelist-cache - (setq spam-whitelist-cache (spam-parse-list spam-whitelist))) - (if (spam-from-listed-p spam-whitelist-cache) - t - (if spam-use-whitelist-exclusive - spam-split-group - nil)))) + (unless spam-whitelist-cache + (setq spam-whitelist-cache (spam-parse-list spam-whitelist))) + (if (spam-from-listed-p 'spam-use-whitelist) + t + (if spam-use-whitelist-exclusive + spam-split-group + nil))) (defun spam-check-blacklist () ;; FIXME! Should it detect when file timestamps change? - (let ((spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group))) - (unless spam-blacklist-cache - (setq spam-blacklist-cache (spam-parse-list spam-blacklist))) - (and (spam-from-listed-p spam-blacklist-cache) spam-split-group))) + (unless spam-blacklist-cache + (setq spam-blacklist-cache (spam-parse-list spam-blacklist))) + (and (spam-from-listed-p 'spam-use-blacklist) + spam-split-group)) (defun spam-parse-list (file) (when (file-readable-p file) @@ -1589,7 +2387,7 @@ REMOVE not nil, remove the ADDRESSES." (with-temp-buffer (insert-file-contents file) (while (not (eobp)) - (setq address (buffer-substring (point) (spam-point-at-eol))) + (setq address (buffer-substring (point) (point-at-eol))) (forward-line 1) ;; insert the e-mail address if detected, otherwise the raw data (unless (zerop (length address)) @@ -1597,20 +2395,10 @@ REMOVE not nil, remove the ADDRESSES." (push (or pure-address address) contents))))) (nreverse contents)))) -(defun spam-from-listed-p (cache) - (let ((from (nnmail-fetch-field "from")) +(defun spam-from-listed-p (type) + (let ((from (message-fetch-field "from")) found) - (while cache - (let ((address (pop cache))) - (unless (zerop (length address)) ; 0 for a nil address too - (setq address (regexp-quote address)) - ;; fix regexp-quote's treatment of user-intended regexes - (while (string-match "\\\\\\*" address) - (setq address (replace-match ".*" t t address)))) - (when (and address (string-match address from)) - (setq found t - cache nil)))) - found)) + (spam-filelist-check-cache type from))) (defun spam-filelist-register-routine (articles blacklist &optional unregister) (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist)) @@ -1619,7 +2407,7 @@ REMOVE not nil, remove the ADDRESSES." (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist)) (remove-function (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist)) - from addresses unregister-list) + from addresses unregister-list article-unregister-list) (dolist (article articles) (let ((from (spam-fetch-field-from-fast article)) (id (spam-fetch-field-message-id-fast article)) @@ -1635,6 +2423,7 @@ REMOVE not nil, remove the ADDRESSES." (null unregister) (spam-log-unregistration-needed-p id 'process declassification de-symbol)) + (push article article-unregister-list) (push from unregister-list)) (unless sender-ignored (push from addresses))))) @@ -1643,7 +2432,7 @@ REMOVE not nil, remove the ADDRESSES." (funcall enter-function addresses t) ; unregister all these addresses ;; else, register normally and unregister what we need to (funcall remove-function unregister-list t) - (dolist (article unregister-list) + (dolist (article article-unregister-list) (spam-log-undo-registration (spam-fetch-field-message-id-fast article) 'process @@ -1663,19 +2452,34 @@ REMOVE not nil, remove the ADDRESSES." (defun spam-whitelist-register-routine (articles &optional unregister) (spam-filelist-register-routine articles nil unregister)) - -;;;; Spam-report glue +;;}}} + +;;{{{ Spam-report glue (gmane and resend reporting) (defun spam-report-gmane-register-routine (articles) (when articles - (apply 'spam-report-gmane articles))) + (apply 'spam-report-gmane-spam articles))) + +(defun spam-report-gmane-unregister-routine (articles) + (when articles + (apply 'spam-report-gmane-ham articles))) + +(defun spam-report-resend-register-ham-routine (articles) + (spam-report-resend-register-routine articles t)) + +(defun spam-report-resend-register-routine (articles &optional ham) + (let* ((resend-to-gp + (if ham + (gnus-parameter-ham-resend-to gnus-newsgroup-name) + (gnus-parameter-spam-resend-to gnus-newsgroup-name))) + (spam-report-resend-to (or (car-safe resend-to-gp) + spam-report-resend-to))) + (spam-report-resend articles ham))) - -;;;; Bogofilter +;;}}} + +;;{{{ Bogofilter (defun spam-check-bogofilter-headers (&optional score) - (let ((header (nnmail-fetch-field spam-bogofilter-header)) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group))) + (let ((header (message-fetch-field spam-bogofilter-header))) (when header ; return nil when no header (if score ; scoring mode (if (string-match "spamicity=\\([0-9.]+\\)" header) @@ -1687,58 +2491,72 @@ REMOVE not nil, remove the ADDRESSES." spam-split-group))))) ;; return something sensible if the score can't be determined -(defun spam-bogofilter-score () +(defun spam-bogofilter-score (&optional recheck) "Get the Bogofilter spamicity score" - (interactive) + (interactive "P") (save-window-excursion (gnus-summary-show-article t) (set-buffer gnus-article-buffer) - (let ((score (or (spam-check-bogofilter-headers t) + (let ((score (or (unless recheck + (spam-check-bogofilter-headers t)) (spam-check-bogofilter t)))) + (gnus-summary-show-article) (message "Spamicity score %s" score) - (or score "0")) - (gnus-summary-show-article))) - + (or score "0")))) + +(defun spam-verify-bogofilter () + "Verify the Bogofilter version is sufficient." + (when (eq spam-bogofilter-valid 'unknown) + (setq spam-bogofilter-valid + (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\." + (shell-command-to-string + (format "%s -V" spam-bogofilter-program)))))) + spam-bogofilter-valid) + (defun spam-check-bogofilter (&optional score) - "Check the Bogofilter backend for the classification of this message" - (let ((article-buffer-name (buffer-name)) - (db spam-bogofilter-database-directory) + "Check the Bogofilter backend for the classification of this message." + (if (spam-verify-bogofilter) + (let ((article-buffer-name (buffer-name)) + (db spam-bogofilter-database-directory) + return) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (set-buffer article-buffer-name) + (apply 'call-process-region + (point-min) (point-max) + spam-bogofilter-program + nil temp-buffer-name nil + (if db `("-d" ,db "-v") `("-v")))) + (setq return (spam-check-bogofilter-headers score)))) return) - (with-temp-buffer - (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) - (apply 'call-process-region - (point-min) (point-max) - spam-bogofilter-program - nil temp-buffer-name nil - (if db `("-d" ,db "-v") `("-v")))) - (setq return (spam-check-bogofilter-headers score)))) - return)) + (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-with-bogofilter (articles spam &optional unregister) "Register an article, given as a string, as spam or non-spam." - (dolist (article articles) - (let ((article-string (spam-get-article-as-string article)) - (db spam-bogofilter-database-directory) - (switch (if unregister - (if spam - spam-bogofilter-spam-strong-switch - spam-bogofilter-ham-strong-switch) - (if spam - spam-bogofilter-spam-switch - spam-bogofilter-ham-switch)))) - (when (stringp article-string) - (with-temp-buffer - (insert article-string) - - (apply 'call-process-region - (point-min) (point-max) - spam-bogofilter-program - nil nil nil switch - (if db `("-d" ,db "-v") `("-v")))))))) + (if (spam-verify-bogofilter) + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article)) + (db spam-bogofilter-database-directory) + (switch (if unregister + (if spam + spam-bogofilter-spam-strong-switch + spam-bogofilter-ham-strong-switch) + (if spam + spam-bogofilter-spam-switch + spam-bogofilter-ham-switch)))) + (when (stringp article-string) + (with-temp-buffer + (insert article-string) + + (apply 'call-process-region + (point-min) (point-max) + spam-bogofilter-program + nil nil nil switch + (if db `("-d" ,db "-v") `("-v"))))))) + (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-spam-routine (articles &optional unregister) (spam-bogofilter-register-with-bogofilter articles t unregister)) @@ -1753,14 +2571,12 @@ REMOVE not nil, remove the ADDRESSES." (spam-bogofilter-register-ham-routine articles t)) - -;;;; spamoracle +;;}}} + +;;{{{ spamoracle (defun spam-check-spamoracle () "Run spamoracle on an article to determine whether it's spam." - (let ((article-buffer-name (buffer-name)) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group))) + (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion @@ -1816,13 +2632,283 @@ REMOVE not nil, remove the ADDRESSES." (defun spam-spamoracle-unlearn-spam (articles &optional unregister) (spam-spamoracle-learn-spam articles t)) - -;;;; Hooks +;;}}} + +;;{{{ SpamAssassin +;;; based mostly on the bogofilter code +(defun spam-check-spamassassin-headers (&optional score) + "Check the SpamAssassin headers for the classification of this message." + (if score ; scoring mode + (let ((header (message-fetch-field spam-spamassassin-spam-status-header))) + (when header + (if (string-match spam-spamassassin-score-regexp header) + (match-string 1 header) + "0"))) + ;; spam detection mode + (let ((header (message-fetch-field spam-spamassassin-spam-flag-header))) + (when header ; return nil when no header + (when (string-match spam-spamassassin-positive-spam-flag-header + header) + spam-split-group))))) + +(defun spam-check-spamassassin (&optional score) + "Check the SpamAssassin backend for the classification of this message." + (let ((article-buffer-name (buffer-name))) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (set-buffer article-buffer-name) + (apply 'call-process-region + (point-min) (point-max) spam-assassin-program + nil temp-buffer-name nil spam-spamassassin-arguments)) + ;; check the return now (we're back in the temp buffer) + (goto-char (point-min)) + (spam-check-spamassassin-headers score))))) + +;; return something sensible if the score can't be determined +(defun spam-spamassassin-score (&optional recheck) + "Get the SpamAssassin score" + (interactive "P") + (save-window-excursion + (gnus-summary-show-article t) + (set-buffer gnus-article-buffer) + (let ((score (or (unless recheck + (spam-check-spamassassin-headers t)) + (spam-check-spamassassin t)))) + (gnus-summary-show-article) + (message "SpamAssassin score %s" score) + (or score "0")))) + +(defun spam-spamassassin-register-with-sa-learn (articles spam + &optional unregister) + "Register articles with spamassassin's sa-learn as spam or non-spam." + (if articles + (let ((action (if unregister spam-sa-learn-unregister-switch + (if spam spam-sa-learn-spam-switch + spam-sa-learn-ham-switch))) + (summary-buffer-name (buffer-name))) + (with-temp-buffer + ;; group the articles into mbox format + (dolist (article articles) + (let (article-string) + (save-excursion + (set-buffer summary-buffer-name) + (setq article-string (spam-get-article-as-string article))) + (when (stringp article-string) + (insert "From \n") ; mbox separator (sa-learn only checks the + ; first five chars, so we can get away with + ; a bogus line)) + (insert article-string) + (insert "\n")))) + ;; call sa-learn on all messages at the same time + (apply 'call-process-region + (point-min) (point-max) + spam-sa-learn-program + nil nil nil "--mbox" + (if spam-sa-learn-rebuild + (list action) + `("--no-rebuild" ,action))))))) + +(defun spam-spamassassin-register-spam-routine (articles &optional unregister) + (spam-spamassassin-register-with-sa-learn articles t unregister)) + +(defun spam-spamassassin-register-ham-routine (articles &optional unregister) + (spam-spamassassin-register-with-sa-learn articles nil unregister)) + +(defun spam-spamassassin-unregister-spam-routine (articles) + (spam-spamassassin-register-with-sa-learn articles t t)) + +(defun spam-spamassassin-unregister-ham-routine (articles) + (spam-spamassassin-register-with-sa-learn articles nil t)) + +;;}}} + +;;{{{ Bsfilter +;;; based mostly on the bogofilter code +(defun spam-check-bsfilter-headers (&optional score) + (if score + (or (nnmail-fetch-field spam-bsfilter-probability-header) + "0") + (let ((header (nnmail-fetch-field spam-bsfilter-header))) + (when header ; return nil when no header + (when (string-match "YES" header) + spam-split-group))))) + +;; return something sensible if the score can't be determined +(defun spam-bsfilter-score (&optional recheck) + "Get the Bsfilter spamicity score" + (interactive "P") + (save-window-excursion + (gnus-summary-show-article t) + (set-buffer gnus-article-buffer) + (let ((score (or (unless recheck + (spam-check-bsfilter-headers t)) + (spam-check-bsfilter t)))) + (gnus-summary-show-article) + (message "Spamicity score %s" score) + (or score "0")))) + +(defun spam-check-bsfilter (&optional score) + "Check the Bsfilter backend for the classification of this message" + (let ((article-buffer-name (buffer-name)) + (dir spam-bsfilter-database-directory) + return) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (set-buffer article-buffer-name) + (apply 'call-process-region + (point-min) (point-max) + spam-bsfilter-program + nil temp-buffer-name nil + "--pipe" + "--insert-flag" + "--insert-probability" + (when dir + (list "--homedir" dir)))) + (setq return (spam-check-bsfilter-headers score)))) + return)) + +(defun spam-bsfilter-register-with-bsfilter (articles + spam + &optional unregister) + "Register an article, given as a string, as spam or non-spam." + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article)) + (switch (if unregister + (if spam + spam-bsfilter-spam-strong-switch + spam-bsfilter-ham-strong-switch) + (if spam + spam-bsfilter-spam-switch + spam-bsfilter-ham-switch)))) + (when (stringp article-string) + (with-temp-buffer + (insert article-string) + (apply 'call-process-region + (point-min) (point-max) + spam-bsfilter-program + nil nil nil switch + "--update" + (when spam-bsfilter-database-directory + (list "--homedir" + spam-bsfilter-database-directory)))))))) + +(defun spam-bsfilter-register-spam-routine (articles &optional unregister) + (spam-bsfilter-register-with-bsfilter articles t unregister)) + +(defun spam-bsfilter-unregister-spam-routine (articles) + (spam-bsfilter-register-spam-routine articles t)) + +(defun spam-bsfilter-register-ham-routine (articles &optional unregister) + (spam-bsfilter-register-with-bsfilter articles nil unregister)) + +(defun spam-bsfilter-unregister-ham-routine (articles) + (spam-bsfilter-register-ham-routine articles t)) + +;;}}} + +;;{{{ CRM114 Mailfilter +(defun spam-check-crm114-headers (&optional score) + (let ((header (message-fetch-field spam-crm114-header))) + (when header ; return nil when no header + (if score ; scoring mode + (if (string-match "( pR: \\([0-9.-]+\\)" header) + (match-string 1 header) + "0") + ;; spam detection mode + (when (string-match spam-crm114-positive-spam-header + header) + spam-split-group))))) + +;; return something sensible if the score can't be determined +(defun spam-crm114-score () + "Get the CRM114 Mailfilter pR" + (interactive) + (save-window-excursion + (gnus-summary-show-article t) + (set-buffer gnus-article-buffer) + (let ((score (or (spam-check-crm114-headers t) + (spam-check-crm114 t)))) + (gnus-summary-show-article) + (message "pR: %s" score) + (or score "0")))) + +(defun spam-check-crm114 (&optional score) + "Check the CRM114 Mailfilter backend for the classification of this message" + (let ((article-buffer-name (buffer-name)) + (db spam-crm114-database-directory) + return) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (set-buffer article-buffer-name) + (apply 'call-process-region + (point-min) (point-max) + spam-crm114-program + nil temp-buffer-name nil + (when db (list (concat "--fileprefix=" db))))) + (setq return (spam-check-crm114-headers score)))) + return)) + +(defun spam-crm114-register-with-crm114 (articles + spam + &optional unregister) + "Register an article, given as a string, as spam or non-spam." + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article)) + (db spam-crm114-database-directory) + (switch (if unregister + (if spam + spam-crm114-spam-strong-switch + spam-crm114-ham-strong-switch) + (if spam + spam-crm114-spam-switch + spam-crm114-ham-switch)))) + (when (stringp article-string) + (with-temp-buffer + (insert article-string) + + (apply 'call-process-region + (point-min) (point-max) + spam-crm114-program + nil nil nil + (when db (list switch (concat "--fileprefix=" db))))))))) + +(defun spam-crm114-register-spam-routine (articles &optional unregister) + (spam-crm114-register-with-crm114 articles t unregister)) + +(defun spam-crm114-unregister-spam-routine (articles) + (spam-crm114-register-spam-routine articles t)) + +(defun spam-crm114-register-ham-routine (articles &optional unregister) + (spam-crm114-register-with-crm114 articles nil unregister)) + +(defun spam-crm114-unregister-ham-routine (articles) + (spam-crm114-register-ham-routine articles t)) + +;;}}} + +;;}}} + +;;{{{ Hooks ;;;###autoload -(defun spam-initialize () - "Install the spam.el hooks and do other initialization" +(defun spam-initialize (&rest symbols) + "Install the spam.el hooks and do other initialization. +When SYMBOLS is given, set those variables to t. This is so you +can call spam-initialize before you set spam-use-* variables on +explicitly, and matters only if you need the extra headers +installed through spam-necessary-extra-headers." (interactive) + + (dolist (var symbols) + (set var t)) + + (dolist (header (spam-necessary-extra-headers)) + (add-to-list 'nnmail-extra-headers header) + (add-to-list 'gnus-extra-headers header)) + (setq spam-install-hooks t) ;; TODO: How do we redo this every time the `spam' face is customized? (push '((eq mark gnus-spam-mark) . spam) @@ -1834,7 +2920,7 @@ REMOVE not nil, remove the ADDRESSES." (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) (add-hook 'gnus-get-new-news-hook 'spam-setup-widening) - (add-hook 'gnus-summary-prepare-hook 'spam-find-spam)) + (add-hook 'gnus-summary-prepared-hook 'spam-find-spam)) (defun spam-unload-hook () "Uninstall the spam.el hooks" @@ -1851,6 +2937,7 @@ REMOVE not nil, remove the ADDRESSES." (when spam-install-hooks (spam-initialize)) +;;}}} (provide 'spam) diff --git a/lisp/gnus/uudecode.el b/lisp/gnus/uudecode.el index 1d1860d9a7e..74abeff6621 100644 --- a/lisp/gnus/uudecode.el +++ b/lisp/gnus/uudecode.el @@ -27,8 +27,6 @@ ;;; Code: -(autoload 'executable-find "executable") - (eval-when-compile (require 'cl)) (eval-and-compile diff --git a/lisp/gnus/webmail.el b/lisp/gnus/webmail.el index c238134749a..52b2ed82a79 100644 --- a/lisp/gnus/webmail.el +++ b/lisp/gnus/webmail.el @@ -196,10 +196,9 @@ (defun webmail-debug (str) (with-temp-buffer (insert "\n---------------- A bug at " str " ------------------\n") - (mapcar #'(lambda (sym) - (if (boundp sym) - (gnus-pp `(setq ,sym ',(eval sym))))) - '(webmail-type user)) + (dolist (sym '(webmail-type user)) + (if (boundp sym) + (gnus-pp `(setq ,sym ',(eval sym))))) (insert "---------------- webmail buffer ------------------\n\n") (insert-buffer-substring webmail-buffer) (insert "\n---------------- end of buffer ------------------\n\n") diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el index ee35e04dec0..f14b00ca83a 100644 --- a/lisp/help-at-pt.el +++ b/lisp/help-at-pt.el @@ -350,8 +350,6 @@ different regions. With numeric argument ARG, behaves like (interactive "p") (scan-buf-move-to-region 'help-echo (- arg) 'scan-buf-move-hook)) -(add-hook 'help-at-pt-unload-hook 'help-at-pt-cancel-timer) - (provide 'help-at-pt) ;;; arch-tag: d0b8b86d-d23f-45d0-a82d-208d6205a583 diff --git a/lisp/help-fns.el b/lisp/help-fns.el index bf57824dcf0..2bfd4176567 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -55,13 +55,12 @@ (message "You didn't specify a function") (help-setup-xref (list #'describe-function function) (interactive-p)) (save-excursion - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (prin1 function) ;; Use " is " instead of a colon so that ;; it is easier to get out the function name using forward-sexp. (princ " is ") (describe-function-1 function) - (print-help-return-message) (with-current-buffer standard-output ;; Return the text we displayed. (buffer-string)))))) @@ -517,7 +516,7 @@ it is displayed along with the global value." locus (variable-binding-locus variable))))) (help-setup-xref (list #'describe-variable variable buffer) (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (with-current-buffer buffer (prin1 variable) ;; Make a hyperlink to the library if appropriate. (Don't @@ -685,7 +684,6 @@ it is displayed along with the global value." (terpri) (princ output)))) - (print-help-return-message) (save-excursion (set-buffer standard-output) ;; Return the text we displayed. @@ -700,7 +698,7 @@ BUFFER defaults to the current buffer." (interactive) (setq buffer (or buffer (current-buffer))) (help-setup-xref (list #'describe-syntax buffer) (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (let ((table (with-current-buffer buffer (syntax-table)))) (with-current-buffer standard-output (describe-vector table 'internal-describe-syntax-value) @@ -725,7 +723,7 @@ BUFFER should be a buffer or a buffer name." (interactive) (setq buffer (or buffer (current-buffer))) (help-setup-xref (list #'describe-categories buffer) (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (let ((table (with-current-buffer buffer (category-table)))) (with-current-buffer standard-output (describe-vector table 'help-describe-category-set) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 1435eb019ec..bca0b5b65e6 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -221,13 +221,22 @@ Commands: (use-local-map help-mode-map) (setq mode-name "Help") (setq major-mode 'help-mode) + (view-mode) - (make-local-variable 'view-no-disable-on-exit) - (setq view-no-disable-on-exit t) - (setq view-exit-action (lambda (buffer) - (or (window-minibuffer-p (selected-window)) - (one-window-p t) - (delete-window)))) + (set (make-local-variable 'view-no-disable-on-exit) t) + ;; With Emacs 22 `view-exit-action' could delete the selected window + ;; disregarding whether the help buffer was shown in that window at + ;; all. Since `view-exit-action' is called with the help buffer as + ;; argument it seems more appropriate to have it work on the buffer + ;; only and leave it to `view-mode-exit' to delete any associated + ;; window(s). + (setq view-exit-action + (lambda (buffer) + ;; Use `with-current-buffer' to make sure that `bury-buffer' + ;; also removes BUFFER from the selected window. + (with-current-buffer buffer + (bury-buffer)))) + (run-mode-hooks 'help-mode-hook)) ;;;###autoload @@ -237,16 +246,23 @@ Commands: ;;;###autoload (defun help-mode-finish () - (let ((entry (assq (selected-window) view-return-to-alist))) - (if entry - ;; When entering Help mode from the Help window, - ;; such as by following a link, preserve the same - ;; meaning for the q command. - ;; (setcdr entry (cons (selected-window) help-return-method)) - nil - (setq view-return-to-alist - (cons (cons (selected-window) help-return-method) - view-return-to-alist)))) + (if (eq help-window t) + ;; If `help-window' is t, `view-return-to-alist' is handled by + ;; `with-help-window'. In this case set `help-window' to the + ;; selected window since now is the only moment where we can + ;; unambiguously identify it. + (setq help-window (selected-window)) + (let ((entry (assq (selected-window) view-return-to-alist))) + (if entry + ;; When entering Help mode from the Help window, + ;; such as by following a link, preserve the same + ;; meaning for the q command. + ;; (setcdr entry (cons (selected-window) help-return-method)) + nil + (setq view-return-to-alist + (cons (cons (selected-window) help-return-method) + view-return-to-alist))))) + (when (eq major-mode 'help-mode) ;; View mode's read-only status of existing *Help* buffer is lost ;; by with-output-to-temp-buffer. @@ -321,6 +337,7 @@ restore it properly when going back." (defvar help-xref-following nil "Non-nil when following a help cross-reference.") +;;;###autoload (defun help-buffer () (buffer-name ;for with-output-to-temp-buffer (if help-xref-following @@ -668,14 +685,14 @@ help buffer." (if (get-buffer-window buffer) (set-window-point (get-buffer-window buffer) position) (goto-char position))))) - + (defun help-go-back () "Go back to previous topic in this help buffer." (interactive) (if help-xref-stack (help-xref-go-back (current-buffer)) (error "No previous help buffer"))) - + (defun help-go-forward () "Go back to next topic in this help buffer." (interactive) diff --git a/lisp/help.el b/lisp/help.el index b957f88a7e4..ac6af2d9e50 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -38,6 +38,26 @@ (add-hook 'temp-buffer-setup-hook 'help-mode-setup) (add-hook 'temp-buffer-show-hook 'help-mode-finish) +;; The variable `help-window' below is used by `help-mode-finish' to +;; communicate the window displaying help (the "help window") to the +;; macro `with-help-window'. The latter sets `help-window' to t before +;; invoking `with-output-to-temp-buffer'. If and only if `help-window' +;; is eq to t, `help-mode-finish' (called by `temp-buffer-setup-hook') +;; sets `help-window' to the window selected by `display-buffer'. +;; Exiting `with-help-window' and calling `print-help-return-message' +;; reset `help-window' to nil. +(defvar help-window nil + "Window chosen for displaying help.") + +;; `help-window-point-marker' is a marker you can move to a valid +;; position of the buffer shown in the help window in order to override +;; the standard positioning mechanism (`point-min') chosen by +;; `with-output-to-temp-buffer'. `with-help-window' has this point +;; nowhere before exiting. Currently used by `view-lossage' to assert +;; that the last keystrokes are always visible. +(defvar help-window-point-marker (make-marker) + "Marker to override default `window-point' of `help-window'.") + (defvar help-map (let ((map (make-sparse-keymap))) (define-key map (char-to-string help-char) 'help-for-help) @@ -124,6 +144,8 @@ It computes a message, and applies the optional argument FUNCTION to it. If FUNCTION is nil, it applies `message', thus displaying the message. In addition, this function sets up `help-return-method', which see, that specifies what to do when the user exits the help buffer." + ;; Reset `help-window' here to avoid confusing `help-mode-finish'. + (setq help-window nil) (and (not (get-buffer-window standard-output)) (let ((first-message (cond ((or @@ -431,7 +453,7 @@ is specified by the variable `message-log-max'." To record all your input on a file, use `open-dribble-file'." (interactive) (help-setup-xref (list #'view-lossage) (interactive-p)) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (princ (mapconcat (lambda (key) (if (or (integerp key) (symbolp key) (listp key)) (single-key-description key) @@ -443,8 +465,9 @@ To record all your input on a file, use `open-dribble-file'." (while (progn (move-to-column 50) (not (eobp))) (when (search-forward " " nil t) (delete-char -1)) - (insert "\n"))) - (print-help-return-message))) + (insert "\n")) + ;; jidanni wants to see the last keystrokes immediately. + (set-marker help-window-point-marker (point))))) ;; Key bindings @@ -475,7 +498,7 @@ The optional argument PREFIX, if non-nil, should be a key sequence; then we display only bindings that start with that prefix." (interactive) (let ((buf (current-buffer))) - (with-output-to-temp-buffer "*Help*" + (with-help-window "*Help*" (with-current-buffer standard-output (describe-buffer-bindings buf prefix menus))))) @@ -719,7 +742,7 @@ temporarily enables it to allow getting help on disabled items and buttons." (setq sequence (vector up-event)) (aset sequence 0 'mouse-1) (setq defn-up-tricky (key-binding sequence nil nil (event-start up-event)))))) - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (princ (help-key-description key untranslated)) (princ (format "\ %s runs the command %S @@ -755,8 +778,7 @@ runs the command %S ev-type mouse-msg mouse-1-click-follows-link defn-up-tricky)) - (describe-function-1 defn-up-tricky))) - (print-help-return-message))))) + (describe-function-1 defn-up-tricky))))))) (defun describe-mode (&optional buffer) "Display documentation of current major mode and minor modes. @@ -773,7 +795,7 @@ whose documentation describes the minor mode." (interactive-p)) ;; For the sake of help-do-xref and help-xref-go-back, ;; don't switch buffers before calling `help-buffer'. - (with-output-to-temp-buffer (help-buffer) + (with-help-window (help-buffer) (with-current-buffer buffer (let (minor-modes) ;; Older packages do not register in minor-mode-list but only in @@ -841,8 +863,7 @@ whose documentation describes the minor mode." (insert (format-mode-line mode)) (add-text-properties start (point) '(face bold))))) (princ " mode:\n") - (princ (documentation major-mode))) - (print-help-return-message)))) + (princ (documentation major-mode)))))) (defun describe-minor-mode (minor-mode) @@ -975,6 +996,248 @@ out of view." temp-buffer-max-height)))) +;;; help-window + +(defcustom help-window-select 'other + "Non-nil means select help window for viewing. +Choices are: + never (nil) Select help window only if there is no other window + on its frame. + other Select help window unless the selected window is the + only other window on its frame. + always (t) Always select the help window. + +This option has effect if and only if the help window was created +by `with-help-window'" + :type '(choice (const :tag "never (nil)" nil) + (const :tag "other" other) + (const :tag "always (t)" t)) + :group 'help + :version "23.1") + +(defun help-window-display-message (quit-part window &optional other) + "Display message telling how to quit and scroll help window. +QUIT-PART is a string telling how to quit the help window WINDOW. +Optional argument OTHER non-nil means return text telling how to +scroll the \"other\" window." + (let ((scroll-part + (cond + ((pos-visible-in-window-p + (with-current-buffer (window-buffer window) + (point-max)) window) + ;; Buffer end is visible. + ".") + (other ", \\[scroll-other-window] to scroll help.") + (t ", \\[scroll-up] to scroll help.")))) + (message + (substitute-command-keys (concat quit-part scroll-part))))) + +(defun help-window-setup-finish (window &optional reuse keep-frame) + "Finish setting up help window WINDOW. +Select WINDOW according to the value of `help-window-select'. +Display message telling how to scroll and eventually quit WINDOW. + +Optional argument REUSE non-nil means WINDOW has been reused \(by +`display-buffer'\) for displaying help. Optional argument +KEEP-FRAME non-nil means that quitting must no delete the frame +of WINDOW." + (let ((number-of-windows + (length (window-list (window-frame window) 'no-mini window)))) + (cond + ((eq window (selected-window)) + ;; The help window is the selected window, probably the + ;; `pop-up-windows' nil case. + (help-window-display-message + (if reuse + "Type \"q\" to restore this window" + ;; This should not be taken. + "Type \"q\" to quit") window)) + ((= number-of-windows 1) + ;; The help window is alone on a frame and not the selected + ;; window, could be the `pop-up-frames' t case. + (help-window-display-message + (cond + (keep-frame "Type \"q\" to delete this window") + (reuse "Type \"q\" to restore this window") + (view-remove-frame-by-deleting "Type \"q\" to delete this frame") + (t "Type \"q\" to iconify this frame")) + window)) + ((and (= number-of-windows 2) + (eq (window-frame window) (window-frame (selected-window)))) + ;; There are two windows on the help window's frame and the other + ;; window is the selected one. + (if (memq help-window-select '(nil other)) + ;; Do not select the help window. + (help-window-display-message + (if reuse + ;; Offer `display-buffer' for consistency with + ;; `print-help-return-message'. This is hardly TRT when + ;; the other window and the selected window display the + ;; same buffer but has been handled this way ever since. + "Type \\[display-buffer] RET to restore the other window" + ;; The classic "two windows" configuration. + "Type \\[delete-other-windows] to delete the help window") + window t) + ;; Select help window and tell how to quit. + (select-window window) + (help-window-display-message + (if reuse + "Type \"q\" to restore this window" + "Type \"q\" to delete this window") window))) + (help-window-select + ;; Issuing a message with 3 or more windows on the same frame + ;; without selecting the help window doesn't make any sense. + (select-window window) + (help-window-display-message + (if reuse + "Type \"q\" to restore this window" + "Type \"q\" to delete this window") window))))) + +(defun help-window-setup (list-of-frames list-of-window-tuples) + "Set up help window. +LIST-OF-FRAMES and LIST-OF-WINDOW-TUPLES are the lists of frames +and window quadruples built by `with-help-window'. The help +window itself is specified by the variable `help-window'." + (let* ((help-buffer (window-buffer help-window)) + ;; `help-buffer' now denotes the help window's buffer. + (view-entry + (assq help-window + (buffer-local-value 'view-return-to-alist help-buffer))) + (help-entry (assq help-window list-of-window-tuples))) + + ;; Handle `help-window-point-marker'. + (when (eq (marker-buffer help-window-point-marker) help-buffer) + (set-window-point help-window help-window-point-marker) + ;; Reset `help-window-point-marker'. + (set-marker help-window-point-marker nil)) + + (cond + (view-entry + ;; `view-return-to-alist' has an entry for the help window. + (cond + ((eq help-window (selected-window)) + ;; The help window is the selected window, probably because the + ;; user followed a backward/forward button or a cross reference. + ;; In this case just purge stale entries from + ;; `view-return-to-alist' but leave the entry alone and don't + ;; display a message. + (view-return-to-alist-update help-buffer)) + ((and help-entry (eq (cadr help-entry) help-buffer)) + ;; The help window was not selected but displayed the help + ;; buffer. In this case reuse existing exit information but try + ;; to get back to the selected window when quitting. Don't + ;; display a message since the user must have seen one before. + (view-return-to-alist-update + help-buffer (cons help-window + (cons (selected-window) (cddr view-entry))))) + (help-entry + ;; The help window was not selected, did display the help buffer + ;; earlier, but displayed another buffer when help was invoked. + ;; Set up things so that quitting will show that buffer again. + (view-return-to-alist-update + help-buffer (cons help-window + (cons (selected-window) (cdr help-entry)))) + (help-window-setup-finish help-window t)) + (t + ;; The help window is new but `view-return-to-alist' had an + ;; entry for it. This should never happen. + (view-return-to-alist-update + help-buffer (cons help-window + (cons (selected-window) 'quit-window))) + (help-window-setup-finish help-window t)))) + (help-entry + ;; `view-return-to-alist' does not have an entry for help window + ;; but `list-of-window-tuples' does. Hence `display-buffer' must + ;; have reused an existing window. + (if (eq (cadr help-entry) help-buffer) + ;; The help window displayed `help-buffer' before but no + ;; `view-return-to-alist' entry was found probably because the + ;; user manually switched to the help buffer. Set up things + ;; for `quit-window' although `view-exit-action' should be + ;; able to handle this case all by itself. + (progn + (view-return-to-alist-update + help-buffer (cons help-window + (cons (selected-window) 'quit-window))) + (help-window-setup-finish help-window t)) + ;; The help window displayed another buffer before. Set up + ;; things in a way that quitting can orderly show that buffer + ;; again. The window-start and window-point information from + ;; `list-of-window-tuples' provide the necessary information. + (view-return-to-alist-update + help-buffer (cons help-window + (cons (selected-window) (cdr help-entry)))) + (help-window-setup-finish help-window t))) + ((memq (window-frame help-window) list-of-frames) + ;; The help window is a new window on an existing frame. This + ;; case must be handled specially by `help-window-setup-finish' + ;; and `view-mode-exit' to ascertain that quitting does _not_ + ;; inadvertently delete the frame. + (view-return-to-alist-update + help-buffer (cons help-window + (cons (selected-window) 'keep-frame))) + (help-window-setup-finish help-window nil t)) + (t + ;; The help window is shown on a new frame. In this case quitting + ;; shall handle both, the help window _and_ its frame. We changed + ;; the default of `view-remove-frame-by-deleting' to t in order to + ;; intuitively DTRT here. + (view-return-to-alist-update + help-buffer (cons help-window (cons (selected-window) t))) + (help-window-setup-finish help-window))))) + +;; `with-help-window' is a wrapper for `with-output-to-temp-buffer' +;; providing the following additional twists: + +;; (1) Issue more accurate messages telling how to scroll and quit the +;; help window. + +;; (2) Make `view-mode-exit' DTRT in more cases. + +;; (3) An option (customizable via `help-window-select') to select the +;; help window automatically. + +;; (4) A marker (`help-window-point-marker') to move point in the help +;; window to an arbitrary buffer position. + +;; Note: It's usually always wrong to use `print-help-return-message' in +;; the body of `with-help-window'. +(defmacro with-help-window (buffer-name &rest body) + "Display buffer BUFFER-NAME in a help window evaluating BODY. +Select help window if the actual value of the user option +`help-window-select' says so." + (declare (indent 1) (debug t)) + ;; Bind list-of-frames to `frame-list' and list-of-window-tuples to a + ;; list of one <window window-buffer window-start window-point> tuple + ;; for each live window. + `(let ((list-of-frames (frame-list)) + (list-of-window-tuples + (let (list) + (walk-windows + (lambda (window) + (push (list window (window-buffer window) + (window-start window) (window-point window)) + list)) + 'no-mini t) + list))) + ;; We set `help-window' to t in order to trigger `help-mode-finish' + ;; to set `help-window' to the actual help window. + (setq help-window t) + ;; Make `help-window-point-marker' point nowhere (the only place + ;; where this should be set to a buffer position is within BODY). + (set-marker help-window-point-marker nil) + + (with-output-to-temp-buffer ,buffer-name + (progn ,@body)) + + (when (windowp help-window) + ;; Set up help window. + (help-window-setup list-of-frames list-of-window-tuples)) + + ;; Reset `help-window' to nil to avoid confusing future calls of + ;; `help-mode-finish' by "plain" `with-output-to-temp-buffer'. + (setq help-window nil))) + (provide 'help) ;; arch-tag: cf427352-27e9-49b7-9a6f-741ebab02423 diff --git a/lisp/ido.el b/lisp/ido.el index 27e9d66e25c..0a077f9dab6 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -449,7 +449,7 @@ in merged file and directory lists." ;(setq ido-ignore-files '("^ " "\\.c$" "\\.h$")) (defcustom ido-default-file-method 'raise-frame - "*How to visit a new file when using `ido-find-file'. + "*How to visit a new file when using `ido-find-file'. Possible values: `selected-window' Show new file in selected window `other-window' Show new file in another window (same frame) @@ -469,7 +469,7 @@ Possible values: :group 'ido) (defcustom ido-default-buffer-method 'raise-frame - "*How to switch to new buffer when using `ido-switch-buffer'. + "*How to switch to new buffer when using `ido-switch-buffer'. See `ido-default-file-method' for details." :type '(choice (const :tag "Show in selected window" selected-window) (const :tag "Show in other window" other-window) @@ -1309,6 +1309,7 @@ Value is an integer which is number of chars to right of prompt.") (unwind-protect (with-current-buffer buf (erase-buffer) + (setq buffer-file-coding-system 'utf-8) (ido-pp 'ido-last-directory-list) (ido-pp 'ido-work-directory-list) (ido-pp 'ido-work-file-list) @@ -1316,7 +1317,7 @@ Value is an integer which is number of chars to right of prompt.") (if (listp ido-unc-hosts-cache) (ido-pp 'ido-unc-hosts-cache) (insert "\n;; ----- ido-unc-hosts-cache -----\nt\n")) - (insert "\n") + (insert "\n;; Local Variables:\n;; coding: utf-8\n;; End:\n") (write-file ido-save-directory-list-file nil)) (kill-buffer buf))))) diff --git a/lisp/ielm.el b/lisp/ielm.el index 98df0d1e3d4..a734f87ad92 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -169,7 +169,7 @@ This variable is buffer-local.") (defvar ielm-map nil) (if ielm-map nil - (if (string-match "Lucid" emacs-version) + (if (featurep 'xemacs) ;; Lemacs (progn (setq ielm-map (make-sparse-keymap)) diff --git a/lisp/iimage.el b/lisp/iimage.el index 29d98cbda69..f662d9f1042 100644 --- a/lisp/iimage.el +++ b/lisp/iimage.el @@ -109,11 +109,7 @@ Examples of image filename regexps: (interactive) (iimage-mode 0)) -;; Emacs21.3 or earlier does not heve locate-file. -(if (fboundp 'locate-file) - (defalias 'iimage-locate-file 'locate-file) - (defun iimage-locate-file (filename path) - (locate-library filename t path))) +(defalias 'iimage-locate-file 'locate-file) (defun iimage-mode-buffer (arg) "Display/undisplay images. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 3cf57ca7c4d..283f6ae3ff1 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -59,7 +59,7 @@ Stop if the right edge of the image is reached." (set-window-hscroll (selected-window) (max 0 (+ (window-hscroll) n)))) (t - (let* ((image (get-text-property 1 'display)) + (let* ((image (get-char-property (point-min) 'display)) (edges (window-inside-edges)) (win-width (- (nth 2 edges) (nth 0 edges))) (img-width (ceiling (car (image-size image))))) @@ -82,7 +82,7 @@ Stop if the bottom edge of the image is reached." (set-window-vscroll (selected-window) (max 0 (+ (window-vscroll) n)))) (t - (let* ((image (get-text-property 1 'display)) + (let* ((image (get-char-property (point-min) 'display)) (edges (window-inside-edges)) (win-height (- (nth 3 edges) (nth 1 edges))) (img-height (ceiling (cdr (image-size image))))) @@ -156,7 +156,7 @@ stopping if the top or bottom edge of the image is reached." (and arg (/= (setq arg (prefix-numeric-value arg)) 1) (image-next-line (- arg 1))) - (let* ((image (get-text-property 1 'display)) + (let* ((image (get-char-property (point-min) 'display)) (edges (window-inside-edges)) (win-width (- (nth 2 edges) (nth 0 edges))) (img-width (ceiling (car (image-size image))))) @@ -172,7 +172,7 @@ stopping if the top or bottom edge of the image is reached." (defun image-eob () "Scroll to the bottom-right corner of the image in the current window." (interactive) - (let* ((image (get-text-property 1 'display)) + (let* ((image (get-char-property (point-min) 'display)) (edges (window-inside-edges)) (win-width (- (nth 2 edges) (nth 0 edges))) (img-width (ceiling (car (image-size image)))) @@ -221,7 +221,7 @@ to toggle between display as an image and display as text." (setq major-mode 'image-mode) (add-hook 'change-major-mode-hook 'image-toggle-display-text nil t) (if (and (display-images-p) - (not (get-text-property (point-min) 'display))) + (not (get-char-property (point-min) 'display))) (image-toggle-display) ;; Set next vars when image is already displayed but local ;; variables were cleared by kill-all-local-variables @@ -232,7 +232,7 @@ to toggle between display as an image and display as text." (message "%s" (concat (substitute-command-keys "Type \\[image-toggle-display] to view as ") - (if (get-text-property (point-min) 'display) + (if (get-char-property (point-min) 'display) "text" "an image") ".")))) ;;;###autoload @@ -245,13 +245,13 @@ See the command `image-mode' for more information on this mode." :version "22.1" (if (not image-minor-mode) (image-toggle-display-text) - (if (get-text-property (point-min) 'display) + (if (get-char-property (point-min) 'display) (setq cursor-type nil truncate-lines t) (setq image-type "text")) (add-hook 'change-major-mode-hook (lambda () (image-minor-mode -1)) nil t) (message "%s" (concat (substitute-command-keys "Type \\[image-toggle-display] to view the image as ") - (if (get-text-property (point-min) 'display) + (if (get-char-property (point-min) 'display) "text" "an image") ".")))) ;;;###autoload @@ -281,7 +281,7 @@ information on these modes." (defun image-toggle-display-text () "Showing the text of the image file." - (if (get-text-property (point-min) 'display) + (if (get-char-property (point-min) 'display) (image-toggle-display))) (defvar archive-superior-buffer) @@ -292,7 +292,7 @@ information on these modes." This command toggles between showing the text of the image file and showing the image as an image." (interactive) - (if (get-text-property (point-min) 'display) + (if (get-char-property (point-min) 'display) (let ((inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p))) diff --git a/lisp/info.el b/lisp/info.el index 70edf10e0b8..a9a81b9aaf5 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -706,8 +706,8 @@ otherwise, that defaults to `Top'." (Info-find-node-2 nil nodename)) ;; It's perhaps a bit nasty to kill the *info* buffer to force a re-read, -;; but at least it keeps this routine (which is only for the benefit of -;; makeinfo-buffer) out of the way of normal operations. +;; but at least it keeps this routine (which is for makeinfo-buffer and +;; Info-revert-buffer-function) out of the way of normal operations. ;; (defun Info-revert-find-node (filename nodename) "Go to an Info node FILENAME and NODENAME, re-reading disk contents. @@ -739,6 +739,11 @@ is preserved, if possible." (if new-history (setq Info-history (cons new-history Info-history)))))) +(defun Info-revert-buffer-function (ignore-auto noconfirm) + (when (or noconfirm (y-or-n-p "Revert info buffer? ")) + (Info-revert-find-node Info-current-file Info-current-node) + (message "Reverted %s" Info-current-file))) + (defun Info-find-in-tag-table-1 (marker regexp case-fold) "Find a node in a tag table. MARKER specifies the buffer and position to start searching at. @@ -3353,7 +3358,7 @@ With a zero prefix arg, put the name inside a function call to `info'." (unless Info-current-node (error "No current Info node")) (let ((node (if (stringp Info-current-file) - (concat "(" (file-name-nondirectory Info-current-file) ")" + (concat "(" (file-name-nondirectory Info-current-file) ") " Info-current-node)))) (if (zerop (prefix-numeric-value arg)) (setq node (concat "(info \"" node "\")"))) @@ -3478,6 +3483,8 @@ Advanced commands: 'Info-isearch-push-state) (set (make-local-variable 'search-whitespace-regexp) Info-search-whitespace-regexp) + (set (make-local-variable 'revert-buffer-function) + 'Info-revert-buffer-function) (Info-set-mode-line) (run-mode-hooks 'Info-mode-hook)) diff --git a/lisp/international/iso-cvt.el b/lisp/international/iso-cvt.el index d3c2f623e66..d7149b8a9bc 100644 --- a/lisp/international/iso-cvt.el +++ b/lisp/international/iso-cvt.el @@ -84,7 +84,8 @@ ;;;###autoload (defun iso-spanish (from to &optional buffer) "Translate net conventions for Spanish to ISO 8859-1. -The region between FROM and TO is translated using the table TRANS-TAB. +The region between FROM and TO is translated using +the table `iso-spanish-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-spanish-trans-tab)) @@ -125,7 +126,8 @@ little.") ;;;###autoload (defun iso-german (from to &optional buffer) "Translate net conventions for German to ISO 8859-1. -The region between FROM and TO is translated using the table TRANS-TAB. +The region between FROM and TO is translated using +the table `iso-german-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-german-trans-tab)) @@ -197,7 +199,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-iso2tex (from to &optional buffer) "Translate ISO 8859-1 characters to TeX sequences. -The region between FROM and TO is translated using the table TRANS-TAB. +The region between FROM and TO is translated using +the table `iso-iso2tex-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2tex-trans-tab)) @@ -389,7 +392,8 @@ contains commonly used sequences.") ;;;###autoload (defun iso-tex2iso (from to &optional buffer) "Translate TeX sequences to ISO 8859-1 characters. -The region between FROM and TO is translated using the table TRANS-TAB. +The region between FROM and TO is translated using +the table `iso-tex2iso-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-tex2iso-trans-tab)) @@ -647,7 +651,8 @@ contains commonly used sequences.") ;;;###autoload (defun iso-gtex2iso (from to &optional buffer) "Translate German TeX sequences to ISO 8859-1 characters. -The region between FROM and TO is translated using the table TRANS-TAB. +The region between FROM and TO is translated using +the table `iso-gtex2iso-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-gtex2iso-trans-tab)) @@ -655,7 +660,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-iso2gtex (from to &optional buffer) "Translate ISO 8859-1 characters to German TeX sequences. -The region between FROM and TO is translated using the table TRANS-TAB. +The region between FROM and TO is translated using +the table `iso-iso2gtex-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2gtex-trans-tab)) @@ -667,12 +673,14 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ("Ö" "Oe") ("ü" "ue") ("Ü" "Ue") - ("ß" "ss"))) + ("ß" "ss")) + "Translation table for translating ISO 8859-1 characters to Duden sequences.") ;;;###autoload (defun iso-iso2duden (from to &optional buffer) - "Translate ISO 8859-1 characters to German TeX sequences. -The region between FROM and TO is translated using the table TRANS-TAB. + "Translate ISO 8859-1 characters to Duden sequences. +The region between FROM and TO is translated using +the table `iso-iso2duden-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2duden-trans-tab)) @@ -845,7 +853,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." (translate-to-menu-map (make-sparse-keymap "Translate to...")) (translate-from-menu-map (make-sparse-keymap "Translate from...")) (menu menu-bar-file-menu)) - + (define-key menu [load-as-separator] '("--")) (define-key menu [load-as] '("Load As..." . iso-cvt-load-as)) diff --git a/lisp/isearch.el b/lisp/isearch.el index 62a4be8227a..22fa28e70ef 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -159,10 +159,10 @@ command history." (defvar isearch-mode-end-hook nil "Function(s) to call after terminating an incremental search. When these functions are called, `isearch-mode-end-hook-quit' -is non-nil if the user quit the search.") +is non-nil if the user quits the search.") (defvar isearch-mode-end-hook-quit nil - "Non-nil while running `isearch-mode-end-hook' if user quit the search.") + "Non-nil while running `isearch-mode-end-hook' if the user quits the search.") (defvar isearch-message-function nil "Function to call to display the search prompt. @@ -1734,6 +1734,12 @@ Isearch mode." (isearch-back-into-window (eq ab-bel 'above) isearch-point) (goto-char isearch-point))) (isearch-update)) + ;; A mouse click on the isearch message starts editing the search string + ((and (eq (car-safe main-event) 'down-mouse-1) + (window-minibuffer-p (posn-window (event-start main-event)))) + ;; Swallow the up-event. + (read-event) + (isearch-edit-string)) (search-exit-option (let (window) (isearch-unread-key-sequence keylist) @@ -2495,19 +2501,20 @@ Attempt to do the search exactly the way the pending isearch would." (run-at-time lazy-highlight-interval nil 'isearch-lazy-highlight-update))))))))) -(defun isearch-resume (search regexp word forward message case-fold) +(defun isearch-resume (string regexp word forward message case-fold) "Resume an incremental search. -SEARCH is the string or regexp searched for. +STRING is the string or regexp searched for. REGEXP non-nil means the resumed search was a regexp search. WORD non-nil means resume a word search. FORWARD non-nil means resume a forward search. MESSAGE is the echo-area message recorded for the search resumed. CASE-FOLD non-nil means the search was case-insensitive." (isearch-mode forward regexp nil nil word) - (setq isearch-string search + (setq isearch-string string isearch-message message isearch-case-fold-search case-fold) - (isearch-search)) + (isearch-search) + (isearch-update)) ;; arch-tag: 74850515-f7d8-43a6-8a2c-ca90a4c1e675 ;;; isearch.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index c7679a7e58a..9a1092b724f 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1451,19 +1451,14 @@ Special commands: ;;;*** -;;;### (autoloads (auto-show-mode auto-show-mode) "auto-show" "obsolete/auto-show.el" -;;;;;; (17994 6715)) -;;; Generated autoloads from obsolete/auto-show.el +;;;### (autoloads (assistant) "assistant" "gnus/assistant.el" (18212 +;;;;;; 21478)) +;;; Generated autoloads from gnus/assistant.el -(defvar auto-show-mode nil "\ -Obsolete.") +(autoload 'assistant "assistant" "\ +Assist setting up Emacs based on FILE. -(custom-autoload (quote auto-show-mode) "auto-show" t) - -(autoload (quote auto-show-mode) "auto-show" "\ -This command is obsolete. - -\(fn ARG)" t nil) +\(fn FILE)" t nil) ;;;*** @@ -2321,8 +2316,7 @@ When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'. The order attempted is gnome-moz-remote, Mozilla, Firefox, -Galeon, Konqueror, Netscape, Mosaic, IXI Mosaic, Lynx in an -xterm, MMM, and then W3. +Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3. \(fn URL &rest ARGS)" nil nil) @@ -2514,7 +2508,7 @@ Default to the URL around or before point. With a prefix argument, run a new Lynx process in a new buffer. When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new lynx in a new term window, +non-nil, load the document in a new browser process in a new term window, otherwise use any existing one. A non-nil interactive prefix argument reverses the effect of `browse-url-new-window-flag'. @@ -2737,6 +2731,7 @@ Also see `make-text-button'. (put 'byte-compile-dynamic 'safe-local-variable 'booleanp) (put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp) (put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) +(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p) (autoload 'byte-compile-warnings-safe-p "bytecomp" "\ Not documented @@ -5581,7 +5576,7 @@ or default values have changed since the previous major Emacs release. With argument SINCE-VERSION (a string), customize all settings that were added or redefined since that version. -\(fn SINCE-VERSION)" t nil) +\(fn &optional SINCE-VERSION)" t nil) (autoload 'customize-face "cus-edit" "\ Customize FACE, which should be a face name or nil. @@ -7346,13 +7341,10 @@ For absolute symlinks, use \\[dired-do-symlink]. Determine the current directory by scanning the process output for a prompt. The prompt to look for is the first item in `dirtrack-list'. -You can toggle directory tracking by using the function `dirtrack-toggle'. +You can toggle directory tracking by using the function `dirtrack-mode'. If directory tracking does not seem to be working, you can use the -function `dirtrack-debug-toggle' to turn on debugging output. - -You can enable directory tracking by adding this function to -`comint-output-filter-functions'. +function `dirtrack-debug-mode' to turn on debugging output. \(fn INPUT)" nil nil) @@ -7583,7 +7575,7 @@ Switch to *doctor* buffer and start giving psychotherapy. ;;;;;; (18190 35187)) ;;; Generated autoloads from double.el -(defvar double-mode nil "\ +(autoload 'double-mode "double" "\ Toggle Double mode. Setting this variable directly does not take effect; use either \\[customize] or the function `double-mode'.") @@ -7598,7 +7590,7 @@ turn it off. When Double mode is on, some keys will insert different strings when pressed twice. See variable `double-map' for details. -\(fn ARG)" t nil) +\(fn &optional ARG)" t nil) ;;;*** @@ -8331,6 +8323,17 @@ With prefix arg NOCONFIRM, execute current line as-is without editing. ;;;*** +;;;### (autoloads (ecomplete-setup) "ecomplete" "gnus/ecomplete.el" +;;;;;; (18212 21473)) +;;; Generated autoloads from gnus/ecomplete.el + +(autoload 'ecomplete-setup "ecomplete" "\ +Not documented + +\(fn)" nil nil) + +;;;*** + ;;;### (autoloads (edebug-all-forms edebug-all-defs edebug-eval-top-level-form ;;;;;; edebug-basic-spec edebug-all-forms edebug-all-defs) "edebug" ;;;;;; "emacs-lisp/edebug.el" (18190 35188)) @@ -8652,7 +8655,7 @@ Not documented ;;; Generated autoloads from ediff-hook.el (defvar ediff-window-setup-function) - (defmacro ediff-cond-compile-for-xemacs-or-emacs (xemacs-form emacs-form) (if (string-match "XEmacs" emacs-version) xemacs-form emacs-form)) + (defmacro ediff-cond-compile-for-xemacs-or-emacs (xemacs-form emacs-form) (if (featurep 'xemacs) xemacs-form emacs-form)) (ediff-cond-compile-for-xemacs-or-emacs (defun ediff-xemacs-init-menus nil (if (featurep 'menubar) (progn (add-submenu '("Tools") ediff-menu "OO-Browser...") (add-submenu '("Tools") ediff-merge-menu "OO-Browser...") (add-submenu '("Tools") epatch-menu "OO-Browser...") (add-submenu '("Tools") ediff-misc-menu "OO-Browser...") (add-menu-button '("Tools") "-------" "OO-Browser...")))) nil) @@ -9009,6 +9012,22 @@ DISPLAY may be a display id, a frame, or nil for the selected frame's display. ;;;*** +;;;### (autoloads (encrypt-insert-file-contents encrypt-find-model) +;;;;;; "encrypt" "gnus/encrypt.el" (18212 21482)) +;;; Generated autoloads from gnus/encrypt.el + +(autoload 'encrypt-find-model "encrypt" "\ +Given a filename, find a encrypt-file-alist entry + +\(fn FILENAME)" nil nil) + +(autoload 'encrypt-insert-file-contents "encrypt" "\ +Decrypt FILE into the current buffer. + +\(fn FILE &optional MODEL)" t nil) + +;;;*** + ;;;### (autoloads (enriched-decode enriched-encode enriched-mode) ;;;;;; "enriched" "textmodes/enriched.el" (18177 875)) ;;; Generated autoloads from textmodes/enriched.el @@ -10329,9 +10348,9 @@ Variables controlling indentation style and extra features: `f90-do-indent' Extra indentation within do blocks (default 3). `f90-if-indent' - Extra indentation within if/select case/where/forall blocks (default 3). + Extra indentation within if/select/where/forall blocks (default 3). `f90-type-indent' - Extra indentation within type/interface/block-data blocks (default 3). + Extra indentation within type/enum/interface/block-data blocks (default 3). `f90-program-indent' Extra indentation within program/module/subroutine/function blocks (default 2). @@ -11161,7 +11180,7 @@ Not documented (autoload 'fill-flowed "flow-fill" "\ Not documented -\(fn &optional BUFFER)" nil nil) +\(fn &optional BUFFER DELETE-SPACE)" nil nil) ;;;*** @@ -11281,7 +11300,7 @@ of two major techniques: * The windows always displays adjacent sections of the buffer. This means that whenever one window is moved, all the - others will follow. (Hence the name Follow Mode.) + others will follow. (Hence the name Follow mode.) * Should the point (cursor) end up outside a window, another window displaying that point is selected, if possible. This @@ -11317,7 +11336,7 @@ Create two side by side windows and enter Follow Mode. Execute this command to display as much as possible of the text in the selected window. All other windows, in the current frame, are deleted and the selected window is split in two -side-by-side windows. Follow Mode is activated, hence the +side-by-side windows. Follow mode is activated, hence the two windows always will display two successive pages. \(If one window is moved, the other one will follow.) @@ -11431,7 +11450,7 @@ Variables controlling indentation style and extra features: `fortran-minimum-statement-indent-tab' (TAB format), depending on the continuation format in use. relative indent to `fortran-comment-line-extra-indent' beyond the - indentation for a line of code. + indentation for a line of code. (default 'fixed) `fortran-comment-indent-char' Single-character string to be inserted instead of space for @@ -11892,6 +11911,30 @@ Play a sound FILE through the speaker. ;;;*** +;;;### (autoloads (gnus-bookmark-bmenu-list gnus-bookmark-jump gnus-bookmark-set) +;;;;;; "gnus-bookmark" "gnus/gnus-bookmark.el" (18212 21481)) +;;; Generated autoloads from gnus/gnus-bookmark.el + +(autoload 'gnus-bookmark-set "gnus-bookmark" "\ +Set a bookmark for this article. + +\(fn)" t nil) + +(autoload 'gnus-bookmark-jump "gnus-bookmark" "\ +Jump to a Gnus bookmark (BMK-NAME). + +\(fn &optional BMK-NAME)" t nil) + +(autoload 'gnus-bookmark-bmenu-list "gnus-bookmark" "\ +Display a list of existing Gnus bookmarks. +The list is displayed in a buffer named `*Gnus Bookmark List*'. +The leftmost column displays a D if the bookmark is flagged for +deletion, or > if it is flagged for displaying. + +\(fn)" t nil) + +;;;*** + ;;;### (autoloads (gnus-cache-delete-group gnus-cache-rename-group ;;;;;; gnus-cache-generate-nov-databases gnus-cache-generate-active ;;;;;; gnus-jog-cache) "gnus-cache" "gnus/gnus-cache.el" (18177 @@ -12029,11 +12072,17 @@ Insert a random X-Face header from `gnus-x-face-directory'. (autoload 'gnus-x-face-from-file "gnus-fun" "\ Insert an X-Face header based on an image file. +Depending on `gnus-convert-image-to-x-face-command' it may accept +different input formats. + \(fn FILE)" t nil) (autoload 'gnus-face-from-file "gnus-fun" "\ Return a Face header based on an image file. +Depending on `gnus-convert-image-to-face-command' it may accept +different input formats. + \(fn FILE)" t nil) (autoload 'gnus-convert-face-to-png "gnus-fun" "\ @@ -12057,6 +12106,7 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to (autoload 'gnus-fetch-group "gnus-group" "\ Start Gnus if necessary and enter GROUP. +If ARTICLES, display those articles. Returns whether the fetching was successful or not. \(fn GROUP &optional ARTICLES)" t nil) @@ -12120,14 +12170,14 @@ group parameters. If AUTO-UPDATE is non-nil (prefix argument accepted, if called interactively), it makes sure nnmail-split-fancy is re-computed before -getting new mail, by adding gnus-group-split-update to -nnmail-pre-get-new-mail-hook. +getting new mail, by adding `gnus-group-split-update' to +`nnmail-pre-get-new-mail-hook'. A non-nil CATCH-ALL replaces the current value of -gnus-group-split-default-catch-all-group. This variable is only used +`gnus-group-split-default-catch-all-group'. This variable is only used by gnus-group-split-update, and only when its CATCH-ALL argument is nil. This argument may contain any fancy split, that will be added as -the last split in a `|' split produced by gnus-group-split-fancy, +the last split in a `|' split produced by `gnus-group-split-fancy', unless overridden by any group marked as a catch-all group. Typical uses are as simple as the name of a default mail group, but more elaborate fancy splits may also be useful to split mail that doesn't @@ -12141,8 +12191,8 @@ Computes nnmail-split-fancy from group params and CATCH-ALL. It does this by calling by calling (gnus-group-split-fancy nil nil CATCH-ALL). -If CATCH-ALL is nil, gnus-group-split-default-catch-all-group is used -instead. This variable is set by gnus-group-split-setup. +If CATCH-ALL is nil, `gnus-group-split-default-catch-all-group' is used +instead. This variable is set by `gnus-group-split-setup'. \(fn &optional CATCH-ALL)" t nil) @@ -12150,7 +12200,7 @@ instead. This variable is set by gnus-group-split-setup. Uses information from group parameters in order to split mail. See `gnus-group-split-fancy' for more information. -gnus-group-split is a valid value for nnmail-split-methods. +`gnus-group-split' is a valid value for `nnmail-split-methods'. \(fn)" nil nil) @@ -12802,6 +12852,50 @@ to be updated. ;;;*** +;;;### (autoloads (mail-check-payment mail-add-payment-async mail-add-payment +;;;;;; hashcash-verify-payment hashcash-insert-payment-async hashcash-insert-payment) +;;;;;; "hashcash" "gnus/hashcash.el" (18212 21477)) +;;; Generated autoloads from gnus/hashcash.el + +(autoload 'hashcash-insert-payment "hashcash" "\ +Insert X-Payment and X-Hashcash headers with a payment for ARG + +\(fn ARG)" t nil) + +(autoload 'hashcash-insert-payment-async "hashcash" "\ +Insert X-Payment and X-Hashcash headers with a payment for ARG +Only start calculation. Results are inserted when ready. + +\(fn ARG)" t nil) + +(autoload 'hashcash-verify-payment "hashcash" "\ +Verify a hashcash payment + +\(fn TOKEN &optional RESOURCE AMOUNT)" nil nil) + +(autoload 'mail-add-payment "hashcash" "\ +Add X-Payment: and X-Hashcash: headers with a hashcash payment +for each recipient address. Prefix arg sets default payment temporarily. +Set ASYNC to t to start asynchronous calculation. (See +`mail-add-payment-async'). + +\(fn &optional ARG ASYNC)" t nil) + +(autoload 'mail-add-payment-async "hashcash" "\ +Add X-Payment: and X-Hashcash: headers with a hashcash payment +for each recipient address. Prefix arg sets default payment temporarily. +Calculation is asynchronous. + +\(fn &optional ARG)" t nil) + +(autoload 'mail-check-payment "hashcash" "\ +Look for a valid X-Payment: or X-Hashcash: header. +Prefix arg sets default accept amount temporarily. + +\(fn &optional ARG)" t nil) + +;;;*** + ;;;### (autoloads (scan-buf-previous-region scan-buf-next-region ;;;;;; scan-buf-move-to-region help-at-pt-display-when-idle help-at-pt-set-timer ;;;;;; help-at-pt-cancel-timer display-local-help help-at-pt-kbd-string @@ -13888,9 +13982,7 @@ They are removed from `ibuffer-saved-filter-groups'. (autoload 'ibuffer-switch-to-saved-filter-groups "ibuf-ext" "\ Set this buffer's filter groups to saved version with NAME. -The value from `ibuffer-saved-filters' is used. -If prefix argument ADD is non-nil, then add the saved filters instead -of replacing the current filters. +The value from `ibuffer-saved-filter-groups' is used. \(fn NAME)" t nil) @@ -13948,8 +14040,6 @@ Add saved filters from `ibuffer-saved-filters' to this buffer's filters. (autoload 'ibuffer-switch-to-saved-filters "ibuf-ext" "\ Set this buffer's filters to filters with NAME from `ibuffer-saved-filters'. -If prefix argument ADD is non-nil, then add the saved filters instead -of replacing the current filters. \(fn NAME)" t nil) (autoload 'ibuffer-filter-by-mode "ibuf-ext") @@ -15747,6 +15837,39 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\" ;;;*** +;;;### (autoloads (isearch-buffers-minor-mode) "isearch-multi" "isearch-multi.el" +;;;;;; (18210 13714)) +;;; Generated autoloads from isearch-multi.el + +(defvar isearch-buffers-current-buffer nil "\ +The buffer where the search is currently searching. +The value is nil when the search still is in the initial buffer.") + +(defvar isearch-buffers-next-buffer-function nil "\ +Function to call to get the next buffer to search. + +When this variable is set to a function that returns a buffer, then +after typing another C-s or C-r at a failing search, the search goes +to the next buffer in the series and continues searching for the +next occurrence. + +The first argument of this function is the current buffer where the +search is currently searching. It defines the base buffer relative to +which this function should find the next buffer. When the isearch +direction is backward (when isearch-forward is nil), this function +should return the previous buffer to search. If the second argument of +this function WRAP is non-nil, then it should return the first buffer +in the series; and for the backward search, it should return the last +buffer in the series.") + +(autoload 'isearch-buffers-minor-mode "isearch-multi" "\ +Minor mode for using isearch to search through multiple buffers. +With arg, turn isearch-buffers minor mode on if arg is positive, off otherwise. + +\(fn &optional ARG)" t nil) + +;;;*** + ;;;### (autoloads (isearch-process-search-multibyte-characters isearch-toggle-input-method ;;;;;; isearch-toggle-specified-input-method) "isearch-x" "international/isearch-x.el" ;;;;;; (18177 864)) @@ -16055,6 +16178,9 @@ when called interactively, non-corrective messages are suppressed. With a prefix argument (or if CONTINUE is non-nil), resume interrupted spell-checking of a buffer or region. +Interactively, in Transient Mark mode when the mark is active, call +`ispell-region' to check the active region for spelling errors. + Word syntax is controlled by the definition of the chosen dictionary, which is in `ispell-local-dictionary-alist' or `ispell-dictionary-alist'. @@ -16068,7 +16194,7 @@ nil word is correct or spelling is accepted. \(\"word\" arg) word is hand entered. quit spell session exited. -\(fn &optional FOLLOWING QUIETLY CONTINUE)" t nil) +\(fn &optional FOLLOWING QUIETLY CONTINUE REGION)" t nil) (autoload 'ispell-pdict-save "ispell" "\ Check to see if the personal dictionary has been modified. @@ -16875,15 +17001,24 @@ Unload the library that provided FEATURE, restoring all its autoloads. If the feature is required by any other loaded code, and prefix arg FORCE is nil, raise an error. -This function tries to undo modifications made by the package to -hooks. Packages may define a hook FEATURE-unload-hook that is called -instead of the normal heuristics for doing this. Such a hook should -undo all the relevant global state changes that may have been made by -loading the package or executing functions in it. It has access to -the package's feature list (before anything is unbound) in the -variable `unload-hook-features-list' and could remove features from it -in the event that the package has done something normally-ill-advised, -such as redefining an Emacs function. +Standard unloading activities include restoring old autoloads for +functions defined by the library, undoing any additions that the +library has made to hook variables or to `auto-mode-alist', undoing +ELP profiling of functions in that library, unproviding any features +provided by the library, and canceling timers held in variables +defined by the library. + +If a function `FEATURE-unload-function' is defined, this function +calls it with no arguments, before doing anything else. That function +can do whatever is appropriate to undo the loading of the library. If +`FEATURE-unload-function' returns non-nil, that suppresses the +standard unloading of the library. Otherwise the standard unloading +proceeds. + +`FEATURE-unload-function' has access to the package's list of +definitions in the variable `unload-function-defs-list' and could +remove symbols from it in the event that the package has done +something strange, such as redefining an Emacs function. \(fn FEATURE &optional FORCE)" t nil) @@ -17661,7 +17796,7 @@ turn on menu bars; otherwise, turn off menu bars. ;;;*** -;;;### (autoloads (unbold-region bold-region message-news-other-frame +;;;### (autoloads (message-unbold-region message-bold-region message-news-other-frame ;;;;;; message-news-other-window message-mail-other-frame message-mail-other-window ;;;;;; message-bounce message-resend message-insinuate-rmail message-forward-rmail-make-body ;;;;;; message-forward-make-body message-forward message-recover @@ -17778,9 +17913,10 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to From (\"Originator\") + C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To C-c C-f C-m move to Mail-Followup-To + C-c C-f C-e move to Expires C-c C-f C-i cycle through Importance values C-c C-f s change subject and append \"(was: <Old Subject>)\" C-c C-f x crossposting with FollowUp-To header and note in body @@ -19622,7 +19758,7 @@ Call `remember'. If this is already a remember buffer, re-apply template. If there is an active region, make sure remember uses it as initial content of the remember buffer. -\(fn)" t nil) +\(fn &optional ORG-FORCE-REMEMBER-TEMPLATE-CHAR)" t nil) (autoload 'org-remember-handler "org" "\ Store stuff from remember.el into an org file. @@ -19664,9 +19800,9 @@ See also the variable `org-reverse-note-order'. (autoload 'org-agenda "org" "\ Dispatch agenda commands to collect entries to the agenda buffer. -Prompts for a character to select a command. Any prefix arg will be passed +Prompts for a command to execute. Any prefix arg will be passed on to the selected command. The default selections are: -g + a Call `org-agenda-list' to display the agenda for current day or week. t Call `org-todo-list' to display the global todo list. T Call `org-todo-list' to display the global todo list, select only @@ -19682,10 +19818,12 @@ More commands can be added by configuring the variable searches can be pre-defined in this way. If the current buffer is in Org-mode and visiting a file, you can also -first press `1' to indicate that the agenda should be temporarily (until the -next use of \\[org-agenda]) restricted to the current file. +first press `<' once to indicate that the agenda should be temporarily +\(until the next use of \\[org-agenda]) restricted to the current file. +Pressing `<' twice means to restrict to the current subtree or region +\(if active). -\(fn ARG)" t nil) +\(fn ARG &optional KEYS RESTRICTION)" t nil) (autoload 'org-batch-agenda "org" "\ Run an agenda command in batch mode and send the result to STDOUT. @@ -19762,7 +19900,6 @@ on the days are also shown. See the variable `org-log-done' for how to turn on logging. START-DAY defaults to TODAY, or to the most recent match for the weekday given in `org-agenda-start-on-weekday'. -NDAYS defaults to `org-agenda-ndays'. \(fn &optional INCLUDE-ALL START-DAY NDAYS)" t nil) @@ -19792,7 +19929,7 @@ items should be listed. The following arguments are allowed: date range matching the selected date. Deadlines will also be listed, on the expiration day. - :sexp FIXME + :sexp List entries resulting from diary-like sexps. :deadline List any deadlines past due, or due within `org-deadline-warning-days'. The listing occurs only @@ -25059,7 +25196,7 @@ From a program takes two point or marker arguments, BEG and END. (autoload 'spam-initialize "spam" "\ Install the spam.el hooks and do other initialization -\(fn)" t nil) +\(fn &rest SYMBOLS)" t nil) ;;;*** @@ -25731,20 +25868,20 @@ Read a complex stroke and insert its glyph into the current buffer. ;;;*** ;;;### (autoloads (studlify-buffer studlify-word studlify-region) -;;;;;; "studly" "play/studly.el" (17994 6715)) +;;;;;; "studly" "play/studly.el" (16268 23254)) ;;; Generated autoloads from play/studly.el -(autoload (quote studlify-region) "studly" "\ +(autoload 'studlify-region "studly" "\ Studlify-case the region. \(fn BEGIN END)" t nil) -(autoload (quote studlify-word) "studly" "\ +(autoload 'studlify-word "studly" "\ Studlify-case the current word, or COUNT words if given an argument. \(fn COUNT)" t nil) -(autoload (quote studlify-buffer) "studly" "\ +(autoload 'studlify-buffer "studly" "\ Studlify-case the current buffer. \(fn)" t nil) @@ -28029,8 +28166,8 @@ See `tramp-file-name-structure' for more explanations.") This regexp should match tramp file names but no other file names. \(When tramp.el is loaded, this regular expression is prepended to `file-name-handler-alist', and that is searched sequentially. Thus, -if the tramp entry appears rather early in the `file-name-handler-alist' -and is a bit too general, then some files might be considered tramp +if the Tramp entry appears rather early in the `file-name-handler-alist' +and is a bit too general, then some files might be considered Tramp files which are not really Tramp files. Please note that the entry in `file-name-handler-alist' is made when @@ -28083,16 +28220,16 @@ pass to the OPERATION." (let* ((inhibit-file-name-handlers (\` (tramp-completion (autoload 'tramp-file-name-handler "tramp" "\ Invoke Tramp file name handler. -Falls back to normal file name handler if no tramp file name handler exists. +Falls back to normal file name handler if no Tramp file name handler exists. \(fn OPERATION &rest ARGS)" nil nil) (defun tramp-completion-file-name-handler (operation &rest args) "\ -Invoke tramp file name completion handler. -Falls back to normal file name handler if no tramp file name handler exists." (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) (if fn (save-match-data (apply (cdr fn) args)) (tramp-completion-run-real-handler operation args)))) +Invoke Tramp file name completion handler. +Falls back to normal file name handler if no Tramp file name handler exists." (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) (if fn (save-match-data (apply (cdr fn) args)) (tramp-completion-run-real-handler operation args)))) (defsubst tramp-register-file-name-handler nil "\ -Add tramp file name handler to `file-name-handler-alist'." (let ((a1 (rassq (quote tramp-file-name-handler) file-name-handler-alist))) (setq file-name-handler-alist (delete a1 file-name-handler-alist))) (add-to-list (quote file-name-handler-alist) (cons tramp-file-name-regexp (quote tramp-file-name-handler))) (let ((jka (rassoc (quote jka-compr-handler) file-name-handler-alist))) (when jka (setq file-name-handler-alist (cons jka (delete jka file-name-handler-alist)))))) +Add Tramp file name handler to `file-name-handler-alist'." (let ((a1 (rassq (quote tramp-file-name-handler) file-name-handler-alist))) (setq file-name-handler-alist (delete a1 file-name-handler-alist))) (add-to-list (quote file-name-handler-alist) (cons tramp-file-name-regexp (quote tramp-file-name-handler))) (let ((jka (rassoc (quote jka-compr-handler) file-name-handler-alist))) (when jka (setq file-name-handler-alist (cons jka (delete jka file-name-handler-alist)))))) (tramp-register-file-name-handler) (defsubst tramp-register-completion-file-name-handler nil "\ @@ -28998,7 +29135,10 @@ Not documented (autoload 'url-basepath "url-util" "\ Return the base pathname of FILE, or the actual filename if X is true. -\(fn FILE &optional X)" nil nil) +\(fn FILE)" nil nil) + +(autoload 'url-file-nondirectory "url-util" "\ +Return the nondirectory part of FILE, for a URL. (autoload 'url-parse-query-string "url-util" "\ Not documented @@ -29117,9 +29257,9 @@ If FILE-NAME is non-nil, save the result to FILE-NAME. ;;;*** -;;;### (autoloads (vc-annotate vc-update-change-log vc-rename-file -;;;;;; vc-transfer-file vc-switch-backend vc-rollback vc-update -;;;;;; vc-revert vc-print-log vc-retrieve-snapshot vc-create-snapshot +;;;### (autoloads (vc-annotate vc-branch-part vc-trunk-p vc-update-change-log +;;;;;; vc-rename-file vc-transfer-file vc-switch-backend vc-update +;;;;;; vc-rollback vc-revert vc-print-log vc-retrieve-snapshot vc-create-snapshot ;;;;;; vc-directory vc-merge vc-insert-headers vc-revision-other-window ;;;;;; vc-diff vc-register vc-next-action vc-do-command edit-vc-file ;;;;;; with-vc-file vc-before-checkin-hook vc-checkin-hook vc-checkout-hook) @@ -29171,7 +29311,7 @@ considered successful if its exit status does not exceed OKSTATUS (if OKSTATUS is nil, that means to ignore error status, if it is `async', that means not to wait for termination of the subprocess; if it is t it means to ignore all execution errors). FILE-OR-LIST is the name of a working file; -it may be a list of files or be nil (to execute commands that don't expect +it may be a list of files or be nil (to execute commands that don't expect a file name or set of files). If an optional list of FLAGS is present, that is inserted into the command line before the filename. @@ -29189,29 +29329,27 @@ each one. The log message will be used as a comment for any register or checkin operations, but ignored when doing checkouts. Attempted lock steals will raise an error. -A prefix argument lets you specify the version number to use. - -For RCS and SCCS files: - If the file is not already registered, this registers it for version +For locking systems: + If every file is not already registered, this registers each for version control. - If the file is registered and not locked by anyone, this checks out -a writable and locked file ready for editing. - If the file is checked out and locked by the calling user, this -first checks to see if the file has changed since checkout. If not, -it performs a revert. - If the file has been changed, this pops up a buffer for entry + If every file is registered and not locked by anyone, this checks out +a writable and locked file of each ready for editing. + If every file is checked out and locked by the calling user, this +first checks to see if each file has changed since checkout. If not, +it performs a revert on that file. + If every file has been changed, this pops up a buffer for entry of a log message; when the message has been entered, it checks in the resulting changes along with the log message as change commentary. If the variable `vc-keep-workfiles' is non-nil (which is its default), a -read-only copy of the changed file is left in place afterwards. - If the file is registered and locked by someone else, you are given -the option to steal the lock. - -For CVS files: - If the file is not already registered, this registers it for version -control. This does a \"cvs add\", but no \"cvs commit\". - If the file is added but not committed, it is committed. - If your working file is changed, but the repository file is +read-only copy of each changed file is left in place afterwards. + If the affected file is registered and locked by someone else, you are +given the option to steal the lock(s). + +For merging systems: + If every file is not already registered, this registers each one for version +control. This does an add, but not a commit. + If every file is added but not committed, each one is committed. + If every working file is changed, but the corresponding repository file is unchanged, this pops up a buffer for entry of a log message; when the message has been entered, it checks in the resulting changes along with the logmessage as change commentary. A writable file is retained. @@ -29222,7 +29360,7 @@ merge in the changes into your working copy. (autoload 'vc-register "vc" "\ Register the current file into a version control system. -With prefix argument SET-VERSION, allow user to specify initial version +With prefix argument SET-REVISION, allow user to specify initial revision level. If COMMENT is present, use that as an initial comment. The version control system to use is found by cycling through the list @@ -29232,7 +29370,12 @@ directory are already registered under that backend) will be used to register the file. If no backend declares itself responsible, the first backend that could register the file is used. -\(fn &optional SET-VERSION COMMENT)" t nil) +\(fn &optional SET-REVISION COMMENT)" t nil) + +(autoload 'vc-version-diff "vc" "\ +Report diffs between revisions of the fileset in the repository history. + +\(fn FILES REV1 REV2)" t nil) (autoload 'vc-diff "vc" "\ Display diffs between file versions. @@ -29284,16 +29427,16 @@ With prefix arg READ-SWITCHES, specify a value to override (autoload 'vc-create-snapshot "vc" "\ Descending recursively from DIR, make a snapshot called NAME. -For each registered file, the version level of its latest version -becomes part of the named configuration. If the prefix argument -BRANCHP is given, the snapshot is made as a new branch and the files -are checked out in that new branch. +For each registered file, the working revision becomes part of +the named configuration. If the prefix argument BRANCHP is +given, the snapshot is made as a new branch and the files are +checked out in that new branch. \(fn DIR NAME BRANCHP)" t nil) (autoload 'vc-retrieve-snapshot "vc" "\ Descending recursively from DIR, retrieve the snapshot called NAME. -If NAME is empty, it refers to the latest versions. +If NAME is empty, it refers to the latest revisions. If locking is used for the files in DIR, then there must not be any locked files at or below DIR (but if NAME is empty, locked files are allowed and simply skipped). @@ -29304,13 +29447,12 @@ allowed and simply skipped). List the change log of the current buffer in a window. If FOCUS-REV is non-nil, leave the point at that revision. -\(fn &optional FOCUS-REV)" t nil) +\(fn &optional WORKING-REVISION)" t nil) (autoload 'vc-revert "vc" "\ Revert the current buffer's file to the version it was based on. This asks for confirmation if the buffer contents are not identical -to that version. This function does not automatically pick up newer -changes found in the master file; use \\[universal-argument] \\[vc-next-action] to do so. +to the working revision (except for keyword expansion). \(fn)" t nil) @@ -29345,7 +29487,7 @@ To get a prompt, use a prefix argument. Transfer FILE to another version control system NEW-BACKEND. If NEW-BACKEND has a higher precedence than FILE's current backend \(i.e. it comes earlier in `vc-handled-backends'), then register FILE in -NEW-BACKEND, using the version number from the current backend as the +NEW-BACKEND, using the revision number from the current backend as the base level. If NEW-BACKEND has a lower precedence than the current backend, then commit all changes that were made under the current backend to NEW-BACKEND, and unregister FILE from the current backend. @@ -29395,8 +29537,8 @@ default, the time scale stretches back one year into the past; everything that is older than that is shown in blue. With a prefix argument, this command asks two questions in the -minibuffer. First, you may enter a version number; then the buffer -displays and annotates that version instead of the current version +minibuffer. First, you may enter a revision number; then the buffer +displays and annotates that revision instead of the working revision \(type RET in the minibuffer to leave that default unchanged). Then, you are prompted for the time span in days which the color range should cover. For example, a time span of 20 days means that changes @@ -29406,9 +29548,9 @@ age, and everything that is older than that is shown in blue. Customization variables: `vc-annotate-menu-elements' customizes the menu elements of the -mode-specific menu. `vc-annotate-color-map' and -`vc-annotate-very-old-color' defines the mapping of time to -colors. `vc-annotate-background' specifies the background color. +mode-specific menu. `vc-annotate-color-map' and +`vc-annotate-very-old-color' define the mapping of time to colors. +`vc-annotate-background' specifies the background color. \(fn FILE REV &optional DISPLAY-MODE BUF)" t nil) @@ -31190,18 +31332,19 @@ Zone out, completely. ;;;;;; "gnus/dig.el" "gnus/dns.el" "gnus/format-spec.el" "gnus/gnus-async.el" ;;;;;; "gnus/gnus-bcklg.el" "gnus/gnus-cite.el" "gnus/gnus-cus.el" ;;;;;; "gnus/gnus-demon.el" "gnus/gnus-dup.el" "gnus/gnus-eform.el" -;;;;;; "gnus/gnus-ems.el" "gnus/gnus-gl.el" "gnus/gnus-int.el" "gnus/gnus-logic.el" +;;;;;; "gnus/gnus-ems.el" "gnus/gnus-int.el" "gnus/gnus-logic.el" ;;;;;; "gnus/gnus-mh.el" "gnus/gnus-salt.el" "gnus/gnus-score.el" ;;;;;; "gnus/gnus-setup.el" "gnus/gnus-srvr.el" "gnus/gnus-sum.el" ;;;;;; "gnus/gnus-topic.el" "gnus/gnus-undo.el" "gnus/gnus-util.el" -;;;;;; "gnus/gnus-uu.el" "gnus/gnus-vm.el" "gnus/hex-util.el" "gnus/ietf-drums.el" -;;;;;; "gnus/imap.el" "gnus/legacy-gnus-agent.el" "gnus/mail-parse.el" -;;;;;; "gnus/mail-prsvr.el" "gnus/mail-source.el" "gnus/mailcap.el" -;;;;;; "gnus/messcompat.el" "gnus/mm-bodies.el" "gnus/mm-decode.el" -;;;;;; "gnus/mm-encode.el" "gnus/mm-util.el" "gnus/mm-view.el" "gnus/mml-sec.el" -;;;;;; "gnus/mml-smime.el" "gnus/mml.el" "gnus/nnagent.el" "gnus/nnbabyl.el" -;;;;;; "gnus/nndb.el" "gnus/nndir.el" "gnus/nndraft.el" "gnus/nneething.el" -;;;;;; "gnus/nngateway.el" "gnus/nnheader.el" "gnus/nnimap.el" "gnus/nnlistserv.el" +;;;;;; "gnus/gnus-uu.el" "gnus/gnus-vm.el" "gnus/hex-util.el" "gnus/hmac-def.el" +;;;;;; "gnus/hmac-md5.el" "gnus/ietf-drums.el" "gnus/imap.el" "gnus/legacy-gnus-agent.el" +;;;;;; "gnus/mail-parse.el" "gnus/mail-prsvr.el" "gnus/mail-source.el" +;;;;;; "gnus/mailcap.el" "gnus/md4.el" "gnus/messcompat.el" "gnus/mm-bodies.el" +;;;;;; "gnus/mm-decode.el" "gnus/mm-encode.el" "gnus/mm-util.el" +;;;;;; "gnus/mm-view.el" "gnus/mml-sec.el" "gnus/mml-smime.el" "gnus/mml.el" +;;;;;; "gnus/nnagent.el" "gnus/nnbabyl.el" "gnus/nndb.el" "gnus/nndir.el" +;;;;;; "gnus/nndraft.el" "gnus/nneething.el" "gnus/nngateway.el" +;;;;;; "gnus/nnheader.el" "gnus/nnimap.el" "gnus/nnlistserv.el" ;;;;;; "gnus/nnmail.el" "gnus/nnmaildir.el" "gnus/nnmbox.el" "gnus/nnmh.el" ;;;;;; "gnus/nnnil.el" "gnus/nnoo.el" "gnus/nnrss.el" "gnus/nnslashdot.el" ;;;;;; "gnus/nnspool.el" "gnus/nntp.el" "gnus/nnultimate.el" "gnus/nnvirtual.el" diff --git a/lisp/loadhist.el b/lisp/loadhist.el index 2e052d8cf96..0c1766143d6 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -120,16 +120,16 @@ from a file." '(after-change-functions after-insert-file-functions after-make-frame-functions auto-fill-function before-change-functions blink-paren-function buffer-access-fontify-functions command-line-functions - comment-indent-function compilation-finish-functions + comment-indent-function compilation-finish-functions delete-frame-functions disabled-command-function find-file-not-found-functions font-lock-beginning-of-syntax-function font-lock-fontify-buffer-function font-lock-fontify-region-function font-lock-mark-block-function font-lock-syntactic-face-function font-lock-unfontify-buffer-function font-lock-unfontify-region-function kill-buffer-query-functions kill-emacs-query-functions lisp-indent-function mouse-position-function - redisplay-end-trigger-functions temp-buffer-show-function - window-scroll-functions window-size-change-functions - write-contents-functions write-file-functions + redisplay-end-trigger-functions suspend-tty-functions + temp-buffer-show-function window-scroll-functions + window-size-change-functions write-contents-functions write-file-functions write-region-annotate-functions) "A list of special hooks from Info node `(elisp)Standard Hooks'. @@ -191,7 +191,7 @@ something strange, such as redefining an Emacs function." (unload-func (intern-soft (concat name "-unload-function")))) ;; If FEATURE-unload-function is defined and returns non-nil, ;; don't try to do anything more; otherwise proceed normally. - (unless (and (bound-and-true-p unload-func) + (unless (and (fboundp unload-func) (funcall unload-func)) ;; Try to avoid losing badly when hooks installed in critical ;; places go away. (Some packages install things on diff --git a/lisp/loadup.el b/lisp/loadup.el index 36bedfc67ec..12aaae60aab 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -153,6 +153,7 @@ (load "textmodes/page") (load "register") (load "textmodes/paragraphs") +(load "abbrev") ;lisp-mode.el uses define-abbrev-table. (load "emacs-lisp/lisp-mode") (load "textmodes/text-mode") (load "textmodes/fill") @@ -162,7 +163,6 @@ (if (eq system-type 'vax-vms) (progn (load "vmsproc"))) -(load "abbrev") (load "buff-menu") (if (fboundp 'x-create-frame) diff --git a/lisp/longlines.el b/lisp/longlines.el index c820150c27a..f043a48c737 100644 --- a/lisp/longlines.el +++ b/lisp/longlines.el @@ -93,6 +93,8 @@ This is used when `longlines-show-hard-newlines' is on." ;; Mode +(defvar message-indent-citation-function) + ;;;###autoload (define-minor-mode longlines-mode "Toggle Long Lines mode. diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index be47032a0c2..b94f3bc8297 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -139,7 +139,7 @@ See also `footnote-section-tag'." ;;; Default styles ;;; NUMERIC -(defconst footnote-numeric-regexp "[0-9]" +(defconst footnote-numeric-regexp "[0-9]+" "Regexp for digits.") (defun Footnote-numeric (n) @@ -151,7 +151,7 @@ Use Arabic numerals for footnoting." (defconst footnote-english-upper "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "Upper case English alphabet.") -(defconst footnote-english-upper-regexp "[A-Z]" +(defconst footnote-english-upper-regexp "[A-Z]+" "Regexp for upper case English alphabet.") (defun Footnote-english-upper (n) @@ -170,7 +170,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (defconst footnote-english-lower "abcdefghijklmnopqrstuvwxyz" "Lower case English alphabet.") -(defconst footnote-english-lower-regexp "[a-z]" +(defconst footnote-english-lower-regexp "[a-z]+" "Regexp of lower case English alphabet.") (defun Footnote-english-lower (n) @@ -191,7 +191,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (50 . "l") (100 . "c") (500 . "d") (1000 . "m")) "List of roman numerals with their values.") -(defconst footnote-roman-lower-regexp "[ivxlcdm]" +(defconst footnote-roman-lower-regexp "[ivxlcdm]+" "Regexp of roman numerals.") (defun Footnote-roman-lower (n) @@ -204,7 +204,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (50 . "L") (100 . "C") (500 . "D") (1000 . "M")) "List of roman numerals with their values.") -(defconst footnote-roman-upper-regexp "[IVXLCDM]" +(defconst footnote-roman-upper-regexp "[IVXLCDM]+" "Regexp of roman numerals. Not complete") (defun Footnote-roman-upper (n) @@ -270,6 +270,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (defconst footnote-latin-string "¹²³ºª§¶" "String of Latin-1 footnoting characters.") +;; Note not [...]+, because this style cycles. (defconst footnote-latin-regexp (concat "[" footnote-latin-string "]") "Regexp for Latin-1 footnoting characters.") diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el index 8862e6ca2d2..0b2c0177234 100644 --- a/lisp/mail/mailabbrev.el +++ b/lisp/mail/mailabbrev.el @@ -133,19 +133,16 @@ "Expand mail aliases as abbrevs, in certain mail headers." :group 'abbrev-mode) -(defcustom mail-abbrevs-mode nil - "*Non-nil means expand mail aliases as abbrevs, in certain message headers." - :type 'boolean +;;;###autoload +(define-minor-mode mail-abbrevs-mode + "Non-nil means expand mail aliases as abbrevs, in certain message headers." + :global t :group 'mail-abbrev - :require 'mailabbrev - :set (lambda (symbol value) - (setq mail-abbrevs-mode value) - (if value (mail-abbrevs-enable) (mail-abbrevs-disable))) - :initialize 'custom-initialize-default - :version "20.3") + :version "20.3" + (if mail-abbrevs-mode (mail-abbrevs-enable) (mail-abbrevs-disable))) (defcustom mail-abbrevs-only nil - "*Non-nil means only mail abbrevs should expand automatically. + "Non-nil means only mail abbrevs should expand automatically. Other abbrevs expand only when you explicitly use `expand-abbrev'." :type 'boolean :group 'mail-abbrev) @@ -179,8 +176,7 @@ no aliases, which is represented by this being a table with no entries.)") (nth 5 (file-attributes mail-personal-alias-file))) (build-mail-abbrevs))) (mail-abbrevs-sync-aliases) - (add-hook 'pre-abbrev-expand-hook 'sendmail-pre-abbrev-expand-hook - nil t) + (add-hook 'abbrev-expand-functions 'mail-abbrev-expand-wrapper nil t) (abbrev-mode 1)) (defun mail-abbrevs-enable () @@ -201,64 +197,56 @@ By default this is the file specified by `mail-personal-alias-file'." (setq mail-abbrevs nil) (define-abbrev-table 'mail-abbrevs '())) (message "Parsing %s..." file) - (let ((buffer nil) - (obuf (current-buffer))) - (unwind-protect - (progn - (setq buffer (generate-new-buffer " mailrc")) - (buffer-disable-undo buffer) - (set-buffer buffer) - (cond ((get-file-buffer file) - (insert (save-excursion - (set-buffer (get-file-buffer file)) - (buffer-substring (point-min) (point-max))))) - ((not (file-exists-p file))) - (t (insert-file-contents file))) - ;; Don't lose if no final newline. - (goto-char (point-max)) - (or (eq (preceding-char) ?\n) (newline)) - (goto-char (point-min)) - ;; Delete comments from the file - (while (search-forward "# " nil t) - (let ((p (- (point) 2))) - (end-of-line) - (delete-region p (point)))) - (goto-char (point-min)) - ;; handle "\\\n" continuation lines - (while (not (eobp)) - (end-of-line) - (if (= (preceding-char) ?\\) - (progn (delete-char -1) (delete-char 1) (insert ?\ )) - (forward-char 1))) - (goto-char (point-min)) - (while (re-search-forward - "^\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+" nil t) - (beginning-of-line) - (if (looking-at "source[ \t]+\\([^ \t\n]+\\)") - (progn - (end-of-line) - (build-mail-abbrevs - (substitute-in-file-name - (buffer-substring (match-beginning 1) (match-end 1))) - t)) - (re-search-forward "[ \t]+\\([^ \t\n]+\\)") - (let* ((name (buffer-substring - (match-beginning 1) (match-end 1))) - (start (progn (skip-chars-forward " \t") (point)))) - (end-of-line) -; (message "** %s \"%s\"" name (buffer-substring start (point)))(sit-for 1) - (define-mail-abbrev - name - (buffer-substring start (point)) - t)))) - ;; Resolve forward references in .mailrc file. - ;; This would happen automatically before the first abbrev was - ;; expanded, but why not do it now. - (or recursivep (mail-resolve-all-aliases)) - mail-abbrevs) - (if buffer (kill-buffer buffer)) - (set-buffer obuf))) - (message "Parsing %s... done" file)) + (with-temp-buffer + (buffer-disable-undo) + (cond ((get-file-buffer file) + (insert (with-current-buffer (get-file-buffer file) + (buffer-substring (point-min) (point-max))))) + ((not (file-exists-p file))) + (t (insert-file-contents file))) + ;; Don't lose if no final newline. + (goto-char (point-max)) + (or (eq (preceding-char) ?\n) (newline)) + (goto-char (point-min)) + ;; Delete comments from the file + (while (search-forward "# " nil t) + (let ((p (- (point) 2))) + (end-of-line) + (delete-region p (point)))) + (goto-char (point-min)) + ;; handle "\\\n" continuation lines + (while (not (eobp)) + (end-of-line) + (if (= (preceding-char) ?\\) + (progn (delete-char -1) (delete-char 1) (insert ?\ )) + (forward-char 1))) + (goto-char (point-min)) + (while (re-search-forward + "^\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+" nil t) + (beginning-of-line) + (if (looking-at "source[ \t]+\\([^ \t\n]+\\)") + (progn + (end-of-line) + (build-mail-abbrevs + (substitute-in-file-name + (buffer-substring (match-beginning 1) (match-end 1))) + t)) + (re-search-forward "[ \t]+\\([^ \t\n]+\\)") + (let* ((name (buffer-substring + (match-beginning 1) (match-end 1))) + (start (progn (skip-chars-forward " \t") (point)))) + (end-of-line) + ;; (message "** %s \"%s\"" name (buffer-substring start (point)))(sit-for 1) + (define-mail-abbrev + name + (buffer-substring start (point)) + t)))) + ;; Resolve forward references in .mailrc file. + ;; This would happen automatically before the first abbrev was + ;; expanded, but why not do it now. + (or recursivep (mail-resolve-all-aliases)) + mail-abbrevs) + (message "Parsing %s... done" file)) (defvar mail-alias-separator-string ", " "*A string inserted between addresses in multi-address mail aliases. @@ -280,12 +268,7 @@ If DEFINITION contains multiple addresses, separate them with commas." ;; true, and we do some evil space->comma hacking like /bin/mail does. (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ") ;; Read the defaults first, if we have not done so. - (if (vectorp mail-abbrevs) - nil - (setq mail-abbrevs nil) - (define-abbrev-table 'mail-abbrevs '()) - (if (file-exists-p mail-personal-alias-file) - (build-mail-abbrevs))) + (unless (vectorp mail-abbrevs) (build-mail-abbrevs)) ;; strip garbage from front and end (if (string-match "\\`[ \t\n,]+" definition) (setq definition (substring definition (match-end 0)))) @@ -454,72 +437,58 @@ of a mail alias. The value is set up, buffer-local, when first needed.") (rfc822-goto-eoh) (point))))))) -(defun sendmail-pre-abbrev-expand-hook () - (and (and mail-abbrevs (not (eq mail-abbrevs t))) - (if (mail-abbrev-in-expansion-header-p) - - ;; We are in a To: (or CC:, or whatever) header, and - ;; should use word-abbrevs to expand mail aliases. - (let ((local-abbrev-table mail-abbrevs) - (old-syntax-table (syntax-table))) - - ;; Before anything else, resolve aliases if they need it. - (and mail-abbrev-aliases-need-to-be-resolved - (mail-resolve-all-aliases)) - - ;; Now proceed with the abbrev section. - ;; - We already installed mail-abbrevs as the abbrev table. - ;; - Then install the mail-abbrev-syntax-table, which - ;; temporarily marks all of the - ;; non-alphanumeric-atom-characters (the "_" - ;; syntax ones) as being normal word-syntax. We do this - ;; because the C code for expand-abbrev only works on words, - ;; and we want these characters to be considered words for - ;; the purpose of abbrev expansion. - ;; - Then we call expand-abbrev again, recursively, to do - ;; the abbrev expansion with the above syntax table. - ;; - Restore the previous syntax table. - ;; - Then we do a trick which tells the expand-abbrev frame - ;; which invoked us to not continue (and thus not - ;; expand twice.) This means that any abbrev expansion - ;; will happen as a result of this function's call to - ;; expand-abbrev, and not as a result of the call to - ;; expand-abbrev which invoked *us*. - - (mail-abbrev-make-syntax-table) - - ;; If the character just typed was non-alpha-symbol-syntax, - ;; then don't expand the abbrev now (that is, don't expand - ;; when the user types -.) Check the character's syntax in - ;; the usual syntax table. - - (or (and (integerp last-command-char) - ;; Some commands such as M-> may want to expand first. - (equal this-command 'self-insert-command) - (or (eq (char-syntax last-command-char) ?_) - ;; Don't expand on @. - (memq last-command-char '(?@ ?. ?% ?! ?_ ?-)))) - (let ((pre-abbrev-expand-hook nil)) ; That's us; don't loop. - ;; Use this table so that abbrevs can have hyphens in them. - (set-syntax-table mail-abbrev-syntax-table) - (unwind-protect - (expand-abbrev) - ;; Now set it back to what it was before. - (set-syntax-table old-syntax-table)))) - (setq abbrev-start-location (point-max) ; This is the trick. - abbrev-start-location-buffer (current-buffer))) - - (if (or (not mail-abbrevs-only) - (eq this-command 'expand-abbrev)) - ;; We're not in a mail header where mail aliases should - ;; be expanded, then use the normal mail-mode abbrev table - ;; (if any) and the normal mail-mode syntax table. - nil - ;; This is not a mail abbrev, and we should not expand it. - ;; This kludge stops expand-abbrev from doing anything. - (setq abbrev-start-location (point-max) - abbrev-start-location-buffer (current-buffer)))) - )) +(defun mail-abbrev-expand-wrapper (expand) + (if (and mail-abbrevs (not (eq mail-abbrevs t))) + (if (mail-abbrev-in-expansion-header-p) + + ;; We are in a To: (or CC:, or whatever) header, and + ;; should use word-abbrevs to expand mail aliases. + (let ((local-abbrev-table mail-abbrevs)) + + ;; Before anything else, resolve aliases if they need it. + (and mail-abbrev-aliases-need-to-be-resolved + (mail-resolve-all-aliases)) + + ;; Now proceed with the abbrev section. + ;; - We already installed mail-abbrevs as the abbrev table. + ;; - Then install the mail-abbrev-syntax-table, which + ;; temporarily marks all of the + ;; non-alphanumeric-atom-characters (the "_" + ;; syntax ones) as being normal word-syntax. We do this + ;; because the C code for expand-abbrev only works on words, + ;; and we want these characters to be considered words for + ;; the purpose of abbrev expansion. + ;; - Then we call the expand function, to do + ;; the abbrev expansion with the above syntax table. + + (mail-abbrev-make-syntax-table) + + ;; If the character just typed was non-alpha-symbol-syntax, + ;; then don't expand the abbrev now (that is, don't expand + ;; when the user types -.) Check the character's syntax in + ;; the usual syntax table. + + (or (and (integerp last-command-char) + ;; Some commands such as M-> may want to expand first. + (equal this-command 'self-insert-command) + (or (eq (char-syntax last-command-char) ?_) + ;; Don't expand on @. + (memq last-command-char '(?@ ?. ?% ?! ?_ ?-)))) + ;; Use this table so that abbrevs can have hyphens in them. + (with-syntax-table mail-abbrev-syntax-table + (funcall expand)))) + + (if (or (not mail-abbrevs-only) + (eq this-command 'expand-abbrev)) + ;; We're not in a mail header where mail aliases should + ;; be expanded, then use the normal mail-mode abbrev table + ;; (if any) and the normal mail-mode syntax table. + (funcall expand) + ;; This is not a mail abbrev, and we should not expand it. + ;; Don't expand anything. + nil)) + ;; No mail-abbrevs at all, do the normal thing. + (funcall expand))) ;;; utilities @@ -568,14 +537,11 @@ of a mail alias. The value is set up, buffer-local, when first needed.") (interactive) (mail-abbrev-make-syntax-table) (let* ((end (point)) - (syntax-table (syntax-table)) - (beg (unwind-protect - (save-excursion - (set-syntax-table mail-abbrev-syntax-table) - (backward-word 1) - (point)) - (set-syntax-table syntax-table))) - (alias (buffer-substring beg end)) + (beg (with-syntax-table mail-abbrev-syntax-table + (save-excursion + (backward-word 1) + (point)))) + (alias (buffer-substring beg end)) (completion (try-completion alias mail-abbrevs))) (cond ((eq completion t) (message "%s" alias)) ; confirm @@ -612,7 +578,7 @@ and more reliable (no dependence on goal column, etc.)." (interactive "p") (if (looking-at "[ \t]*\n") (expand-abbrev)) (setq this-command 'next-line) - (next-line arg)) + (with-no-warnings (next-line arg))) (defun mail-abbrev-end-of-buffer (&optional arg) "Expand any mail abbrev, then move point to end of buffer. @@ -638,8 +604,5 @@ Don't use this command in Lisp programs! (provide 'mailabbrev) -(if mail-abbrevs-mode - (mail-abbrevs-enable)) - -;;; arch-tag: 5aa2d901-73f8-4ad7-b73c-4802282ad2ff +;; arch-tag: 5aa2d901-73f8-4ad7-b73c-4802282ad2ff ;;; mailabbrev.el ends here diff --git a/lisp/msb.el b/lisp/msb.el index 11c9cfc4d37..cc5a0adcded 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -190,9 +190,6 @@ 3099 "Other files (%d)"))) -;; msb--many-menus is obsolete -(defvar msb--many-menus msb--very-many-menus) - ;;; ;;; Customizable variables ;;; @@ -235,12 +232,12 @@ A value of nil means don't display this menu. MENU-TITLE is really a format. If you add %d in it, the %d is replaced with the number of items in that menu. -ITEM-HANDLING-FN, is optional. If it is supplied and is a function, -than it is used for displaying the items in that particular buffer +ITEM-HANDLING-FN is optional. If it is supplied and is a function, +then it is used for displaying the items in that particular buffer menu, otherwise the function pointed out by `msb-item-handling-function' is used. -ITEM-SORT-FN, is also optional. +ITEM-SORT-FN is also optional. If it is not supplied, the function pointed out by `msb-item-sort-function' is used. If it is nil, then no sort takes place and the buffers are presented @@ -282,7 +279,7 @@ that differs by this value or more." (defcustom msb-max-menu-items 15 "*The maximum number of items in a menu. If this variable is set to 15 for instance, then the submenu will be -split up in minor parts, 15 items each. nil means no limit." +split up in minor parts, 15 items each. A value of nil means no limit." :type '(choice integer (const nil)) :set 'msb-custom-set :group 'msb) @@ -336,7 +333,7 @@ names that starts with a space character." "*The appearance of a buffer menu. The default function to call for handling the appearance of a menu -item. It should take to arguments, BUFFER and MAX-BUFFER-NAME-LENGTH, +item. It should take two arguments, BUFFER and MAX-BUFFER-NAME-LENGTH, where the latter is the max length of all buffer names. The function should return the string to use in the menu. @@ -664,7 +661,7 @@ If the argument is left out or nil, then the current buffer is considered." (defun msb--create-function-info (menu-cond-elt) "Create a vector from an element MENU-COND-ELT of `msb-menu-cond'. This takes the form: -\]BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER) +\[BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER] See `msb-menu-cond' for a description of its elements." (let* ((list-symbol (make-symbol "-msb-buffer-list")) (tmp-ih (and (> (length menu-cond-elt) 3) @@ -727,7 +724,7 @@ See `msb-menu-cond' for a description of its elements." (defun msb--add-to-menu (buffer function-info max-buffer-name-length) "Add BUFFER to the menu depicted by FUNCTION-INFO. All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER) -to the buffer-list variable in function-info." +to the buffer-list variable in FUNCTION-INFO." (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE ;; Here comes the hairy side-effect! (set list-symbol @@ -955,13 +952,13 @@ It takes the form ((TITLE . BUFFER-LIST)...)." "*Files by directory*") 'msb--toggle-menu-type))))))) -(defun msb--create-buffer-menu () +(defun msb--create-buffer-menu () (save-match-data (save-excursion (msb--create-buffer-menu-2)))) (defun msb--toggle-menu-type () - "Multi purpose function for selecting a buffer with the mouse." + "Multi-purpose function for selecting a buffer with the mouse." (interactive) (setq msb-files-by-directory (not msb-files-by-directory)) ;; This gets a warning, but it is correct, @@ -1104,7 +1101,7 @@ variable `msb-menu-cond'." (f-title (format "Frames (%d)" frame-length))) ;; List only the N most recently selected frames (when (and (integerp msb-max-menu-items) - (> msb-max-menu-items 1) + (> msb-max-menu-items 1) (> frame-length msb-max-menu-items)) (setcdr (nthcdr msb-max-menu-items frames) nil)) (setq frames-menu @@ -1149,9 +1146,11 @@ different buffer menu using the function `msb'." (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers) (menu-bar-update-buffers t))) -(defun msb-unload-hook () - (msb-mode 0)) -(add-hook 'msb-unload-hook 'msb-unload-hook) +(defun msb-unload-function () + "Unload the Msb library." + (msb-mode -1) + ;; continue standard unloading + nil) (provide 'msb) (eval-after-load "msb" '(run-hooks 'msb-after-load-hook 'msb-after-load-hooks)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index c2a0442478c..523588ec7c2 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -46,7 +46,7 @@ ;; browse-url-cci XMosaic 2.5 ;; browse-url-w3 w3 0 ;; browse-url-w3-gnudoit w3 remotely -;; browse-url-lynx-* Lynx 0 +;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary ;; browse-url-default-windows-browser MS-Windows browser ;; browse-url-default-macosx-browser Mac OS X browser @@ -246,10 +246,10 @@ regexp should probably be \".\" to specify a default browser." (function-item :tag "Netscape" :value browse-url-netscape) (function-item :tag "Mosaic" :value browse-url-mosaic) (function-item :tag "Mosaic using CCI" :value browse-url-cci) - (function-item :tag "Lynx in an xterm window" - :value browse-url-lynx-xterm) - (function-item :tag "Lynx in an Emacs window" - :value browse-url-lynx-emacs) + (function-item :tag "Text browser in an xterm window" + :value browse-url-text-xterm) + (function-item :tag "Text browser in an Emacs window" + :value browse-url-text-emacs) (function-item :tag "KDE" :value browse-url-kde) (function-item :tag "Elinks" :value browse-url-elinks) (function-item :tag "Specified by `Browse Url Generic Program'" @@ -502,9 +502,9 @@ enabled. The port number should be set in `browse-url-CCI-port'." (defvar browse-url-temp-file-name nil) (make-variable-buffer-local 'browse-url-temp-file-name) - + (defcustom browse-url-xterm-program "xterm" - "The name of the terminal emulator used by `browse-url-lynx-xterm'. + "The name of the terminal emulator used by `browse-url-text-xterm'. This might, for instance, be a separate color version of xterm." :type 'string :group 'browse-url) @@ -515,17 +515,6 @@ These might set its size, for instance." :type '(repeat (string :tag "Argument")) :group 'browse-url) -(defcustom browse-url-lynx-emacs-args (and (not window-system) - '("-show_cursor")) - "A list of strings defining options for Lynx in an Emacs buffer. - -The default is none in a window system, otherwise `-show_cursor' to -indicate the position of the current link in the absence of -highlighting, assuming the normal default for showing the cursor." - :type '(repeat (string :tag "Argument")) - :version "20.3" - :group 'browse-url) - (defcustom browse-url-gnudoit-program "gnudoit" "The name of the `gnudoit' program used by `browse-url-w3-gnudoit'." :type 'string @@ -562,28 +551,47 @@ incompatibly at version 4." :type 'number :group 'browse-url) -(defcustom browse-url-lynx-input-field 'avoid - "Action on selecting an existing Lynx buffer at an input field. -What to do when sending a new URL to an existing Lynx buffer in Emacs -if the Lynx cursor is on an input field (in which case the `g' command +(defcustom browse-url-text-browser "lynx" + "The name of the text browser to invoke." + :type 'string + :group 'browse-url + :version "23.1") + +(defcustom browse-url-text-emacs-args (and (not window-system) + '("-show_cursor")) + "A list of strings defining options for a text browser in an Emacs buffer. + +The default is none in a window system, otherwise `-show_cursor' to +indicate the position of the current link in the absence of +highlighting, assuming the normal default for showing the cursor." + :type '(repeat (string :tag "Argument")) + :version "23.1" + :group 'browse-url) + +(defcustom browse-url-text-input-field 'avoid + "Action on selecting an existing text browser buffer at an input field. +What to do when sending a new URL to an existing text browser buffer in Emacs +if the browser cursor is on an input field (in which case the `g' command would be entered as data). Such fields are recognized by the -underlines ____. Allowed values: nil: disregard it, 'warn: warn the -user and don't emit the URL, 'avoid: try to avoid the field by moving +underlines ____. Allowed values: nil: disregard it, `warn': warn the +user and don't emit the URL, `avoid': try to avoid the field by moving down (this *won't* always work)." :type '(choice (const :tag "Move to try to avoid field" :value avoid) (const :tag "Disregard" :value nil) (const :tag "Warn, don't emit URL" :value warn)) - :version "20.3" + :version "23.1" :group 'browse-url) -(defcustom browse-url-lynx-input-attempts 10 - "How many times to try to move down from a series of lynx input fields." +(defcustom browse-url-text-input-attempts 10 + "How many times to try to move down from a series of text browser input fields." :type 'integer + :version "23.1" :group 'browse-url) -(defcustom browse-url-lynx-input-delay 0.2 - "How many seconds to wait for lynx between moves down from an input field." +(defcustom browse-url-text-input-delay 0.2 + "Seconds to wait for a text browser between moves down from an input field." :type 'number + :version "23.1" :group 'browse-url) (defcustom browse-url-kde-program "kfmclient" @@ -876,7 +884,7 @@ Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3." ((executable-find browse-url-kde-program) 'browse-url-kde) ((executable-find browse-url-netscape-program) 'browse-url-netscape) ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) - ((executable-find browse-url-xterm-program) 'browse-url-lynx-xterm) + ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t (lambda (&ignore args) (error "No usable browser found")))) @@ -1308,38 +1316,41 @@ The `browse-url-gnudoit-program' program is used with options given by ;; --- Lynx in an xterm --- ;;;###autoload -(defun browse-url-lynx-xterm (url &optional new-window) +(defun browse-url-text-xterm (url &optional new-window) ;; new-window ignored - "Ask the Lynx WWW browser to load URL. -Default to the URL around or before point. A new Lynx process is run + "Ask a text browser to load URL. +URL defaults to the URL around or before point. +This runs the text browser specified by `browse-url-text-browser'. in an Xterm window using the Xterm program named by `browse-url-xterm-program' with possible additional arguments `browse-url-xterm-args'." - (interactive (browse-url-interactive-arg "Lynx URL: ")) - (apply #'start-process `(,(concat "lynx" url) nil ,browse-url-xterm-program - ,@browse-url-xterm-args "-e" "lynx" + (interactive (browse-url-interactive-arg "Text browser URL: ")) + (apply #'start-process `(,(concat browse-url-text-browser url) + nil ,browse-url-xterm-program + ,@browse-url-xterm-args "-e" browse-url-text-browser ,url))) ;; --- Lynx in an Emacs "term" window --- ;;;###autoload -(defun browse-url-lynx-emacs (url &optional new-buffer) - "Ask the Lynx WWW browser to load URL. -Default to the URL around or before point. With a prefix argument, run -a new Lynx process in a new buffer. +(defun browse-url-text-emacs (url &optional new-buffer) + "Ask a text browser to load URL. +URL defaults to the URL around or before point. +This runs the text browser specified by `browse-url-text-browser'. +With a prefix argument, it runs a new browser process in a new buffer. When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new lynx in a new term window, +non-nil, load the document in a new browser process in a new term window, otherwise use any existing one. A non-nil interactive prefix argument reverses the effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." - (interactive (browse-url-interactive-arg "Lynx URL: ")) + (interactive (browse-url-interactive-arg "Text browser URL: ")) (let* ((system-uses-terminfo t) ; Lynx uses terminfo ;; (term-term-name "vt100") ; ?? - (buf (get-buffer "*lynx*")) + (buf (get-buffer "*text browser*")) (proc (and buf (get-buffer-process buf))) - (n browse-url-lynx-input-attempts)) + (n browse-url-text-input-attempts)) (if (and (browse-url-maybe-new-window new-buffer) buf) ;; Rename away the OLD buffer. This isn't very polite, but ;; term insists on working in a buffer named *lynx* and would @@ -1350,11 +1361,13 @@ used instead of `browse-url-new-window-flag'." (not buf) (not proc) (not (memq (process-status proc) '(run stop)))) - ;; start a new lynx + ;; start a new text browser (progn (setq buf (apply #'make-term - `("lynx" "lynx" nil ,@browse-url-lynx-emacs-args + `(,browse-url-text-browser + ,browse-url-text-browser + nil ,@browse-url-text-emacs-args ,url))) (switch-to-buffer buf) (term-char-mode) @@ -1366,18 +1379,18 @@ used instead of `browse-url-new-window-flag'." (if (not (memq (process-status process) '(run stop))) (let ((buf (process-buffer process))) (if buf (kill-buffer buf))))))) - ;; send the url to lynx in the old buffer + ;; Send the url to the text browser in the old buffer (let ((win (get-buffer-window buf t))) (if win (select-window win) (switch-to-buffer buf))) (if (eq (following-char) ?_) - (cond ((eq browse-url-lynx-input-field 'warn) + (cond ((eq browse-url-text-input-field 'warn) (error "Please move out of the input field first")) - ((eq browse-url-lynx-input-field 'avoid) + ((eq browse-url-text-input-field 'avoid) (while (and (eq (following-char) ?_) (> n 0)) (term-send-down) ; down arrow - (sit-for browse-url-lynx-input-delay)) + (sit-for browse-url-text-input-delay)) (if (eq (following-char) ?_) (error "Cannot move out of the input field, sorry"))))) (term-send-string proc (concat "g" ; goto diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index 1b52090abf6..8c4b0a08f51 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -32,27 +32,45 @@ ;;; Code: ;;; -;;; .netrc and .authinforc parsing +;;; .netrc and .authinfo rc parsing ;;; (defalias 'netrc-point-at-eol (if (fboundp 'point-at-eol) 'point-at-eol 'line-end-position)) +;; autoload encrypt + +(eval-and-compile + (autoload 'encrypt-find-model "encrypt") + (autoload 'encrypt-insert-file-contents "encrypt")) + +(defgroup netrc nil + "Netrc configuration." + :group 'comm) + +(defvar netrc-services-file "/etc/services" + "The name of the services file.") (defun netrc-parse (file) - "Parse FILE and return a list of all entries in the file." + (interactive "fFile to Parse: ") + "Parse FILE and return an list of all entries in the file." (when (file-exists-p file) (with-temp-buffer (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force" "port")) + (encryption-model (encrypt-find-model file)) alist elem result pair) - (insert-file-contents file) + + (if encryption-model + (encrypt-insert-file-contents file encryption-model) + (insert-file-contents file)) + (goto-char (point-min)) ;; Go through the file, line by line. (while (not (eobp)) - (narrow-to-region (point) (netrc-point-at-eol)) + (narrow-to-region (point) (point-at-eol)) ;; For each line, get the tokens and values. (while (not (eobp)) (skip-chars-forward "\t ") @@ -113,16 +131,79 @@ Entries without port tokens default to DEFAULTPORT." (when result (setq result (nreverse result)) (while (and result - (not (equal (or port defaultport "nntp") - (or (netrc-get (car result) "port") - defaultport "nntp")))) + (not (netrc-port-equal + (or port defaultport "nntp") + (or (netrc-get (car result) "port") + defaultport "nntp")))) (pop result)) (car result)))) +(defun netrc-machine-user-or-password (mode authinfo-file-or-list machines ports defaults) + "Get the user name or password according to MODE from AUTHINFO-FILE-OR-LIST. +Matches a machine from MACHINES and a port from PORTS, giving +default ports DEFAULTS to `netrc-machine'. + +MODE can be \"login\" or \"password\", suitable for passing to +`netrc-get'." + (let ((authinfo-list (if (stringp authinfo-file-or-list) + (netrc-parse authinfo-file-or-list) + authinfo-file-or-list)) + (ports (or ports '(nil))) + (defaults (or defaults '(nil))) + info) + (dolist (machine machines) + (dolist (default defaults) + (dolist (port ports) + (let ((alist (netrc-machine authinfo-list machine port default))) + (setq info (or (netrc-get alist mode) info)))))) + info)) + (defun netrc-get (alist type) "Return the value of token TYPE from ALIST." (cdr (assoc type alist))) +(defun netrc-port-equal (port1 port2) + (when (numberp port1) + (setq port1 (or (netrc-find-service-name port1) port1))) + (when (numberp port2) + (setq port2 (or (netrc-find-service-name port2) port2))) + (equal port1 port2)) + +(defun netrc-parse-services () + (when (file-exists-p netrc-services-file) + (let ((services nil)) + (with-temp-buffer + (insert-file-contents netrc-services-file) + (while (search-forward "#" nil t) + (delete-region (1- (point)) (point-at-eol))) + (goto-char (point-min)) + (while (re-search-forward + "^ *\\([^ \n\t]+\\)[ \t]+\\([0-9]+\\)/\\([^ \t\n]+\\)" nil t) + (push (list (match-string 1) (string-to-number (match-string 2)) + (intern (downcase (match-string 3)))) + services)) + (nreverse services))))) + +(defun netrc-find-service-name (number &optional type) + (let ((services (netrc-parse-services)) + service) + (setq type (or type 'tcp)) + (while (and (setq service (pop services)) + (not (and (= number (cadr service)) + (eq type (caddr service))))) + ) + (car service))) + +(defun netrc-find-service-number (name &optional type) + (let ((services (netrc-parse-services)) + service) + (setq type (or type 'tcp)) + (while (and (setq service (pop services)) + (not (and (string= name (car service)) + (eq type (caddr service))))) + ) + (cadr service))) + (provide 'netrc) ;;; arch-tag: af9929cc-2d12-482f-936e-eb4366f9fa55 diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el index eb70a2e2d31..735d946346d 100644 --- a/lisp/net/newsticker.el +++ b/lisp/net/newsticker.el @@ -1199,10 +1199,11 @@ buffers *newsticker-wget-<feed>* will not be closed." (unless (fboundp 'match-string-no-properties) (defalias 'match-string-no-properties 'match-string)) -(unless (fboundp 'replace-regexp-in-string) - (defun replace-regexp-in-string (re rp st) - (save-match-data ;; apparently XEmacs needs save-match-data - (replace-in-string st re rp)))) +(when (featurep 'xemacs) + (unless (fboundp 'replace-regexp-in-string) + (defun replace-regexp-in-string (re rp st) + (save-match-data ;; apparently XEmacs needs save-match-data + (replace-in-string st re rp))))) ;; copied from subr.el (unless (fboundp 'add-to-invisibility-spec) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index b2ad08d7ccd..ef24de44e50 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -93,11 +93,11 @@ VALUE must be a list of strings describing which channels to join when connecting to this server. If absent, no channels will be connected to automatically." :type '(alist :key-type string - :value-type (plist :options ((nick string) - (port integer) - (user-name string) - (full-name string) - (channels (repeat string))))) + :value-type (plist :options ((:nick string) + (:port integer) + (:user-name string) + (:full-name string) + (:channels (repeat string))))) :group 'rcirc) (defcustom rcirc-default-port 6667 @@ -323,6 +323,9 @@ and the cdr part is used for encoding." (defvar rcirc-nick-table nil) +(defvar rcirc-recent-quit-alist nil + "Alist of nicks that have recently quit or parted the channel.") + (defvar rcirc-nick-syntax-table (let ((table (make-syntax-table text-mode-syntax-table))) (mapc (lambda (c) (modify-syntax-entry c "w" table)) @@ -417,8 +420,11 @@ If ARG is non-nil, instead prompt for connection parameters." connected-servers)))))))) (when connected-servers (message "Already connected to %s" - (concat (mapconcat 'identity (butlast connected-servers) ", ") - ", and " (car (last connected-servers)))))))) + (if (cdr connected-servers) + (concat (mapconcat 'identity (butlast connected-servers) ", ") + ", and " + (car (last connected-servers))) + (car connected-servers))))))) ;;;###autoload (defalias 'irc 'rcirc) @@ -763,7 +769,6 @@ If SILENT is non-nil, do not print the message in any irc buffer." rcirc-target)))))) (let ((completion (car rcirc-nick-completions))) (when completion - (rcirc-put-nick-channel (rcirc-buffer-process) completion rcirc-target) (delete-region (+ rcirc-prompt-end-marker rcirc-nick-completion-start-offset) (point)) @@ -799,6 +804,7 @@ If SILENT is non-nil, do not print the message in any irc buffer." (define-key rcirc-mode-map (kbd "C-c C-m") 'rcirc-cmd-msg) (define-key rcirc-mode-map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename (define-key rcirc-mode-map (kbd "C-c C-o") 'rcirc-omit-mode) +(define-key rcirc-mode-map (kbd "M-o") 'rcirc-omit-mode) (define-key rcirc-mode-map (kbd "C-c C-p") 'rcirc-cmd-part) (define-key rcirc-mode-map (kbd "C-c C-q") 'rcirc-cmd-query) (define-key rcirc-mode-map (kbd "C-c C-t") 'rcirc-cmd-topic) @@ -828,6 +834,10 @@ If SILENT is non-nil, do not print the message in any irc buffer." "Alist of lines to log to disk when `rcirc-log-flag' is non-nil. Each element looks like (FILENAME . TEXT).") +(defvar rcirc-current-line 0 + "The current number of responses printed in this channel. +This number is independent of the number of lines in the buffer.") + (defun rcirc-mode (process target) "Major mode for IRC channel buffers. @@ -850,12 +860,24 @@ Each element looks like (FILENAME . TEXT).") (setq rcirc-last-post-time (current-time)) (make-local-variable 'fill-paragraph-function) (setq fill-paragraph-function 'rcirc-fill-paragraph) + (make-local-variable 'rcirc-recent-quit-alist) + (setq rcirc-recent-quit-alist nil) + (make-local-variable 'rcirc-current-line) + (setq rcirc-current-line 0) (make-local-variable 'rcirc-short-buffer-name) (setq rcirc-short-buffer-name nil) (make-local-variable 'rcirc-urls) (setq use-hard-newlines t) + ;; setup for omitting responses + (setq buffer-invisibility-spec '()) + (setq buffer-display-table (make-display-table)) + (set-display-table-slot buffer-display-table 4 + (let ((glyph (make-glyph-code + ?. 'font-lock-keyword-face))) + (make-vector 3 glyph))) + (make-local-variable 'rcirc-decode-coding-system) (make-local-variable 'rcirc-encode-coding-system) (dolist (i rcirc-coding-system-alist) @@ -879,8 +901,6 @@ Each element looks like (FILENAME . TEXT).") (setq overlay-arrow-position (make-marker)) (set-marker overlay-arrow-position nil) - (setq buffer-invisibility-spec '(rcirc-ignored-user)) - ;; if the user changes the major mode or kills the buffer, there is ;; cleanup work to do (add-hook 'change-major-mode-hook 'rcirc-change-major-mode-hook nil t) @@ -1005,8 +1025,9 @@ Create the buffer if it doesn't exist." (let ((new-buffer (get-buffer-create (rcirc-generate-new-buffer-name process target)))) (with-current-buffer new-buffer - (rcirc-mode process target)) - (rcirc-put-nick-channel process (rcirc-nick process) target) + (rcirc-mode process target) + (rcirc-put-nick-channel process (rcirc-nick process) target + rcirc-current-line)) new-buffer))))) (defun rcirc-send-input () @@ -1090,7 +1111,8 @@ Create the buffer if it doesn't exist." (interactive) (let ((pos (1+ (- (point) rcirc-prompt-end-marker)))) (goto-char (point-max)) - (let ((text (buffer-substring rcirc-prompt-end-marker (point))) + (let ((text (buffer-substring-no-properties rcirc-prompt-end-marker + (point))) (parent (buffer-name))) (delete-region rcirc-prompt-end-marker (point)) (setq rcirc-window-configuration (current-window-configuration)) @@ -1187,7 +1209,7 @@ the of the following escape sequences replaced by the described values: :group 'rcirc) (defcustom rcirc-omit-responses - '("JOIN" "PART" "QUIT") + '("JOIN" "PART" "QUIT" "NICK") "Responses which will be hidden when `rcirc-omit-mode' is enabled." :type '(repeat string) :group 'rcirc) @@ -1281,19 +1303,50 @@ Logfiles are kept in `rcirc-log-directory'." :type 'boolean :group 'rcirc) +(defcustom rcirc-omit-threshold 100 + "Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted." + :type 'integer + :group 'rcirc) + +(defun rcirc-last-quit-line (process nick target) + "Return the line number where NICK left TARGET. +Returns nil if the information is not recorded." + (let ((chanbuf (rcirc-get-buffer process target))) + (when chanbuf + (cdr (assoc-string nick (with-current-buffer chanbuf + rcirc-recent-quit-alist)))))) + +(defun rcirc-last-line (process nick target) + "Return the line from the last activity from NICK in TARGET." + (let* ((chanbuf (rcirc-get-buffer process target)) + (line (or (cdr (assoc-string target + (gethash nick (with-rcirc-server-buffer + rcirc-nick-table)) t)) + (rcirc-last-quit-line process nick target)))) + (if line + line + ;;(message "line is nil for %s in %s" nick target) + nil))) + +(defun rcirc-elapsed-lines (process nick target) + "Return the number of lines since activity from NICK in TARGET." + (let ((last-activity-line (rcirc-last-line process nick target))) + (when (and last-activity-line + (> last-activity-line 0)) + (- rcirc-current-line last-activity-line)))) + (defvar rcirc-markup-text-functions '(rcirc-markup-attributes rcirc-markup-my-nick rcirc-markup-urls rcirc-markup-keywords - rcirc-markup-bright-nicks - rcirc-markup-fill) + rcirc-markup-bright-nicks) "List of functions used to manipulate text before it is printed. -Each function takes two arguments, SENDER, RESPONSE. The buffer -is narrowed with the text to be printed and the point is at the -beginning of the `rcirc-text' propertized text.") +Each function takes two arguments, SENDER, and RESPONSE. The +buffer is narrowed with the text to be printed and the point is +at the beginning of the `rcirc-text' propertized text.") (defun rcirc-print (process sender response target text &optional activity) "Print TEXT in the buffer associated with TARGET. @@ -1305,7 +1358,8 @@ record activity." (when (string-match "^\\([^/]\\w*\\)[:,]" text) (match-string 1 text))) rcirc-ignore-list)) - (not (string= sender (rcirc-nick process)))) + ;; do not ignore if we sent the message + (not (string= sender (rcirc-nick process)))) (let* ((buffer (rcirc-target-buffer process sender response target text)) (inhibit-read-only t)) (with-current-buffer buffer @@ -1350,16 +1404,22 @@ record activity." (save-excursion (rcirc-markup-timestamp sender response)) (dolist (fn rcirc-markup-text-functions) (save-excursion (funcall fn sender response))) - (save-excursion (rcirc-markup-fill sender response))) + (when rcirc-fill-flag + (save-excursion (rcirc-markup-fill sender response)))) (when rcirc-read-only-flag (add-text-properties (point-min) (point-max) '(read-only t front-sticky t)))) ;; make text omittable - (when (and (member response rcirc-omit-responses) - (> start (point-min))) - (put-text-property (1- start) (1- rcirc-prompt-start-marker) - 'invisible 'rcirc-omit)))) + (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) + (if (and (not (string= (rcirc-nick process) sender)) + (member response rcirc-omit-responses) + (or (not last-activity-lines) + (< rcirc-omit-threshold last-activity-lines))) + (put-text-property (1- start) (1- rcirc-prompt-start-marker) + 'invisible 'rcirc-omit) + ;; otherwise increment the line count + (setq rcirc-current-line (1+ rcirc-current-line)))))) (set-marker-insertion-type rcirc-prompt-start-marker nil) (set-marker-insertion-type rcirc-prompt-end-marker nil) @@ -1442,9 +1502,10 @@ Log data is written to `rcirc-log-directory'." (dolist (cell rcirc-log-alist) (with-temp-buffer (insert (cdr cell)) - (write-region (point-min) (point-max) - (concat rcirc-log-directory "/" (car cell)) - t 'quiet))) + (let ((coding-system-for-write 'utf-8)) + (write-region (point-min) (point-max) + (concat rcirc-log-directory "/" (car cell)) + t 'quiet)))) (setq rcirc-log-alist nil)) (defun rcirc-join-channels (process channels) @@ -1470,15 +1531,19 @@ Log data is written to `rcirc-log-directory'." (mapcar (lambda (x) (car x)) (gethash nick rcirc-nick-table)))) -(defun rcirc-put-nick-channel (process nick channel) - "Add CHANNEL to list associated with NICK." +(defun rcirc-put-nick-channel (process nick channel &optional line) + "Add CHANNEL to list associated with NICK. +Update the associated linestamp if LINE is non-nil. + +If the record doesn't exist, and LINE is nil, set the linestamp +to zero." (let ((nick (rcirc-user-nick nick))) (with-rcirc-process-buffer process (let* ((chans (gethash nick rcirc-nick-table)) (record (assoc-string channel chans t))) (if record - (setcdr record (current-time)) - (puthash nick (cons (cons channel (current-time)) + (when line (setcdr record line)) + (puthash nick (cons (cons channel (or line 0)) chans) rcirc-nick-table)))))) @@ -1514,7 +1579,10 @@ Log data is written to `rcirc-log-directory'." (setq nicks (cons (cons k (cdr record)) nicks))))) rcirc-nick-table) (mapcar (lambda (x) (car x)) - (sort nicks (lambda (x y) (time-less-p (cdr y) (cdr x))))))) + (sort nicks (lambda (x y) + (let ((lx (or (cdr x) 0)) + (ly (or (cdr y) 0))) + (< ly lx))))))) (list target)))) (defun rcirc-ignore-update-automatic (nick) @@ -1593,15 +1661,13 @@ Uninteresting lines are those whose responses are listed in `rcirc-omit-responses'." (interactive) (setq rcirc-omit-mode (not rcirc-omit-mode)) - (let ((line (1- (count-screen-lines (point) (window-start))))) - (if rcirc-omit-mode - (progn - (add-to-invisibility-spec 'rcirc-omit) - (message "Rcirc-Omit mode enabled")) - (remove-from-invisibility-spec 'rcirc-omit) - (message "Rcirc-Omit mode disabled")) - (recenter line)) - (force-mode-line-update)) + (if rcirc-omit-mode + (progn + (add-to-invisibility-spec '(rcirc-omit . t)) + (message "Rcirc-Omit mode enabled")) + (remove-from-invisibility-spec '(rcirc-omit . t)) + (message "Rcirc-Omit mode disabled")) + (recenter (when (> (point) rcirc-prompt-start-marker) -1))) (defun rcirc-switch-to-server-buffer () "Switch to the server buffer associated with current channel buffer." @@ -1636,7 +1702,10 @@ With prefix ARG, go to the next low priority buffer with activity." (hipri (cdr pair))) (if (or (and (not arg) hipri) (and arg lopri)) - (switch-to-buffer (car (if arg lopri hipri)) t) + (progn + (switch-to-buffer (car (if arg lopri hipri))) + (when (> (point) rcirc-prompt-start-marker) + (recenter -1))) (if (eq major-mode 'rcirc-mode) (switch-to-buffer (rcirc-non-irc-buffer)) (message (concat @@ -2169,11 +2238,13 @@ keywords when no KEYWORD is given." (let ((fill-prefix (or rcirc-fill-prefix (make-string (- (point) (line-beginning-position)) ?\s))) - (fill-column (cond ((eq rcirc-fill-column 'frame-width) - (1- (frame-width))) - (rcirc-fill-column - rcirc-fill-column) - (t fill-column)))) + (fill-column (- (cond ((eq rcirc-fill-column 'frame-width) + (1- (frame-width))) + (rcirc-fill-column + rcirc-fill-column) + (t fill-column)) + ;; make sure ... doesn't cause line wrapping + 3))) (fill-region (point) (point-max) nil t)))) ;;; handlers @@ -2183,7 +2254,6 @@ keywords when no KEYWORD is given." ;; verbatim (defun rcirc-handler-001 (process sender args text) (rcirc-handler-generic process "001" sender args text) - ;; set the real server name (with-rcirc-process-buffer process (setq rcirc-connecting nil) (rcirc-reschedule-timeout process) @@ -2201,9 +2271,9 @@ keywords when no KEYWORD is given." (if (string-match "^\C-a\\(.*\\)\C-a$" message) (rcirc-handler-CTCP process target sender (match-string 1 message)) (rcirc-print process sender "PRIVMSG" target message t)) - ;; update nick timestamp - (if (member target (rcirc-nick-channels process sender)) - (rcirc-put-nick-channel process sender target)))) + ;; update nick linestamp + (with-current-buffer (rcirc-get-buffer process target t) + (rcirc-put-nick-channel process sender target rcirc-current-line)))) (defun rcirc-handler-NOTICE (process sender args text) (let ((target (car args)) @@ -2228,21 +2298,29 @@ keywords when no KEYWORD is given." (defun rcirc-handler-JOIN (process sender args text) (let ((channel (car args))) - (rcirc-get-buffer-create process channel) + (with-current-buffer (rcirc-get-buffer-create process channel) + ;; when recently rejoining, restore the linestamp + (rcirc-put-nick-channel process sender channel + (let ((last-activity-lines + (rcirc-elapsed-lines process sender channel))) + (when (and last-activity-lines + (< last-activity-lines rcirc-omit-threshold)) + (rcirc-last-line process sender channel))))) + (rcirc-print process sender "JOIN" channel "") ;; print in private chat buffer if it exists (when (rcirc-get-buffer (rcirc-buffer-process) sender) - (rcirc-print process sender "JOIN" sender channel)) - - (rcirc-put-nick-channel process sender channel))) + (rcirc-print process sender "JOIN" sender channel)))) ;; PART and KICK are handled the same way (defun rcirc-handler-PART-or-KICK (process response channel sender nick args) (rcirc-ignore-update-automatic nick) (if (not (string= nick (rcirc-nick process))) ;; this is someone else leaving - (rcirc-remove-nick-channel process nick channel) + (progn + (rcirc-maybe-remember-nick-quit process nick channel) + (rcirc-remove-nick-channel process nick channel)) ;; this is us leaving (mapc (lambda (n) (rcirc-remove-nick-channel process n channel)) @@ -2276,16 +2354,30 @@ keywords when no KEYWORD is given." (rcirc-handler-PART-or-KICK process "KICK" channel sender nick reason))) +(defun rcirc-maybe-remember-nick-quit (process nick channel) + "Remember NICK as leaving CHANNEL if they recently spoke." + (let ((elapsed-lines (rcirc-elapsed-lines process nick channel))) + (when (and elapsed-lines + (< elapsed-lines rcirc-omit-threshold)) + (let ((buffer (rcirc-get-buffer process channel))) + (when buffer + (with-current-buffer buffer + (let ((record (assoc-string nick rcirc-recent-quit-alist t)) + (line (rcirc-last-line process nick channel))) + (if record + (setcdr record line) + (setq rcirc-recent-quit-alist + (cons (cons nick line) + rcirc-recent-quit-alist)))))))))) + (defun rcirc-handler-QUIT (process sender args text) (rcirc-ignore-update-automatic sender) (mapc (lambda (channel) - (rcirc-print process sender "QUIT" channel (apply 'concat args))) + ;; broadcast quit message each channel + (rcirc-print process sender "QUIT" channel (apply 'concat args)) + ;; record nick in quit table if they recently spoke + (rcirc-maybe-remember-nick-quit process sender channel)) (rcirc-nick-channels process sender)) - - ;; print in private chat buffer if it exists - (when (rcirc-get-buffer (rcirc-buffer-process) sender) - (rcirc-print process sender "QUIT" sender (apply 'concat args))) - (rcirc-nick-remove process sender)) (defun rcirc-handler-NICK (process sender args text) diff --git a/lisp/net/tls.el b/lisp/net/tls.el index 2e890a4a476..104cb991254 100644 --- a/lisp/net/tls.el +++ b/lisp/net/tls.el @@ -55,6 +55,29 @@ "Transport Layer Security (TLS) parameters." :group 'comm) +(defcustom tls-end-of-info + (concat + "\\(" + ;; `openssl s_client' regexp. See ssl/ssl_txt.c lines 219-220. + ;; According to apps/s_client.c line 1515 `---' is always the last + ;; line that is printed by s_client before the real data. + "^ Verify return code: .+\n---\n\\|" + ;; `gnutls' regexp. See src/cli.c lines 721-. + "^- Simple Client Mode:\n" + "\\(\n\\|" ; ignore blank lines + ;; According to GnuTLS v2.1.5 src/cli.c lines 640-650 and 705-715 + ;; in `main' the handshake will start after this message. If the + ;; handshake fails, the programs will abort. + "^\\*\\*\\* Starting TLS handshake\n\\)*" + "\\)") + "Regexp matching end of TLS client informational messages. +Client data stream begins after the last character matched by +this. The default matches `openssl s_client' (version 0.9.8c) +and `gnutls-cli' (version 2.0.1) output." + :version "22.2" + :type 'regexp + :group 'tls) + (defcustom tls-program '("gnutls-cli -p %p %h" "gnutls-cli -p %p %h --protocols ssl3" "openssl s_client -connect %h:%p -no_ssl2") @@ -130,35 +153,51 @@ Fourth arg PORT is an integer specifying a port to connect to." process cmd done) (if use-temp-buffer (setq buffer (generate-new-buffer " TLS"))) - (message "Opening TLS connection to `%s'..." host) - (while (and (not done) (setq cmd (pop cmds))) - (message "Opening TLS connection with `%s'..." cmd) - (let ((process-connection-type tls-process-connection-type) - response) - (setq process (start-process - name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?h host - ?p (if (integerp port) - (int-to-string port) - port))))) - (while (and process - (memq (process-status process) '(open run)) - (save-excursion - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - (not (setq done (re-search-forward tls-success nil t))))) - (unless (accept-process-output process 1) - (sit-for 1))) - (message "Opening TLS connection with `%s'...%s" cmd - (if done "done" "failed")) - (if done - (setq done process) - (delete-process process)))) - (message "Opening TLS connection to `%s'...%s" - host (if done "done" "failed")) + (with-current-buffer buffer + (message "Opening TLS connection to `%s'..." host) + (while (and (not done) (setq cmd (pop cmds))) + (message "Opening TLS connection with `%s'..." cmd) + (let ((process-connection-type tls-process-connection-type) + response) + (setq process (start-process + name buffer shell-file-name shell-command-switch + (format-spec + cmd + (format-spec-make + ?h host + ?p (if (integerp port) + (int-to-string port) + port))))) + (while (and process + (memq (process-status process) '(open run)) + (progn + (goto-char (point-min)) + (not (setq done (re-search-forward tls-success nil t))))) + (unless (accept-process-output process 1) + (sit-for 1))) + (message "Opening TLS connection with `%s'...%s" cmd + (if done "done" "failed")) + (if (not done) + (delete-process process) + ;; advance point to after all informational messages that + ;; `openssl s_client' and `gnutls' print + (let ((start-of-data nil)) + (while + (not (setq start-of-data + ;; the string matching `tls-end-of-info' + ;; might come in separate chunks from + ;; `accept-process-output', so start the + ;; search where `tls-success' ended + (save-excursion + (if (re-search-forward tls-end-of-info nil t) + (match-end 0))))) + (accept-process-output process 1)) + (if start-of-data + ;; move point to start of client data + (goto-char start-of-data))) + (setq done process)))) + (message "Opening TLS connection to `%s'...%s" + host (if done "done" "failed"))) (when use-temp-buffer (if done (set-process-buffer process nil)) (kill-buffer buffer)) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 35147e7907c..b28c20263f4 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -138,42 +138,29 @@ Remove also properties of all files in subdirectories." (remhash key tramp-cache-data))) tramp-cache-data))) -(defun tramp-cache-print (table) - "Prints hash table TABLE." - (when (hash-table-p table) - (let (result) - (maphash - '(lambda (key value) - (let ((tmp (format - "(%s %s)" - (if (processp key) - (prin1-to-string (prin1-to-string key)) - (prin1-to-string key)) - (if (hash-table-p value) - (tramp-cache-print value) - (if (bufferp value) - (prin1-to-string (prin1-to-string value)) - (prin1-to-string value)))))) - (setq result (if result (concat result " " tmp) tmp)))) - table) - result))) - ;; Reverting or killing a buffer should also flush file properties. -;; They could have been changed outside Tramp. +;; They could have been changed outside Tramp. In eshell, "ls" would +;; not show proper directory contents when a file has been copied or +;; deleted before. (defun tramp-flush-file-function () "Flush all Tramp cache properties from buffer-file-name." - (let ((bfn (buffer-file-name))) - (when (and (stringp bfn) (tramp-tramp-file-p bfn)) + (let ((bfn (if (stringp (buffer-file-name)) + (buffer-file-name) + default-directory))) + (when (tramp-tramp-file-p bfn) (let* ((v (tramp-dissect-file-name bfn)) (localname (tramp-file-name-localname v))) (tramp-flush-file-property v localname))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) +(add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) (add-hook 'kill-buffer-hook 'tramp-flush-file-function) (add-hook 'tramp-cache-unload-hook '(lambda () (remove-hook 'before-revert-hook 'tramp-flush-file-function) + (remove-hook 'eshell-pre-command-hook + 'tramp-flush-file-function) (remove-hook 'kill-buffer-hook 'tramp-flush-file-function))) @@ -229,9 +216,38 @@ function is intended to run also as process sentinel." ; (tramp-message key 7 "%s" event) (remhash key tramp-cache-data)) +(defun tramp-cache-print (table) + "Print hash table TABLE." + (when (hash-table-p table) + (let (result) + (maphash + '(lambda (key value) + (let ((tmp (format + "(%s %s)" + (if (processp key) + (prin1-to-string (prin1-to-string key)) + (prin1-to-string key)) + (if (hash-table-p value) + (tramp-cache-print value) + (if (bufferp value) + (prin1-to-string (prin1-to-string value)) + (prin1-to-string value)))))) + (setq result (if result (concat result " " tmp) tmp)))) + table) + result))) + +(defun tramp-list-connections () + "Return a list of all known connection vectors according to `tramp-cache'." + (let (result) + (maphash + '(lambda (key value) + (when (and (vectorp key) (null (aref key 3))) + (add-to-list 'result key))) + tramp-cache-data) + result)) + (defun tramp-dump-connection-properties () -"Writes persistent connection properties into file -`tramp-persistency-file-name'." + "Write persistent connection properties into file `tramp-persistency-file-name'." ;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed. (condition-case nil (when (and (hash-table-p tramp-cache-data) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 72e57799dc4..7cf2bf3d923 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -61,12 +61,12 @@ When called interactively, a Tramp connection has to be selected." (let ((connections (mapcar (lambda (x) - (with-current-buffer x (list (file-remote-p default-directory)))) - ;; We shall not count debug buffers, because their - ;; default-directory is random. It could be even a remote - ;; one from another connection. - (all-completions - "*tramp" (mapcar 'list (tramp-list-tramp-buffers))))) + (tramp-make-tramp-file-name + (tramp-file-name-method x) + (tramp-file-name-user x) + (tramp-file-name-host x) + (tramp-file-name-localname x))) + (tramp-list-connections))) name) (when connections @@ -125,12 +125,270 @@ This includes password cache, file cache, connection cache, buffers." (dolist (name (tramp-list-remote-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) +;; Tramp version is useful in a number of situations. + +(defun tramp-version (arg) + "Print version number of tramp.el in minibuffer or current buffer." + (interactive "P") + (if arg (insert tramp-version) (message tramp-version))) + +;; Make the `reporter` functionality available for making bug reports about +;; the package. A most useful piece of code. + +(autoload 'reporter-submit-bug-report "reporter") + +(defun tramp-bug () + "Submit a bug report to the Tramp developers." + (interactive) + (require 'reporter) + (catch 'dont-send + (let ((reporter-prompt-for-summary-p t)) + (reporter-submit-bug-report + tramp-bug-report-address ; to-address + (format "tramp (%s)" tramp-version) ; package name and version + (delq nil + `(;; Current state + tramp-current-method + tramp-current-user + tramp-current-host + + ;; System defaults + tramp-auto-save-directory ; vars to dump + tramp-default-method + tramp-default-method-alist + tramp-default-host + tramp-default-proxies-alist + tramp-default-user + tramp-default-user-alist + tramp-rsh-end-of-line + tramp-default-password-end-of-line + tramp-login-prompt-regexp + ;; Mask non-7bit characters + (tramp-password-prompt-regexp . tramp-reporter-dump-variable) + tramp-wrong-passwd-regexp + tramp-yesno-prompt-regexp + tramp-yn-prompt-regexp + tramp-terminal-prompt-regexp + tramp-temp-name-prefix + tramp-file-name-structure + tramp-file-name-regexp + tramp-methods + tramp-end-of-output + tramp-local-coding-commands + tramp-remote-coding-commands + tramp-actions-before-shell + tramp-actions-copy-out-of-band + tramp-terminal-type + ;; Mask non-7bit characters + (tramp-shell-prompt-pattern . tramp-reporter-dump-variable) + ,(when (boundp 'tramp-backup-directory-alist) + 'tramp-backup-directory-alist) + ,(when (boundp 'tramp-bkup-backup-directory-info) + 'tramp-bkup-backup-directory-info) + ;; Dump cache. + (tramp-cache-data . tramp-reporter-dump-variable) + + ;; Non-tramp variables of interest + ;; Mask non-7bit characters + (shell-prompt-pattern . tramp-reporter-dump-variable) + backup-by-copying + backup-by-copying-when-linked + backup-by-copying-when-mismatch + ,(when (boundp 'backup-by-copying-when-privileged-mismatch) + 'backup-by-copying-when-privileged-mismatch) + ,(when (boundp 'password-cache) + 'password-cache) + ,(when (boundp 'password-cache-expiry) + 'password-cache-expiry) + ,(when (boundp 'backup-directory-alist) + 'backup-directory-alist) + ,(when (boundp 'bkup-backup-directory-info) + 'bkup-backup-directory-info) + file-name-handler-alist)) + + 'tramp-load-report-modules ; pre-hook + 'tramp-append-tramp-buffers ; post-hook + "\ +Enter your bug report in this message, including as much detail +as you possibly can about the problem, what you did to cause it +and what the local and remote machines are. + +If you can give a simple set of instructions to make this bug +happen reliably, please include those. Thank you for helping +kill bugs in Tramp. + +Another useful thing to do is to put + + (setq tramp-verbose 8) + +in the ~/.emacs file and to repeat the bug. Then, include the +contents of the *tramp/foo* buffer and the *debug tramp/foo* +buffer in your bug report. + +--bug report follows this line-- +")))) + +(defun tramp-reporter-dump-variable (varsym mailbuf) + "Pretty-print the value of the variable in symbol VARSYM. +Used for non-7bit chars in strings." + (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) + (val (with-current-buffer reporter-eval-buffer + (symbol-value varsym)))) + + (if (hash-table-p val) + ;; Pretty print the cache. + (set varsym (read (format "(%s)" (tramp-cache-print val)))) + ;; There are characters to be masked. + (when (and (boundp 'mm-7bit-chars) + (string-match + (concat "[^" (symbol-value 'mm-7bit-chars) "]") val)) + (with-current-buffer reporter-eval-buffer + (set varsym (format "(base64-decode-string \"%s\"" + (base64-encode-string val)))))) + + ;; Dump variable. + (funcall (symbol-function 'reporter-dump-variable) varsym mailbuf) + + (unless (hash-table-p val) + ;; Remove string quotation. + (forward-line -1) + (when (looking-at + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$")) ;; \4 " + (replace-match "\\1\\2\\3\\4") + (beginning-of-line) + (insert " ;; variable encoded due to non-printable characters\n")) + (forward-line 1)) + + ;; Reset VARSYM to old value. + (with-current-buffer reporter-eval-buffer + (set varsym val)))) + +(defun tramp-load-report-modules () + "Load needed modules for reporting." + + ;; We load message.el and mml.el from Gnus. + (if (featurep 'xemacs) + (progn + (load "message" 'noerror) + (load "mml" 'noerror)) + (require 'message nil 'noerror) + (require 'mml nil 'noerror)) + (when (functionp 'message-mode) + (funcall (symbol-function 'message-mode))) + (when (functionp 'mml-mode) + (funcall (symbol-function 'mml-mode) t))) + +(defun tramp-append-tramp-buffers () + "Append Tramp buffers and buffer local variables into the bug report." + + (goto-char (point-max)) + + ;; Dump buffer local variables. + (dolist (buffer + (delq nil + (mapcar + '(lambda (b) + (when (string-match "\\*tramp/" (buffer-name b)) b)) + (buffer-list)))) + (let ((reporter-eval-buffer buffer) + (buffer-name (buffer-name buffer)) + (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) + (with-current-buffer elbuf + (emacs-lisp-mode) + (erase-buffer) + (insert "\n(setq\n") + (lisp-indent-line) + (funcall (symbol-function 'reporter-dump-variable) + 'buffer-name (current-buffer)) + (dolist (varsym-or-cons-cell (buffer-local-variables buffer)) + (let ((varsym (or (car-safe varsym-or-cons-cell) + varsym-or-cons-cell))) + (when (string-match "tramp" (symbol-name varsym)) + (funcall + (symbol-function 'reporter-dump-variable) + varsym (current-buffer))))) + (lisp-indent-line) + (insert ")\n")) + (insert-buffer-substring elbuf))) + + ;; Append buffers only when we are in message mode. + (when (and + (eq major-mode 'message-mode) + (boundp 'mml-mode) + (symbol-value 'mml-mode)) + + (let ((tramp-buf-regexp "\\*\\(debug \\)?tramp/") + (buffer-list (funcall (symbol-function 'tramp-list-tramp-buffers))) + (curbuf (current-buffer))) + + ;; There is at least one Tramp buffer. + (when buffer-list + (switch-to-buffer (list-buffers-noselect nil)) + (delete-other-windows) + (setq buffer-read-only nil) + (goto-char (point-min)) + (while (not (eobp)) + (if (re-search-forward + tramp-buf-regexp (tramp-compat-line-end-position) t) + (forward-line 1) + (forward-line 0) + (let ((start (point))) + (forward-line 1) + (kill-region start (point))))) + (insert " +The buffer(s) above will be appended to this message. If you +don't want to append a buffer because it contains sensitive data, +or because the buffer is too large, you should delete the +respective buffer. The buffer(s) will contain user and host +names. Passwords will never be included there.") + + (when (>= tramp-verbose 6) + (insert "\n\n") + (let ((start (point))) + (insert "\ +Please note that you have set `tramp-verbose' to a value of at +least 6. Therefore, the contents of files might be included in +the debug buffer(s).") + (add-text-properties start (point) (list 'face 'italic)))) + + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (goto-char (point-min)) + + (if (y-or-n-p "Do you want to append the buffer(s)? ") + ;; OK, let's send. First we delete the buffer list. + (progn + (kill-buffer nil) + (switch-to-buffer curbuf) + (goto-char (point-max)) + (insert "\n\ +This is a special notion of the `gnus/message' package. If you +use another mail agent (by copying the contents of this buffer) +please ensure that the buffers are attached to your email.\n\n") + (dolist (buffer buffer-list) + (funcall (symbol-function 'mml-insert-empty-tag) + 'part 'type "text/plain" 'encoding "base64" + 'disposition "attachment" 'buffer buffer + 'description buffer)) + (set-buffer-modified-p nil)) + + ;; Don't send. Delete the message buffer. + (set-buffer curbuf) + (set-buffer-modified-p nil) + (kill-buffer nil) + (throw 'dont-send nil)))))) + +(defalias 'tramp-submit-bug 'tramp-bug) + (provide 'tramp-cmds) ;;; TODO: ;; * Clean up unused *tramp/foo* buffers after a while. (Pete Forman) -;; * WIBNI there was an interactive command prompting for tramp +;; * WIBNI there was an interactive command prompting for Tramp ;; method, hostname, username and filename and translates the user ;; input into the correct filename syntax (depending on the Emacs ;; flavor) (Reiner Steib) diff --git a/lisp/net/tramp-fish.el b/lisp/net/tramp-fish.el index 7116d144061..95091c276bc 100644 --- a/lisp/net/tramp-fish.el +++ b/lisp/net/tramp-fish.el @@ -308,10 +308,10 @@ pass to the OPERATION." v1 'file-error "Error with add-name-to-file %s" newname))))) (defun tramp-fish-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date) + (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) "Like `copy-file' for Tramp files." (tramp-fish-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date)) + 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid)) (defun tramp-fish-handle-delete-directory (directory) "Like `delete-directory' for Tramp files." @@ -346,7 +346,7 @@ pass to the OPERATION." ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a tramp file, run the real handler + ;; If NAME is not a Tramp file, run the real handler, (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name))) (tramp-drop-volume-letter (tramp-run-real-handler 'expand-file-name (list name nil))) @@ -835,7 +835,7 @@ target of the symlink differ." ;; Internal file name functions (defun tramp-fish-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date) + (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) "Copy or rename a remote file. OP must be `copy' or `rename' and indicates the operation to perform. FILENAME specifies the file to copy or rename, NEWNAME @@ -869,7 +869,7 @@ file names." ;; directly. ((tramp-equal-remote filename newname) (tramp-fish-do-copy-or-rename-file-directly - op filename newname keep-date)) + op filename newname keep-date preserve-uid-gid)) ;; No shortcut was possible. So we copy the ;; file first. If the operation was `rename', we go ;; back and delete the original file (if the copy was @@ -899,12 +899,13 @@ file names." (tramp-flush-file-property v (file-name-directory localname))))))) (defun tramp-fish-do-copy-or-rename-file-directly - (op filename newname keep-date) + (op filename newname keep-date preserve-uid-gid) "Invokes `COPY' or `RENAME' on the remote system. OP must be one of `copy' or `rename', indicating `cp' or `mv', respectively. VEC specifies the connection. LOCALNAME1 and LOCALNAME2 specify the two arguments of `cp' or `mv'. If -KEEP-DATE is non-nil, preserve the time stamp when copying." +KEEP-DATE is non-nil, preserve the time stamp when copying. +PRESERVE-UID-GID is completely ignored." (with-parsed-tramp-file-name filename v1 (with-parsed-tramp-file-name newname v2 (tramp-fish-send-command diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 85416d308d3..a8b6bca44f2 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -143,10 +143,13 @@ pass to the OPERATION." ;; cannot disable the file-name-handler this case. We set the ;; connection property "started" in order to put the remote ;; location into the cache, which is helpful for further - ;; completion. + ;; completion. We don't use `with-parsed-tramp-file-name', + ;; because this returns another user but the one declared in + ;; "~/.netrc". ((memq operation '(file-directory-p file-exists-p)) (if (apply 'ange-ftp-hook-function operation args) - (with-parsed-tramp-file-name (car args) nil + (let ((v (tramp-dissect-file-name (car args) t))) + (aset v 0 tramp-ftp-method) (tramp-set-connection-property v "started" t)) nil)) ;; If the second argument of `copy-file' or `rename-file' is a diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index b4e68c77624..706042060f6 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -205,9 +205,10 @@ pass to the OPERATION." ;; File name primitives (defun tramp-smb-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date) + (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) "Like `copy-file' for Tramp files. -KEEP-DATE is not handled in case NEWNAME resides on an SMB server." +KEEP-DATE is not handled in case NEWNAME resides on an SMB server. +PRESERVE-UID-GID is completely ignored." (setq filename (expand-file-name filename) newname (expand-file-name newname)) @@ -562,7 +563,14 @@ KEEP-DATE is not handled in case NEWNAME resides on an SMB server." (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `handle-substitute-in-file-name' for Tramp files. -Catches errors for shares like \"C$/\", which are common in Microsoft Windows." +\"//\" substitutes only in the local filename part. Catches +errors for shares like \"C$/\", which are common in Microsoft Windows." + (with-parsed-tramp-file-name filename nil + ;; Ignore in LOCALNAME everything before "//". + (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) + (setq filename + (concat (file-remote-p filename) + (replace-match "\\1" nil nil localname))))) (condition-case nil (tramp-run-real-handler 'substitute-in-file-name (list filename)) (error filename))) @@ -574,7 +582,7 @@ Catches errors for shares like \"C$/\", which are common in Microsoft Windows." (with-parsed-tramp-file-name filename nil (unless (eq append nil) (tramp-error - v 'file-error "Cannot append to file using tramp (`%s')" filename)) + v 'file-error "Cannot append to file using Tramp (`%s')" filename)) ;; XEmacs takes a coding system as the seventh argument, not `confirm'. (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) @@ -582,7 +590,7 @@ Catches errors for shares like \"C$/\", which are common in Microsoft Windows." filename)) (tramp-error v 'file-error "File not overwritten"))) ;; We must also flush the cache of the directory, because - ;; file-attributes reads the values from there. + ;; `file-attributes' reads the values from there. (tramp-flush-file-property v (file-name-directory localname)) (tramp-flush-file-property v localname) (let ((file (tramp-smb-get-localname localname t)) @@ -1004,8 +1012,6 @@ Returns nil if an error message has appeared." ;; * Return more comprehensive file permission string. Think whether it is ;; possible to implement `set-file-modes'. ;; * Handle links (FILENAME.LNK). -;; * Maybe local tmp files should have the same extension like the original -;; files. Strange behaviour with jka-compr otherwise? ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. ;; * (RMS) Use unwind-protect to clean up the state so as to make the state diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b54641b311e..93fdea9ab27 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -93,7 +93,6 @@ (autoload 'tramp-set-file-property "tramp-cache") (autoload 'tramp-flush-file-property "tramp-cache") (autoload 'tramp-flush-directory-property "tramp-cache") -(autoload 'tramp-cache-print "tramp-cache") (autoload 'tramp-get-connection-property "tramp-cache") (autoload 'tramp-set-connection-property "tramp-cache") (autoload 'tramp-flush-connection-property "tramp-cache") @@ -560,7 +559,7 @@ pair of the form (KEY VALUE). The following KEYs are defined: * `tramp-remote-sh' This specifies the Bourne shell to use on the remote host. This MUST be a Bourne-like shell. It is normally not necessary to set - this to any value other than \"/bin/sh\": tramp wants to use a shell + this to any value other than \"/bin/sh\": Tramp wants to use a shell which groks tilde expansion, but it can search for it. Also note that \"/bin/sh\" exists on all Unixen, this might not be true for the value that you decide to use. You Have Been Warned. @@ -972,7 +971,7 @@ The `sudo' program appears to insert a `^@' character into the prompt." (defcustom tramp-wrong-passwd-regexp (concat "^.*" ;; These strings should be on the last line - (regexp-opt '("Permission denied." + (regexp-opt '("Permission denied" "Login incorrect" "Login Incorrect" "Connection refused" @@ -1117,12 +1116,12 @@ It can have the following values: ((equal tramp-syntax 'sep) "/[") ((equal tramp-syntax 'url) "/") (t (error "Wrong `tramp-syntax' defined"))) - "*String matching the very beginning of tramp file names. + "*String matching the very beginning of Tramp file names. Used in `tramp-make-tramp-file-name'.") (defconst tramp-prefix-regexp (concat "^" (regexp-quote tramp-prefix-format)) - "*Regexp matching the very beginning of tramp file names. + "*Regexp matching the very beginning of Tramp file names. Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp @@ -1214,9 +1213,9 @@ Derived from `tramp-postfix-host-format'.") 2 4 5 7) "*List of five elements (REGEXP METHOD USER HOST FILE), detailing \ -the tramp file name structure. +the Tramp file name structure. -The first element REGEXP is a regular expression matching a tramp file +The first element REGEXP is a regular expression matching a Tramp file name. The regex should contain parentheses around the method name, the user name, the host name, and the file name parts. @@ -1256,11 +1255,11 @@ See `tramp-file-name-structure' for more explanations.") ((equal tramp-syntax 'url) tramp-file-name-regexp-url) (t (error "Wrong `tramp-syntax' defined"))) "*Regular expression matching file names handled by Tramp. -This regexp should match tramp file names but no other file names. +This regexp should match Tramp file names but no other file names. \(When tramp.el is loaded, this regular expression is prepended to `file-name-handler-alist', and that is searched sequentially. Thus, -if the tramp entry appears rather early in the `file-name-handler-alist' -and is a bit too general, then some files might be considered tramp +if the Tramp entry appears rather early in the `file-name-handler-alist' +and is a bit too general, then some files might be considered Tramp files which are not really Tramp files. Please note that the entry in `file-name-handler-alist' is made when @@ -1302,8 +1301,8 @@ See `tramp-file-name-structure' for more explanations.") ((equal tramp-syntax 'sep) tramp-completion-file-name-regexp-separate) ((equal tramp-syntax 'url) tramp-completion-file-name-regexp-url) (t (error "Wrong `tramp-syntax' defined"))) - "*Regular expression matching file names handled by tramp completion. -This regexp should match partial tramp file names only. + "*Regular expression matching file names handled by Tramp completion. +This regexp should match partial Tramp file names only. Please note that the entry in `file-name-handler-alist' is made when this file (tramp.el) is loaded. This means that this variable must be set @@ -1752,7 +1751,7 @@ This is used to map a mode number to a permission string.") "Alist of handler functions. Operations not mentioned here will be handled by the normal Emacs functions.") -;; Handlers for partial tramp file names. For Emacs just +;; Handlers for partial Tramp file names. For Emacs just ;; `file-name-all-completions' is needed. ;;;###autoload (defconst tramp-completion-file-name-handler-alist @@ -1815,7 +1814,7 @@ ARGS to actually emit the message (if applicable)." (defsubst tramp-message (vec-or-proc level fmt-string &rest args) "Emit a message depending on verbosity level. -VEC-OR-PROC identifies the tramp buffer to use. It can be either a +VEC-OR-PROC identifies the Tramp buffer to use. It can be either a vector or a process. LEVEL says to be quiet if `tramp-verbose' is less than LEVEL. The message is emitted only if `tramp-verbose' is greater than or equal to LEVEL. @@ -1966,7 +1965,8 @@ Return the local name of the temporary file." (tramp-file-name-method vec) (tramp-file-name-user vec) (tramp-file-name-host vec) - (expand-file-name tramp-temp-name-prefix "/tmp"))) + (expand-file-name + tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))) result) (while (not result) ;; `make-temp-file' would be the natural choice for @@ -2017,7 +2017,9 @@ Example: (if (string-match "^HKEY_CURRENT_USER" (nth 1 (car v))) ;; Windows registry. (and (memq system-type '(cygwin windows-nt)) - (zerop (call-process "reg" nil nil nil "query" (nth 1 (car v))))) + (zerop + (tramp-local-call-process + "reg" nil nil nil "query" (nth 1 (car v))))) ;; Configuration file. (file-exists-p (nth 1 (car v))))) (setq r (delete (car v) r))) @@ -2163,7 +2165,7 @@ target of the symlink differ." (unless nomessage (tramp-message v 0 "Loading %s...done" file)) t))) -;; Localname manipulation functions that grok TRAMP localnames... +;; Localname manipulation functions that grok Tramp localnames... (defun tramp-handle-file-name-directory (file) "Like `file-name-directory' but aware of Tramp files." ;; Everything except the last filename thing is the directory. We @@ -2548,7 +2550,7 @@ of." ;; We handle also the local part, because in older Emacsen, ;; without `set-file-times', this function is an alias for this. ;; We are local, so we don't need the UTC settings. - (call-process + (tramp-local-call-process "touch" nil nil nil "-t" (format-time-string "%Y%m%d%H%M.%S" time) (tramp-shell-quote-argument filename))))) @@ -2573,16 +2575,12 @@ and gid of the corresponding user is taken. Both parameters must be integers." (tramp-shell-quote-argument localname))))) ;; We handle also the local part, because there doesn't exist - ;; `set-file-uid-gid'. + ;; `set-file-uid-gid'. On Win32 "chown" might not work. (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer))) - (default-directory (tramp-compat-temporary-file-directory))) - ;; "chown" might not exist, for example on Win32. - (condition-case nil - (call-process - "chown" nil nil nil - (format "%d:%d" uid gid) (tramp-shell-quote-argument filename)) - (error nil))))) + (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-local-call-process + "chown" nil nil nil + (format "%d:%d" uid gid) (tramp-shell-quote-argument filename))))) ;; Simple functions using the `test' command. @@ -2897,7 +2895,7 @@ and gid of the corresponding user is taken. Both parameters must be integers." (setq filename (expand-file-name filename)) (setq newname (expand-file-name newname)) (cond - ;; At least one file a tramp file? + ;; At least one file a Tramp file? ((or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) (tramp-do-copy-or-rename-file @@ -2915,10 +2913,10 @@ and gid of the corresponding user is taken. Both parameters must be integers." (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. - ;; Otherwise, use tramp from local system. + ;; Otherwise, use Tramp from local system. (setq filename (expand-file-name filename)) (setq newname (expand-file-name newname)) - ;; At least one file a tramp file? + ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) (tramp-do-copy-or-rename-file @@ -3309,7 +3307,7 @@ be a local filename. The method used must be an out-of-band method." ;; Dired. ;; CCC: This does not seem to be enough. Something dies when -;; we try and delete two directories under TRAMP :/ +;; we try and delete two directories under Tramp :/ (defun tramp-handle-dired-recursive-delete-directory (filename) "Recursively delete the directory given. This is like `dired-recursive-delete-directory' for Tramp files." @@ -3455,7 +3453,7 @@ This is like `dired-recursive-delete-directory' for Tramp files." "" (tramp-shell-quote-argument (file-name-nondirectory localname)))))) - ;; We cannot use `insert-buffer-substring' because the tramp buffer + ;; We cannot use `insert-buffer-substring' because the Tramp buffer ;; changes its contents before insertion due to calling ;; `expand-file' and alike. (insert @@ -3563,8 +3561,8 @@ beginning of local filename are not substituted." ;; Ignore in LOCALNAME everything before "//" or "/~". (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) (setq filename - (tramp-make-tramp-file-name - method user host (replace-match "\\1" nil nil localname))) + (concat (file-remote-p filename) + (replace-match "\\1" nil nil localname))) ;; "/m:h:~" does not work for completion. We use "/m:h:~/". (when (string-match "~$" filename) (setq filename (concat filename "/")))) @@ -3729,6 +3727,20 @@ beginning of local filename are not substituted." ;; Return exit status. ret))) +(defun tramp-local-call-process + (program &optional infile destination display &rest args) + "Calls `call-process' on the local host. +This is needed because for some Emacs flavors Tramp has +defadviced `call-process' to behave like `process-file'. The +Lisp error raised when PROGRAM is nil is trapped also, returning 1." + (let ((default-directory + (if (file-remote-p default-directory) + (tramp-compat-temporary-file-directory) + default-directory))) + (if (executable-find program) + (apply 'call-process program infile destination display args) + 1))) + (defun tramp-handle-call-process-region (start end program &optional delete buffer display &rest args) "Like `call-process-region' for Tramp files." @@ -3764,19 +3776,14 @@ beginning of local filename are not substituted." output-buffer))) (prog1 - ;; Run the process. We cannot use `process-file' and - ;; `start-file-process', because these functions might not - ;; exist in older Emacsen. + ;; Run the process. (if (integerp asynchronous) - (apply 'tramp-handle-start-file-process - "*Async Shell*" buffer args) - (apply 'process-file - (car args) nil buffer nil (cdr args))) + (apply 'start-file-process "*Async Shell*" buffer args) + (apply 'process-file (car args) nil buffer nil (cdr args))) ;; Insert error messages if they were separated. (when (listp buffer) - (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (buffer-file-name (cadr buffer)))) + (with-current-buffer error-buffer (insert-file-contents (cadr buffer))) + (delete-file (cadr buffer))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (if (functionp 'display-message-or-buffer) @@ -4052,9 +4059,9 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) (tramp-error v 'file-error "File not overwritten"))) - (let ((uid (or (nth 2 (file-attributes filename 'integer)) + (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (nth 3 (file-attributes filename 'integer)) + (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) (if (and (tramp-local-host-p v) @@ -4173,17 +4180,15 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (when file-precious-flag (erase-buffer) (and - ;; cksum runs locally - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (zerop (call-process "cksum" tmpfile t))) - ;; cksum runs remotely + ;; cksum runs locally, if possible. + (zerop (tramp-local-call-process "cksum" tmpfile t)) + ;; cksum runs remotely. (zerop (tramp-send-command-and-check v (format "cksum <%s" (tramp-shell-quote-argument localname)))) - ;; ... they are different + ;; ... they are different. (not (string-equal (buffer-string) @@ -4367,7 +4372,7 @@ ARGS are the arguments OPERATION has been called with." ;;;###autoload (defun tramp-file-name-handler (operation &rest args) "Invoke Tramp file name handler. -Falls back to normal file name handler if no tramp file name handler exists." +Falls back to normal file name handler if no Tramp file name handler exists." (save-match-data (let* ((filename (apply 'tramp-file-name-for-operation operation args)) (completion (tramp-completion-mode-p)) @@ -4433,8 +4438,8 @@ Fall back to normal file name handler if no Tramp handler exists." ;;;###autoload (progn (defun tramp-completion-file-name-handler (operation &rest args) - "Invoke tramp file name completion handler. -Falls back to normal file name handler if no tramp file name handler exists." + "Invoke Tramp file name completion handler. +Falls back to normal file name handler if no Tramp file name handler exists." ;; (setq edebug-trace t) ;; (edebug-trace "%s" (with-output-to-string (backtrace))) @@ -4449,7 +4454,7 @@ Falls back to normal file name handler if no tramp file name handler exists." ;;;###autoload (defsubst tramp-register-file-name-handler () - "Add tramp file name handler to `file-name-handler-alist'." + "Add Tramp file name handler to `file-name-handler-alist'." ;; Remove autoloaded handler from file name handler alist. Useful, ;; if `tramp-syntax' has been changed. (let ((a1 (rassq 'tramp-file-name-handler file-name-handler-alist))) @@ -4472,7 +4477,7 @@ Falls back to normal file name handler if no tramp file name handler exists." ;;;###autoload (defsubst tramp-register-completion-file-name-handler () - "Add tramp completion file name handler to `file-name-handler-alist'." + "Add Tramp completion file name handler to `file-name-handler-alist'." ;; Remove autoloaded handler from file name handler alist. Useful, ;; if `tramp-syntax' has been changed. (let ((a1 (rassq @@ -4535,8 +4540,8 @@ should never be set globally, the intention is to let-bind it.") ;; risky, because completing a file might require loading other files, ;; like "~/.netrc", and for them it shouldn't be decided based on that ;; variable. On the other hand, those files shouldn't have partial -;; tramp file name syntax. Maybe another variable should be introduced -;; overwriting this check in such cases. Or we change tramp file name +;; Tramp file name syntax. Maybe another variable should be introduced +;; overwriting this check in such cases. Or we change Tramp file name ;; syntax in order to avoid ambiguities, like in XEmacs ... (defun tramp-completion-mode-p () "Checks whether method / user name / host name completion is active." @@ -5037,7 +5042,7 @@ User is always nil." (let ((default-directory (tramp-compat-temporary-file-directory)) res) (with-temp-buffer - (when (zerop (call-process "reg" nil t nil "query" registry)) + (when (zerop (tramp-local-call-process "reg" nil t nil "query" registry)) (goto-char (point-min)) (while (not (eobp)) (push (tramp-parse-putty-group registry) res)))) @@ -5331,11 +5336,11 @@ file exists and nonzero exit status otherwise." (when extra-args (setq shell (concat shell " " extra-args)))) (tramp-message vec 5 "Starting remote shell `%s' for tilde expansion..." shell) - (tramp-message - vec 6 (format "PROMPT_COMMAND='' PS1='$ ' exec %s" shell)) - ;; We just send a string only without checking resulting prompt. - (tramp-send-string - vec (format "PROMPT_COMMAND='' PS1='$ ' exec %s" shell)) + (let ((tramp-end-of-output "$ ")) + (tramp-send-command + vec + (format "PROMPT_COMMAND='' PS1='$ ' PS2='' PS3='' exec %s" shell) + t)) (tramp-message vec 5 "Setting remote shell prompt...") ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we ;; must use "\n" here, not tramp-rsh-end-of-line. Kai left the @@ -5611,16 +5616,14 @@ process to set up. VEC specifies the connection." ;; called as sh) on startup; this way, we avoid the startup file ;; clobbering $PS1. $PROMP_COMMAND is another way to set the prompt ;; in /bin/bash, it must be discarded as well. - (tramp-message - vec 6 (format "exec env 'ENV=' 'PROMPT_COMMAND=' 'PS1=$ ' %s" - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-sh))) - ;; We just send a string only without checking resulting prompt. - (tramp-send-string - vec - (format "exec env 'ENV=' 'PROMPT_COMMAND=' 'PS1=$ ' %s" - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-sh))) + (let ((tramp-end-of-output "$ ")) + (tramp-send-command + vec + (format + "exec env 'ENV=' 'PROMPT_COMMAND=' 'PS1=$ ' PS2='' PS3='' %s" + (tramp-get-method-parameter + (tramp-file-name-method vec) 'tramp-remote-sh)) + t)) (tramp-message vec 5 "Setting shell prompt") ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we must ;; use "\n" here, not tramp-rsh-end-of-line. @@ -5631,6 +5634,12 @@ process to set up. VEC specifies the connection." tramp-end-of-output tramp-rsh-end-of-line) t) + ;; If the connection buffer is not empty, the remote shell is + ;; echoing, and the prompt has been detected through the echoed + ;; command. We must reread for the real prompt. + (with-current-buffer (process-buffer proc) + (when (> (point-max) (point-min)) (tramp-wait-for-output proc))) + ;; Disable echo. (tramp-message vec 5 "Setting up remote shell environment") (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) ;; Check whether the echo has really been disabled. Some @@ -5906,18 +5915,15 @@ INPUT can also be nil which means `/dev/null'. OUTPUT can be a string (which specifies a filename), or t (which means standard output and thus the current buffer), or nil (which means discard it)." - (let ((default-directory (tramp-compat-temporary-file-directory))) - (call-process - tramp-encoding-shell ;program - (when (and input (not (string-match "%s" cmd))) - input) ;input - (if (eq output t) t nil) ;output - nil ;redisplay - tramp-encoding-command-switch - ;; actual shell command - (concat - (if (string-match "%s" cmd) (format cmd input) cmd) - (if (stringp output) (concat "> " output) ""))))) + (tramp-local-call-process + tramp-encoding-shell + (when (and input (not (string-match "%s" cmd))) input) + (if (eq output t) t nil) + nil + tramp-encoding-command-switch + (concat + (if (string-match "%s" cmd) (format cmd input) cmd) + (if (stringp output) (concat "> " output) "")))) (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'. @@ -6014,7 +6020,8 @@ Gateway hops are already opened." "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the connection if a previous connection has died for some reason." - (let ((p (tramp-get-connection-process vec))) + (let ((p (tramp-get-connection-process vec)) + (process-environment (copy-sequence process-environment))) ;; If too much time has passed since last command was sent, look ;; whether process is still alive. If it isn't, kill it. When @@ -6062,10 +6069,10 @@ connection if a previous connection has died for some reason." (when (and p (processp p)) (delete-process p)) (setenv "TERM" tramp-terminal-type) + (setenv "LC_ALL" "C") (setenv "PROMPT_COMMAND") (setenv "PS1" "$ ") (let* ((target-alist (tramp-compute-multi-hops vec)) - (process-environment (copy-sequence process-environment)) (process-connection-type tramp-process-connection-type) (process-adaptive-read-buffering nil) (coding-system-for-read nil) @@ -6197,7 +6204,9 @@ function waits for output unless NOOUTPUT is set." (let ((found (tramp-wait-for-regexp proc timeout - (format "^%s\r?$" (regexp-quote tramp-end-of-output))))) + ;; Initially, `tramp-end-of-output' is "$ ". There might + ;; be leading escape sequences, which must be ignored. + (format "^[^$\n]*%s\r?$" (regexp-quote tramp-end-of-output))))) (if found (let (buffer-read-only) (goto-char (point-max)) @@ -6514,7 +6523,7 @@ Not actually used. Use `(format \"%o\" i)' instead?" ;; ------------------------------------------------------------ -;; -- TRAMP file names -- +;; -- Tramp file names -- ;; ------------------------------------------------------------ ;; Conversion functions between external representation and ;; internal data structure. Convenience functions for internal @@ -6558,7 +6567,7 @@ Not actually used. Use `(format \"%o\" i)' instead?" (string-to-number (match-string 2 host))))) (defun tramp-tramp-file-p (name) - "Return t if NAME is a tramp file." + "Return t if NAME is a Tramp file." (save-match-data (string-match tramp-file-name-regexp name))) @@ -6608,7 +6617,7 @@ non-nil, the file name parts are not expanded to their default values." (save-match-data (let ((match (string-match (nth 0 tramp-file-name-structure) name))) - (unless match (error "Not a tramp file name: %s" name)) + (unless match (error "Not a Tramp file name: %s" name)) (let ((method (match-string (nth 1 tramp-file-name-structure) name)) (user (match-string (nth 2 tramp-file-name-structure) name)) (host (match-string (nth 3 tramp-file-name-structure) name)) @@ -6726,6 +6735,18 @@ necessary only. This function will be used in file name completion." x)) remote-path))))) +(defun tramp-get-remote-tmpdir (vec) + (with-connection-property vec "tmp-directory" + (let ((dir (tramp-shell-quote-argument "/tmp"))) + (if (and (zerop + (tramp-send-command-and-check + vec (format "%s -d %s" (tramp-get-test-command vec) dir))) + (zerop + (tramp-send-command-and-check + vec (format "%s -w %s" (tramp-get-test-command vec) dir)))) + dir + (tramp-error vec 'file-error "Directory %s not accessible" dir))))) + (defun tramp-get-ls-command (vec) (with-connection-property vec "ls" (with-current-buffer (tramp-get-buffer vec) @@ -7161,265 +7182,6 @@ Only works for Bourne-like shells." (add-hook 'tramp-unload-hook '(lambda () (ad-unadvise 'file-expand-wildcards)))) -;; Tramp version is useful in a number of situations. - -(defun tramp-version (arg) - "Print version number of tramp.el in minibuffer or current buffer." - (interactive "P") - (if arg (insert tramp-version) (message tramp-version))) - -;; Make the `reporter` functionality available for making bug reports about -;; the package. A most useful piece of code. - -(unless (fboundp 'reporter-submit-bug-report) - (autoload 'reporter-submit-bug-report "reporter")) - -(defun tramp-bug () - "Submit a bug report to the TRAMP developers." - (interactive) - (require 'reporter) - (catch 'dont-send - (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - tramp-bug-report-address ; to-address - (format "tramp (%s)" tramp-version) ; package name and version - (delq nil - `(;; Current state - tramp-current-method - tramp-current-user - tramp-current-host - - ;; System defaults - tramp-auto-save-directory ; vars to dump - tramp-default-method - tramp-default-method-alist - tramp-default-host - tramp-default-proxies-alist - tramp-default-user - tramp-default-user-alist - tramp-rsh-end-of-line - tramp-default-password-end-of-line - tramp-login-prompt-regexp - ;; Mask non-7bit characters - (tramp-password-prompt-regexp . tramp-reporter-dump-variable) - tramp-wrong-passwd-regexp - tramp-yesno-prompt-regexp - tramp-yn-prompt-regexp - tramp-terminal-prompt-regexp - tramp-temp-name-prefix - tramp-file-name-structure - tramp-file-name-regexp - tramp-methods - tramp-end-of-output - tramp-local-coding-commands - tramp-remote-coding-commands - tramp-actions-before-shell - tramp-actions-copy-out-of-band - tramp-terminal-type - ;; Mask non-7bit characters - (tramp-shell-prompt-pattern . tramp-reporter-dump-variable) - ,(when (boundp 'tramp-backup-directory-alist) - 'tramp-backup-directory-alist) - ,(when (boundp 'tramp-bkup-backup-directory-info) - 'tramp-bkup-backup-directory-info) - ;; Dump cache. - (tramp-cache-data . tramp-reporter-dump-variable) - - ;; Non-tramp variables of interest - ;; Mask non-7bit characters - (shell-prompt-pattern . tramp-reporter-dump-variable) - backup-by-copying - backup-by-copying-when-linked - backup-by-copying-when-mismatch - ,(when (boundp 'backup-by-copying-when-privileged-mismatch) - 'backup-by-copying-when-privileged-mismatch) - ,(when (boundp 'password-cache) - 'password-cache) - ,(when (boundp 'password-cache-expiry) - 'password-cache-expiry) - ,(when (boundp 'backup-directory-alist) - 'backup-directory-alist) - ,(when (boundp 'bkup-backup-directory-info) - 'bkup-backup-directory-info) - file-name-handler-alist)) - - 'tramp-load-report-modules ; pre-hook - 'tramp-append-tramp-buffers ; post-hook - "\ -Enter your bug report in this message, including as much detail -as you possibly can about the problem, what you did to cause it -and what the local and remote machines are. - -If you can give a simple set of instructions to make this bug -happen reliably, please include those. Thank you for helping -kill bugs in Tramp. - -Another useful thing to do is to put - - (setq tramp-verbose 8) - -in the ~/.emacs file and to repeat the bug. Then, include the -contents of the *tramp/foo* buffer and the *debug tramp/foo* -buffer in your bug report. - ---bug report follows this line-- -")))) - -(defun tramp-reporter-dump-variable (varsym mailbuf) - "Pretty-print the value of the variable in symbol VARSYM. -Used for non-7bit chars in strings." - (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) - (val (with-current-buffer reporter-eval-buffer - (symbol-value varsym)))) - - (if (hash-table-p val) - ;; Pretty print the cache. - (set varsym (read (format "(%s)" (tramp-cache-print val)))) - ;; There are characters to be masked. - (when (and (boundp 'mm-7bit-chars) - (string-match - (concat "[^" (symbol-value 'mm-7bit-chars) "]") val)) - (with-current-buffer reporter-eval-buffer - (set varsym (format "(base64-decode-string \"%s\"" - (base64-encode-string val)))))) - - ;; Dump variable. - (funcall (symbol-function 'reporter-dump-variable) varsym mailbuf) - - (unless (hash-table-p val) - ;; Remove string quotation. - (forward-line -1) - (when (looking-at - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$")) ;; \4 " - (replace-match "\\1\\2\\3\\4") - (beginning-of-line) - (insert " ;; variable encoded due to non-printable characters\n")) - (forward-line 1)) - - ;; Reset VARSYM to old value. - (with-current-buffer reporter-eval-buffer - (set varsym val)))) - -(defun tramp-load-report-modules () - "Load needed modules for reporting." - - ;; We load message.el and mml.el from Gnus. - (if (featurep 'xemacs) - (progn - (load "message" 'noerror) - (load "mml" 'noerror)) - (require 'message nil 'noerror) - (require 'mml nil 'noerror)) - (when (functionp 'message-mode) - (funcall (symbol-function 'message-mode))) - (when (functionp 'mml-mode) - (funcall (symbol-function 'mml-mode) t))) - -(defun tramp-append-tramp-buffers () - "Append Tramp buffers and buffer local variables into the bug report." - - (goto-char (point-max)) - - ;; Dump buffer local variables. - (dolist (buffer - (delq nil - (mapcar - '(lambda (b) - (when (string-match "\\*tramp/" (buffer-name b)) b)) - (buffer-list)))) - (let ((reporter-eval-buffer buffer) - (buffer-name (buffer-name buffer)) - (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) - (with-current-buffer elbuf - (emacs-lisp-mode) - (erase-buffer) - (insert "\n(setq\n") - (lisp-indent-line) - (funcall (symbol-function 'reporter-dump-variable) - 'buffer-name (current-buffer)) - (dolist (varsym-or-cons-cell (buffer-local-variables buffer)) - (let ((varsym (or (car-safe varsym-or-cons-cell) - varsym-or-cons-cell))) - (when (string-match "tramp" (symbol-name varsym)) - (funcall - (symbol-function 'reporter-dump-variable) - varsym (current-buffer))))) - (lisp-indent-line) - (insert ")\n")) - (insert-buffer-substring elbuf))) - - ;; Append buffers only when we are in message mode. - (when (and - (eq major-mode 'message-mode) - (boundp 'mml-mode) - (symbol-value 'mml-mode)) - - (let ((tramp-buf-regexp "\\*\\(debug \\)?tramp/") - (buffer-list (funcall (symbol-function 'tramp-list-tramp-buffers))) - (curbuf (current-buffer))) - - ;; There is at least one Tramp buffer. - (when buffer-list - (switch-to-buffer (list-buffers-noselect nil)) - (delete-other-windows) - (setq buffer-read-only nil) - (goto-char (point-min)) - (while (not (eobp)) - (if (re-search-forward - tramp-buf-regexp (tramp-compat-line-end-position) t) - (forward-line 1) - (forward-line 0) - (let ((start (point))) - (forward-line 1) - (kill-region start (point))))) - (insert " -The buffer(s) above will be appended to this message. If you -don't want to append a buffer because it contains sensitive data, -or because the buffer is too large, you should delete the -respective buffer. The buffer(s) will contain user and host -names. Passwords will never be included there.") - - (when (>= tramp-verbose 6) - (insert "\n\n") - (let ((start (point))) - (insert "\ -Please note that you have set `tramp-verbose' to a value of at -least 6. Therefore, the contents of files might be included in -the debug buffer(s).") - (add-text-properties start (point) (list 'face 'italic)))) - - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (goto-char (point-min)) - - (if (y-or-n-p "Do you want to append the buffer(s)? ") - ;; OK, let's send. First we delete the buffer list. - (progn - (kill-buffer nil) - (switch-to-buffer curbuf) - (goto-char (point-max)) - (insert "\n\ -This is a special notion of the `gnus/message' package. If you -use another mail agent (by copying the contents of this buffer) -please ensure that the buffers are attached to your email.\n\n") - (dolist (buffer buffer-list) - (funcall (symbol-function 'mml-insert-empty-tag) - 'part 'type "text/plain" 'encoding "base64" - 'disposition "attachment" 'buffer buffer - 'description buffer)) - (set-buffer-modified-p nil)) - - ;; Don't send. Delete the message buffer. - (set-buffer curbuf) - (set-buffer-modified-p nil) - (kill-buffer nil) - (throw 'dont-send nil)))))) - -(defalias 'tramp-submit-bug 'tramp-bug) - ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' @@ -7521,7 +7283,7 @@ please ensure that the buffers are attached to your email.\n\n") ;; having the possibility of passing a local file there to a local ;; Emacs session (in case I can arrange for a connection back) would ;; be nice. -;; Likely the corresponding tramp server should not allow the +;; Likely the corresponding Tramp server should not allow the ;; equivalent of the emacsclient -eval option in order to make this ;; reasonably unproblematic. And maybe trampclient should have some ;; way of passing credentials, like by using an SSL socket or diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 06dc7efbc99..2de4fa025fd 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -599,19 +599,20 @@ If CONTINUE is non-nil, use the `comment-continue' markers if any." (let* ((eolpos (line-end-position)) (begpos (comment-search-forward eolpos t)) cpos indent) - ;; An existing comment? - (if begpos - (progn - (if (and (not (looking-at "[\t\n ]")) - (looking-at comment-end-skip)) - ;; The comment is empty and we have skipped all its space - ;; and landed right before the comment-ender: - ;; Go back to the middle of the space. - (forward-char (/ (skip-chars-backward " \t") -2))) - (setq cpos (point-marker))) + (if (and comment-insert-comment-function (not begpos)) + ;; If no comment and c-i-c-f is set, let it do everything. + (funcall comment-insert-comment-function) + ;; An existing comment? + (if begpos + (progn + (if (and (not (looking-at "[\t\n ]")) + (looking-at comment-end-skip)) + ;; The comment is empty and we have skipped all its space + ;; and landed right before the comment-ender: + ;; Go back to the middle of the space. + (forward-char (/ (skip-chars-backward " \t") -2))) + (setq cpos (point-marker))) ;; If none, insert one. - (if comment-insert-comment-function - (funcall comment-insert-comment-function) (save-excursion ;; Some `comment-indent-function's insist on not moving ;; comments that are in column 0, so we first go to the @@ -624,32 +625,32 @@ If CONTINUE is non-nil, use the `comment-continue' markers if any." (setq begpos (point)) (insert starter) (setq cpos (point-marker)) - (insert ender)))) - (goto-char begpos) - ;; Compute desired indent. - (setq indent (save-excursion (funcall comment-indent-function))) - ;; If `indent' is nil and there's code before the comment, we can't - ;; use `indent-according-to-mode', so we default to comment-column. - (unless (or indent (save-excursion (skip-chars-backward " \t") (bolp))) - (setq indent comment-column)) - (if (not indent) - ;; comment-indent-function refuses: delegate to line-indent. - (indent-according-to-mode) - ;; If the comment is at the right of code, adjust the indentation. - (unless (save-excursion (skip-chars-backward " \t") (bolp)) - (setq indent (comment-choose-indent indent))) - ;; Update INDENT to leave at least one space - ;; after other nonwhite text on the line. - (save-excursion - (skip-chars-backward " \t") - (unless (bolp) - (setq indent (max indent (1+ (current-column)))))) - ;; If that's different from comment's current position, change it. - (unless (= (current-column) indent) - (delete-region (point) (progn (skip-chars-backward " \t") (point))) - (indent-to indent))) - (goto-char cpos) - (set-marker cpos nil)))) + (insert ender))) + (goto-char begpos) + ;; Compute desired indent. + (setq indent (save-excursion (funcall comment-indent-function))) + ;; If `indent' is nil and there's code before the comment, we can't + ;; use `indent-according-to-mode', so we default to comment-column. + (unless (or indent (save-excursion (skip-chars-backward " \t") (bolp))) + (setq indent comment-column)) + (if (not indent) + ;; comment-indent-function refuses: delegate to line-indent. + (indent-according-to-mode) + ;; If the comment is at the right of code, adjust the indentation. + (unless (save-excursion (skip-chars-backward " \t") (bolp)) + (setq indent (comment-choose-indent indent))) + ;; Update INDENT to leave at least one space + ;; after other nonwhite text on the line. + (save-excursion + (skip-chars-backward " \t") + (unless (bolp) + (setq indent (max indent (1+ (current-column)))))) + ;; If that's different from comment's current position, change it. + (unless (= (current-column) indent) + (delete-region (point) (progn (skip-chars-backward " \t") (point))) + (indent-to indent))) + (goto-char cpos) + (set-marker cpos nil))))) ;;;###autoload (defun comment-set-column (arg) @@ -1151,7 +1152,8 @@ is passed on to the respective function." If the region is active and `transient-mark-mode' is on, call `comment-region' (unless it only consists of comments, in which case it calls `uncomment-region'). -Else, if the current line is empty, insert a comment and indent it. +Else, if the current line is empty, call `comment-insert-comment-function' +if it is defined, otherwise insert a comment and indent it. Else if a prefix ARG is specified, call `comment-kill'. Else, call `comment-indent'. You can configure `comment-style' to change the way regions are commented." @@ -1163,15 +1165,19 @@ You can configure `comment-style' to change the way regions are commented." ;; FIXME: If there's no comment to kill on this line and ARG is ;; specified, calling comment-kill is not very clever. (if arg (comment-kill (and (integerp arg) arg)) (comment-indent)) - (let ((add (comment-add arg))) - ;; Some modes insist on keeping column 0 comment in column 0 - ;; so we need to move away from it before inserting the comment. - (indent-according-to-mode) - (insert (comment-padright comment-start add)) - (save-excursion - (unless (string= "" comment-end) - (insert (comment-padleft comment-end add))) - (indent-according-to-mode)))))) + ;; Inserting a comment on a blank line. comment-indent calls + ;; c-i-c-f if needed in the non-blank case. + (if comment-insert-comment-function + (funcall comment-insert-comment-function) + (let ((add (comment-add arg))) + ;; Some modes insist on keeping column 0 comment in column 0 + ;; so we need to move away from it before inserting the comment. + (indent-according-to-mode) + (insert (comment-padright comment-start add)) + (save-excursion + (unless (string= "" comment-end) + (insert (comment-padleft comment-end add))) + (indent-according-to-mode))))))) ;;;###autoload (defcustom comment-auto-fill-only-comments nil diff --git a/lisp/emacs-lisp/lselect.el b/lisp/obsolete/lselect.el index 54926a3844e..d457f775a03 100644 --- a/lisp/emacs-lisp/lselect.el +++ b/lisp/obsolete/lselect.el @@ -238,5 +238,10 @@ the kill ring or the Clipboard." (provide 'lselect) + +;; Local variables: +;; byte-compile-warnings: (not unresolved) +;; End: + ;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556 ;;; lselect.el ends here diff --git a/lisp/obsolete/sun-curs.el b/lisp/obsolete/sun-curs.el deleted file mode 100644 index 612102159df..00000000000 --- a/lisp/obsolete/sun-curs.el +++ /dev/null @@ -1,234 +0,0 @@ -;;; sun-curs.el --- cursor definitions for Sun windows - -;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. - -;; Author: Jeff Peck <peck@sun.com> -;; Keywords: hardware - -;; 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 3, 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: - -;;; -;;; Added some more cursors and moved the hot spots -;;; Cursor defined by 16 pairs of 16-bit numbers -;;; -;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <peck@sun.com> - -(eval-when-compile (require 'cl)) - -(defvar *edit-icon*) -(defvar char) -;; These are from term/sun-mouse.el -(defvar *mouse-window*) -(defvar *mouse-x*) -(defvar *mouse-y*) -(defvar menu) - -(require 'sun-fns) - -(eval-and-compile - (defvar sc::cursors nil "List of known cursors")) - -(defmacro defcursor (name x y string) - (if (not (memq name sc::cursors)) - (setq sc::cursors (cons name sc::cursors))) - (list 'defconst name (list 'vector x y string))) - -;;; push should be defined in common lisp, but if not use this: -;(defmacro push (v l) -; "The ITEM is evaluated and consed onto LIST, a list-valued atom" -; (list 'setq l (list 'cons v l))) - -;;; -;;; The standard default cursor -;;; -(defcursor sc:right-arrow 15 0 - (concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15 - 0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192))) - -;;(sc:set-cursor sc:right-arrow) - -(defcursor sc:fat-left-arrow 0 8 - (concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255 - 255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0))) - -(defcursor sc:box 8 8 - (concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4 - 8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252))) - -(defcursor sc:hourglass 8 8 - (concat "\177\376\100\002\040\014\032\070" - "\017\360\007\340\003\300\001\200" - "\001\200\002\100\005\040\010\020" - "\021\210\043\304\107\342\177\376")) - -(defun sc:set-cursor (icon) - "Change the Sun mouse cursor to ICON. -If ICON is nil, switch to the system default cursor, -Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]" - (interactive "XIcon Name: ") - (if (symbolp icon) (setq icon (symbol-value icon))) - (sun-change-cursor-icon icon)) - -;; This does not make much sense... -(make-local-variable '*edit-icon*) - -(defvar icon-edit nil) -(make-variable-buffer-local 'icon-edit) -(or (assq 'icon-edit minor-mode-alist) - (push '(icon-edit " IconEdit") minor-mode-alist)) - -(defun sc:edit-cursor (icon) - "convert icon to rectangle, edit, and repack" - (interactive "XIcon Name: ") - (if (not icon) (setq icon (sc::menu-choose-cursor (selected-window) 1 1))) - (if (symbolp icon) (setq icon (symbol-value icon))) - (if (get-buffer "icon-edit") (kill-buffer "icon-edit")) - (switch-to-buffer "icon-edit") - (local-set-mouse '(text right) 'sc::menu-function) - (local-set-mouse '(text left) '(sc::pic-ins-at-mouse 32)) - (local-set-mouse '(text middle) '(sc::pic-ins-at-mouse 64)) - (local-set-mouse '(text left middle) 'sc::hotspot) - (sc::display-icon icon) - (picture-mode) - (setq icon-edit t) ; for mode line display -) - -(defun sc::pic-ins-at-mouse (char) - "Picture insert char at mouse location" - (mouse-move-point *mouse-window* (min 15 *mouse-x*) (min 15 *mouse-y*)) - (move-to-column (1+ (min 15 (current-column))) t) - (delete-char -1) - (insert char) - (sc::goto-hotspot)) - -(defmenu sc::menu - ("Cursor Menu") - ("Pack & Use" sc::pack-buffer-to-cursor) - ("Pack to Icon" sc::pack-buffer-to-icon - (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) - ("New Icon" call-interactively 'sc::make-cursor) - ("Edit Icon" sc:edit-cursor - (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) - ("Set Cursor" sc:set-cursor - (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) - ("Reset Cursor" sc:set-cursor nil) - ("Help" sc::edit-icon-help-menu) - ("Quit" sc::quit-edit) - ) - -(defun sc::menu-function (window x y) - (sun-menu-evaluate window (1+ x) y sc::menu)) - -(defun sc::quit-edit () - (interactive) - (bury-buffer (current-buffer)) - (switch-to-buffer (other-buffer) 'no-record)) - -(defun sc::make-cursor (symbol) - (interactive "SIcon Name: ") - (eval (list 'defcursor symbol 0 0 "")) - (sc::pack-buffer-to-icon (symbol-value symbol))) - -(defmenu sc::edit-icon-help-menu - ("Simple Icon Editor") - ("Left => CLEAR") - ("Middle => SET") - ("L & M => HOTSPOT") - ("Right => MENU")) - -(defun sc::edit-icon-help () - (message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU")) - -(defun sc::pack-buffer-to-cursor () - (sc::pack-buffer-to-icon *edit-icon*) - (sc:set-cursor *edit-icon*)) - -(defun sc::menu-choose-cursor (window x y) - "Presents a menu of cursor names, and returns one or nil" - (let ((curs sc::cursors) - (items)) - (while curs - (push (sc::menu-item-for-cursor (car curs)) items) - (setq curs (cdr curs))) - (push (list "Choose Cursor") items) - (setq menu (menu-create items)) - (sun-menu-evaluate window x y menu))) - -(defun sc::menu-item-for-cursor (cursor) - "apply function to selected cursor" - (list (symbol-name cursor) 'quote cursor)) - -(defun sc::hotspot (window x y) - (aset *edit-icon* 0 x) - (aset *edit-icon* 1 y) - (sc::goto-hotspot)) - -(defun sc::goto-hotspot () - (goto-line (1+ (aref *edit-icon* 1))) - (move-to-column (aref *edit-icon* 0))) - -(defun sc::display-icon (icon) - (setq *edit-icon* (copy-sequence icon)) - (let ((string (aref *edit-icon* 2)) - (index 0)) - (while (< index 32) - (let ((char (aref string index)) - (bit 128)) - (while (> bit 0) - (insert (sc::char-at-bit char bit)) - (setq bit (lsh bit -1)))) - (if (eq 1 (% index 2)) (newline)) - (setq index (1+ index)))) - (sc::goto-hotspot)) - -(defun sc::char-at-bit (char bit) - (if (> (logand char bit) 0) "@" " ")) - -(defun sc::pack-buffer-to-icon (icon) - "Pack 16 x 16 field into icon string" - (goto-char (point-min)) - (aset icon 0 (aref *edit-icon* 0)) - (aset icon 1 (aref *edit-icon* 1)) - (aset icon 2 (mapconcat 'sc::pack-one-line "1234567890123456" "")) - (sc::goto-hotspot) - ) - -(defun sc::pack-one-line (dummy) - (let (char chr1 chr2) - (setq char 0 chr1 (mapconcat 'sc::pack-one-char "12345678" "") chr1 char) - (setq char 0 chr2 (mapconcat 'sc::pack-one-char "12345678" "") chr2 char) - (forward-line 1) - (concat (char-to-string chr1) (char-to-string chr2)) - )) - -(defun sc::pack-one-char (dummy) - "pack following char into char, unless eolp" - (if (or (eolp) (char-equal (following-char) 32)) - (setq char (lsh char 1)) - (setq char (1+ (lsh char 1)))) - (if (not (eolp))(forward-char))) - -(provide 'sun-curs) - -;;; arch-tag: 7cc861e5-e2d9-4191-b211-2baaaab54e78 -;;; sun-curs.el ends here diff --git a/lisp/obsolete/sun-fns.el b/lisp/obsolete/sun-fns.el deleted file mode 100644 index 1b6a5d239bd..00000000000 --- a/lisp/obsolete/sun-fns.el +++ /dev/null @@ -1,644 +0,0 @@ -;;; sun-fns.el --- subroutines of Mouse handling for Sun windows - -;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. - -;; Author: Jeff Peck <peck@sun.com> -;; Maintainer: none -;; Keywords: hardware - -;; 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 3, 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Submitted Mar. 1987, Jeff Peck -;; Sun Microsystems Inc. <peck@sun.com> -;; Conceived Nov. 1986, Stan Jefferson, -;; Computer Science Lab, SRI International. -;; GoodIdeas Feb. 1987, Steve Greenbaum -;; & UpClicks Reasoning Systems, Inc. -;; -;; -;; Functions for manipulating via the mouse and mouse-map definitions -;; for accessing them. Also definitions of mouse menus. -;; This file you should freely modify to reflect you personal tastes. -;; -;; First half of file defines functions to implement mouse commands, -;; Don't delete any of those, just add what ever else you need. -;; Second half of file defines mouse bindings, do whatever you want there. - -;; -;; Mouse Functions. -;; -;; These functions follow the sun-mouse-handler convention of being called -;; with three arguments: (window x-pos y-pos) -;; This makes it easy for a mouse executed command to know where the mouse is. -;; Use the macro "eval-in-window" to execute a function -;; in a temporarily selected window. -;; -;; If you have a function that must be called with other arguments -;; bind the mouse button to an s-exp that contains the necessary parameters. -;; See "minibuffer" bindings for examples. -;; - -;;; Code: - -(require 'term/sun-mouse) - -(defconst cursor-pause-milliseconds 300 - "*Number of milliseconds to display alternate cursor (usually the mark)") - -(defun indicate-region (&optional pause) - "Bounce cursor to mark for cursor-pause-milliseconds and back again" - (or pause (setq pause cursor-pause-milliseconds)) - (let ((point (point))) - (goto-char (mark)) - (sit-for-millisecs pause) - ;(update-display) - ;(sleep-for-millisecs pause) - (goto-char point))) - - -;;; -;;; Text buffer operations -;;; -(defun mouse-move-point (window x y) - "Move point to mouse cursor." - (select-window window) - (move-to-loc x y) - (if (memq last-command ; support the mouse-copy/delete/yank - '(mouse-copy mouse-delete mouse-yank-move)) - (setq this-command 'mouse-yank-move)) - ) - -(defun mouse-set-mark (&optional window x y) - "Set mark at mouse cursor." - (eval-in-window window ;; use this to get the unwind protect - (let ((point (point))) - (move-to-loc x y) - (set-mark (point)) - (goto-char point) - (indicate-region))) - ) - -(defun mouse-set-mark-and-select (window x y) - "Set mark at mouse cursor, and select that window." - (select-window window) - (mouse-set-mark window x y) - ) - -(defun mouse-set-mark-and-stuff (w x y) - "Set mark at mouse cursor, and put region in stuff buffer." - (mouse-set-mark-and-select w x y) - (sun-select-region (region-beginning) (region-end))) - -;;; -;;; Simple mouse dragging stuff: marking with button up -;;; - -(defvar *mouse-drag-window* nil) -(defvar *mouse-drag-x* -1) -(defvar *mouse-drag-y* -1) - -(defun mouse-drag-move-point (window x y) - "Move point to mouse cursor, and allow dragging." - (mouse-move-point window x y) - (setq *mouse-drag-window* window - *mouse-drag-x* x - *mouse-drag-y* y)) - -(defun mouse-drag-set-mark-stuff (window x y) - "The up click handler that goes with mouse-drag-move-point. -If mouse is in same WINDOW but at different X or Y than when -mouse-drag-move-point was last executed, set the mark at mouse -and put the region in the stuff buffer." - (if (and (eq *mouse-drag-window* window) - (not (and (equal *mouse-drag-x* x) - (equal *mouse-drag-y* y)))) - (mouse-set-mark-and-stuff window x y) - (setq this-command last-command)) ; this was just an upclick no-op. - ) - -(defun mouse-select-or-drag-move-point (window x y) - "Select window if not selected, otherwise do mouse-drag-move-point." - (if (eq (selected-window) window) - (mouse-drag-move-point window x y) - (mouse-select-window window))) - -;;; -;;; esoterica: -;;; -(defun mouse-exch-pt-and-mark (window x y) - "Exchange point and mark." - (select-window window) - (exchange-point-and-mark) - ) - -(defun mouse-call-kbd-macro (window x y) - "Invokes last keyboard macro at mouse cursor." - (mouse-move-point window x y) - (call-last-kbd-macro) - ) - -(defun mouse-mark-thing (window x y) - "Set point and mark to text object using syntax table. -The resulting region is put in the sun-window stuff buffer. -Left or right Paren syntax marks an s-expression. -Clicking at the end of a line marks the line including a trailing newline. -If it doesn't recognize one of these it marks the character at point." - (mouse-move-point window x y) - (if (eobp) (open-line 1)) - (let* ((char (char-after (point))) - (syntax (char-syntax char))) - (cond - ((eq syntax ?w) ; word. - (forward-word 1) - (set-mark (point)) - (forward-word -1)) - ;; try to include a single following whitespace (is this a good idea?) - ;; No, not a good idea since inconsistent. - ;;(if (eq (char-syntax (char-after (mark))) ?\ ) - ;; (set-mark (1+ (mark)))) - ((eq syntax ?\( ) ; open paren. - (mark-sexp 1)) - ((eq syntax ?\) ) ; close paren. - (forward-char 1) - (mark-sexp -1) - (exchange-point-and-mark)) - ((eolp) ; mark line if at end. - (set-mark (1+ (point))) - (beginning-of-line 1)) - (t ; mark character - (set-mark (1+ (point))))) - (indicate-region)) ; display region boundary. - (sun-select-region (region-beginning) (region-end)) - ) - -(defun mouse-kill-thing (window x y) - "Kill thing at mouse, and put point there." - (mouse-mark-thing window x y) - (kill-region-and-unmark (region-beginning) (region-end)) - ) - -(defun mouse-kill-thing-there (window x y) - "Kill thing at mouse, leave point where it was. -See mouse-mark-thing for a description of the objects recognized." - (eval-in-window window - (save-excursion - (mouse-mark-thing window x y) - (kill-region (region-beginning) (region-end)))) - ) - -(defun mouse-save-thing (window x y &optional quiet) - "Put thing at mouse in kill ring. -See mouse-mark-thing for a description of the objects recognized." - (mouse-mark-thing window x y) - (copy-region-as-kill (region-beginning) (region-end)) - (if (not quiet) (message "Thing saved")) - ) - -(defun mouse-save-thing-there (window x y &optional quiet) - "Put thing at mouse in kill ring, leave point as is. -See mouse-mark-thing for a description of the objects recognized." - (eval-in-window window - (save-excursion - (mouse-save-thing window x y quiet)))) - -;;; -;;; Mouse yanking... -;;; -(defun mouse-copy-thing (window x y) - "Put thing at mouse in kill ring, yank to point. -See mouse-mark-thing for a description of the objects recognized." - (setq last-command 'not-kill) ;Avoids appending to previous kills. - (mouse-save-thing-there window x y t) - (yank) - (setq this-command 'yank)) - -(defun mouse-move-thing (window x y) - "Kill thing at mouse, yank it to point. -See mouse-mark-thing for a description of the objects recognized." - (setq last-command 'not-kill) ;Avoids appending to previous kills. - (mouse-kill-thing-there window x y) - (yank) - (setq this-command 'yank)) - -(defun mouse-yank-at-point (&optional window x y) - "Yank from kill-ring at point; then cycle thru kill ring." - (if (eq last-command 'yank) - (let ((before (< (point) (mark)))) - (delete-region (point) (mark)) - (insert (current-kill 1)) - (if before (exchange-point-and-mark))) - (yank)) - (setq this-command 'yank)) - -(defun mouse-yank-at-mouse (window x y) - "Yank from kill-ring at mouse; then cycle thru kill ring." - (mouse-move-point window x y) - (mouse-yank-at-point window x y)) - -(defun mouse-save/delete/yank (&optional window x y) - "Context sensitive save/delete/yank. -Consecutive clicks perform as follows: - * first click saves region to kill ring, - * second click kills region, - * third click yanks from kill ring, - * subsequent clicks cycle thru kill ring. -If mouse-move-point is performed after the first or second click, -the next click will do a yank, etc. Except for a possible mouse-move-point, -this command is insensitive to mouse location." - (cond - ((memq last-command '(mouse-delete yank mouse-yank-move)) ; third+ click - (mouse-yank-at-point)) - ((eq last-command 'mouse-copy) ; second click - (kill-region (region-beginning) (region-end)) - (setq this-command 'mouse-delete)) - (t ; first click - (copy-region-as-kill (region-beginning) (region-end)) - (message "Region saved") - (setq this-command 'mouse-copy)) - )) - - -(defun mouse-split-horizontally (window x y) - "Splits the window horizontally at mouse cursor." - (eval-in-window window (split-window-horizontally (1+ x)))) - -(defun mouse-split-vertically (window x y) - "Split the window vertically at the mouse cursor." - (eval-in-window window (split-window-vertically (1+ y)))) - -(defun mouse-select-window (&optional window x y) - "Selects the window, restoring point." - (select-window window)) - -(defun mouse-delete-other-windows (&optional window x y) - "Deletes all windows except the one mouse is in." - (delete-other-windows window)) - -(defun mouse-delete-window (window &optional x y) - "Deletes the window mouse is in." - (delete-window window)) - -(defun mouse-undo (window x y) - "Invokes undo in the window mouse is in." - (eval-in-window window (undo))) - -;;; -;;; Scroll operations -;;; - -;;; The move-to-window-line is used below because otherwise -;;; scrolling a non-selected process window with the mouse, after -;;; the process has written text past the bottom of the window, -;;; gives an "End of buffer" error, and then scrolls. The -;;; move-to-window-line seems to force recomputing where things are. -(defun mouse-scroll-up (window x y) - "Scrolls the window upward." - (eval-in-window window (move-to-window-line 1) (scroll-up nil))) - -(defun mouse-scroll-down (window x y) - "Scrolls the window downward." - (eval-in-window window (scroll-down nil))) - -(defun mouse-scroll-proportional (window x y) - "Scrolls the window proportionally corresponding to window -relative X divided by window width." - (eval-in-window window - (if (>= x (1- (window-width))) - ;; When x is maximum (equal to or 1 less than window width), - ;; goto end of buffer. We check for this special case - ;; because the calculated goto-char often goes short of the - ;; end due to roundoff error, and we often really want to go - ;; to the end. - (goto-char (point-max)) - (progn - (goto-char (+ (point-min) ; For narrowed regions. - (* x (/ (- (point-max) (point-min)) - (1- (window-width)))))) - (beginning-of-line)) - ) - (what-cursor-position) ; Report position. - )) - -(defun mouse-line-to-top (window x y) - "Scrolls the line at the mouse cursor up to the top." - (eval-in-window window (scroll-up y))) - -(defun mouse-top-to-line (window x y) - "Scrolls the top line down to the mouse cursor." - (eval-in-window window (scroll-down y))) - -(defun mouse-line-to-bottom (window x y) - "Scrolls the line at the mouse cursor to the bottom." - (eval-in-window window (scroll-up (+ y (- 2 (window-height)))))) - -(defun mouse-bottom-to-line (window x y) - "Scrolls the bottom line up to the mouse cursor." - (eval-in-window window (scroll-down (+ y (- 2 (window-height)))))) - -(defun mouse-line-to-middle (window x y) - "Scrolls the line at the mouse cursor to the middle." - (eval-in-window window (scroll-up (- y -1 (/ (window-height) 2))))) - -(defun mouse-middle-to-line (window x y) - "Scrolls the line at the middle to the mouse cursor." - (eval-in-window window (scroll-up (- (/ (window-height) 2) y 1)))) - - -;;; -;;; main emacs menu. -;;; -(defmenu expand-menu - ("Vertically" mouse-expand-vertically *menu-window*) - ("Horizontally" mouse-expand-horizontally *menu-window*)) - -(defmenu delete-window-menu - ("This One" delete-window *menu-window*) - ("All Others" delete-other-windows *menu-window*)) - -(defmenu mouse-help-menu - ("Text Region" - mouse-help-region *menu-window* *menu-x* *menu-y* 'text) - ("Scrollbar" - mouse-help-region *menu-window* *menu-x* *menu-y* 'scrollbar) - ("Modeline" - mouse-help-region *menu-window* *menu-x* *menu-y* 'modeline) - ("Minibuffer" - mouse-help-region *menu-window* *menu-x* *menu-y* 'minibuffer) - ) - -(defmenu emacs-quit-menu - ("Quit" save-buffers-kill-emacs)) - -(defmenu emacs-menu - ("Emacs Menu") - ("Stuff Selection" sun-yank-selection) - ("Expand" . expand-menu) - ("Delete Window" . delete-window-menu) - ("Previous Buffer" mouse-select-previous-buffer *menu-window*) - ("Save Buffers" save-some-buffers) - ("List Directory" list-directory nil) - ("Dired" dired nil) - ("Mouse Help" . mouse-help-menu) - ("Quit" . emacs-quit-menu)) - -(defun emacs-menu-eval (window x y) - "Pop-up menu of editor commands." - (sun-menu-evaluate window (1+ x) (1- y) 'emacs-menu)) - -(defun mouse-expand-horizontally (window) - (eval-in-window window - (enlarge-window 4 t) - (update-display) ; Try to redisplay, since can get confused. - )) - -(defun mouse-expand-vertically (window) - (eval-in-window window (enlarge-window 4))) - -(defun mouse-select-previous-buffer (window) - "Switch buffer in mouse window to most recently selected buffer." - (eval-in-window window (switch-to-buffer (other-buffer)))) - -;;; -;;; minibuffer menu -;;; -(defmenu minibuffer-menu - ("Minibuffer" message "Just some miscellaneous minibuffer commands") - ("Stuff" sun-yank-selection) - ("Do-It" exit-minibuffer) - ("Abort" abort-recursive-edit) - ("Suspend" suspend-emacs)) - -(defun minibuffer-menu-eval (window x y) - "Pop-up menu of commands." - (sun-menu-evaluate window x (1- y) 'minibuffer-menu)) - -(defun mini-move-point (window x y) - ;; -6 is good for most common cases - (mouse-move-point window (- x 6) 0)) - -(defun mini-set-mark-and-stuff (window x y) - ;; -6 is good for most common cases - (mouse-set-mark-and-stuff window (- x 6) 0)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Buffer-mode Mouse commands -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun Buffer-at-mouse (w x y) - "Calls Buffer-menu-buffer from mouse click." - (save-window-excursion - (mouse-move-point w x y) - (beginning-of-line) - (Buffer-menu-buffer t))) - -(defun mouse-buffer-bury (w x y) - "Bury the indicated buffer." - (bury-buffer (Buffer-at-mouse w x y)) - ) - -(defun mouse-buffer-select (w x y) - "Put the indicated buffer in selected window." - (switch-to-buffer (Buffer-at-mouse w x y)) - (list-buffers) - ) - -(defun mouse-buffer-delete (w x y) - "mark indicated buffer for delete" - (save-window-excursion - (mouse-move-point w x y) - (Buffer-menu-delete) - )) - -(defun mouse-buffer-execute (w x y) - "execute buffer-menu selections" - (save-window-excursion - (mouse-move-point w x y) - (Buffer-menu-execute) - )) - -(defun enable-mouse-in-buffer-list () - "Call this to enable mouse selections in *Buffer List* - LEFT puts the indicated buffer in the selected window. - MIDDLE buries the indicated buffer. - RIGHT marks the indicated buffer for deletion. - MIDDLE-RIGHT deletes the marked buffers. -To unmark a buffer marked for deletion, select it with LEFT." - (save-window-excursion - (list-buffers) ; Initialize *Buffer List* - (set-buffer "*Buffer List*") - (local-set-mouse '(text middle) 'mouse-buffer-bury) - (local-set-mouse '(text left) 'mouse-buffer-select) - (local-set-mouse '(text right) 'mouse-buffer-delete) - (local-set-mouse '(text middle right) 'mouse-buffer-execute) - ) - ) - - -;;;******************************************************************* -;;; -;;; Global Mouse Bindings. -;;; -;;; There is some sense to this mouse binding madness: -;;; LEFT and RIGHT scrolls are inverses. -;;; SHIFT makes an opposite meaning in the scroll bar. -;;; SHIFT is an alternative to DOUBLE (but double chords do not exist). -;;; META makes the scrollbar functions work in the text region. -;;; MIDDLE operates the mark -;;; LEFT operates at point - -;;; META commands are generally non-destructive, -;;; SHIFT is a little more dangerous. -;;; CONTROL is for the really complicated ones. - -;;; CONTROL-META-SHIFT-RIGHT gives help on that region. - -;;; -;;; Text Region mousemap -;;; -;; The basics: Point, Mark, Menu, Sun-Select: -(global-set-mouse '(text left) 'mouse-drag-move-point) -(global-set-mouse '(text up left) 'mouse-drag-set-mark-stuff) -(global-set-mouse '(text shift left) 'mouse-exch-pt-and-mark) -(global-set-mouse '(text double left) 'mouse-exch-pt-and-mark) - -(global-set-mouse '(text middle) 'mouse-set-mark-and-stuff) - -(global-set-mouse '(text right) 'emacs-menu-eval) -(global-set-mouse '(text shift right) '(sun-yank-selection)) -(global-set-mouse '(text double right) '(sun-yank-selection)) - -;; The Slymoblics multi-command for Save, Kill, Copy, Move: -(global-set-mouse '(text shift middle) 'mouse-save/delete/yank) -(global-set-mouse '(text double middle) 'mouse-save/delete/yank) - -;; Save, Kill, Copy, Move Things: -;; control-left composes with control middle/right to produce copy/move -(global-set-mouse '(text control middle ) 'mouse-save-thing-there) -(global-set-mouse '(text control right ) 'mouse-kill-thing-there) -(global-set-mouse '(text control left) 'mouse-yank-at-point) -(global-set-mouse '(text control middle left) 'mouse-copy-thing) -(global-set-mouse '(text control right left) 'mouse-move-thing) -(global-set-mouse '(text control right middle) 'mouse-mark-thing) - -;; The Universal mouse help command (press all buttons): -(global-set-mouse '(text shift control meta right) 'mouse-help-region) -(global-set-mouse '(text double control meta right) 'mouse-help-region) - -;;; Meta in Text Region is like meta version in scrollbar: -(global-set-mouse '(text meta left) 'mouse-line-to-top) -(global-set-mouse '(text meta shift left) 'mouse-line-to-bottom) -(global-set-mouse '(text meta double left) 'mouse-line-to-bottom) -(global-set-mouse '(text meta middle) 'mouse-line-to-middle) -(global-set-mouse '(text meta shift middle) 'mouse-middle-to-line) -(global-set-mouse '(text meta double middle) 'mouse-middle-to-line) -(global-set-mouse '(text meta control middle) 'mouse-split-vertically) -(global-set-mouse '(text meta right) 'mouse-top-to-line) -(global-set-mouse '(text meta shift right) 'mouse-bottom-to-line) -(global-set-mouse '(text meta double right) 'mouse-bottom-to-line) - -;; Miscellaneous: -(global-set-mouse '(text meta control left) 'mouse-call-kbd-macro) -(global-set-mouse '(text meta control right) 'mouse-undo) - -;;; -;;; Scrollbar mousemap. -;;; Are available in the Scrollbar Region, or with Meta Text (or Meta Scrollbar) -;;; -(global-set-mouse '(scrollbar left) 'mouse-line-to-top) -(global-set-mouse '(scrollbar shift left) 'mouse-line-to-bottom) -(global-set-mouse '(scrollbar double left) 'mouse-line-to-bottom) - -(global-set-mouse '(scrollbar middle) 'mouse-line-to-middle) -(global-set-mouse '(scrollbar shift middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar double middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar control middle) 'mouse-split-vertically) - -(global-set-mouse '(scrollbar right) 'mouse-top-to-line) -(global-set-mouse '(scrollbar shift right) 'mouse-bottom-to-line) -(global-set-mouse '(scrollbar double right) 'mouse-bottom-to-line) - -(global-set-mouse '(scrollbar meta left) 'mouse-line-to-top) -(global-set-mouse '(scrollbar meta shift left) 'mouse-line-to-bottom) -(global-set-mouse '(scrollbar meta double left) 'mouse-line-to-bottom) -(global-set-mouse '(scrollbar meta middle) 'mouse-line-to-middle) -(global-set-mouse '(scrollbar meta shift middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar meta double middle) 'mouse-middle-to-line) -(global-set-mouse '(scrollbar meta control middle) 'mouse-split-vertically) -(global-set-mouse '(scrollbar meta right) 'mouse-top-to-line) -(global-set-mouse '(scrollbar meta shift right) 'mouse-bottom-to-line) -(global-set-mouse '(scrollbar meta double right) 'mouse-bottom-to-line) - -;; And the help menu: -(global-set-mouse '(scrollbar shift control meta right) 'mouse-help-region) -(global-set-mouse '(scrollbar double control meta right) 'mouse-help-region) - -;;; -;;; Modeline mousemap. -;;; -;;; Note: meta of any single button selects window. - -(global-set-mouse '(modeline left) 'mouse-scroll-up) -(global-set-mouse '(modeline meta left) 'mouse-select-window) - -(global-set-mouse '(modeline middle) 'mouse-scroll-proportional) -(global-set-mouse '(modeline meta middle) 'mouse-select-window) -(global-set-mouse '(modeline control middle) 'mouse-split-horizontally) - -(global-set-mouse '(modeline right) 'mouse-scroll-down) -(global-set-mouse '(modeline meta right) 'mouse-select-window) - -;;; control-left selects this window, control-right deletes it. -(global-set-mouse '(modeline control left) 'mouse-delete-other-windows) -(global-set-mouse '(modeline control right) 'mouse-delete-window) - -;; in case of confusion, just select it: -(global-set-mouse '(modeline control left right)'mouse-select-window) - -;; even without confusion (and without the keyboard) select it: -(global-set-mouse '(modeline left right) 'mouse-select-window) - -;; And the help menu: -(global-set-mouse '(modeline shift control meta right) 'mouse-help-region) -(global-set-mouse '(modeline double control meta right) 'mouse-help-region) - -;;; -;;; Minibuffer Mousemap -;;; Demonstrating some variety: -;;; -(global-set-mouse '(minibuffer left) 'mini-move-point) - -(global-set-mouse '(minibuffer middle) 'mini-set-mark-and-stuff) - -(global-set-mouse '(minibuffer shift middle) '(select-previous-complex-command)) -(global-set-mouse '(minibuffer double middle) '(select-previous-complex-command)) -(global-set-mouse '(minibuffer control middle) '(next-complex-command 1)) -(global-set-mouse '(minibuffer meta middle) '(previous-complex-command 1)) - -(global-set-mouse '(minibuffer right) 'minibuffer-menu-eval) - -(global-set-mouse '(minibuffer shift control meta right) 'mouse-help-region) -(global-set-mouse '(minibuffer double control meta right) 'mouse-help-region) - -(provide 'sun-fns) - -;;; arch-tag: 1c4c1192-f71d-4d5f-b883-ae659c28e132 -;;; sun-fns.el ends here diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index b5dde4323d0..5f2a76e1328 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -402,7 +402,7 @@ static unsigned char gamegrid_bits[] = { (defun gamegrid-start-timer (period func) (setq gamegrid-timer - (if (featurep 'itimer) + (if (featurep 'xemacs) (start-itimer "Gamegrid" func period @@ -427,7 +427,7 @@ static unsigned char gamegrid_bits[] = { (defun gamegrid-kill-timer () (if gamegrid-timer - (if (featurep 'itimer) + (if (featurep 'xemacs) (delete-itimer gamegrid-timer) (cancel-timer gamegrid-timer))) (setq gamegrid-timer nil)) diff --git a/lisp/printing.el b/lisp/printing.el index 245d21d7de5..6de22743c97 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -1674,7 +1674,7 @@ separator; otherwise, ensure unix-style directory separator." :tag "Printing Utilities" :link '(emacs-library-link :tag "Source Lisp File" "printing.el") :prefix "pr-" - :version "20" + :version "22.1" :group 'wp :group 'postscript) @@ -1694,7 +1694,6 @@ Valid values are: :type '(choice :tag "Path style" (const :tag "Windows 9x/NT Style (\\)" :value windows) (const :tag "Unix Style (/)" :value unix)) - :version "20" :group 'printing) @@ -1773,7 +1772,6 @@ Examples: :tag "Directory" (string :value "") (symbol :value symbol))))) - :version "20" :group 'printing) @@ -1788,7 +1786,6 @@ modified by other means (for example, a lisp function), use `pr-update-menus' function (see it for documentation) to update text printer menu." :type 'symbol :set 'pr-txt-name-custom-set - :version "20" :group 'printing) @@ -1921,7 +1918,6 @@ Useful links: (const :tag "None" nil) string))) :set 'pr-alist-custom-set - :version "20" :group 'printing) @@ -1936,7 +1932,6 @@ modified by other means (for example, a lisp function), use `pr-update-menus' function (see it for documentation) to update PostScript printer menu." :type 'symbol :set 'pr-ps-name-custom-set - :version "20" :group 'printing) @@ -2209,7 +2204,6 @@ Useful links: (sexp :tag "Value"))) )) :set 'pr-alist-custom-set - :version "20" :group 'printing) @@ -2228,7 +2222,6 @@ Useful links: See also `pr-ps-temp-file' and `pr-file-modes'." :type '(directory :tag "Temporary Directory") - :version "20" :group 'printing) @@ -2237,7 +2230,6 @@ See also `pr-ps-temp-file' and `pr-file-modes'." See also `pr-temp-dir' and `pr-file-modes'." :type '(file :tag "PostScript Temporary File Name") - :version "21" :group 'printing) @@ -2251,7 +2243,6 @@ It should be an integer; only the low 9 bits are used. See also `pr-temp-dir' and `pr-ps-temp-file'." :type '(integer :tag "File Permission Bits") - :version "21.3" :group 'printing) @@ -2293,7 +2284,6 @@ Useful links: `http://www.cs.wisc.edu/~ghost/macos/index.htm' " :type '(string :tag "Ghostview Utility") - :version "20" :group 'printing) @@ -2320,7 +2310,6 @@ Useful links: `http://www.cs.wisc.edu/~ghost/doc/printer.htm' " :type '(string :tag "Ghostscript Utility") - :version "20" :group 'printing) @@ -2363,7 +2352,6 @@ Useful links: `http://www.cs.wisc.edu/~ghost/doc/printer.htm' " :type '(repeat (string :tag "Ghostscript Switch")) - :version "20" :group 'printing) @@ -2380,7 +2368,6 @@ A note on the gs switches: See `pr-gs-switches' for documentation. See also `pr-ps-printer-alist'." :type '(string :tag "Ghostscript Device") - :version "20" :group 'printing) @@ -2394,7 +2381,6 @@ A note on the gs switches: See `pr-gs-switches' for documentation. See also `pr-ps-printer-alist'." :type '(integer :tag "Ghostscript Resolution") - :version "20" :group 'printing) @@ -2407,35 +2393,30 @@ ghostscript to print a PostScript file. In GNU or Unix system, if ghostscript is set as a PostScript filter, this variable should be nil." :type 'boolean - :version "20" :group 'printing) (defcustom pr-faces-p nil "*Non-nil means print with face attributes." :type 'boolean - :version "20" :group 'printing) (defcustom pr-spool-p nil "*Non-nil means spool printing in a buffer." :type 'boolean - :version "20" :group 'printing) (defcustom pr-file-landscape nil "*Non-nil means print PostScript file in landscape orientation." :type 'boolean - :version "20" :group 'printing) (defcustom pr-file-duplex nil "*Non-nil means print PostScript file in duplex mode." :type 'boolean - :version "20" :group 'printing) @@ -2447,7 +2428,6 @@ right. If tumble is on, produces a printing suitable for binding at the top or bottom." :type 'boolean - :version "20" :group 'printing) @@ -2460,7 +2440,6 @@ When this variable is non-nil, the `*-buffer*' commands will behave like `*-region*' commands, that is, `*-buffer*' commands will print only the region marked instead of all buffer." :type 'boolean - :version "20" :group 'printing) @@ -2472,7 +2451,6 @@ and `*-region*' commands will behave like `*-mode*' commands; otherwise, `*-buffer*' commands will print the current buffer and `*-region*' commands will print the current region." :type 'boolean - :version "20" :group 'printing) @@ -2673,7 +2651,6 @@ DEFAULT It's a way to set default values when this entry is selected. (variable :tag "Other")) (sexp :tag "Value"))) )) - :version "20" :group 'printing) @@ -2691,7 +2668,6 @@ NOTE: Don't forget to download and install the utilities declared on `pr-ps-utility-alist'." :type '(symbol :tag "PS File Utility") :set 'pr-ps-utility-custom-set - :version "20" :group 'printing) @@ -2904,7 +2880,6 @@ Useful links: (sexp :tag "Value"))) )) :set 'pr-alist-custom-set - :version "20" :group 'printing) @@ -2913,7 +2888,6 @@ Useful links: See also `pr-menu-char-height' and `pr-menu-char-width'." :type 'boolean - :version "20" :group 'printing) @@ -2925,7 +2899,6 @@ menu, so don't forget to adjust it if menu position is not ok. See also `pr-menu-lock' and `pr-menu-char-width'." :type 'integer - :version "20" :group 'printing) @@ -2937,7 +2910,6 @@ menu, so don't forget to adjust it if menu position is not ok. See also `pr-menu-lock' and `pr-menu-char-height'." :type 'integer - :version "20" :group 'printing) @@ -3054,7 +3026,6 @@ SETTING It's a cons like: (variable :tag "Other")) (sexp :tag "Value"))) )) - :version "20" :group 'printing) @@ -3108,7 +3079,6 @@ Any other value is ignored." (const postscript-process) (const printing) (const help))) - :version "20" :group 'printing) @@ -3120,7 +3090,6 @@ happens when printing: Error: could not open \"c:\\temp\\prspool.ps\" for reading." :type 'boolean - :version "20" :group 'printing) @@ -3134,7 +3103,6 @@ It's used by `pr-ps-directory-preview', `pr-ps-directory-using-ghostscript', `pr-ps-directory-print', `pr-ps-directory-ps-print', `pr-printify-directory' and `pr-txt-directory'." :type 'boolean - :version "20" :group 'printing) @@ -3143,7 +3111,6 @@ and `pr-txt-directory'." It's used by `pr-interface'." :type 'string - :version "20" :group 'printing) @@ -3157,7 +3124,6 @@ NOTE: Case is important for matching, that is, `case-fold-search' is always It's used by `pr-interface'." :type '(repeat (regexp :tag "Buffer Name Regexp")) - :version "20" :group 'printing) @@ -3166,7 +3132,6 @@ It's used by `pr-interface'." It's used by `pr-interface'." :type 'boolean - :version "20" :group 'printing) diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 5a69df4e457..935cba76fcf 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -395,8 +395,8 @@ Don't use within `eval-when-compile'." (defun cc-bytecomp-ignore-obsolete (form) ;; Wraps a call to `byte-compile-obsolete' that suppresses the warning. - (let ((byte-compile-warnings - (delq 'obsolete (append byte-compile-warnings nil)))) + (let ((byte-compile-warnings byte-compile-warnings)) + (byte-compile-disable-warning 'obsolete) (byte-compile-obsolete form))) (defmacro cc-bytecomp-obsolete-fun (symbol) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index e932456fa91..f6adfb8cef9 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -73,9 +73,9 @@ ; (eval-after-load "font-lock" ; 2006-07-09. font-lock is now preloaded ; ' -(if (and (not (featurep 'cc-fix)) ; only load the file once. - (featurep 'xemacs) ; There is now (2005/12) code in GNU Emacs CVS +(if (and (featurep 'xemacs) ; There is now (2005/12) code in GNU Emacs CVS ; to make the call to f-l-c-k throw an error. + (not (featurep 'cc-fix)) ; only load the file once. (let (font-lock-keywords) (font-lock-compile-keywords '("\\<\\>")) font-lock-keywords)) ; did the previous call foul this up? @@ -84,8 +84,8 @@ ;; The above takes care of the delayed loading, but this is necessary ;; to ensure correct byte compilation. (eval-when-compile - (if (and (not (featurep 'cc-fix)) - (featurep 'xemacs) + (if (and (featurep 'xemacs) + (not (featurep 'cc-fix)) (progn (require 'font-lock) (let (font-lock-keywords) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index d030110d85a..13f1e0c24b8 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -78,9 +78,8 @@ (condition-case nil (require 'man) (error nil)) - (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) (defvar cperl-can-font-lock - (or cperl-xemacs-p + (or (featurep 'xemacs) (and (boundp 'emacs-major-version) (or window-system (> emacs-major-version 20))))) @@ -131,14 +130,14 @@ (cperl-make-face ,arg ,descr)) (or (boundp (quote ,arg)) ; We use unquoted variants too (defvar ,arg (quote ,arg) ,descr)))) - (if cperl-xemacs-p + (if (featurep 'xemacs) (defmacro cperl-etags-snarf-tag (file line) `(progn (beginning-of-line 2) (list ,file ,line))) (defmacro cperl-etags-snarf-tag (file line) `(etags-snarf-tag))) - (if cperl-xemacs-p + (if (featurep 'xemacs) (defmacro cperl-etags-goto-tag-location (elt) ;;(progn ;; (switch-to-buffer (get-file-buffer (elt ,elt 0))) @@ -151,10 +150,8 @@ (defmacro cperl-etags-goto-tag-location (elt) `(etags-goto-tag-location ,elt)))) -(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) - (defvar cperl-can-font-lock - (or cperl-xemacs-p + (or (featurep 'xemacs) (and (boundp 'emacs-major-version) (or window-system (> emacs-major-version 20))))) @@ -458,7 +455,7 @@ Font for POD headers." :group 'cperl-faces) ;;; Some double-evaluation happened with font-locks... Needed with 21.2... -(defvar cperl-singly-quote-face cperl-xemacs-p) +(defvar cperl-singly-quote-face (featurep 'xemacs)) (defcustom cperl-invalid-face 'underline "*Face for highlighting trailing whitespace." @@ -1011,7 +1008,7 @@ In regular expressions (except character classes): (defmacro cperl-define-key (emacs-key definition &optional xemacs-key) `(define-key cperl-mode-map ,(if xemacs-key - `(if cperl-xemacs-p ,xemacs-key ,emacs-key) + `(if (featurep 'xemacs) ,xemacs-key ,emacs-key) emacs-key) ,definition)) @@ -1024,7 +1021,7 @@ In regular expressions (except character classes): (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) (defun cperl-mark-active () (mark)) ; Avoid undefined warning -(if cperl-xemacs-p +(if (featurep 'xemacs) (progn ;; "Active regions" are on: use region only if active ;; "Active regions" are off: use region unconditionally @@ -1040,7 +1037,7 @@ In regular expressions (except character classes): (defun cperl-putback-char (c) ; Emacs 19 (set 'unread-command-events (list c))) ; Avoid undefined warning -(if cperl-xemacs-p +(if (featurep 'xemacs) (defun cperl-putback-char (c) ; XEmacs >= 19.12 (setq unread-command-events (list (eval '(character-to-event c)))))) @@ -1192,7 +1189,7 @@ versions of Emacs." ;;(concat (char-to-string help-char) "v") ; does not work 'cperl-get-help [(control c) (control h) v])) - (if (and cperl-xemacs-p + (if (and (featurep 'xemacs) (<= emacs-minor-version 11) (<= emacs-major-version 19)) (progn ;; substitute-key-definition is usefulness-deenhanced... @@ -1744,7 +1741,7 @@ or as help on variables `cperl-tips', `cperl-problems', (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) - (if cperl-xemacs-p + (if (featurep 'xemacs) (progn (make-local-variable 'paren-backwards-message) (set 'paren-backwards-message t))) @@ -1835,7 +1832,7 @@ or as help on variables `cperl-tips', `cperl-problems', (or (boundp 'font-lock-unfontify-region-function) (set 'font-lock-unfontify-region-function 'font-lock-default-unfontify-region)) - (unless cperl-xemacs-p ; Our: just a plug for wrong font-lock + (unless (featurep 'xemacs) ; Our: just a plug for wrong font-lock (make-local-variable 'font-lock-unfontify-region-function) (set 'font-lock-unfontify-region-function ; not present with old Emacs 'cperl-font-lock-unfontify-region-function)) @@ -5854,7 +5851,7 @@ indentation and initial hashes. Behaves usually outside of comment." (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock ;; not yet as of XEmacs 19.12, works with 21.1.11 (or - (not cperl-xemacs-p) + (not (featurep 'xemacs)) (string< "21.1.9" emacs-version) (and (string< "21.1.10" emacs-version) (string< emacs-version "21.1.2"))) @@ -6015,7 +6012,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; (defconst cperl-nonoverridable-face ;; 'cperl-nonoverridable-face ;; "Face to use for data types from another group.")) - ;;(if (not cperl-xemacs-p) nil + ;;(if (not (featurep 'xemacs)) nil ;; (or (boundp 'font-lock-comment-face) ;; (defconst font-lock-comment-face ;; 'font-lock-comment-face @@ -6964,7 +6961,7 @@ Use as (save-excursion (cond (inbuffer nil) ; Already there ((file-exists-p tags-file-name) - (if cperl-xemacs-p + (if (featurep 'xemacs) (visit-tags-table-buffer) (visit-tags-table-buffer tags-file-name))) (t (set-buffer (find-file-noselect tags-file-name)))) @@ -7100,7 +7097,7 @@ One may build such TAGS files from CPerl mode menu." pack name cons1 to l1 l2 l3 l4 b) ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! (setq cperl-hierarchy (list l1 l2 l3)) - (if cperl-xemacs-p ; Not checked + (if (featurep 'xemacs) ; Not checked (progn (or tags-file-name ;; Does this work in XEmacs? @@ -8451,7 +8448,7 @@ the appropriate statement modifier." 'variable-documentation)))) (manual-program (if is-func "perldoc -f" "perldoc"))) (cond - (cperl-xemacs-p + ((featurep 'xemacs) (let ((Manual-program "perldoc") (Manual-switches (if is-func (list "-f")))) (manual-entry word))) @@ -8493,7 +8490,7 @@ the appropriate statement modifier." (interactive) (require 'man) (cond - (cperl-xemacs-p + ((featurep 'xemacs) (let ((Manual-program "perldoc")) (manual-entry buffer-file-name))) (t @@ -8689,6 +8686,8 @@ start with default arguments, then refine the slowdown regions." (message "to %s:%6s,%7s" l delta tot)) tot)) +(defvar font-lock-cache-position) + (defun cperl-emulate-lazy-lock (&optional window-size) "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works. Start fontifying the buffer from the start (or end) using the given diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 275773049e7..302fa6567bc 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -277,8 +277,9 @@ One argument, the tag info returned by `snarf-tag-function'.") (defun tags-table-mode () "Major mode for tags table file buffers." (interactive) - (setq major-mode 'tags-table-mode) - (setq mode-name "Tags Table") + (setq major-mode 'tags-table-mode + mode-name "Tags Table" + buffer-undo-list t) (initialize-new-tags-table)) ;;;###autoload diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 49cfa504b89..29ffbcfe6b1 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -540,7 +540,7 @@ and variable-name parts, respectively." ;; TODO ? actually check for balanced parens in that case. '("^[ \t0-9]*\\(?:pure\\|elemental\\)?[ \t]*\ \\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|\ -enumerator\\|generic\\|procedure\\|logical\\|double[ \t]*precision\\|type[ \t]*(\\sw+)\\)\ +enumerator\\|generic\\|procedure\\|logical\\|double[ \t]*precision\\)\ \\(.*::\\|[ \t]*(.*)\\)?\\([^&!\n]*\\)" (1 font-lock-type-face t) (4 font-lock-variable-name-face t)) ;; Derived type/class variables. @@ -1508,7 +1508,7 @@ Return (TYPE NAME), or nil if not found." Return (TYPE NAME), or nil if not found." (interactive) (let ((case-fold-search t) - (count 1) + (count 1) matching-end) (end-of-line) (while (and (> count 0) diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 9ce55c27780..43cb61cba6b 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -59,7 +59,8 @@ (defvar gud-find-expr-function) (defvar imenu-case-fold-search) (defvar imenu-syntax-alist) - +(defvar comment-region-function) +(defvar uncomment-region-function) (defgroup fortran nil "Major mode for editing fixed format Fortran code." @@ -100,7 +101,7 @@ with a character in column 6." "String to appear in mode line in TAB format buffers." :type 'string :group 'fortran-indent) -(put 'fortran-tab-mode-string 'safe-local-variable 'stringp) +(put 'fortran-tab-mode-string 'risky-local-variable t) (defcustom fortran-do-indent 3 "Extra indentation applied to DO blocks." @@ -593,7 +594,8 @@ Used in the Fortran entry in `hs-special-modes-alist'.") (let ((map (make-sparse-keymap))) (define-key map ";" 'fortran-abbrev-start) (define-key map "\C-c;" 'fortran-comment-region) - (define-key map "\M-;" 'fortran-indent-comment) + ;; The default comment-dwim does at least as much as this. +;;; (define-key map "\M-;" 'fortran-indent-comment) (define-key map "\M-\n" 'fortran-split-line) (define-key map "\M-\C-n" 'fortran-end-of-block) (define-key map "\M-\C-p" 'fortran-beginning-of-block) @@ -841,6 +843,11 @@ with no args, if that value is non-nil." ;; (concat "\\(\\)\\(![ \t]*\\|" fortran-comment-line-start-skip "\\)") "\\(\\)\\(?:^[CcDd*]\\|!\\)\\(?:\\([^ \t\n]\\)\\2+\\)?[ \t]*") (set (make-local-variable 'comment-indent-function) 'fortran-comment-indent) + (set (make-local-variable 'comment-region-function) 'fortran-comment-region) + (set (make-local-variable 'uncomment-region-function) + 'fortran-uncomment-region) + (set (make-local-variable 'comment-insert-comment-function) + 'fortran-indent-comment) (set (make-local-variable 'abbrev-all-caps) t) (set (make-local-variable 'normal-auto-fill-function) 'fortran-auto-fill) (set (make-local-variable 'indent-tabs-mode) (fortran-analyze-file-format)) @@ -981,6 +988,11 @@ With non-nil ARG, uncomments the region." (set-marker end-region-mark nil) (set-marker save-point nil))) +;; uncomment-region calls this with 3 args. +(defun fortran-uncomment-region (start end &optional ignored) + "Uncomment every line in the region." + (fortran-comment-region start end t)) + (defun fortran-abbrev-start () "Typing ;\\[help-command] or ;? lists all the Fortran abbrevs. diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el index c6ae98c5b12..0d1a4b05d65 100644 --- a/lisp/progmodes/gdb-ui.el +++ b/lisp/progmodes/gdb-ui.el @@ -947,6 +947,12 @@ Changed values are highlighted with the face `font-lock-warning-face'." :group 'gud :version "22.1") +(defcustom gdb-delete-out-of-scope t + "If non-nil delete watch expressions automatically when they go out of scope." + :type 'boolean + :group 'gud + :version "22.2") + (defun gdb-speedbar-expand-node (text token indent) "Expand the node the user clicked on. TEXT is the text of the button we clicked on, a + or - item. @@ -3515,7 +3521,9 @@ in_scope=\"\\(.*?\\)\".*?}") (when var (let ((match (match-string 3))) (cond ((string-equal match "false") - (setcar (nthcdr 5 var) 'out-of-scope)) + (if gdb-delete-out-of-scope + (gdb-var-delete-1 varnum) + (setcar (nthcdr 5 var) 'out-of-scope))) ((string-equal match "true") (setcar (nthcdr 5 var) 'changed) (setcar (nthcdr 4 var) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 50dcd6a83bf..ce231f4c662 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -709,25 +709,14 @@ The option \"--fullname\" must be included in this value." (defvar gud-filter-pending-text nil "Non-nil means this is text that has been saved for later in `gud-filter'.") -;; The old gdb command. The new one is in gdb-ui.el. +;; The old gdb command (text command mode). The new one is in gdb-ui.el. ;;;###autoload (defun gud-gdb (command-line) "Run gdb on program FILE in buffer *gud-FILE*. The directory containing FILE becomes the initial working -directory and source-file directory for your debugger. By -default this command starts GDB using a graphical interface. See -`gdba' for more information. - -To run GDB in text command mode, replace the GDB \"--annotate=3\" -option with \"--fullname\" either in the minibuffer for the -current Emacs session, or the custom variable -`gud-gdb-command-name' for all future sessions. You need to use -text command mode to debug multiple programs within one Emacs -session." +directory and source-file directory for your debugger." (interactive (list (gud-query-cmdline 'gud-gdb))) - (require 'gdb-ui) - (when (and gud-comint-buffer (buffer-name gud-comint-buffer) (get-buffer-process gud-comint-buffer) @@ -736,8 +725,8 @@ session." (error "Multiple debugging requires restarting in text command mode")) - (gud-common-init command-line nil 'gud-gdba-marker-filter) - (set (make-local-variable 'gud-minor-mode) 'gdba) + (gud-common-init command-line nil 'gud-gdb-marker-filter) + (set (make-local-variable 'gud-minor-mode) 'gdb) (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") (gud-def gud-tbreak "tbreak %f:%l" "\C-t" diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el index 60dcdc625a8..f4ab9e5e4f3 100644 --- a/lisp/progmodes/mixal-mode.el +++ b/lisp/progmodes/mixal-mode.el @@ -1091,15 +1091,19 @@ EXECUTION-TIME holds info about the time it takes, number or string.") (defun mixal-run () "Run mixal file in current buffer, assumes that file has been compiled." (interactive) - (mixvm (concat "mixvm -r -t -d " - (file-name-sans-extension (buffer-file-name))))) + (if (fboundp 'mixvm) + (mixvm (concat "mixvm -r -t -d " + (file-name-sans-extension (buffer-file-name)))) + (error "mixvm.el needs to be loaded to run `mixvm'"))) (defun mixal-debug () "Start mixvm for debugging. Assumes that file has been compiled with debugging support." (interactive) - (mixvm (concat "mixvm " - (file-name-sans-extension (buffer-file-name))))) + (if (fboundp 'mixvm) + (mixvm (concat "mixvm " + (file-name-sans-extension (buffer-file-name)))) + (error "mixvm.el needs to be loaded to run `mixvm'"))) ;;;###autoload (define-derived-mode mixal-mode fundamental-mode "mixal" diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el index c791e217ccb..c131575f57c 100644 --- a/lisp/progmodes/ps-mode.el +++ b/lisp/progmodes/ps-mode.el @@ -529,7 +529,10 @@ Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number t)) (set (make-local-variable 'comment-start) "%") ;; NOTE: `\' has a special meaning in strings only - (set (make-local-variable 'comment-start-skip) "%+[ \t]*")) + (set (make-local-variable 'comment-start-skip) "%+[ \t]*") + ;; enable doc-view-minor-mode => C-c C-c starts viewing the current ps file + ;; with doc-view-mode. + (doc-view-minor-mode 1)) (defun ps-mode-show-version () "Show current version of PostScript mode." diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index fc28b72bfd1..f54b7c9f928 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -2036,10 +2036,11 @@ the if condition." "Alist of named skeletons for Python mode. Elements are of the form (NAME . EXPANDER-FUNCTION).") -(defvar python-mode-abbrev-table nil +(define-abbrev-table 'python-mode-abbrev-table () "Abbrev table for Python mode. -The default contents correspond to the elements of `python-skeletons'.") -(define-abbrev-table 'python-mode-abbrev-table ()) +The default contents correspond to the elements of `python-skeletons'." + ;; Allow / in abbrevs. + :regexp "\\<\\([[:word:]/]+\\)\\W*") (eval-when-compile ;; Define a user-level skeleton and add it to `python-skeletons' and @@ -2049,8 +2050,9 @@ The default contents correspond to the elements of `python-skeletons'.") (function (intern (concat "python-insert-" name)))) `(progn (add-to-list 'python-skeletons ',(cons name function)) - (if python-use-skeletons - (define-abbrev python-mode-abbrev-table ,name "" ',function nil t)) + (define-abbrev python-mode-abbrev-table ,name "" ',function + :system t :case-fixed t + :enable-function (lambda () python-use-skeletons)) (define-skeleton ,function ,(format "Insert Python \"%s\" template." name) ,@elements))))) @@ -2205,23 +2207,6 @@ without confirmation." (defvar outline-heading-end-regexp) (defvar eldoc-documentation-function) - -;; Stuff to allow expanding abbrevs with non-word constituents. -(defun python-abbrev-pc-hook () - "Set the syntax table before possibly expanding abbrevs." - (remove-hook 'post-command-hook 'python-abbrev-pc-hook t) - (set-syntax-table python-mode-syntax-table)) - -(defvar python-abbrev-syntax-table - (copy-syntax-table python-mode-syntax-table) - "Syntax table used when expanding abbrevs.") - -(defun python-pea-hook () - "Reset the syntax table after possibly expanding abbrevs." - (set-syntax-table python-abbrev-syntax-table) - (add-hook 'post-command-hook 'python-abbrev-pc-hook nil t)) -(modify-syntax-entry ?/ "w" python-abbrev-syntax-table) - (defvar python-mode-running) ;Dynamically scoped var. ;;;###autoload @@ -2309,7 +2294,6 @@ with skeleton expansions for compound statement templates. '((< '(backward-delete-char-untabify (min python-indent (current-column)))) (^ '(- (1+ (current-indentation)))))) - (add-hook 'pre-abbrev-expand-hook 'python-pea-hook nil t) (if (featurep 'hippie-exp) (set (make-local-variable 'hippie-expand-try-functions-list) (cons 'python-try-complete hippie-expand-try-functions-list))) diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el index db5d6552c84..e0b04cfebe8 100644 --- a/lisp/progmodes/simula.el +++ b/lisp/progmodes/simula.el @@ -1615,9 +1615,9 @@ If not nil and not t, move to limit of search and return nil." (simula-install-standard-abbrevs)) ;; Hilit mode support. -(if (and (fboundp 'hilit-set-mode-patterns) - (boundp 'hilit-patterns-alist) - (not (assoc 'simula-mode hilit-patterns-alist))) +(when (fboundp 'hilit-set-mode-patterns) + (when (and (boundp 'hilit-patterns-alist) + (not (assoc 'simula-mode hilit-patterns-alist))) (hilit-set-mode-patterns 'simula-mode '( @@ -1626,7 +1626,7 @@ If not nil and not t, move to limit of search and return nil." ("\"[^\"\n]*\"\\|'.'\\|'![0-9]+!'" nil string) ("\\<\\(ACTIVATE\\|AFTER\\|AND\\|ARRAY\\|AT\\|BEFORE\\|BEGIN\\|BOOLEAN\\|CHARACTER\\|CLASS\\|DELAY\\|DO\\|ELSE\\|END\\|EQ\\|EQV\\|EXTERNAL\\|FALSE\\|FOR\\|GE\\|GO\\|GOTO\\|GT\\|HIDDEN\\|IF\\|IMP\\|IN\\|INNER\\|INSPECT\\|INTEGER\\|IS\\|LABEL\\|LE\\|LONG\\|LT\\|NAME\\|NE\\|NEW\\|NONE\\|NOT\\|NOTEXT\\|OR\\|OTHERWISE\\|PRIOR\\|PROCEDURE\\|PROTECTED\\|QUA\\|REACTIVATE\\|REAL\\|REF\\|SHORT\\|STEP\\|SWITCH\\|TEXT\\|THEN\\|THIS\\|TO\\|TRUE\\|UNTIL\\|VALUE\\|VIRTUAL\\|WHEN\\|WHILE\\)\\>" nil keyword) ("!\\|\\<COMMENT\\>" ";" comment)) - nil 'case-insensitive)) + nil 'case-insensitive))) ;; defuns for submitting bug reports diff --git a/lisp/ps-print.el b/lisp/ps-print.el index 7c408573797..f66416de667 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -1480,6 +1480,10 @@ Please send all bug fixes and enhancements to ;; Load XEmacs/Emacs definitions (eval-and-compile (require 'ps-def)) +(defun ps-face-background-name (face) + (if (featurep 'xemacs) + (ps-xemacs-color-name (face-background face)) + (face-background face nil t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User Variables: diff --git a/lisp/register.el b/lisp/register.el index 1f0811561c2..5648ca385a8 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -287,10 +287,12 @@ With prefix arg, delete as well. Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to append." (interactive "cAppend to register: \nr\nP") - (or (stringp (get-register register)) - (error "Register does not contain text")) - (set-register register (concat (get-register register) - (filter-buffer-substring start end))) + (let ((reg (get-register register)) + (text (filter-buffer-substring start end))) + (set-register + register (cond ((not reg) text) + ((stringp reg) (concat reg text)) + (t (error "Register does not contain text"))))) (if delete-flag (delete-region start end))) (defun prepend-to-register (register start end &optional delete-flag) @@ -299,10 +301,12 @@ With prefix arg, delete as well. Called from program, takes four args: REGISTER, START, END and DELETE-FLAG. START and END are buffer positions indicating what to prepend." (interactive "cPrepend to register: \nr\nP") - (or (stringp (get-register register)) - (error "Register does not contain text")) - (set-register register (concat (filter-buffer-substring start end) - (get-register register))) + (let ((reg (get-register register)) + (text (filter-buffer-substring start end))) + (set-register + register (cond ((not reg) text) + ((stringp reg) (concat text reg)) + (t (error "Register does not contain text"))))) (if delete-flag (delete-region start end))) (defun copy-rectangle-to-register (register start end &optional delete-flag) diff --git a/lisp/replace.el b/lisp/replace.el index 5fe8ad43d22..7876f9bb47c 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -69,6 +69,12 @@ strings or patterns." :group 'matching :version "22.1") +(defcustom query-replace-show-replacement t + "*Non-nil means to show what actual replacement text will be." + :type 'boolean + :group 'matching + :version "23.1") + (defcustom query-replace-highlight t "*Non-nil means to highlight matches during query replacement." :type 'boolean @@ -1570,10 +1576,17 @@ make, or the user didn't cancel the call." (or delimited-flag regexp-flag) case-fold-search) ;; Bind message-log-max so we don't fill up the message log ;; with a bunch of identical messages. - (let ((message-log-max nil)) + (let ((message-log-max nil) + (replacement-presentation + (if query-replace-show-replacement + (save-match-data + (set-match-data real-match-data) + (match-substitute-replacement next-replacement + nocasify literal)) + next-replacement))) (message message (query-replace-descr from-string) - (query-replace-descr next-replacement))) + (query-replace-descr replacement-presentation))) (setq key (read-event)) ;; Necessary in case something happens during read-event ;; that clobbers the match data. diff --git a/lisp/savehist.el b/lisp/savehist.el index 7cc56842d4b..705be69088d 100644 --- a/lisp/savehist.el +++ b/lisp/savehist.el @@ -308,7 +308,8 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, (current-buffer)) (insert ?\n) (dolist (symbol savehist-minibuffer-history-variables) - (when (boundp symbol) + (when (and (boundp symbol) + (not (memq symbol savehist-ignored-variables))) (let ((value (savehist-trim-history (symbol-value symbol))) excess-space) (when value ; Don't save empty histories. diff --git a/lisp/server.el b/lisp/server.el index 70d2283b0eb..329010cc950 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -239,7 +239,7 @@ ENV should be in the same format as `process-environment'." (progn ,@body)))) (defun server-delete-client (proc &optional noframe) - "Delete CLIENT, including its buffers, terminals and frames. + "Delete PROC, including its buffers, terminals and frames. If NOFRAME is non-nil, let the frames live. (To be used from `delete-frame-functions'.)" (server-log (concat "server-delete-client" (if noframe " noframe")) @@ -294,8 +294,7 @@ If NOFRAME is non-nil, let the frames live. (To be used from (defun server-log (string &optional client) "If a *server* buffer exists, write STRING to it for logging purposes. -If CLIENT is non-nil, add a description of it to the logged -message." +If CLIENT is non-nil, add a description of it to the logged message." (when (get-buffer "*server*") (with-current-buffer "*server*" (goto-char (point-max)) @@ -484,6 +483,7 @@ kill any existing server communications subprocess." (add-hook 'delete-frame-functions 'server-handle-delete-frame) (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) + (add-hook 'kill-emacs-hook (lambda () (server-mode -1))) ;Cleanup upon exit. (setq server-process (apply #'make-network-process :name server-name @@ -572,7 +572,7 @@ Server mode runs a process that accepts commands from the "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" - "TERMINFO_DIRS" "TERMPATH" + "TERMINFO_DIRS" "TERMPATH" ;; rxvt wants these "COLORFGBG" "COLORTERM") (make-frame-on-tty tty type @@ -590,7 +590,7 @@ Server mode runs a process that accepts commands from the ;; C functions `child_setup' and ;; `getenv_internal' accordingly. (environment . ,(process-get proc 'env))))))) - + ;; ttys don't use the `display' parameter, but callproc.c does to set ;; the DISPLAY environment on subprocesses. (set-frame-parameter frame 'display @@ -737,7 +737,7 @@ The following commands are accepted by the server: on this tty until it gets a -resume command. `-resume' - Resume this tty frame. The client sends this string when it + Resume this tty frame. The client sends this string when it gets the SIGCONT signal and it is the foreground process on its controlling tty. @@ -753,9 +753,8 @@ The following commands are accepted by the client: used to forward window change signals to it. `-window-system-unsupported' - Signals that the server does not - support creating X frames; the client must try again with a tty - frame. + Signals that the server does not support creating X frames; + the client must try again with a tty frame. `-print STRING' Print STRING on stdout. Used to send values @@ -765,8 +764,8 @@ The following commands are accepted by the client: Signal an error (but continue processing). `-suspend' - Suspend this terminal, i.e., stop the client process. Sent - when the user presses C-z." + Suspend this terminal, i.e., stop the client process. + Sent when the user presses C-z." (server-log (concat "Received " string) proc) ;; First things first: let's check the authentication (unless (process-get proc :authenticated) @@ -793,7 +792,7 @@ The following commands are accepted by the client: ;; Save for later any partial line that remains. (when (> (length string) 0) (process-put proc 'previous-string string)) - + ;; In earlier versions of server.el (where we used an `emacsserver' ;; process), there could be multiple lines. Nowadays this is not ;; supported any more. @@ -931,7 +930,7 @@ The following commands are accepted by the client: ;; Unknown command. (t (error "Unknown command: %s" arg))))) - + (setq frame (case tty-name ((nil) (if display (server-select-display display))) @@ -967,7 +966,7 @@ The following commands are accepted by the client: (run-hooks 'post-command-hook))))) (mapc 'funcall (nreverse commands)) - + ;; Delete the client if necessary. (cond (nowait @@ -1008,8 +1007,8 @@ FILE-LINE-COL should be a three-element list as described in `server-visit-files'." (goto-line (nth 1 file-line-col)) (let ((column-number (nth 2 file-line-col))) - (if (> column-number 0) - (move-to-column (1- column-number))))) + (when (> column-number 0) + (move-to-column (1- column-number))))) (defun server-visit-files (files proc &optional nowait) "Find FILES and return a list of buffers created. @@ -1159,7 +1158,7 @@ specifically for the clients and did not exist before their request for it." (buffer-name (current-buffer)))))) (defun server-kill-emacs-query-function () - "Ask before exiting Emacs it has live clients." + "Ask before exiting Emacs if it has live clients." (or (not server-clients) (let (live-client) (dolist (proc server-clients live-client) @@ -1285,17 +1284,17 @@ only these files will be asked to be saved." (define-key ctl-x-map "#" 'server-edit) -(defun server-unload-hook () +(defun server-unload-function () "Unload the server library." (server-mode -1) - (remove-hook 'suspend-tty-functions 'server-handle-suspend-tty) - (remove-hook 'delete-frame-functions 'server-handle-delete-frame) - (remove-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) - (remove-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) - (remove-hook 'kill-buffer-hook 'server-kill-buffer)) - -(add-hook 'kill-emacs-hook (lambda () (server-mode -1))) ;Cleanup upon exit. -(add-hook 'server-unload-hook 'server-unload-hook) + (substitute-key-definition 'server-edit nil ctl-x-map) + (save-current-buffer + (dolist (buffer (buffer-list)) + (set-buffer buffer) + (remove-hook 'kill-buffer-hook 'server-kill-buffer t))) + ;; continue standard unloading + nil) + (provide 'server) diff --git a/lisp/ses.el b/lisp/ses.el index 62067471b60..f76befa874d 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -2921,7 +2921,7 @@ TEST is evaluated." ;;---------------------------------------------------------------------------- ;;These functions use the variables 'row' and 'col' that are -;;dynamically bound by ses-print-cell. We define these varables at +;;dynamically bound by ses-print-cell. We define these variables at ;;compile-time to make the compiler happy. (eval-when-compile (dolist (x '(row col)) @@ -2980,6 +2980,19 @@ current column and continues until the next nonblank column." (dolist (x (cons 'ses-unsafe ses-standard-printer-functions)) (put x 'side-effect-free t)) +(defun ses-unload-function () + "Unload the Simple Emacs Spreadsheet." + (dolist (fun '(copy-region-as-kill yank)) + (ad-remove-advice fun 'around (intern (concat "ses-" (symbol-name fun)))) + (ad-update fun)) + (save-current-buffer + (dolist (buf (buffer-list)) + (set-buffer buf) + (when (eq major-mode 'ses-mode) + (funcall (or default-major-mode 'fundamental-mode))))) + ;; continue standard unloading + nil) + (provide 'ses) ;; arch-tag: 88c1ccf0-4293-4824-8c5d-0757b52217f3 diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el index d1de8be3910..be30ccc8c6a 100644 --- a/lisp/shadowfile.el +++ b/lisp/shadowfile.el @@ -28,7 +28,7 @@ ;; This package helps you to keep identical copies of files in more than one ;; place - possibly on different machines. When you save a file, it checks ;; whether it is on the list of files with "shadows", and if so, it tries to -;; copy it when you exit emacs (or use the shadow-copy-files command). +;; copy it when you exit Emacs (or use the shadow-copy-files command). ;; Installation & Use: @@ -38,8 +38,8 @@ ;; them). After doing this once, everything should be automatic. ;; The lists of clusters and shadows are saved in a file called .shadows, -;; so that they can be remembered from one emacs session to another, even -;; (as much as possible) if the emacs session terminates abnormally. The +;; so that they can be remembered from one Emacs session to another, even +;; (as much as possible) if the Emacs session terminates abnormally. The ;; files needing to be copied are stored in .shadow_todo; if a file cannot ;; be copied for any reason, it will stay on the list to be tried again ;; next time. The .shadows file should itself have shadows on all your @@ -47,7 +47,7 @@ ;; .shadow_todo is local information and should have no shadows. ;; If you do not want to copy a particular file, you can answer "no" and -;; be asked again next time you hit C-x 4 s or exit emacs. If you do not +;; be asked again next time you hit C-x 4 s or exit Emacs. If you do not ;; want to be asked again, use shadow-cancel, and you will not be asked ;; until you change the file and save it again. If you do not want to ;; shadow that file ever again, you can edit it out of the .shadows @@ -103,8 +103,8 @@ is no buffer currently visiting the file." (defcustom shadow-inhibit-overload nil "If non-nil, shadowfile won't redefine \\[save-buffers-kill-emacs]. -Normally it overloads the function `save-buffers-kill-emacs' to check -for files have been changed and need to be copied to other systems." +Normally it overloads the function `save-buffers-kill-emacs' to check for +files that have been changed and need to be copied to other systems." :type 'boolean :group 'shadow) @@ -192,12 +192,6 @@ Nondestructive; actually returns a copy of the list with the elements removed." (cons (car list) (shadow-remove-if func (cdr list)))) nil)) -(defun shadow-join (strings sep) - "Concatenate elements of the list of STRINGS with SEP between each." - (cond ((null strings) "") - ((null (cdr strings)) (car strings)) - ((concat (car strings) " " (shadow-join (cdr strings) sep))))) - (defun shadow-regexp-superquote (string) "Like `regexp-quote', but includes the ^ and $. This makes sure regexp matches nothing but STRING." @@ -305,7 +299,7 @@ be matched against the primary of SITE2." (defun shadow-parse-fullname (fullname) "Parse FULLNAME into \(site user path) list. -Leave it alone if it already is one. Returns nil if the argument is +Leave it alone if it already is one. Return nil if the argument is not a full ange-ftp pathname." (if (listp fullname) fullname @@ -398,9 +392,9 @@ local filename." "Return t if PATTERN matches FILE. If REGEXP is supplied and non-nil, the file part of the pattern is a regular expression, otherwise it must match exactly. The sites and usernames must -match---see `shadow-same-site'. The pattern must be in full ange-ftp format, but -the file can be any valid filename. This function does not do any filename -expansion or contraction, you must do that yourself first." +match---see `shadow-same-site'. The pattern must be in full ange-ftp format, +but the file can be any valid filename. This function does not do any +filename expansion or contraction, you must do that yourself first." (let* ((pattern-sup (shadow-parse-fullname pattern)) (file-sup (shadow-parse-name file))) (and (shadow-same-site pattern-sup file-sup) @@ -418,8 +412,8 @@ expansion or contraction, you must do that yourself first." This is a group of hosts that share directories, so that copying to or from one of them is sufficient to update the file on all of them. Clusters are defined by a name, the network address of a primary host \(the one we copy -files to), and a regular expression that matches the hostnames of all the sites -in the cluster." +files to), and a regular expression that matches the hostnames of all the +sites in the cluster." (interactive (list (completing-read "Cluster name: " shadow-clusters () ()))) (let* ((old (shadow-get-cluster name)) (primary (read-string "Primary host: " @@ -475,8 +469,8 @@ specific hostnames, or names of clusters \(see `shadow-define-cluster')." "Make each of a group of files be shared between hosts. Prompts for regular expression; files matching this are shared between a list of sites, which are also prompted for. The filenames must be identical on all -hosts \(if they aren't, use `shadow-define-literal-group' instead of this function). -Each site can be either a hostname or the name of a cluster \(see +hosts \(if they aren't, use `shadow-define-literal-group' instead of this +function). Each site can be either a hostname or the name of a cluster \(see `shadow-define-cluster')." (interactive) (let ((regexp (read-string @@ -503,9 +497,7 @@ Each site can be either a hostname or the name of a cluster \(see ;; Mostly for debugging. "Interactive function to display shadows of a buffer." (interactive) - (let ((msg (shadow-join (mapcar (function cdr) - (shadow-shadows-of (buffer-file-name))) - " "))) + (let ((msg (mapconcat #'cdr (shadow-shadows-of (buffer-file-name)) " "))) (message "%s" (if (zerop (length msg)) "No shadows." @@ -643,11 +635,11 @@ Consider them as regular expressions if third arg REGEXP is true." "Use \\[shadow-copy-files] to update shadows.")) (sit-for 1)) (shadow-write-todo-file))) - nil) ; Return nil for write-file-hooks + nil) ; Return nil for write-file-functions (defun shadow-remove-from-todo (pair) "Remove PAIR from `shadow-files-to-copy'. -PAIR must be (eq to) one of the elements of that list." +PAIR must be `eq' to one of the elements of that list." (setq shadow-files-to-copy (shadow-remove-if (function (lambda (s) (eq s pair))) shadow-files-to-copy))) @@ -655,7 +647,7 @@ PAIR must be (eq to) one of the elements of that list." (defun shadow-read-files () "Visit and load `shadow-info-file' and `shadow-todo-file'. Thus restores shadowfile's state from your last Emacs session. -Returns t unless files were locked; then returns nil." +Return t unless files were locked; then return nil." (interactive) (if (and (fboundp 'file-locked-p) (or (stringp (file-locked-p shadow-info-file)) @@ -731,8 +723,9 @@ With non-nil argument also saves the buffer." (setq shadow-hashtable (make-vector 37 0))) (defun shadow-insert-var (variable) - "Prettily insert a `setq' command for VARIABLE, -which, when later evaluated, will restore it to its current setting. + "Build a `setq' to restore VARIABLE. +Prettily insert a `setq' command which, when later evaluated, +will restore VARIABLE to its current setting. VARIABLE must be the name of a variable whose value is a list." (let ((standard-output (current-buffer))) (insert (format "(setq %s" variable)) @@ -830,16 +823,16 @@ look for files that have been changed and need to be copied to other systems." (defalias 'shadow-orig-save-buffers-kill-emacs (symbol-function 'save-buffers-kill-emacs)) (defalias 'save-buffers-kill-emacs 'shadow-save-buffers-kill-emacs)) - (add-hook 'write-file-hooks 'shadow-add-to-todo) + (add-hook 'write-file-functions 'shadow-add-to-todo) (define-key ctl-x-4-map "s" 'shadow-copy-files))) -(defun shadowfile-unload-hook () - (if (fboundp 'shadow-orig-save-buffers-kill-emacs) - (fset 'save-buffers-kill-emacs - (symbol-function 'shadow-orig-save-buffers-kill-emacs))) - (remove-hook 'write-file-hooks 'shadow-add-to-todo)) - -(add-hook 'shadowfile-unload-hook 'shadowfile-unload-hook) +(defun shadowfile-unload-function () + (substitute-key-definition 'shadow-copy-files nil ctl-x-4-map) + (when (fboundp 'shadow-orig-save-buffers-kill-emacs) + (fset 'save-buffers-kill-emacs + (symbol-function 'shadow-orig-save-buffers-kill-emacs))) + ;; continue standard unloading + nil) (provide 'shadowfile) diff --git a/lisp/shell.el b/lisp/shell.el index a8daf8b76d2..24ef65a384a 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -88,7 +88,7 @@ ;; m-c-f shell-forward-command Forward a shell command ;; m-c-b shell-backward-command Backward a shell command ;; dirs Resync the buffer's dir stack -;; dirtrack-mode Turn dir tracking on/off +;; shell-dirtrack-mode Turn dir tracking on/off ;; comint-strip-ctrl-m Remove trailing ^Ms from output ;; ;; The shell mode hook is shell-mode-hook @@ -258,7 +258,9 @@ This mirrors the optional behavior of tcsh." (defcustom shell-dirtrack-verbose t "If non-nil, show the directory stack following directory change. -This is effective only if directory tracking is enabled." +This is effective only if directory tracking is enabled. +The `dirtrack' package provides an alternative implementation of this feature - +see the function `dirtrack-mode'." :type 'boolean :group 'shell-directories) @@ -393,7 +395,9 @@ While directory tracking is enabled, the shell's working directory is displayed by \\[list-buffers] or \\[mouse-buffer-menu] in the `File' field. \\[dirs] queries the shell and resyncs Emacs' idea of what the current directory stack is. -\\[dirtrack-mode] turns directory tracking on and off. +\\[shell-dirtrack-mode] turns directory tracking on and off. +\(The `dirtrack' package provides an alternative implementation of this +feature - see the function `dirtrack-mode'.) \\{shell-mode-map} Customization: Entry to this mode runs the hooks on `comint-mode-hook' and @@ -621,8 +625,10 @@ This function is called on each input passed to the shell. It watches for cd, pushd and popd commands and sets the buffer's default directory to track these commands. -You may toggle this tracking on and off with \\[dirtrack-mode]. +You may toggle this tracking on and off with \\[shell-dirtrack-mode]. If Emacs gets confused, you can resync with the shell with \\[dirs]. +\(The `dirtrack' package provides an alternative implementation of this +feature - see the function `dirtrack-mode'.) See variables `shell-cd-regexp', `shell-chdrive-regexp', `shell-pushd-regexp', and `shell-popd-regexp', while `shell-pushd-tohome', `shell-pushd-dextract', @@ -778,17 +784,17 @@ Environment variables are expanded, see function `substitute-in-file-name'." (defvaralias 'shell-dirtrack-mode 'shell-dirtrackp) (define-minor-mode shell-dirtrack-mode - "Turn directory tracking on and off in a shell buffer." + "Turn directory tracking on and off in a shell buffer. +The `dirtrack' package provides an alternative implementation of this +feature - see the function `dirtrack-mode'." nil nil nil (setq list-buffers-directory (if shell-dirtrack-mode default-directory)) (if shell-dirtrack-mode (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) (remove-hook 'comint-input-filter-functions 'shell-directory-tracker t))) -;; For your typing convenience: -(defalias 'shell-dirtrack-toggle 'shell-dirtrack-mode) ;??Convenience?? -(defalias 'dirtrack-toggle 'shell-dirtrack-mode) -(defalias 'dirtrack-mode 'shell-dirtrack-mode) +(define-obsolete-function-alias 'shell-dirtrack-toggle 'shell-dirtrack-mode + "23.1") (defun shell-cd (dir) "Do normal `cd' to DIR, and set `list-buffers-directory'." diff --git a/lisp/simple.el b/lisp/simple.el index 6fa14e2edf7..f6a8818e5a9 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2561,8 +2561,6 @@ the text which should be made available. The second, optional, argument PUSH, has the same meaning as the similar argument to `x-set-cut-buffer', which see.") -(make-variable-frame-local 'interprogram-cut-function) - (defvar interprogram-paste-function nil "Function to call to get text cut from other programs. @@ -2588,8 +2586,6 @@ most recent string, the function should return nil. If it is difficult to tell whether Emacs or some other program provided the current string, it is probably good enough to return nil if the string is equal (according to `string=') to the last text Emacs provided.") - -(make-variable-frame-local 'interprogram-paste-function) @@ -5841,7 +5837,7 @@ works by saving the value of `buffer-invisibility-spec' and setting it to nil." (defconst bad-packages-alist ;; Not sure exactly which semantic versions have problems. ;; Definitely 2.0pre3, probably all 2.0pre's before this. - '((semantic semantic-version "2\\.0pre[1-3]" + '((semantic semantic-version "\\`2\\.0pre[1-3]\\'" "The version of `semantic' loaded does not work in Emacs 22. It can cause constant high CPU load. Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).") diff --git a/lisp/smerge-mode.el b/lisp/smerge-mode.el index cd5c7c20f8d..18ca1a34181 100644 --- a/lisp/smerge-mode.el +++ b/lisp/smerge-mode.el @@ -790,12 +790,17 @@ replace chars to try and eliminate some spurious differences." (unwind-protect (with-temp-buffer (let ((coding-system-for-read 'emacs-mule)) - ;; Don't forget -a to make sure diff treats it as a text file - ;; even if it contains \0 and such. (call-process diff-command nil t nil (if (and smerge-refine-ignore-whitespace (not smerge-refine-weight-hack)) - "-aw" "-a") + ;; Pass -a so diff treats it as a text file even + ;; if it contains \0 and such. + ;; Pass -d so as to get the smallest change, but + ;; also and more importantly because otherwise it + ;; may happen that diff doesn't behave like + ;; smerge-refine-weight-hack expects it to. + ;; See http://thread.gmane.org/gmane.emacs.devel/82685. + "-awd" "-ad") file1 file2)) ;; Process diff's output. (goto-char (point-min)) diff --git a/lisp/strokes.el b/lisp/strokes.el index de4123453f5..d4fcdb66f61 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -1370,7 +1370,7 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead." (goto-char (point-min)))) (defun strokes-alphabetic-lessp (stroke1 stroke2) - "T if command name for STROKE1 is less than STROKE2's in lexicographic order." + "Return t if STROKE1's command name precedes STROKE2's in lexicographic order." (let ((command-name-1 (symbol-name (cdr stroke1))) (command-name-2 (symbol-name (cdr stroke2)))) (string-lessp command-name-1 command-name-2))) @@ -1745,11 +1745,11 @@ Store XPM in buffer BUFNAME if supplied \(default is ` *strokes-xpm*'\)" ;; strokes-decode-buffer does a save-excursion. (forward-char))) -(defun strokes-unload-hook () +(defun strokes-unload-function () + "Unload the Strokes library." (strokes-mode -1) - (remove-hook 'kill-emacs-query-functions 'strokes-prompt-user-save-strokes)) - -(add-hook 'strokes-unload-hook 'strokes-unload-hook) + ;; continue standard unloading + nil) (run-hooks 'strokes-load-hook) (provide 'strokes) diff --git a/lisp/subr.el b/lisp/subr.el index d48b5a130a6..16cb8913559 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2709,6 +2709,24 @@ STRING should be given if the last search was by `string-match' on STRING." (buffer-substring-no-properties (match-beginning num) (match-end num))))) + +(defun match-substitute-replacement (replacement + &optional fixedcase literal string subexp) + "Return REPLACEMENT as it will be inserted by `replace-match'. +In other words, all back-references in the form `\\&' and `\\N' +are substituted with actual strings matched by the last search. +Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same +meaning as for `replace-match'." + (let ((match (match-string 0 string))) + (save-match-data + (set-match-data (mapcar (lambda (x) + (if (numberp x) + (- x (match-beginning 0)) + x)) + (match-data t))) + (replace-match replacement fixedcase literal match subexp)))) + + (defun looking-back (regexp &optional limit greedy) "Return non-nil if text before point matches regular expression REGEXP. Like `looking-at' except matches before point, and is slower. diff --git a/lisp/term/sun-mouse.el b/lisp/term/sun-mouse.el deleted file mode 100644 index d3e85508b03..00000000000 --- a/lisp/term/sun-mouse.el +++ /dev/null @@ -1,667 +0,0 @@ -;;; sun-mouse.el --- mouse handling for Sun windows - -;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. - -;; Author: Jeff Peck -;; Maintainer: FSF -;; Keywords: hardware - -;; 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 3, 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; Jeff Peck, Sun Microsystems, Jan 1987. -;; Original idea by Stan Jefferson - -;; Modeled after the GNUEMACS keymap interface. -;; -;; User Functions: -;; make-mousemap, copy-mousemap, -;; define-mouse, global-set-mouse, local-set-mouse, -;; use-global-mousemap, use-local-mousemap, -;; mouse-lookup, describe-mouse-bindings -;; -;; Options: -;; extra-click-wait, scrollbar-width - -;;; Code: - -(defvar extra-click-wait 150 - "*Number of milliseconds to wait for an extra click. -Set this to zero if you don't want chords or double clicks.") - -(defvar scrollbar-width 5 - "*The character width of the scrollbar. -The cursor is deemed to be in the right edge scrollbar if it is this near the -right edge, and more than two chars past the end of the indicated line. -Setting to nil limits the scrollbar to the edge or vertical dividing bar.") - -;;; -;;; Mousemaps -;;; -(defun make-mousemap () - "Returns a new mousemap." - (cons 'mousemap nil)) - -;;; initialize mouse maps -(defvar current-global-mousemap (make-mousemap)) -(defvar current-local-mousemap nil) -(make-variable-buffer-local 'current-local-mousemap) - -(defun copy-mousemap (mousemap) - "Return a copy of mousemap." - (copy-alist mousemap)) - -(defun define-mouse (mousemap mouse-list def) - "Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF. -MOUSE-LIST is a list of atoms specifying a mouse hit according to these rules: - * One of these atoms specifies the active region of the definition. - text, scrollbar, modeline, minibuffer - * One or two or these atoms specify the button or button combination. - left, middle, right, double - * Any combination of these atoms specify the active shift keys. - control, shift, meta - * With a single unshifted button, you can add - up - to indicate an up-click. -The atom `double' is used with a button designator to denote a double click. -Two button chords are denoted by listing the two buttons. -See sun-mouse-handler for the treatment of the form DEF." - (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def)) - -(defun global-set-mouse (mouse-list def) - "Give MOUSE-EVENT-LIST a local definition of DEF. -See define-mouse for a description of MOUSE-EVENT-LIST and DEF. -Note that if MOUSE-EVENT-LIST has a local definition in the current buffer, -that local definition will continue to shadow any global definition." - (interactive "xMouse event: \nxDefinition: ") - (define-mouse current-global-mousemap mouse-list def)) - -(defun local-set-mouse (mouse-list def) - "Give MOUSE-EVENT-LIST a local definition of DEF. -See define-mouse for a description of the arguments. -The definition goes in the current buffer's local mousemap. -Normally buffers in the same major mode share a local mousemap." - (interactive "xMouse event: \nxDefinition: ") - (if (null current-local-mousemap) - (setq current-local-mousemap (make-mousemap))) - (define-mouse current-local-mousemap mouse-list def)) - -(defun use-global-mousemap (mousemap) - "Selects MOUSEMAP as the global mousemap." - (setq current-global-mousemap mousemap)) - -(defun use-local-mousemap (mousemap) - "Selects MOUSEMAP as the local mousemap. -nil for MOUSEMAP means no local mousemap." - (setq current-local-mousemap mousemap)) - - -;;; -;;; Interface to the Mouse encoding defined in Emacstool.c -;;; -;;; Called when mouse-prefix is sent to emacs, additional -;;; information is read in as a list (button x y time-delta) -;;; -;;; First, some generally useful functions: -;;; - -(defun logtest (x y) - "True if any bits set in X are also set in Y. -Just like the Common Lisp function of the same name." - (not (zerop (logand x y)))) - - -;;; -;;; Hit accessors. -;;; - -(defconst sm::ButtonBits 7) ; Lowest 3 bits. -(defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7). -(defconst sm::DoubleBits 64) ; Bit 7. -(defconst sm::UpBits 128) ; Bit 8. - -;;; All the useful code bits -(defmacro sm::hit-code (hit) - `(nth 0 ,hit)) -;;; The button, or buttons if a chord. -(defmacro sm::hit-button (hit) - `(logand sm::ButtonBits (nth 0 ,hit))) -;;; The shift, control, and meta flags. -(defmacro sm::hit-shiftmask (hit) - `(logand sm::ShiftmaskBits (nth 0 ,hit))) -;;; Set if a double click (but not a chord). -(defmacro sm::hit-double (hit) - `(logand sm::DoubleBits (nth 0 ,hit))) -;;; Set on button release (as opposed to button press). -(defmacro sm::hit-up (hit) - `(logand sm::UpBits (nth 0 ,hit))) -;;; Screen x position. -(defmacro sm::hit-x (hit) (list 'nth 1 hit)) -;;; Screen y position. -(defmacro sm::hit-y (hit) (list 'nth 2 hit)) -;;; Milliseconds since last hit. -(defmacro sm::hit-delta (hit) (list 'nth 3 hit)) - -(defmacro sm::hit-up-p (hit) ; A predicate. - `(not (zerop (sm::hit-up ,hit)))) - -;;; -;;; Loc accessors. for sm::window-xy -;;; -(defmacro sm::loc-w (loc) (list 'nth 0 loc)) -(defmacro sm::loc-x (loc) (list 'nth 1 loc)) -(defmacro sm::loc-y (loc) (list 'nth 2 loc)) - -(defmacro eval-in-buffer (buffer &rest forms) - "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer." - ;; When you don't need the complete window context of eval-in-window - `(let ((StartBuffer (current-buffer))) - (unwind-protect - (progn - (set-buffer ,buffer) - ,@forms) - (set-buffer StartBuffer)))) - -(put 'eval-in-buffer 'lisp-indent-function 1) - -;;; this is used extensively by sun-fns.el -;;; -(defmacro eval-in-window (window &rest forms) - "Switch to WINDOW, evaluate FORMS, return to original window." - `(let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (progn - (select-window ,window) - ,@forms) - (select-window OriginallySelectedWindow)))) -(put 'eval-in-window 'lisp-indent-function 1) - -;;; -;;; handy utility, generalizes window_loop -;;; - -;;; It's a macro (and does not evaluate its arguments). -(defmacro eval-in-windows (form &optional yesmini) - "Switches to each window and evaluates FORM. Optional argument -YESMINI says to include the minibuffer as a window. -This is a macro, and does not evaluate its arguments." - `(let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (while (progn - ,form - (not (eq OriginallySelectedWindow - (select-window - (next-window nil ,yesmini)))))) - (select-window OriginallySelectedWindow)))) -(put 'eval-in-window 'lisp-indent-function 0) - -(defun move-to-loc (x y) - "Move cursor to window location X, Y. -Handles wrapped and horizontally scrolled lines correctly." - (move-to-window-line y) - ;; window-line-end expects this to return the window column it moved to. - (let ((cc (current-column)) - (nc (move-to-column - (if (zerop (window-hscroll)) - (+ (current-column) - (min (- (window-width) 2) ; To stay on the line. - x)) - (+ (window-hscroll) -1 - (min (1- (window-width)) ; To stay on the line. - x)))))) - (- nc cc))) - - -(defun minibuffer-window-p (window) - "True if this WINDOW is minibuffer." - (= (frame-height) - (nth 3 (window-edges window)) ; The bottom edge. - )) - - -(defun sun-mouse-handler (&optional hit) - "Evaluates the function or list associated with a mouse hit. -Expecting to read a hit, which is a list: (button x y delta). -A form bound to button by define-mouse is found by mouse-lookup. -The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound. -If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*, -*mouse-x*, and *mouse-y* as arguments; if the form is a list (listp), -the form is eval'ed; if the form is neither of these, it is an error. -Returns nil." - (interactive) - (if (null hit) (setq hit (sm::combined-hits))) - (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit)))) - (let ((*mouse-window* (sm::loc-w loc)) - (*mouse-x* (sm::loc-x loc)) - (*mouse-y* (sm::loc-y loc)) - (mouse-code (mouse-event-code hit loc))) - (let ((form (eval-in-buffer (window-buffer *mouse-window*) - (mouse-lookup mouse-code)))) - (cond ((null form) - (if (not (sm::hit-up-p hit)) ; undefined up hits are ok. - (error "Undefined mouse event: %s" - (prin1-to-string - (mouse-code-to-mouse-list mouse-code))))) - ((symbolp form) - (setq this-command form) - (funcall form *mouse-window* *mouse-x* *mouse-y*)) - ((listp form) - (setq this-command (car form)) - (eval form)) - (t - (error "Mouse action must be symbol or list, but was: %s" - form)))))) - ;; Don't let 'sun-mouse-handler get on last-command, - ;; since this function should be transparent. - (if (eq this-command 'sun-mouse-handler) - (setq this-command last-command)) - ;; (message (prin1-to-string this-command)) ; to see what your buttons did - nil) - -(defun sm::combined-hits () - "Read and return next mouse-hit, include possible double click" - (let ((hit1 (mouse-hit-read))) - (if (not (sm::hit-up-p hit1)) ; Up hits don't start doubles or chords. - (let ((hit2 (mouse-second-hit extra-click-wait))) - (if hit2 ; we cons'd it, we can smash it. - ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...)) - (setcar hit1 (logior (sm::hit-code hit1) - (sm::hit-code hit2) - (if (= (sm::hit-button hit1) - (sm::hit-button hit2)) - sm::DoubleBits 0)))))) - hit1)) - -(defun mouse-hit-read () - "Read mouse-hit list from keyboard. Like (read 'read-char), -but that uses minibuffer, and mucks up last-command." - (let ((char-list nil) (char nil)) - (while (not (equal 13 ; Carriage return. - (prog1 (setq char (read-char)) - (setq char-list (cons char char-list)))))) - (read (mapconcat 'char-to-string (nreverse char-list) "")) - )) - -;;; Second Click Hackery.... -;;; if prefix is not mouse-prefix, need a way to unread the char... -;;; or else have mouse flush input queue, or else need a peek at next char. - -;;; There is no peek, but since one character can be unread, we only -;;; have to flush the queue when the command after a mouse click -;;; starts with mouse-prefix1 (see below). -;;; Something to do later: We could buffer the read commands and -;;; execute them ourselves after doing the mouse command (using -;;; lookup-key ??). - -(defvar mouse-prefix1 24 ; C-x - "First char of mouse-prefix. Used to detect double clicks and chords.") - -(defvar mouse-prefix2 0 ; C-@ - "Second char of mouse-prefix. Used to detect double clicks and chords.") - - -(defun mouse-second-hit (hit-wait) - "Returns the next mouse hit occurring within HIT-WAIT milliseconds." - (if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs. - (let ((pc1 (read-char))) - (if (or (not (equal pc1 mouse-prefix1)) - (sit-for-millisecs 3)) ; a mouse prefix will have second char - ;; Can get away with one unread. - (progn (setq unread-command-events (list pc1)) - nil) ; Next input not mouse event. - (let ((pc2 (read-char))) - (if (not (equal pc2 mouse-prefix2)) - (progn (setq unread-command-events (list pc1)) ; put back the ^X -;;; Too bad can't do two: (setq unread-command-event (list pc1 pc2)) -;;; Well, now we can, but I don't understand this code well enough to fix it... - (ding) ; user will have to retype that pc2. - nil) ; This input is not a mouse event. - ;; Next input has mouse prefix and is within time limit. - (let ((new-hit (mouse-hit-read))) ; Read the new hit. - (if (sm::hit-up-p new-hit) ; Ignore up events when timing. - (mouse-second-hit (- hit-wait (sm::hit-delta new-hit))) - new-hit ; New down hit within limit, return it. - )))))))) - -(defun sm::window-xy (x y) - "Find window containing screen coordinates X and Y. -Returns list (window x y) where x and y are relative to window." - (or - (catch 'found - (eval-in-windows - (let ((we (window-edges (selected-window)))) - (let ((le (nth 0 we)) - (te (nth 1 we)) - (re (nth 2 we)) - (be (nth 3 we))) - (if (= re (frame-width)) - ;; include the continuation column with this window - (setq re (1+ re))) - (if (= be (frame-height)) - ;; include partial line at bottom of frame with this window - ;; id est, if window is not multiple of char size. - (setq be (1+ be))) - - (if (and (>= x le) (< x re) - (>= y te) (< y be)) - (throw 'found - (list (selected-window) (- x le) (- y te)))))) - t)) ; include minibuffer in eval-in-windows - ;;If x,y from a real mouse click, we shouldn't get here. - (list nil x y) - )) - -(defun sm::window-region (loc) - "Parse LOC into a region symbol. -Returns one of (text scrollbar modeline minibuffer)" - (let ((w (sm::loc-w loc)) - (x (sm::loc-x loc)) - (y (sm::loc-y loc))) - (let ((right (1- (window-width w))) - (bottom (1- (window-height w)))) - (cond ((minibuffer-window-p w) 'minibuffer) - ((>= y bottom) 'modeline) - ((>= x right) 'scrollbar) - ;; far right column (window separator) is always a scrollbar - ((and scrollbar-width - ;; mouse within scrollbar-width of edge. - (>= x (- right scrollbar-width)) - ;; mouse a few chars past the end of line. - (>= x (+ 2 (window-line-end w x y)))) - 'scrollbar) - (t 'text))))) - -(defun window-line-end (w x y) - "Return WINDOW column (ignore X) containing end of line Y" - (eval-in-window w (save-excursion (move-to-loc (frame-width) y)))) - -;;; -;;; The encoding of mouse events into a mousemap. -;;; These values must agree with coding in emacstool: -;;; -(defconst sm::keyword-alist - '((left . 1) (middle . 2) (right . 4) - (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128) - (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048) - )) - -(defun mouse-event-code (hit loc) - "Maps MOUSE-HIT and LOC into a mouse-code." -;;;Region is a code for one of text, modeline, scrollbar, or minibuffer. - (logior (sm::hit-code hit) - (mouse-region-to-code (sm::window-region loc)))) - -(defun mouse-region-to-code (region) - "Returns partial mouse-code for specified REGION." - (cdr (assq region sm::keyword-alist))) - -(defun mouse-list-to-mouse-code (mouse-list) - "Map a MOUSE-LIST to a mouse-code." - (apply 'logior - (mapcar (function (lambda (x) - (cdr (assq x sm::keyword-alist)))) - mouse-list))) - -(defun mouse-code-to-mouse-list (mouse-code) - "Map a MOUSE-CODE to a mouse-list." - (apply 'nconc (mapcar - (function (lambda (x) - (if (logtest mouse-code (cdr x)) - (list (car x))))) - sm::keyword-alist))) - -(defun mousemap-set (code mousemap value) - (let* ((alist (cdr mousemap)) - (assq-result (assq code alist))) - (if assq-result - (setcdr assq-result value) - (setcdr mousemap (cons (cons code value) alist))))) - -(defun mousemap-get (code mousemap) - (cdr (assq code (cdr mousemap)))) - -(defun mouse-lookup (mouse-code) - "Look up MOUSE-EVENT and return the definition. nil means undefined." - (or (mousemap-get mouse-code current-local-mousemap) - (mousemap-get mouse-code current-global-mousemap))) - -;;; -;;; I (jpeck) don't understand the utility of the next four functions -;;; ask Steven Greenbaum <froud@kestrel> -;;; -(defun mouse-mask-lookup (mask list) - "Args MASK (a bit mask) and LIST (a list of (code . form) pairs). -Returns a list of elements of LIST whose code or'ed with MASK is non-zero." - (let ((result nil)) - (while list - (if (logtest mask (car (car list))) - (setq result (cons (car list) result))) - (setq list (cdr list))) - result)) - -(defun mouse-union (l l-unique) - "Return the union of list of mouse (code . form) pairs L and L-UNIQUE, -where L-UNIQUE is considered to be union'ized already." - (let ((result l-unique)) - (while l - (let ((code-form-pair (car l))) - (if (not (assq (car code-form-pair) result)) - (setq result (cons code-form-pair result)))) - (setq l (cdr l))) - result)) - -(defun mouse-union-first-preferred (l1 l2) - "Return the union of lists of mouse (code . form) pairs L1 and L2, -based on the code's, with preference going to elements in L1." - (mouse-union l2 (mouse-union l1 nil))) - -(defun mouse-code-function-pairs-of-region (region) - "Return a list of (code . function) pairs, where each code is -currently set in the REGION." - (let ((mask (mouse-region-to-code region))) - (mouse-union-first-preferred - (mouse-mask-lookup mask (cdr current-local-mousemap)) - (mouse-mask-lookup mask (cdr current-global-mousemap)) - ))) - -;;; -;;; Functions for DESCRIBE-MOUSE-BINDINGS -;;; And other mouse documentation functions -;;; Still need a good procedure to print out a help sheet in readable format. -;;; - -(defun one-line-doc-string (function) - "Returns first line of documentation string for FUNCTION. -If there is no documentation string, then the string -\"No documentation\" is returned." - (while (consp function) (setq function (car function))) - (let ((doc (documentation function))) - (if (null doc) - "No documentation." - (string-match "^.*$" doc) - (substring doc 0 (match-end 0))))) - -(defun print-mouse-format (binding) - (princ (car binding)) - (princ ": ") - (mapc (function - (lambda (mouse-list) - (princ mouse-list) - (princ " "))) - (cdr binding)) - (terpri) - (princ " ") - (princ (one-line-doc-string (car binding))) - (terpri) - ) - -(defun print-mouse-bindings (region) - "Prints mouse-event bindings for REGION." - (mapcar 'print-mouse-format (sm::event-bindings region))) - -(defun sm::event-bindings (region) - "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION, -where each mouse-list is bound to the function in REGION." - (let ((mouse-bindings (mouse-code-function-pairs-of-region region)) - (result nil)) - (while mouse-bindings - (let* ((code-function-pair (car mouse-bindings)) - (current-entry (assoc (cdr code-function-pair) result))) - (if current-entry - (setcdr current-entry - (cons (mouse-code-to-mouse-list (car code-function-pair)) - (cdr current-entry))) - (setq result (cons (cons (cdr code-function-pair) - (list (mouse-code-to-mouse-list - (car code-function-pair)))) - result)))) - (setq mouse-bindings (cdr mouse-bindings)) - ) - result)) - -(defun describe-mouse-bindings () - "Lists all current mouse-event bindings." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ "Text Region") (terpri) - (princ "---- ------") (terpri) - (print-mouse-bindings 'text) (terpri) - (princ "Modeline Region") (terpri) - (princ "-------- ------") (terpri) - (print-mouse-bindings 'modeline) (terpri) - (princ "Scrollbar Region") (terpri) - (princ "--------- ------") (terpri) - (print-mouse-bindings 'scrollbar))) - -(defun describe-mouse-briefly (mouse-list) - "Print a short description of the function bound to MOUSE-LIST." - (interactive "xDescribe mouse list briefly: ") - (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list)))) - (if function - (message "%s runs the command %s" mouse-list function) - (message "%s is undefined" mouse-list)))) - -(defun mouse-help-menu (function-and-binding) - (cons (prin1-to-string (car function-and-binding)) - (menu-create ; Two sub-menu items of form ("String" . nil) - (list (list (one-line-doc-string (car function-and-binding))) - (list (prin1-to-string (cdr function-and-binding))))))) - -(defun mouse-help-region (w x y &optional region) - "Displays a menu of mouse functions callable in this region." - (let* ((region (or region (sm::window-region (list w x y)))) - (mlist (mapcar (function mouse-help-menu) - (sm::event-bindings region))) - (menu (menu-create (cons (list (symbol-name region)) mlist))) - (item (sun-menu-evaluate w 0 y menu)) - ))) - -;;; -;;; Menu interface functions -;;; -;;; use defmenu, because this interface is subject to change -;;; really need a menu-p, but we use vectorp and the context... -;;; -(defun menu-create (items) - "Functional form for defmenu, given a list of ITEMS returns a menu. -Each ITEM is a (STRING . VALUE) pair." - (apply 'vector items) - ) - -(defmacro defmenu (menu &rest itemlist) - "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs. -See sun-menu-evaluate for interpretation of ITEMS." - (list 'defconst menu (funcall 'menu-create itemlist)) - ) - -(defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu) - "Display a pop-up menu in WINDOW at X Y and evaluate selected item -of MENU. MENU (or its symbol-value) should be a menu defined by defmenu. - A menu ITEM is a (STRING . FORM) pair; -the FORM associated with the selected STRING is evaluated, -and the resulting value is returned. Generally these FORMs are -evaluated for their side-effects rather than their values. - If the selected form is a menu or a symbol whose value is a menu, -then it is displayed and evaluated as a pullright menu item. - If the FORM of the first ITEM is nil, the STRING of the item -is used as a label for the menu, i.e. it's inverted and not selectable." - - (if (symbolp menu) (setq menu (symbol-value menu))) - (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu))) - -(defun sun-get-frame-data (code) - "Sends the tty-sub-window escape sequence CODE to terminal, -and returns a cons of the two numbers in returned escape sequence. -That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". -CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars." - (send-string-to-terminal (concat "\033[" (int-to-string code) "t")) - (let (char str x y) - (while (not (equal 116 (setq char (read-char)))) ; #\t = 116 - (setq str (cons char str))) - (setq str (mapconcat 'char-to-string (nreverse str) "")) - (string-match ";[0-9]*" str) - (setq y (substring str (1+ (match-beginning 0)) (match-end 0))) - (setq str (substring str (match-end 0))) - (string-match ";[0-9]*" str) - (setq x (substring str (1+ (match-beginning 0)) (match-end 0))) - (cons (string-to-number y) (string-to-number x)))) - -(defun sm::font-size () - "Returns font size in pixels: (cons Ysize Xsize)" - (let ((pix (sun-get-frame-data 14)) ; returns size in pixels - (chr (sun-get-frame-data 18))) ; returns size in chars - (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr))))) - -(defvar sm::menu-kludge-x nil - "Cached frame-to-window X-Offset for sm::menu-kludge") -(defvar sm::menu-kludge-y nil - "Cached frame-to-window Y-Offset for sm::menu-kludge") - -(defun sm::menu-kludge () - "If sunfns.c uses <Menu_Base_Kludge> this function must be here!" - (or sm::menu-kludge-y - (let ((fs (sm::font-size))) - (setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders - sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu - (let ((wl (sun-get-frame-data 13))) ; returns frame location - (cons (+ (car wl) sm::menu-kludge-y) - (+ (cdr wl) sm::menu-kludge-x)))) - -;;; -;;; Function interface to selection/region -;;; primitive functions are defined in sunfns.c -;;; -(defun sun-yank-selection () - "Set mark and yank the contents of the current sunwindows selection. -Insert contents into the current buffer at point." - (interactive "*") - (set-mark-command nil) - (insert (sun-get-selection))) - -(defun sun-select-region (beg end) - "Set the sunwindows selection to the region in the current buffer." - (interactive "r") - (sun-set-selection (buffer-substring beg end))) - -(provide 'sun-mouse) -(provide 'term/sun-mouse) ; have to (require 'term/sun-mouse) - -;;; arch-tag: 6e879372-b899-4509-833f-d7f6250e309a -;;; sun-mouse.el ends here diff --git a/lisp/term/sun.el b/lisp/term/sun.el index 4736e57340c..22b29c92790 100644 --- a/lisp/term/sun.el +++ b/lisp/term/sun.el @@ -47,14 +47,6 @@ (setq this-command 'kill-region-and-unmark) (set-mark-command t)) -(defun select-previous-complex-command () - "Select Previous-complex-command" - (interactive) - (if (zerop (minibuffer-depth)) - (repeat-complex-command 1) - ;; FIXME: this function does not seem to exist. -stef'01 - (previous-complex-command 1))) - (defun rerun-prev-command () "Repeat Previous-complex-command." (interactive) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index b233d0d62e0..cba8ba0cbb7 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -1158,6 +1158,17 @@ pop-up menu are unaffected by `w32-list-proportional-fonts')." ;; Setup the default fontset. (setup-default-fontset) + + ;; Enable Japanese fonts on Windows to be used by default. + (set-fontset-font nil (make-char 'katakana-jisx0201) + '("*" . "JISX0208-SJIS")) + (set-fontset-font nil (make-char 'latin-jisx0201) + '("*" . "JISX0208-SJIS")) + (set-fontset-font nil (make-char 'japanese-jisx0208) + '("*" . "JISX0208-SJIS")) + (set-fontset-font nil (make-char 'japanese-jisx0208-1978) + '("*" . "JISX0208-SJIS")) + ;; Create the standard fontset. (create-fontset-from-fontset-spec w32-standard-fontset-spec t) ;; Create fontset specified in X resources "Fontset-N" (N is 0, 1,...). diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 7d7afd88f61..8f5c092f126 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -2180,25 +2180,26 @@ Also, set the value of X cut buffer 0, for backward compatibility with older X applications. gildea@stop.mail-abuse.org says it's not desirable to put kills in the clipboard." - ;; Don't send the cut buffer too much text. - ;; It becomes slow, and if really big it causes errors. - (cond ((>= (length text) x-cut-buffer-max) - (x-set-cut-buffer "" push) - (setq x-last-selected-text-cut "" - x-last-selected-text-cut-encoded "")) - (t - (setq x-last-selected-text-cut text - x-last-cut-buffer-coding 'iso-latin-1 - x-last-selected-text-cut-encoded - ;; ICCCM says cut buffer always contain ISO-Latin-1 - (encode-coding-string text 'iso-latin-1)) - (x-set-cut-buffer x-last-selected-text-cut-encoded push))) - (x-set-selection 'PRIMARY text) - (setq x-last-selected-text-primary text) - (when x-select-enable-clipboard - (x-set-selection 'CLIPBOARD text) - (setq x-last-selected-text-clipboard text)) - ) + ;; With multi-tty, this function may be called from a tty frame. + (when (eq (framep (selected-frame)) 'x) + ;; Don't send the cut buffer too much text. + ;; It becomes slow, and if really big it causes errors. + (cond ((>= (length text) x-cut-buffer-max) + (x-set-cut-buffer "" push) + (setq x-last-selected-text-cut "" + x-last-selected-text-cut-encoded "")) + (t + (setq x-last-selected-text-cut text + x-last-cut-buffer-coding 'iso-latin-1 + x-last-selected-text-cut-encoded + ;; ICCCM says cut buffer always contain ISO-Latin-1 + (encode-coding-string text 'iso-latin-1)) + (x-set-cut-buffer x-last-selected-text-cut-encoded push))) + (x-set-selection 'PRIMARY text) + (setq x-last-selected-text-primary text) + (when x-select-enable-clipboard + (x-set-selection 'CLIPBOARD text) + (setq x-last-selected-text-clipboard text)))) (defvar x-select-request-type nil "*Data type request for X selection. @@ -2319,99 +2320,103 @@ order until succeed.") ;; it returns nil the second time. This is so that a single ;; selection won't be added to the kill ring over and over. (defun x-cut-buffer-or-selection-value () - (let (clip-text primary-text cut-text) - (when x-select-enable-clipboard - (setq clip-text (x-selection-value 'CLIPBOARD)) - (if (string= clip-text "") (setq clip-text nil)) - - ;; Check the CLIPBOARD selection for 'newness', is it different + ;; With multi-tty, this function may be called from a tty frame. + (when (eq (framep (selected-frame)) 'x) + (let (clip-text primary-text cut-text) + (when x-select-enable-clipboard + (setq clip-text (x-selection-value 'CLIPBOARD)) + (if (string= clip-text "") (setq clip-text nil)) + + ;; Check the CLIPBOARD selection for 'newness', is it different + ;; from what we remebered them to be last time we did a + ;; cut/paste operation. + (setq clip-text + (cond ;; check clipboard + ((or (not clip-text) (string= clip-text "")) + (setq x-last-selected-text-clipboard nil)) + ((eq clip-text x-last-selected-text-clipboard) nil) + ((string= clip-text x-last-selected-text-clipboard) + ;; Record the newer string, + ;; so subsequent calls can use the `eq' test. + (setq x-last-selected-text-clipboard clip-text) + nil) + (t (setq x-last-selected-text-clipboard clip-text))))) + + (setq primary-text (x-selection-value 'PRIMARY)) + ;; Check the PRIMARY selection for 'newness', is it different + ;; from what we remebered them to be last time we did a + ;; cut/paste operation. + (setq primary-text + (cond ;; check primary selection + ((or (not primary-text) (string= primary-text "")) + (setq x-last-selected-text-primary nil)) + ((eq primary-text x-last-selected-text-primary) nil) + ((string= primary-text x-last-selected-text-primary) + ;; Record the newer string, + ;; so subsequent calls can use the `eq' test. + (setq x-last-selected-text-primary primary-text) + nil) + (t + (setq x-last-selected-text-primary primary-text)))) + + (setq cut-text (x-get-cut-buffer 0)) + + ;; Check the x cut buffer for 'newness', is it different ;; from what we remebered them to be last time we did a ;; cut/paste operation. - (setq clip-text - (cond;; check clipboard - ((or (not clip-text) (string= clip-text "")) - (setq x-last-selected-text-clipboard nil)) - ((eq clip-text x-last-selected-text-clipboard) nil) - ((string= clip-text x-last-selected-text-clipboard) - ;; Record the newer string, - ;; so subsequent calls can use the `eq' test. - (setq x-last-selected-text-clipboard clip-text) - nil) - (t - (setq x-last-selected-text-clipboard clip-text)))) - ) - - (setq primary-text (x-selection-value 'PRIMARY)) - ;; Check the PRIMARY selection for 'newness', is it different - ;; from what we remebered them to be last time we did a - ;; cut/paste operation. - (setq primary-text - (cond;; check primary selection - ((or (not primary-text) (string= primary-text "")) - (setq x-last-selected-text-primary nil)) - ((eq primary-text x-last-selected-text-primary) nil) - ((string= primary-text x-last-selected-text-primary) - ;; Record the newer string, - ;; so subsequent calls can use the `eq' test. - (setq x-last-selected-text-primary primary-text) - nil) - (t - (setq x-last-selected-text-primary primary-text)))) - - (setq cut-text (x-get-cut-buffer 0)) - - ;; Check the x cut buffer for 'newness', is it different - ;; from what we remebered them to be last time we did a - ;; cut/paste operation. - (setq cut-text - (let ((next-coding (or next-selection-coding-system 'iso-latin-1))) - (cond;; check cut buffer - ((or (not cut-text) (string= cut-text "")) - (setq x-last-selected-text-cut nil)) - ;; This short cut doesn't work because x-get-cut-buffer - ;; always returns a newly created string. - ;; ((eq cut-text x-last-selected-text-cut) nil) - ((and (string= cut-text x-last-selected-text-cut-encoded) - (eq x-last-cut-buffer-coding next-coding)) - ;; See the comment above. No need of this recording. - ;; Record the newer string, - ;; so subsequent calls can use the `eq' test. - ;; (setq x-last-selected-text-cut cut-text) - nil) - (t - (setq x-last-selected-text-cut-encoded cut-text - x-last-cut-buffer-coding next-coding - x-last-selected-text-cut - ;; ICCCM says cut buffer always contain ISO-Latin-1, but - ;; use next-selection-coding-system if not nil. - (decode-coding-string - cut-text next-coding)))))) - - ;; As we have done one selection, clear this now. - (setq next-selection-coding-system nil) - - ;; At this point we have recorded the current values for the - ;; selection from clipboard (if we are supposed to) primary, - ;; and cut buffer. So return the first one that has changed - ;; (which is the first non-null one). - ;; - ;; NOTE: There will be cases where more than one of these has - ;; changed and the new values differ. This indicates that - ;; something like the following has happened since the last time - ;; we looked at the selections: Application X set all the - ;; selections, then Application Y set only one or two of them (say - ;; just the cut-buffer). In this case since we don't have - ;; timestamps there is no way to know what the 'correct' value to - ;; return is. The nice thing to do would be to tell the user we - ;; saw multiple possible selections and ask the user which was the - ;; one they wanted. - ;; This code is still a big improvement because now the user can - ;; futz with the current selection and get emacs to pay attention - ;; to the cut buffer again (previously as soon as clipboard or - ;; primary had been set the cut buffer would essentially never be - ;; checked again). - (or clip-text primary-text cut-text) - )) + (setq cut-text + (let ((next-coding (or next-selection-coding-system 'iso-latin-1))) + (cond ;; check cut buffer + ((or (not cut-text) (string= cut-text "")) + (setq x-last-selected-text-cut nil)) + ;; This short cut doesn't work because x-get-cut-buffer + ;; always returns a newly created string. + ;; ((eq cut-text x-last-selected-text-cut) nil) + ((and (string= cut-text x-last-selected-text-cut-encoded) + (eq x-last-cut-buffer-coding next-coding)) + ;; See the comment above. No need of this recording. + ;; Record the newer string, + ;; so subsequent calls can use the `eq' test. + ;; (setq x-last-selected-text-cut cut-text) + nil) + (t + (setq x-last-selected-text-cut-encoded cut-text + x-last-cut-buffer-coding next-coding + x-last-selected-text-cut + ;; ICCCM says cut buffer always contain ISO-Latin-1, but + ;; use next-selection-coding-system if not nil. + (decode-coding-string + cut-text next-coding)))))) + + ;; As we have done one selection, clear this now. + (setq next-selection-coding-system nil) + + ;; At this point we have recorded the current values for the + ;; selection from clipboard (if we are supposed to) primary, + ;; and cut buffer. So return the first one that has changed + ;; (which is the first non-null one). + ;; + ;; NOTE: There will be cases where more than one of these has + ;; changed and the new values differ. This indicates that + ;; something like the following has happened since the last time + ;; we looked at the selections: Application X set all the + ;; selections, then Application Y set only one or two of them (say + ;; just the cut-buffer). In this case since we don't have + ;; timestamps there is no way to know what the 'correct' value to + ;; return is. The nice thing to do would be to tell the user we + ;; saw multiple possible selections and ask the user which was the + ;; one they wanted. + ;; This code is still a big improvement because now the user can + ;; futz with the current selection and get emacs to pay attention + ;; to the cut buffer again (previously as soon as clipboard or + ;; primary had been set the cut buffer would essentially never be + ;; checked again). + (or clip-text primary-text cut-text) + ))) + +;; Arrange for the kill and yank functions to set and check the clipboard. +(setq interprogram-cut-function 'x-select-text) +(setq interprogram-paste-function 'x-cut-buffer-or-selection-value) (defun x-clipboard-yank () "Insert the clipboard contents, or the last stretch of killed text." diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 69d8c814f46..73e8ec49045 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -296,6 +296,7 @@ property of the major mode name.") ;;*--- mail mode -------------------------------------------------------*/ (put 'mail-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) (put 'message-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) +(defvar message-signature-separator) (defun mail-mode-flyspell-verify () "Function used for `flyspell-generic-check-word-predicate' in Mail mode." (let ((header-end (save-excursion diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el index 31ec234fddc..97b9f3b45c3 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -132,6 +132,8 @@ closing requests for requests that are used in matched pairs." (set (make-local-variable 'comment-start-skip) "\\\\[\"#][ \t]*") (set (make-local-variable 'comment-column) 24) (set (make-local-variable 'comment-indent-function) 'nroff-comment-indent) + (set (make-local-variable 'comment-insert-comment-function) + 'nroff-insert-comment-function) (set (make-local-variable 'imenu-generic-expression) nroff-imenu-expression)) (defun nroff-outline-level () @@ -151,6 +153,7 @@ Puts a full-stop before comments on a line by themselves." (skip-chars-backward " \t") (if (bolp) (progn + ;; FIXME delete-horizontal-space? (setq pt (1+ pt)) (insert ?.) 1) @@ -163,6 +166,12 @@ Puts a full-stop before comments on a line by themselves." 9) 8)))))) ; add 9 to ensure at least two blanks (goto-char pt)))) +;; http://lists.gnu.org/archive/html/emacs-devel/2007-10/msg01869.html +(defun nroff-insert-comment-function () + "Function for `comment-insert-comment-function' in `nroff-mode'." + (indent-to (nroff-comment-indent)) + (insert comment-start)) + (defun nroff-count-text-lines (start end &optional print) "Count lines in region, except for nroff request lines. All lines not starting with a period are counted up. @@ -175,7 +184,7 @@ Noninteractively, return number of non-request lines from START to END." (save-restriction (narrow-to-region start end) (goto-char (point-min)) - (- (buffer-size) (forward-text-line (buffer-size))))))) + (- (buffer-size) (nroff-forward-text-line (buffer-size))))))) (defun nroff-forward-text-line (&optional cnt) "Go forward one nroff text line, skipping lines of nroff requests. diff --git a/lisp/textmodes/org-export-latex.el b/lisp/textmodes/org-export-latex.el index e6c68f25c4c..b1b31b622d1 100644 --- a/lisp/textmodes/org-export-latex.el +++ b/lisp/textmodes/org-export-latex.el @@ -1,6 +1,6 @@ ;;; org-export-latex.el --- LaTeX exporter for org-mode ;; -;; copyright (c) 2007 free software foundation, inc. +;; Copyright (C) 2007 Free Software Foundation, Inc. ;; ;; Emacs Lisp Archive Entry ;; Filename: org-export-latex.el @@ -22,7 +22,7 @@ ;; 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., 51 Franklin Street, Fifth Floor, Boston, MA diff --git a/lisp/textmodes/org-publish.el b/lisp/textmodes/org-publish.el index 26dc409e19c..e98afaf4a6b 100644 --- a/lisp/textmodes/org-publish.el +++ b/lisp/textmodes/org-publish.el @@ -426,7 +426,7 @@ nil if not found." (defun org-publish-get-plist-from-filename (filename) "Return publishing configuration plist for file FILENAME." (let ((found nil)) - (mapcar + (mapc (lambda (plist) (let ((files (org-publish-get-base-files plist))) (if (member (expand-file-name filename) files) diff --git a/lisp/textmodes/org.el b/lisp/textmodes/org.el index 4ba90216d85..b555e6c1102 100644 --- a/lisp/textmodes/org.el +++ b/lisp/textmodes/org.el @@ -5,7 +5,7 @@ ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://orgmode.org -;; Version: 5.13g +;; Version: 5.13i ;; ;; This file is part of GNU Emacs. ;; @@ -83,7 +83,7 @@ ;;; Version -(defconst org-version "5.13g" +(defconst org-version "5.13i" "The version number of the file org.el.") (defun org-version () (interactive) @@ -9780,7 +9780,6 @@ With prefix arg ALL, do this for all lines in the table." (defun org-table-formula-substitute-names (f) "Replace $const with values in string F." - (message "form %s" f) (sit-for 1) (let ((start 0) a (f1 f) (pp (/= (string-to-char f) ?'))) ;; First, check for column names (while (setq start (string-match org-table-column-name-regexp f start)) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 35714ddb0b2..f430e9bd01a 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -52,7 +52,7 @@ which is part of AUCTeX, the string is first processed with the (interactive "P") (let* ((use-default (not (equal arg '(16)))) ; check for double prefix ;; check if we have an active selection - (active (if (boundp 'zmacs-regions) + (active (if (featurep 'xemacs) (and zmacs-regions (region-exists-p)) ; XEmacs (and transient-mark-mode mark-active))) ; Emacs (beg (if active diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 0c1beb17763..5383d88c386 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -338,6 +338,169 @@ (defvar reftex-toc-auto-recenter-timer nil "The idle timer used to recenter the toc window.") +;;; ========================================================================= +;;; +;;; Parser functions + +(autoload 'reftex-parse-one "reftex-parse" + "Re-parse this file." t) +(autoload 'reftex-parse-all "reftex-parse" + "Re-parse entire document." t) +(autoload 'reftex-do-parse "reftex-parse") +(autoload 'reftex-where-am-I "reftex-parse") +(autoload 'reftex-init-section-numbers "reftex-parse") +(autoload 'reftex-section-info "reftex-parse") +(autoload 'reftex-section-number "reftex-parse") +(autoload 'reftex-what-macro "reftex-parse") +(autoload 'reftex-what-macro-safe "reftex-parse") +(autoload 'reftex-index-info "reftex-parse") +(autoload 'reftex-index-info-safe "reftex-parse") +(autoload 'reftex-short-context "reftex-parse") +(autoload 'reftex-what-environment "reftex-parse") +(autoload 'reftex-what-special-env "reftex-parse") +(autoload 'reftex-move-over-touching-args "reftex-parse") +(autoload 'reftex-notice-new "reftex-parse") +(autoload 'reftex-nth-arg "reftex-parse") +(autoload 'reftex-locate-bibliography-files "reftex-parse") +(autoload 'reftex-ensure-index-support "reftex-parse") +(autoload 'reftex-everything-regexp "reftex-parse") + + +;;; ========================================================================= +;;; +;;; Labels and References + +(autoload 'reftex-label-location "reftex-ref") +(autoload 'reftex-label-info-update "reftex-ref") +(autoload 'reftex-label-info "reftex-ref") +(autoload 'reftex-label "reftex-ref" + "Insert a unique label." t) +(autoload 'reftex-reference "reftex-ref" + "Make a LaTeX reference." t) +(autoload 'reftex-varioref-vref "reftex-ref" + "Make a varioref reference." t) +(autoload 'reftex-fancyref-fref "reftex-ref" + "Make a fancyref \\fref reference." t) +(autoload 'reftex-fancyref-Fref "reftex-ref" + "Make a fancyref \\Fref reference." t) +(autoload 'reftex-show-label-location "reftex-ref") +(autoload 'reftex-query-label-type "reftex-ref") +(autoload 'reftex-goto-label "reftex-ref" + "Prompt for label name and go to that location." t) + +;;; ========================================================================= +;;; +;;; Table of contents + +(autoload 'reftex-toc "reftex-toc" + "Show the table of contents for the current document." t) +(autoload 'reftex-toc-recenter "reftex-toc" + "Display the TOC window and highlight line corresponding to current position." t) +(autoload 'reftex-toggle-auto-toc-recenter "reftex-toc" + "Toggle automatic recentering of TOC window." t) + +;;; ========================================================================= +;;; +;;; BibTeX citations. + +(autoload 'reftex-citep "reftex-cite") +(autoload 'reftex-citet "reftex-cite") +(autoload 'reftex-make-cite-echo-string "reftex-cite") +(autoload 'reftex-get-bibfile-list "reftex-cite") +(autoload 'reftex-pop-to-bibtex-entry "reftex-cite") +(autoload 'reftex-end-of-bib-entry "reftex-cite") +(autoload 'reftex-parse-bibtex-entry "reftex-cite") +(autoload 'reftex-citation "reftex-cite" + "Make a citation using BibTeX database files." t) +(autoload 'reftex-default-bibliography "reftex-cite") +(autoload 'reftex-bib-or-thebib "reftex-cite") +(autoload 'reftex-create-bibtex-file "reftex-cite") + +;;; ========================================================================= +;;; +;;; Selection + +(autoload 'reftex-select-label-mode "reftex-sel") +(autoload 'reftex-select-bib-mode "reftex-sel") +(autoload 'reftex-find-start-point "reftex-sel") +(autoload 'reftex-insert-docstruct "reftex-sel") +(autoload 'reftex-get-offset "reftex-sel") +(autoload 'reftex-select-item "reftex-sel") + + +;;; ========================================================================= +;;; +;;; Index support + +(autoload 'reftex-index "reftex-index" + "Query for an index macro and insert it along with its argments." t) +(autoload 'reftex-index-selection-or-word "reftex-index" + "Put selection or the word near point into the default index macro." t) +(autoload 'reftex-index-phrase-selection-or-word "reftex-index" + "Put selection or the word near point into Index Phrases File." t) +(autoload 'reftex-display-index "reftex-index" + "Display a buffer with an index compiled from the current document." t) +(autoload 'reftex-index-visit-phrases-buffer "reftex-index" + "Visit the Index Phrases File." t) +(autoload 'reftex-index-phrases-mode "reftex-index" + "Major mode for managing the Index phrases of a LaTeX document." t) +(autoload 'reftex-index-complete-tag "reftex-index") +(autoload 'reftex-index-complete-key "reftex-index") +(autoload 'reftex-index-show-entry "reftex-index") +(autoload 'reftex-index-select-tag "reftex-index") + + +;;; ========================================================================= +;;; +;;; View cross references + +(autoload 'reftex-view-crossref "reftex-dcr" + "View cross reference of \\ref or \\cite macro at point." t) +(autoload 'reftex-mouse-view-crossref "reftex-dcr" + "View cross reference of \\ref or \\cite macro where you click." t) +(autoload 'reftex-toggle-auto-view-crossref "reftex-dcr") +(autoload 'reftex-view-crossref-from-bibtex "reftex-dcr" + "View location in a LaTeX document which cites the BibTeX entry at point." t) + + +;;; ========================================================================= +;;; +;;; Operations on entire Multifile documents + +(autoload 'reftex-create-tags-file "reftex-global" + "Create TAGS file by running `etags' on the current document." t) +(autoload 'reftex-grep-document "reftex-global" + "Run grep query through all files related to this document." t) +(autoload 'reftex-search-document "reftex-global" + "Regexp search through all files of the current TeX document." t) +(autoload 'reftex-query-replace-document "reftex-global" + "Run a query-replace-regexp of FROM with TO over the entire TeX document." t) +(autoload 'reftex-find-duplicate-labels "reftex-global" + "Produce a list of all duplicate labels in the document." t) +(autoload 'reftex-change-label "reftex-global" + "Query replace FROM with TO in all \\label and \\ref commands." t) +(autoload 'reftex-renumber-simple-labels "reftex-global" + "Renumber all simple labels in the document to make them sequentially." t) +(autoload 'reftex-save-all-document-buffers "reftex-global" + "Save all documents associated with the current document." t) + + +;;; ========================================================================= +;;; +;;; AUCTeX Interface + +(autoload 'reftex-arg-label "reftex-auc") +(autoload 'reftex-arg-cite "reftex-auc") +(autoload 'reftex-arg-index-tag "reftex-auc") +(autoload 'reftex-arg-index "reftex-auc") +(autoload 'reftex-plug-into-AUCTeX "reftex-auc") +(autoload 'reftex-toggle-plug-into-AUCTeX "reftex-auc" + "Toggle Interface between AUCTeX and RefTeX on and off." t) +(autoload 'reftex-add-label-environments "reftex-auc") +(autoload 'reftex-add-to-label-alist "reftex-auc") +(autoload 'reftex-add-section-levels "reftex-auc") +(autoload 'reftex-notice-new-section "reftex-auc") + ;;;###autoload (defun turn-on-reftex () "Turn on RefTeX mode." @@ -1608,169 +1771,6 @@ When DIE is non-nil, throw an error if file not found." ;;; ========================================================================= ;;; -;;; Parser functions - -(autoload 'reftex-parse-one "reftex-parse" - "Re-parse this file." t) -(autoload 'reftex-parse-all "reftex-parse" - "Re-parse entire document." t) -(autoload 'reftex-do-parse "reftex-parse") -(autoload 'reftex-where-am-I "reftex-parse") -(autoload 'reftex-init-section-numbers "reftex-parse") -(autoload 'reftex-section-info "reftex-parse") -(autoload 'reftex-section-number "reftex-parse") -(autoload 'reftex-what-macro "reftex-parse") -(autoload 'reftex-what-macro-safe "reftex-parse") -(autoload 'reftex-index-info "reftex-parse") -(autoload 'reftex-index-info-safe "reftex-parse") -(autoload 'reftex-short-context "reftex-parse") -(autoload 'reftex-what-environment "reftex-parse") -(autoload 'reftex-what-special-env "reftex-parse") -(autoload 'reftex-move-over-touching-args "reftex-parse") -(autoload 'reftex-notice-new "reftex-parse") -(autoload 'reftex-nth-arg "reftex-parse") -(autoload 'reftex-locate-bibliography-files "reftex-parse") -(autoload 'reftex-ensure-index-support "reftex-parse") -(autoload 'reftex-everything-regexp "reftex-parse") - - -;;; ========================================================================= -;;; -;;; Labels and References - -(autoload 'reftex-label-location "reftex-ref") -(autoload 'reftex-label-info-update "reftex-ref") -(autoload 'reftex-label-info "reftex-ref") -(autoload 'reftex-label "reftex-ref" - "Insert a unique label." t) -(autoload 'reftex-reference "reftex-ref" - "Make a LaTeX reference." t) -(autoload 'reftex-varioref-vref "reftex-ref" - "Make a varioref reference." t) -(autoload 'reftex-fancyref-fref "reftex-ref" - "Make a fancyref \\fref reference." t) -(autoload 'reftex-fancyref-Fref "reftex-ref" - "Make a fancyref \\Fref reference." t) -(autoload 'reftex-show-label-location "reftex-ref") -(autoload 'reftex-query-label-type "reftex-ref") -(autoload 'reftex-goto-label "reftex-ref" - "Prompt for label name and go to that location." t) - -;;; ========================================================================= -;;; -;;; Table of contents - -(autoload 'reftex-toc "reftex-toc" - "Show the table of contents for the current document." t) -(autoload 'reftex-toc-recenter "reftex-toc" - "Display the TOC window and highlight line corresponding to current position." t) -(autoload 'reftex-toggle-auto-toc-recenter "reftex-toc" - "Toggle automatic recentering of TOC window." t) - -;;; ========================================================================= -;;; -;;; BibTeX citations. - -(autoload 'reftex-citep "reftex-cite") -(autoload 'reftex-citet "reftex-cite") -(autoload 'reftex-make-cite-echo-string "reftex-cite") -(autoload 'reftex-get-bibfile-list "reftex-cite") -(autoload 'reftex-pop-to-bibtex-entry "reftex-cite") -(autoload 'reftex-end-of-bib-entry "reftex-cite") -(autoload 'reftex-parse-bibtex-entry "reftex-cite") -(autoload 'reftex-citation "reftex-cite" - "Make a citation using BibTeX database files." t) -(autoload 'reftex-default-bibliography "reftex-cite") -(autoload 'reftex-bib-or-thebib "reftex-cite") -(autoload 'reftex-create-bibtex-file "reftex-cite") - -;;; ========================================================================= -;;; -;;; Selection - -(autoload 'reftex-select-label-mode "reftex-sel") -(autoload 'reftex-select-bib-mode "reftex-sel") -(autoload 'reftex-find-start-point "reftex-sel") -(autoload 'reftex-insert-docstruct "reftex-sel") -(autoload 'reftex-get-offset "reftex-sel") -(autoload 'reftex-select-item "reftex-sel") - - -;;; ========================================================================= -;;; -;;; Index support - -(autoload 'reftex-index "reftex-index" - "Query for an index macro and insert it along with its argments." t) -(autoload 'reftex-index-selection-or-word "reftex-index" - "Put selection or the word near point into the default index macro." t) -(autoload 'reftex-index-phrase-selection-or-word "reftex-index" - "Put selection or the word near point into Index Phrases File." t) -(autoload 'reftex-display-index "reftex-index" - "Display a buffer with an index compiled from the current document." t) -(autoload 'reftex-index-visit-phrases-buffer "reftex-index" - "Visit the Index Phrases File." t) -(autoload 'reftex-index-phrases-mode "reftex-index" - "Major mode for managing the Index phrases of a LaTeX document." t) -(autoload 'reftex-index-complete-tag "reftex-index") -(autoload 'reftex-index-complete-key "reftex-index") -(autoload 'reftex-index-show-entry "reftex-index") -(autoload 'reftex-index-select-tag "reftex-index") - - -;;; ========================================================================= -;;; -;;; View cross references - -(autoload 'reftex-view-crossref "reftex-dcr" - "View cross reference of \\ref or \\cite macro at point." t) -(autoload 'reftex-mouse-view-crossref "reftex-dcr" - "View cross reference of \\ref or \\cite macro where you click." t) -(autoload 'reftex-toggle-auto-view-crossref "reftex-dcr") -(autoload 'reftex-view-crossref-from-bibtex "reftex-dcr" - "View location in a LaTeX document which cites the BibTeX entry at point." t) - - -;;; ========================================================================= -;;; -;;; Operations on entire Multifile documents - -(autoload 'reftex-create-tags-file "reftex-global" - "Create TAGS file by running `etags' on the current document." t) -(autoload 'reftex-grep-document "reftex-global" - "Run grep query through all files related to this document." t) -(autoload 'reftex-search-document "reftex-global" - "Regexp search through all files of the current TeX document." t) -(autoload 'reftex-query-replace-document "reftex-global" - "Run a query-replace-regexp of FROM with TO over the entire TeX document." t) -(autoload 'reftex-find-duplicate-labels "reftex-global" - "Produce a list of all duplicate labels in the document." t) -(autoload 'reftex-change-label "reftex-global" - "Query replace FROM with TO in all \\label and \\ref commands." t) -(autoload 'reftex-renumber-simple-labels "reftex-global" - "Renumber all simple labels in the document to make them sequentially." t) -(autoload 'reftex-save-all-document-buffers "reftex-global" - "Save all documents associated with the current document." t) - - -;;; ========================================================================= -;;; -;;; AUCTeX Interface - -(autoload 'reftex-arg-label "reftex-auc") -(autoload 'reftex-arg-cite "reftex-auc") -(autoload 'reftex-arg-index-tag "reftex-auc") -(autoload 'reftex-arg-index "reftex-auc") -(autoload 'reftex-plug-into-AUCTeX "reftex-auc") -(autoload 'reftex-toggle-plug-into-AUCTeX "reftex-auc" - "Toggle Interface between AUCTeX and RefTeX on and off." t) -(autoload 'reftex-add-label-environments "reftex-auc") -(autoload 'reftex-add-to-label-alist "reftex-auc") -(autoload 'reftex-add-section-levels "reftex-auc") -(autoload 'reftex-notice-new-section "reftex-auc") - -;;; ========================================================================= -;;; ;;; Some generally useful functions (defun reftex-typekey-check (typekey conf-variable &optional n) @@ -2334,16 +2334,14 @@ IGNORE-WORDS List of words which should be removed from the string." (if (facep face) (throw 'exit face))))))) ;; Highlighting uses overlays. For XEmacs, we use extends. -(if (featurep 'xemacs) - (progn - (defalias 'reftex-make-overlay 'make-extent) - (defalias 'reftex-overlay-put 'set-extent-property) - (defalias 'reftex-move-overlay 'set-extent-endpoints) - (defalias 'reftex-delete-overlay 'detach-extent)) - (defalias 'reftex-make-overlay 'make-overlay) - (defalias 'reftex-overlay-put 'overlay-put) - (defalias 'reftex-move-overlay 'move-overlay) - (defalias 'reftex-delete-overlay 'delete-overlay)) +(defalias 'reftex-make-overlay + (if (featurep 'xemacs) 'make-extent 'make-overlay)) +(defalias 'reftex-overlay-put + (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) +(defalias 'reftex-move-overlay + (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay)) +(defalias 'reftex-delete-overlay + (if (featurep 'xemacs) 'detach-extent 'delete-overlay)) ;; We keep a vector with several different overlays to do our highlighting. (defvar reftex-highlight-overlays [nil nil nil]) diff --git a/lisp/textmodes/remember-diary.el b/lisp/textmodes/remember-diary.el new file mode 100644 index 00000000000..e35909fb589 --- /dev/null +++ b/lisp/textmodes/remember-diary.el @@ -0,0 +1,94 @@ +;;; remember-diary --- extracting diary information from buffers + +;; Copyright (C) 1999, 2000, 2001, 2004, 2007 Free Software Foundation, Inc. + +;; Author: Sacha Chua <sacha@free.net.ph> +;; Created: 24 Mar 2004 +;; Keywords: data memory todo pim diary +;; URL: http://gna.org/projects/remember-el/ + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This module recognizes entries of the form +;; +;; DIARY: .... +;; +;; and puts them in your ~/.diary (or remember-diary-file) together +;; with an annotation. Planner-style dates (yyyy.mm.dd) are converted +;; to yyyy-mm-dd so that diary can understand them. +;; +;; For example: +;; +;; DIARY: 2003.08.12 Sacha's birthday +;; +;; is stored as +;; +;; 2003.08.12 Sacha's birthday [[/home/sacha/notebook/emacs/emacs-wiki/remember-diary.el]] +;; +;; To use, add the following to your .emacs: +;; +;; (require 'remember-diary) +;; ;; This should be before other entries that may return t +;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) +;; + +(require 'remember) +(require 'diary-lib) + +;;; Code: +(defcustom remember-diary-file diary-file + "*File for extracted diary entries." + :type 'file + :group 'remember) + +(defun remember-diary-convert-entry (entry) + "Translate MSG to an entry readable by diary." + (save-match-data + (when remember-annotation + (setq entry (concat entry " " remember-annotation))) + (if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)" entry) + (replace-match + (if european-calendar-style + (concat (match-string 3 entry) "/" + (match-string 2 entry) "/" + (match-string 1 entry)) + (concat (match-string 2 entry) "/" + (match-string 3 entry) "/" + (match-string 1 entry))) + t t entry) + entry))) + +;;;###autoload +(defun remember-diary-extract-entries () + "Extract diary entries from the region." + (save-excursion + (goto-char (point-min)) + (let (list) + (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) + (add-to-list 'list (remember-diary-convert-entry (match-string 1)))) + (when list + (make-diary-entry (mapconcat 'identity list "\n") + nil remember-diary-file)) + nil))) ;; Continue processing + +(provide 'remember-diary) + +;; arch-tag: bda8a3f8-9a9b-46aa-8493-d71d7f1e445d +;;; remember-diary.el ends here diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el new file mode 100644 index 00000000000..7249f1d4c57 --- /dev/null +++ b/lisp/textmodes/remember.el @@ -0,0 +1,471 @@ +;;; remember --- a mode for quickly jotting down things to remember + +;; Copyright (C) 1999, 2000, 2001, 2003, 2004, 2005, 2006, +;; 2007 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw@gnu.org> +;; Created: 29 Mar 1999 +;; Version: 1.9 +;; Keywords: data memory todo pim +;; URL: http://gna.org/projects/remember-el/ + +;; 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 3, 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; * The idea +;; +;; Todo lists, schedules, phone databases... everything we use +;; databases for is really just a way to extend the power of our +;; memory. To be able to remember what our conscious mind may not +;; currently have access to. +;; +;; There are many different databases out there -- and good ones -- +;; which this mode is not trying to replace. Rather, it's how that +;; data gets there that's the question. Most of the time, we just +;; want to say "Remember so-and-so's phone number, or that I have to +;; buy dinner for the cats tonight." That's the FACT. How it's +;; stored is really the computer's problem. But at this point in +;; time, it's most definitely also the user's problem, and sometimes +;; so laboriously so that people just let data slip, rather than +;; expend the effort to record it. +;; +;; "Remember" is a mode for remembering data. It uses whatever +;; back-end is appropriate to record and correlate the data, but it's +;; main intention is to allow you to express as _little_ structure as +;; possible up front. If you later want to express more powerful +;; relationships between your data, or state assumptions that were at +;; first too implicit to be recognized, you can "study" the data later +;; and rearrange it. But the initial "just remember this" impulse +;; should be as close to simply throwing the data at Emacs as +;; possible. +;; +;; * Implementation +;; +;; Hyperbole, as a data presentation tool, always struck me as being +;; very powerful, but it seemed to require a lot of "front-end" work +;; before that data was really available. The problem with BBDB, or +;; keeping up a Bibl-mode file, is that you have to use different +;; functions to record the data, and it always takes time to stop what +;; you're doing, format the data in the manner expected by that +;; particular data interface, and then resume your work. +;; +;; With "remember", you just hit `M-x remember' (you'd probably want +;; to bind this to an easily accessible keystroke, like C-x M-r), slam +;; in your text however you like, and then hit C-c C-c. It will file +;; the data away for later retrieval, and possibly indexing. +;; +;; Indexing is to data what "studying" is in the real world. What you +;; do when you study (or lucubrate, for some of us) is to realize +;; certain relationships implicit in the data, so that you can make +;; use of those relationships. Expressing that a certain quote you +;; remembered was a religious quote, and that you want the ability to +;; pull up all quotes of a religious nature, is what studying does. +;; This is a more labor intensive task than the original remembering +;; of the data, and it's typical in real life to set aside a special +;; period of time for doing this work. +;; +;; "Remember" works in the same way. When you enter data, either by +;; typing it into a buffer, or using the contents of the selected +;; region, it will store that data -- unindexed, uninterpreted -- in a +;; data pool. It will also try to remember as much context +;; information as possible (any text properties that were set, where +;; you copied it from, when, how, etc). Later, you can walk through +;; your accumulated set of data (both organized, and unorganized) and +;; easily begin moving things around, and making annotations that will +;; express the full meaning of that data, as far as you know it. +;; +;; Obviously this latter stage is more user-interface intensive, and +;; it would be nice if "remember" could do it as elegantly as +;; possible, rather than requiring a billion keystrokes to reorganize +;; your hierarchy. Well, as the future arrives, hopefully experience +;; and user feedback will help to make this as intuitive a tool as +;; possible. +;; +;; * Future Goals +;; +;; This tool hopes to track (and by doing it with as little new code +;; as possible): +;; +;; - The raw data that gets entered +;; +;; - The relationships between that data (either determined +;; implicitly by parsing the input, or explicitly by the user's +;; studying the data). +;; +;; - Revisioning of the data +;; +;; - Where it came from, and any context information that can be +;; programmatically determined. +;; +;; - Allowing particular views of the initially amorphous data pool +;; (ala the Xanadu concept). +;; +;; - Storage of the data in a manner most appopriate to that data, +;; such as keeping address-book type information in BBDB, etc. +;; +;; * Using "remember" +;; +;; As a rough beginning, what I do is to keep my .notes file in +;; outline-mode format, with a final entry called "* Raw data". Then, +;; at intervals, I can move the data that gets appended there into +;; other places. But certainly this should evolve into an intuitive +;; mechanism for shuffling data off to its appropriate corner of the +;; universe. +;; +;; To map the primary remember function to the keystroke F8, do the +;; following. +;; +;; (autoload 'remember "remember" nil t) +;; +;; (define-key global-map [f8] 'remember) +;; +;; * Feedback +;; +;; If Emacs could become a more intelligent data store, where +;; brainstorming would focus on the IDEAS involved -- rather than the +;; structuring and format of those ideas, or having to stop your +;; current flow of work in order to record them -- it would map much +;; more closely to how the mind (well, at least mine) works, and hence +;; would eliminate that very manual-ness which computers from the very +;; beginning have been championed as being able to reduce. +;; +;; Have you ever noticed that having a laptop to write on doesn't +;; _actually_ increase the amount of quality material that you turn +;; out, in the long run? Perhaps its because the time we save +;; electronically in one way, we're losing electronically in another; +;; the tool should never dominate one's focus. As the mystic +;; Faridu'd-Din `Attar wrote: "Be occupied as little as possible with +;; things of the outer world but much with things of the inner world; +;; then right action will overcome inaction." + +;;; History: + +;;; Code: + +(provide 'remember) + +(defconst remember-version "1.9" + "This version of remember.") + +(defgroup remember nil + "A mode to remember information." + :group 'data) + +;;; User Variables: + +(defcustom remember-mode-hook nil + "Functions run upon entering `remember-mode'." + :type 'hook + :options '(flyspell-mode turn-on-auto-fill org-remember-apply-template) + :group 'remember) + +(defcustom remember-in-new-frame nil + "Non-nil means use a separate frame for capturing remember data." + :type 'boolean + :group 'remember) + +(defcustom remember-register ?R + "The register in which the window configuration is stored." + :type 'character + :group 'remember) + +(defcustom remember-filter-functions nil + "*Functions run to filter remember data. +All functions are run in the remember buffer." + :type 'hook + :group 'remember) + +(defcustom remember-handler-functions '(remember-append-to-file) + "*Functions run to process remember data. +Each function is called with the current buffer narrowed to what the +user wants remembered. +If any function returns non-nil, the data is assumed to have been +recorded somewhere by that function. " + :type 'hook + :options '(remember-store-in-mailbox + remember-append-to-file + remember-diary-extract-entries + org-remember-handler) + :group 'remember) + +(defcustom remember-all-handler-functions nil + "If non-nil every function in `remember-handler-functions' is +called." + :type 'boolean + :group 'remember) + +;;; Internal Variables: + +(defvar remember-buffer "*Remember*" + "The name of the remember data entry buffer.") + +(defcustom remember-save-after-remembering t + "*Non-nil means automatically save after remembering." + :type 'boolean + :group 'remember) + +;;; User Functions: + +(defcustom remember-annotation-functions '(buffer-file-name) + "Hook that returns an annotation to be inserted into the remember buffer." + :type 'hook + :options '(org-remember-annotation buffer-file-name) + :group 'remember) + +(defvar remember-annotation nil + "Current annotation.") +(defvar remember-initial-contents nil + "Initial contents to place into *Remember* buffer.") + +(defcustom remember-before-remember-hook nil + "Functions run before switching to the *Remember* buffer." + :type 'hook + :group 'remember) + +(defcustom remember-run-all-annotation-functions-flag nil + "Non-nil means use all annotations returned by +`remember-annotation-functions'." + :type 'boolean + :group 'remember) + +;;;###autoload +(defun remember (&optional initial) + "Remember an arbitrary piece of data. +INITIAL is the text to initially place in the *Remember* buffer, +or nil to bring up a blank *Remember* buffer. + +With a prefix, use the region as INITIAL." + (interactive + (list (when current-prefix-arg + (buffer-substring (point) (mark))))) + (funcall (if remember-in-new-frame + #'frame-configuration-to-register + #'window-configuration-to-register) remember-register) + (let* ((annotation + (if remember-run-all-annotation-functions-flag + (mapconcat 'identity + (delq nil + (mapcar 'funcall remember-annotation-functions)) + "\n") + (run-hook-with-args-until-success + 'remember-annotation-functions))) + (buf (get-buffer-create remember-buffer))) + (run-hooks 'remember-before-remember-hook) + (funcall (if remember-in-new-frame + #'switch-to-buffer-other-frame + #'switch-to-buffer-other-window) buf) + (if remember-in-new-frame + (set-window-dedicated-p + (get-buffer-window (current-buffer) (selected-frame)) t)) + (remember-mode) + (when (= (point-max) (point-min)) + (when initial (insert initial)) + (setq remember-annotation annotation) + (when remember-initial-contents (insert remember-initial-contents)) + (when (and (stringp annotation) + (not (equal annotation ""))) + (insert "\n\n" annotation)) + (setq remember-initial-contents nil) + (goto-char (point-min))) + (message "Use C-c C-c to remember the data."))) + +;;;###autoload +(defun remember-other-frame (&optional initial) + "Call `remember' in another frame." + (interactive + (list (when current-prefix-arg + (buffer-substring (point) (mark))))) + (let ((remember-in-new-frame t)) + (remember initial))) + +(defsubst remember-time-to-seconds (time) + "Convert TIME to a floating point number." + (+ (* (car time) 65536.0) + (cadr time) + (/ (or (car (cdr (cdr time))) 0) 1000000.0))) + +(defsubst remember-mail-date (&optional rfc822-p) + "Return a simple date. Nothing fancy." + (if rfc822-p + (format-time-string "%a, %e %b %Y %T %z" (current-time)) + (format-time-string "%c" (current-time)))) + +(defun remember-buffer-desc () + "Using the first line of the current buffer, create a short description." + (buffer-substring (point-min) + (save-excursion + (goto-char (point-min)) + (end-of-line) + (if (> (- (point) (point-min)) 60) + (goto-char (+ (point-min) 60))) + (point)))) + +;; Remembering to UNIX mailboxes + +(defcustom remember-mailbox "~/Mail/remember" + "*The file in which to store remember data as mail." + :type 'file + :group 'remember) + +(defcustom remember-default-priority "medium" + "*The default priority for remembered mail messages." + :type 'string + :group 'remember) + +(defun remember-store-in-mailbox () + "Store remember data as if it were incoming mail. +In which case `remember-mailbox' should be the name of the mailbox. +Each piece of psuedo-mail created will have an `X-Todo-Priority' +field, for the purpose of appropriate splitting." + (let ((who (read-string "Who is this item related to? ")) + (moment + (format "%.0f" (remember-time-to-seconds (current-time)))) + (desc (remember-buffer-desc)) + (text (buffer-string))) + (with-temp-buffer + (insert (format " +From %s %s +Date: %s +From: %s +Message-Id: <remember-%s@%s> +X-Todo-Priority: %s +To: %s <%s> +Subject: %s\n\n" + (user-login-name) + (remember-mail-date) + (remember-mail-date t) + who + moment (system-name) + remember-default-priority + (user-full-name) user-mail-address + desc)) + (let ((here (point))) + (insert text) + (unless (bolp) + (insert "\n")) + (insert "\n") + (goto-char here) + (while (re-search-forward "^\\(From[: ]\\)" nil t) + (replace-match ">\\1"))) + (append-to-file (point-min) (point-max) remember-mailbox) + t))) + +;; Remembering to plain files + +(defcustom remember-data-file "~/.notes" + "*The file in which to store unprocessed data." + :type 'file + :group 'remember) + +(defcustom remember-leader-text "** " + "*The text used to begin each remember item." + :type 'string + :group 'remember) + +(defun remember-append-to-file () + "Remember, with description DESC, the given TEXT." + (let ((text (buffer-string)) + (desc (remember-buffer-desc))) + (with-temp-buffer + (insert "\n" remember-leader-text (current-time-string) + " (" desc ")\n\n" text) + (if (not (bolp)) + (insert "\n")) + (if (find-buffer-visiting remember-data-file) + (let ((remember-text (buffer-string))) + (set-buffer (get-file-buffer remember-data-file)) + (save-excursion + (goto-char (point-max)) + (insert remember-text) + (when remember-save-after-remembering (save-buffer)))) + (append-to-file (point-min) (point-max) remember-data-file))))) + +(defun remember-region (&optional beg end) + "Remember the data from BEG to END. +It is called from within the *Remember* buffer to save the text +that was entered, + +If BEG and END are nil, the entire buffer will be remembered. + +If you want to remember a region, supply a universal prefix to +`remember' instead. For example: C-u M-x remember RET." + ;; Sacha: I have no idea where remember.el gets this context information, but + ;; you can just use remember-annotation-functions. + (interactive) + (let ((b (or beg (min (point) (or (mark) (point-min))))) + (e (or end (max (point) (or (mark) (point-max)))))) + (save-restriction + (narrow-to-region b e) + (if remember-all-handler-functions + (run-hooks 'remember-handler-functions) + (run-hook-with-args-until-success 'remember-handler-functions)) + (remember-destroy)))) + +;;;###autoload +(defun remember-clipboard () + "Remember the contents of the current clipboard. +Most useful for remembering things from Netscape or other X Windows +application." + (interactive) + (remember (current-kill 0))) + +(defun remember-finalize () + "Remember the contents of the current buffer." + (interactive) + (remember-region (point-min) (point-max))) + +;; Org needs this +(define-obsolete-function-alias 'remember-buffer 'remember-finalize) + +(defun remember-destroy () + "Destroy the current *Remember* buffer." + (interactive) + (when (equal remember-buffer (buffer-name)) + (kill-buffer (current-buffer)) + (jump-to-register remember-register))) + +;;; Internal Functions: + +(defvar remember-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-x\C-s" 'remember-finalize) + (define-key map "\C-c\C-c" 'remember-finalize) + (define-key map "\C-c\C-k" 'remember-destroy) + + map) + "Keymap used in Remember mode.") + +(defun remember-mode () + "Major mode for output from \\[remember]. +This buffer is used to collect data that you want to remember. + +Just hit `C-c C-c' when you're done entering, and it will file +the data away for latter retrieval, and possible indexing. + +\\{remember-mode-map}" + (interactive) + (kill-all-local-variables) + (indented-text-mode) + (use-local-map remember-mode-map) + (setq major-mode 'remember-mode + mode-name "Remember") + (run-hooks 'remember-mode-hook)) + +;; arch-tag: 59312a05-06c7-4da1-b6f7-5ea41c9d5577 +;;; remember.el ends here diff --git a/lisp/time.el b/lisp/time.el index 4d94fb7aeb3..ef98c6a7819 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -112,17 +112,61 @@ A value of nil means 1 <= hh <= 12, and an AM/PM suffix is used." "Time when mail file's file system was recorded to be down. If that file system seems to be up, the value is nil.") -(defcustom display-time-world-list +(defcustom zoneinfo-style-world-list '(("America/Los_Angeles" "Seattle") ("America/New_York" "New York") ("Europe/London" "London") ("Europe/Paris" "Paris") ("Asia/Calcutta" "Bangalore") ("Asia/Tokyo" "Tokyo")) - "Alist specifying time zones and places for `display-time-world'. + "Alist of zoneinfo-style time zones and places for `display-time-world'. +Each element has the form (TIMEZONE LABEL). +TIMEZONE should be a string of the form AREA/LOCATION, where AREA is +the name of a region -- a continent or ocean, and LOCATION is the name +of a specific location, e.g., a city, within that region. +LABEL is a string to display as the label of that TIMEZONE's time." + :group 'display-time + :type '(repeat (list string string)) + :version "23.1") + +(defcustom legacy-style-world-list + '(("PST8PDT" "Seattle") + ("EST5EDT" "New York") + ("GMT0BST" "London") + ("CET-1CDT" "Paris") + ("IST-5:30" "Bangalore") + ("JST-9" "Tokyo")) + "Alist of traditional-style time zones and places for `display-time-world'. +Each element has the form (TIMEZONE LABEL). +TIMEZONE should be a string of the form: + + std[+|-]offset[dst[offset][,date[/time],date[/time]]] + +See the documentation of the TZ environment variable on your system, +for more details about the format of TIMEZONE. +LABEL is a string to display as the label of that TIMEZONE's time." + :group 'display-time + :type '(repeat (list string string)) + :version "23.1") + +(defcustom display-time-world-list + ;; Determine if zoneinfo style timezones are supported by testing that + ;; America/New York and Europe/London return different timezones. + (let (gmt nyt) + (set-time-zone-rule "America/New York") + (setq nyt (format-time-string "%z")) + (set-time-zone-rule "Europe/London") + (setq gmt (format-time-string "%z")) + (set-time-zone-rule nil) + (if (string-equal nyt gmt) + legacy-style-world-list + zoneinfo-style-world-list)) + "Alist of time zones and places for `display-time-world' to display. Each element has the form (TIMEZONE LABEL). -TIMEZONE should be a valid argument for `set-time-zone-rule'. -LABEL is a string to display to label that zone's time." +TIMEZONE should be in the format supported by `set-time-zone-rule' on +your system. See the documentation of `zoneinfo-style-world-list' and +\`legacy-style-world-list' for two widely used formats. +LABEL is a string to display as the label of that TIMEZONE's time." :group 'display-time :type '(repeat (list string string)) :version "23.1") diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 8226c65cbb9..492918c7f96 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -421,6 +421,23 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." ;;; Hooks from the rest of Emacs +;; Buffer deletion +;; Rerationalize after a buffer is killed, to reduce coinciding buffer names. +;; This mechanism uses `kill-buffer-hook', which runs *before* deletion, so +;; it calls `uniquify-rerationalize-w/o-cb' to rerationalize the buffer list +;; ignoring the current buffer (which is going to be deleted anyway). +(defun uniquify-maybe-rerationalize-w/o-cb () + "Re-rationalize buffer names, ignoring current buffer. +For use on `kill-buffer-hook'." + (if (and (cdr uniquify-managed) + uniquify-buffer-name-style + uniquify-after-kill-buffer-p) + (uniquify-rerationalize-w/o-cb uniquify-managed))) + +;; Ideally we'd like to add it buffer-locally, but that doesn't work +;; because kill-buffer-hook is not permanent-local :-( +(add-hook 'kill-buffer-hook 'uniquify-maybe-rerationalize-w/o-cb) + ;; The logical place to put all this code is in generate-new-buffer-name. ;; It's written in C, so we would add a generate-new-buffer-name-function ;; which, if non-nil, would be called instead of the C. One problem with @@ -458,28 +475,24 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil." (file-name-nondirectory filename) (file-name-directory filename) ad-return-value)))) -;; Buffer deletion -;; Rerationalize after a buffer is killed, to reduce coinciding buffer names. -;; This mechanism uses `kill-buffer-hook', which runs *before* deletion. -;; That means that the kill-buffer-hook function cannot just delete the -;; buffer -- it has to set something to do the rationalization *later*. -;; It actually puts another function on `post-command-hook'. This other -;; function runs the rationalization and then removes itself from the hook. -;; Is there a better way to accomplish this? -;; (This ought to set some global variables so the work is done only for -;; buffers with names similar to the deleted buffer. -MDE) - -(defun uniquify-maybe-rerationalize-w/o-cb () - "Re-rationalize buffer names, ignoring current buffer. -For use on `kill-buffer-hook'." - (if (and (cdr uniquify-managed) - uniquify-buffer-name-style - uniquify-after-kill-buffer-p) - (uniquify-rerationalize-w/o-cb uniquify-managed))) - -;; Ideally we'd like to add it buffer-locally, but that doesn't work -;; because kill-buffer-hook is not permanent-local :-( -(add-hook 'kill-buffer-hook 'uniquify-maybe-rerationalize-w/o-cb) +;;; The End + +(defun uniquify-unload-function () + "Unload the uniquify library." + (save-current-buffer + (let ((buffers nil)) + (dolist (buf (buffer-list)) + (set-buffer buf) + (when uniquify-managed + (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) + (dolist (fun '(rename-buffer create-file-buffer)) + (ad-remove-advice fun 'after (intern (concat (symbol-name fun) "-uniquify"))) + (ad-update fun)) + (dolist (buf buffers) + (set-buffer (car buf)) + (rename-buffer (cdr buf) t)))) + ;; continue standard uploading + nil) (provide 'uniquify) diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index 8f3979debcf..93552c15ea9 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,8 @@ +2007-10-31 Juanma Barranquero <lekktu@gmail.com> + + * url-vars.el (url-vars-unload-hook): Remove function and variable. + Hooks are automatically removed by `unload-feature'. + 2007-10-13 Richard Stallman <rms@gnu.org> * url-util.el (url-basepath): Function deleted. @@ -34,8 +39,7 @@ 2007-09-21 Diane Murray <disumu@x3y2z1.net> - * url-news.el (url-news-fetch-newsgroup): Fix formatting of Gnus - method. + * url-news.el (url-news-fetch-newsgroup): Fix formatting of Gnus method. * url-util.el (url-get-normalized-date): Pass full timezone information to timezone-make-date-arpa-standard, since zone name diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 7ddab8aab64..564be3e2eb6 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -398,11 +398,6 @@ Currently supported methods: This should be set, e.g. by mail user agents rendering HTML to avoid `bugs' which call home.") -(defun url-vars-unload-hook () - (remove-hook 'set-language-environment-hook 'url-set-mime-charset-string)) - -(add-hook 'url-vars-unload-hook 'url-vars-unload-hook) - (provide 'url-vars) ;;; arch-tag: 29205e5f-c5ce-433c-8d5d-38cbaed64b49 diff --git a/lisp/vc-arch.el b/lisp/vc-arch.el index 3c4e4b4d791..ecaee28c6d2 100644 --- a/lisp/vc-arch.el +++ b/lisp/vc-arch.el @@ -395,7 +395,7 @@ Return non-nil if FILE is unchanged." (setq newvers nil)) (if newvers (error "Diffing specific revisions not implemented") - (let* ((async (and (not vc-disable-async-diff) (fboundp 'start-process))) + (let* ((async (not vc-disable-async-diff)) ;; Run the command from the root dir. (default-directory (vc-arch-root file)) (status diff --git a/lisp/vc-cvs.el b/lisp/vc-cvs.el index 79a4263854d..d6573db9df2 100644 --- a/lisp/vc-cvs.el +++ b/lisp/vc-cvs.el @@ -503,7 +503,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." "Get change log associated with FILE." (vc-cvs-command buffer - (if (and (vc-stay-local-p files) (fboundp 'start-process)) 'async 0) + (if (vc-stay-local-p files) 'async 0) files "log")) (defun vc-cvs-wash-log () @@ -514,8 +514,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (defun vc-cvs-diff (files &optional oldvers newvers buffer) "Get a difference report using CVS between two revisions of FILE." (let* ((async (and (not vc-disable-async-diff) - (vc-stay-local-p files) - (fboundp 'start-process))) + (vc-stay-local-p files))) (status (apply 'vc-cvs-command (or buffer "*vc-diff*") (if async 'async 1) files "diff" @@ -563,7 +562,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER. Optional arg REVISION is a revision to annotate from." (vc-cvs-command buffer - (if (and (vc-stay-local-p file) (fboundp 'start-process)) + (if (vc-stay-local-p file) 'async 0) file "annotate" (if revision (concat "-r" revision))) diff --git a/lisp/vc-mcvs.el b/lisp/vc-mcvs.el index 0a2e69cefac..b5a81866eca 100644 --- a/lisp/vc-mcvs.el +++ b/lisp/vc-mcvs.el @@ -443,14 +443,13 @@ The changes are between FIRST-REVISION and SECOND-REVISION." ;; valid relative names. (vc-mcvs-command buffer - (if (and (vc-stay-local-p files) (fboundp 'start-process)) 'async 0) + (if (vc-stay-local-p files) 'async 0) files "log"))) (defun vc-mcvs-diff (files &optional oldvers newvers buffer) "Get a difference report using Meta-CVS between two revisions of FILES." (let* ((async (and (not vc-disable-async-diff) - (vc-stay-local-p files) - (fboundp 'start-process))) + (vc-stay-local-p files))) ;; Run the command from the root dir so that `mcvs filt' returns ;; valid relative names. (default-directory (vc-mcvs-root (car files))) @@ -468,7 +467,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." Optional arg REVISION is a revision to annotate from." (vc-mcvs-command buffer - (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0) + (if (vc-stay-local-p file) 'async 0) file "annotate" (if revision (concat "-r" revision))) (with-current-buffer buffer (goto-char (point-min)) diff --git a/lisp/vc-svn.el b/lisp/vc-svn.el index 76fdbe5162f..b83f8e0580f 100644 --- a/lisp/vc-svn.el +++ b/lisp/vc-svn.el @@ -391,7 +391,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (vc-delistify (mapcar 'file-relative-name files)) "\n")) (vc-svn-command buffer - (if (and (= (length files) 1) (vc-stay-local-p (car files)) (fboundp 'start-process)) 'async 0) + (if (and (= (length files) 1) (vc-stay-local-p (car files))) 'async 0) files "log" ;; By default Subversion only shows the log upto the working revision, ;; whereas we also want the log of the subsequent commits. At least @@ -422,8 +422,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (list "-x" (mapconcat 'identity (vc-switches nil 'diff) " ")))) (async (and (not vc-disable-async-diff) (vc-stay-local-p files) - (or oldvers newvers) ; Svn diffs those locally. - (fboundp 'start-process)))) + (or oldvers newvers)))) ; Svn diffs those locally. (apply 'vc-svn-command buffer (if async 'async 0) files "diff" diff --git a/lisp/vc.el b/lisp/vc.el index be6e8c5883b..5811b2f7d63 100644 --- a/lisp/vc.el +++ b/lisp/vc.el @@ -1286,7 +1286,7 @@ Otherwise, throw an error." (message "All version-controlled files below %s selected." default-directory) (list default-directory))) - ((and allow-unregistered (not (vc-registered buffer-file-name))) + ((and allow-unregistered (not (vc-registered buffer-file-name))) (list buffer-file-name)) (t (error "No fileset is available here.")))) @@ -1930,9 +1930,11 @@ returns t if the buffer had changes, nil otherwise." (message "No changes between %s and %s" rev1-name rev2-name) nil) (pop-to-buffer (current-buffer)) - ;; Gnus-5.8.5 sets up an autoload for diff-mode, even if it's - ;; not available. Work around that. - (if (require 'diff-mode nil t) (diff-mode)) + (diff-mode) + ;; Make the *vc-diff* buffer read only, the diff-mode key + ;; bindings are nicer for read only buffers. pcl-cvs does the + ;; same thing. + (setq buffer-read-only t) (vc-exec-after `(vc-diff-sentinel ,verbose ,rev1-name ,rev2-name)) ;; In the async case, we return t even if there are no differences ;; because we don't know that yet. @@ -3324,7 +3326,7 @@ mode-specific menu. `vc-annotate-color-map' and ;; of the user's cursor :-( (when ,current-line ;(and (bobp)) (goto-line ,current-line) - (setq vc-sentinel-movepoint)) + (setq vc-sentinel-movepoint (point))) (unless (active-minibuffer-window) (message "Annotating... done"))))))) diff --git a/lisp/view.el b/lisp/view.el index c152383a48b..ad6ca9371b8 100644 --- a/lisp/view.el +++ b/lisp/view.el @@ -77,11 +77,15 @@ for all scroll commands in view mode." :type 'boolean :group 'view) -(defcustom view-remove-frame-by-deleting nil +;;;###autoload +(defcustom view-remove-frame-by-deleting t "*Determine how View mode removes a frame no longer needed. If nil, make an icon of the frame. If non-nil, delete the frame." :type 'boolean - :group 'view) + :group 'view + ;; Changed the default of this to t for Emacs 23. Users consider + ;; frame iconification annoying. + :version "23.1") (defcustom view-exits-all-viewing-windows nil "*Non-nil means restore all windows used to view buffer. @@ -146,10 +150,11 @@ See RETURN-TO-ALIST argument of function `view-mode-exit' for the format of (put 'view-return-to-alist 'permanent-local t) (defvar view-exit-action nil - "nil or a function with one argument (a buffer) called when finished viewing. -This is local in each buffer being viewed. -The \\[view-file] and \\[view-file-other-window] commands may set this to -`kill-buffer'.") + "If non-nil, a function with one argument (a buffer) called when finished viewing. +Commands like \\[view-file] and \\[view-file-other-window] may +set this to bury or kill the viewed buffer. +Observe that the buffer viewed might not appear in any window at +the time this function is called.") (make-variable-buffer-local 'view-exit-action) (defvar view-no-disable-on-exit nil @@ -241,11 +246,11 @@ This is local in each buffer, once it is used.") ;;;###autoload (defun view-file (file) "View FILE in View mode, returning to previous buffer when done. -Emacs commands editing the buffer contents are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. +Emacs commands editing the buffer contents are not available; instead, a +special set of commands (mostly letters and punctuation) are defined for +moving around in the buffer. Space scrolls forward, Delete scrolls backward. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This command runs the normal hook `view-mode-hook'." (interactive "fView file: ") @@ -263,12 +268,12 @@ This command runs the normal hook `view-mode-hook'." ;;;###autoload (defun view-file-other-window (file) "View FILE in View mode in another window. -Return that window to its previous buffer when done. -Emacs commands editing the buffer contents are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. +Return that window to its previous buffer when done. Emacs commands +editing the buffer contents are not available; instead, a special set of +commands (mostly letters and punctuation) are defined for moving around +in the buffer. Space scrolls forward, Delete scrolls backward. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This command runs the normal hook `view-mode-hook'." (interactive "fIn other window view file: ") @@ -281,11 +286,11 @@ This command runs the normal hook `view-mode-hook'." (defun view-file-other-frame (file) "View FILE in View mode in another frame. Maybe delete other frame and/or return to previous buffer when done. -Emacs commands editing the buffer contents are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. +Emacs commands editing the buffer contents are not available; instead, a +special set of commands (mostly letters and punctuation) are defined for +moving around in the buffer. Space scrolls forward, Delete scrolls backward. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This command runs the normal hook `view-mode-hook'." (interactive "fIn other frame view file: ") @@ -298,18 +303,17 @@ This command runs the normal hook `view-mode-hook'." ;;;###autoload (defun view-buffer (buffer &optional exit-action) "View BUFFER in View mode, returning to previous buffer when done. -Emacs commands editing the buffer contents are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. +Emacs commands editing the buffer contents are not available; instead, a +special set of commands (mostly letters and punctuation) are defined for +moving around in the buffer. Space scrolls forward, Delete scrolls backward. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This command runs the normal hook `view-mode-hook'. Optional argument EXIT-ACTION is either nil or a function with buffer as -argument. This function is called when finished viewing buffer. -Use this argument instead of explicitly setting `view-exit-action'." - +argument. This function is called when finished viewing buffer. Use +this argument instead of explicitly setting `view-exit-action'." (interactive "bView buffer: ") (let ((undo-window (list (window-buffer) (window-start) (window-point)))) (switch-to-buffer buffer) @@ -319,18 +323,18 @@ Use this argument instead of explicitly setting `view-exit-action'." ;;;###autoload (defun view-buffer-other-window (buffer &optional not-return exit-action) "View BUFFER in View mode in another window. -Return to previous buffer when done, unless optional NOT-RETURN is non-nil. -Emacs commands editing the buffer contents are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. +Return to previous buffer when done, unless optional NOT-RETURN is +non-nil. Emacs commands editing the buffer contents are not available; +instead, a special set of commands (mostly letters and punctuation) are +defined for moving around in the buffer. Space scrolls forward, Delete scrolls backward. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This command runs the normal hook `view-mode-hook'. Optional argument EXIT-ACTION is either nil or a function with buffer as -argument. This function is called when finished viewing buffer. -Use this argument instead of explicitly setting `view-exit-action'." +argument. This function is called when finished viewing buffer. Use +this argument instead of explicitly setting `view-exit-action'." (interactive "bIn other window view buffer:\nP") (let* ((win ; This window will be selected by (get-lru-window)) ; switch-to-buffer-other-window below. @@ -350,18 +354,18 @@ Use this argument instead of explicitly setting `view-exit-action'." ;;;###autoload (defun view-buffer-other-frame (buffer &optional not-return exit-action) "View BUFFER in View mode in another frame. -Return to previous buffer when done, unless optional NOT-RETURN is non-nil. -Emacs commands editing the buffer contents are not available; instead, -a special set of commands (mostly letters and punctuation) -are defined for moving around in the buffer. +Return to previous buffer when done, unless optional NOT-RETURN is +non-nil. Emacs commands editing the buffer contents are not available; +instead, a special set of commands (mostly letters and punctuation) are +defined for moving around in the buffer. Space scrolls forward, Delete scrolls backward. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This command runs the normal hook `view-mode-hook'. Optional argument EXIT-ACTION is either nil or a function with buffer as -argument. This function is called when finished viewing buffer. -Use this argument instead of explicitly setting `view-exit-action'." +argument. This function is called when finished viewing buffer. Use +this argument instead of explicitly setting `view-exit-action'." (interactive "bView buffer in other frame: \nP") (let ((return-to (and (not not-return) (cons (selected-window) t)))) ; Old window. @@ -495,34 +499,73 @@ Entry to view-mode runs the normal hook `view-mode-hook'." (setq buffer-read-only view-old-buffer-read-only))) ;;;###autoload -(defun view-mode-enter (&optional return-to exit-action) "\ -Enter View mode and set up exit from view mode depending on optional arguments. -If RETURN-TO is non-nil it is added as an element to the buffer local alist -`view-return-to-alist'. -Save EXIT-ACTION in buffer local variable `view-exit-action'. -It should be either nil or a function that takes a buffer as argument. -This function will be called by `view-mode-exit'. - -RETURN-TO is either nil, meaning do nothing when exiting view mode, or -it has the format (WINDOW OLD-WINDOW . OLD-BUF-INFO). -WINDOW is a window used for viewing. -OLD-WINDOW is nil or the window to select after viewing. -OLD-BUF-INFO tells what to do with WINDOW when exiting. It is one of: -1) nil Do nothing. -2) t Delete WINDOW or, if it is the only window, its frame. +(defun view-return-to-alist-update (buffer &optional item) + "Update `view-return-to-alist' of buffer BUFFER. +Remove from `view-return-to-alist' all entries referencing dead +windows. Optional argument ITEM non-nil means add ITEM to +`view-return-to-alist' after purging. For a decsription of items +that can be added see the RETURN-TO-ALIST argument of the +function `view-mode-exit'. If `view-return-to-alist' contains an +entry for the selected window, purge that entry from +`view-return-to-alist' before adding ITEM." + (with-current-buffer buffer + (when view-return-to-alist + (let* ((list view-return-to-alist) + entry entry-window last) + (while list + (setq entry (car list)) + (setq entry-window (car entry)) + (if (and (windowp entry-window) + (or (and item (eq entry-window (selected-window))) + (not (window-live-p entry-window)))) + ;; Remove that entry. + (if last + (setcdr last (cdr list)) + (setq view-return-to-alist + (cdr view-return-to-alist))) + ;; Leave entry alone. + (setq last entry)) + (setq list (cdr list))))) + ;; Add ITEM. + (when item + (setq view-return-to-alist + (cons item view-return-to-alist))))) + +;;;###autoload +(defun view-mode-enter (&optional return-to exit-action) + "Enter View mode and set up exit from view mode depending on optional arguments. +RETURN-TO non-nil means add RETURN-TO as an element to the buffer +local alist `view-return-to-alist'. Save EXIT-ACTION in buffer +local variable `view-exit-action'. It should be either nil or a +function that takes a buffer as argument. This function will be +called by `view-mode-exit'. + +RETURN-TO is either nil, meaning do nothing when exiting view +mode, or must have the format (WINDOW OLD-WINDOW . OLD-BUF-INFO). +WINDOW is the window used for viewing. OLD-WINDOW is nil or the +window to select after viewing. OLD-BUF-INFO tells what to do +with WINDOW when exiting. It is one of: +1) nil Do nothing. +2) t Delete WINDOW or, if it is the only window and + `view-remove-frame-by-deleting' is non-nil, its + frame. 3) (OLD-BUFF START POINT) Display buffer OLD-BUFF with displayed text - starting at START and point at POINT in WINDOW. -4) quit-window Do `quit-window' in WINDOW. + starting at START and point at POINT in WINDOW. +4) quit-window Do `quit-window' in WINDOW. +5) keep-frame Like case 2) but do not delete the frame. -For list of all View commands, type H or h while viewing. +For a list of all View commands, type H or h while viewing. This function runs the normal hook `view-mode-hook'." - (if return-to - (let ((entry (assq (car return-to) view-return-to-alist))) - (if entry (setcdr entry (cdr return-to)) - (setq view-return-to-alist (cons return-to view-return-to-alist))))) - (if exit-action (setq view-exit-action exit-action)) - (unless view-mode ; Do nothing if already in view mode. + (when return-to + (let ((entry (assq (car return-to) view-return-to-alist))) + (if entry + (setcdr entry (cdr return-to)) + (setq view-return-to-alist (cons return-to view-return-to-alist))))) + (when exit-action + (setq view-exit-action exit-action)) + + (unless view-mode (view-mode-enable) (force-mode-line-update) (unless view-inhibit-help-message @@ -532,88 +575,106 @@ View mode: type \\[help-command] for help, \\[describe-mode] for commands, \\[Vi (defun view-mode-exit (&optional return-to-alist exit-action all-win) "Exit View mode in various ways, depending on optional arguments. -RETURN-TO-ALIST, EXIT-ACTION and ALL-WIN determine what to do after exit. -EXIT-ACTION is nil or a function that is called with current buffer as -argument. -RETURN-TO-ALIST is an alist that for some of the windows displaying the -current buffer, associate information on what to do with those windows. -If ALL-WIN or the variable `view-exits-all-viewing-windows' is non-nil, -then all windows on RETURN-TO-ALIST are restored to their old state. -Otherwise only the selected window is affected (if it is on RETURN-TO-ALIST). - -Elements of RETURN-TO-ALIST have the format (WINDOW OLD-WINDOW . OLD-BUF-INFO). -WINDOW is a window displaying the current buffer. -OLD-WINDOW is nil or a window to select after viewing. -OLD-BUF-INFO is information on what to do with WINDOW and is one of: -1) nil Do nothing. -2) t Delete WINDOW and, if it is the only window, its frame. +RETURN-TO-ALIST, EXIT-ACTION and ALL-WIN determine what to do +after exit. EXIT-ACTION is nil or a function that is called with +current buffer as argument. + +RETURN-TO-ALIST is an alist that, for some of the windows +displaying the current buffer, maintains information on what to +do when exiting those windows. If ALL-WIN is non-nil or the +variable `view-exits-all-viewing-windows' is non-nil, +view-mode-exit attempts to restore all windows showing the +current buffer to their old state. Otherwise, only the selected +window is affected (provided it is on RETURN-TO-ALIST). + +Elements of RETURN-TO-ALIST must have the format + (WINDOW OLD-WINDOW . OLD-BUF-INFO) where + +WINDOW is a window displaying the current buffer and OLD-WINDOW +is either nil or a window to select after viewing. OLD-BUF-INFO +provides information on what to do with WINDOW and may be one of: +1) nil Do nothing. +2) t Delete WINDOW and, if it is the only window and + `view-remove-frame-by-deleting' is non-nil, its + frame. 3) (OLD-BUF START POINT) Display buffer OLD-BUF with displayed text - starting at START and point at POINT in WINDOW. -4) quit-window Do `quit-window' in WINDOW. - -If one of the WINDOW in RETURN-TO-ALIST is the selected window and the -corresponding OLD-WINDOW is a live window, then select OLD-WINDOW." - (setq all-win - (and return-to-alist (or all-win view-exits-all-viewing-windows))) - (if view-mode ; Only do something if in view mode. - (let* ((buffer (current-buffer)) - window notlost - (sel-old (assq (selected-window) return-to-alist)) - (alist (cond - (all-win ; Try to restore all windows. - (append return-to-alist nil)) ; Copy. - (sel-old ; Only selected window. - (list sel-old)))) - (old-window (if sel-old (car (cdr sel-old))))) - (if all-win ; Follow chains of old-windows. - (let ((c (length alist)) a) - (while (and (> c 0) ; Safety if mutually refering windows. - (or (not (window-live-p old-window)) - (eq buffer (window-buffer old-window))) - (setq a (assq old-window alist))) - (setq c (1- c)) - (setq old-window (car (cdr a)))) - (if (or (zerop c) (not (window-live-p old-window))) - (setq old-window (selected-window))))) - (or view-no-disable-on-exit - (view-mode-disable)) - (while alist ; Restore windows with info. - (setq notlost nil) - (if (and (window-live-p (setq window (car (car alist)))) + starting at START and point at POINT in WINDOW. +4) quit-window Do `quit-window' in WINDOW. +5) keep-frame Like case 2) but do not delete the frame. + +If one of the WINDOW in RETURN-TO-ALIST is the selected window +and the corresponding OLD-WINDOW is a live window, then select +OLD-WINDOW." + (when view-mode ; Only do something if in view mode. + (setq all-win + (and return-to-alist + (or all-win view-exits-all-viewing-windows))) + (let* ((buffer (current-buffer)) + window notlost + (sel-old (assq (selected-window) return-to-alist)) + (alist (cond + (all-win ; Try to restore all windows. + (append return-to-alist nil)) ; Copy. + (sel-old ; Only selected window. + (list sel-old)))) + (old-window (if sel-old (car (cdr sel-old))))) + (if all-win ; Follow chains of old-windows. + (let ((c (length alist)) a) + (while (and (> c 0) ; Safety if mutually refering windows. + (or (not (window-live-p old-window)) + (eq buffer (window-buffer old-window))) + (setq a (assq old-window alist))) + (setq c (1- c)) + (setq old-window (car (cdr a)))) + (if (or (zerop c) (not (window-live-p old-window))) + (setq old-window (selected-window))))) + (unless view-no-disable-on-exit + (view-mode-disable)) + (while alist ; Restore windows with info. + (setq notlost nil) + (when (and (window-live-p (setq window (car (car alist)))) (eq buffer (window-buffer window))) - (let ((frame (window-frame window)) - (old-buf-info (cdr (cdr (car alist))))) - (if all-win (select-window window)) - (cond - ((and (consp old-buf-info) ; Case 3. - (buffer-live-p (car old-buf-info))) - (set-window-buffer window (car old-buf-info)) ; old-buf - (set-window-start window (car (cdr old-buf-info))) - (set-window-point window (car (cdr (cdr old-buf-info))))) - ((eq old-buf-info 'quit-window) - (quit-window)) ; Case 4. - ((not (eq old-buf-info t)) nil) ; Not case 2, do nothing. - ((not (one-window-p t)) (delete-window)) - ((not (eq frame (next-frame))) - ;; Not the only frame, so can safely be removed. - (if view-remove-frame-by-deleting - (delete-frame frame) - (setq notlost t) ; Keep the window. See below. - (iconify-frame frame)))))) - ;; If a frame is removed by iconifying it, then the window is not - ;; really lost. In this case we keep the entry in - ;; view-return-to-alist so that if the user deiconifies the frame - ;; and then press q, then the frame is iconified again. - (unless notlost + (let ((frame (window-frame window)) + (old-buf-info (cdr (cdr (car alist))))) + (if all-win (select-window window)) + (cond + ((and (consp old-buf-info) ; Case 3. + (buffer-live-p (car old-buf-info))) + (set-window-buffer window (car old-buf-info)) ; old-buf + (set-window-start window (car (cdr old-buf-info))) + (set-window-point window (car (cdr (cdr old-buf-info))))) + ((eq old-buf-info 'quit-window) + (quit-window)) ; Case 4. + (old-buf-info ; Case 2 or 5. + (cond + ((not (one-window-p t)) ; Not only window. + (delete-window)) + ((eq old-buf-info 'keep-frame) ; Case 5. + (bury-buffer)) + ((not (eq frame (next-frame))) ; Case 2 and only window. + ;; Not the only frame, so can safely be removed. + (if view-remove-frame-by-deleting + (delete-frame frame) + (setq notlost t) ; Keep the window. See below. + (iconify-frame frame)))))))) + ;; If a frame is removed by iconifying it, the window is not + ;; really lost. In this case we keep the entry in + ;; `view-return-to-alist' so that if the user deiconifies the + ;; frame and then hits q, the frame is iconified again. + (unless notlost + (with-current-buffer buffer (setq view-return-to-alist - (delete (car alist) view-return-to-alist))) - (setq alist (cdr alist))) - (if (window-live-p old-window) ; still existing window - (select-window old-window)) - (when exit-action - (setq view-exit-action nil) - (funcall exit-action buffer)) - (force-mode-line-update)))) + (delete (car alist) view-return-to-alist)))) + (setq alist (cdr alist))) + (when (window-live-p old-window) + ;; old-window is still alive => select it. + (select-window old-window)) + (when exit-action + ;; Don't do that: If the user wants to quit the *Help* buffer a + ;; second time it won't have any effect. +;;; (setq view-exit-action nil) + (funcall exit-action buffer)) + (force-mode-line-update)))) (defun View-exit () "Exit View mode but stay in current buffer." diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index 26bebe040e0..994eb767232 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -384,9 +384,9 @@ bit output with no translation." (w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932) -(w32-add-charset-info "ksc5601.1987" 'w32-charset-hangeul 949) -(w32-add-charset-info "big5" 'w32-charset-chinesebig5 950) -(w32-add-charset-info "gb2312" 'w32-charset-gb2312 936) +(w32-add-charset-info "ksc5601.1989-1" 'w32-charset-hangeul 949) +(w32-add-charset-info "big5-1" 'w32-charset-chinesebig5 950) +(w32-add-charset-info "gb2312.1980-1" 'w32-charset-gb2312 936) (w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil) (w32-add-charset-info "ms-oem" 'w32-charset-oem 437) (w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850) @@ -402,12 +402,11 @@ bit output with no translation." (w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257) (w32-add-charset-info "koi8-r" 'w32-charset-russian 20866) (w32-add-charset-info "iso8859-5" 'w32-charset-russian 28595) - (w32-add-charset-info "tis620" 'w32-charset-thai 874) - (w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361) + (w32-add-charset-info "tis620-1" 'w32-charset-thai 874) + (w32-add-charset-info "ksc5601.1992-1" 'w32-charset-johab 1361) (w32-add-charset-info "mac-roman" 'w32-charset-mac 10000))) (if (boundp 'w32-unicode-charset-defined) (progn - (w32-add-charset-info "unicode" 'w32-charset-unicode t) (w32-add-charset-info "iso10646-1" 'w32-charset-unicode t)) (w32-add-charset-info "iso10646-1" 'w32-charset-default t)) ;; ;; If unicode windows charset is not defined, use ansi fonts. diff --git a/lisp/wdired.el b/lisp/wdired.el index 0c75592bd03..a76ac809feb 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -130,8 +130,8 @@ is not nil." "If t, the \"up\" and \"down\" movement works as in Dired mode. That is, always move the point to the beginning of the filename at line. -If `sometimes, only move to the beginning of filename if the point is -before it, and `track-eol' is honored. This behavior is very handy +If `sometimes', only move to the beginning of filename if the point is +before it, and `track-eol' is non-nil. This behavior is very handy when editing several filenames. If nil, \"up\" and \"down\" movement is done as in any other buffer." @@ -499,7 +499,7 @@ Optional arguments are ignored." See `wdired-use-dired-vertical-movement'. Optional prefix ARG says how many lines to move; default is one line." (interactive "p") - (forward-line arg) + (with-no-warnings (next-line arg)) (if (or (eq wdired-use-dired-vertical-movement t) (and wdired-use-dired-vertical-movement (< (current-column) @@ -512,7 +512,7 @@ says how many lines to move; default is one line." See `wdired-use-dired-vertical-movement'. Optional prefix ARG says how many lines to move; default is one line." (interactive "p") - (forward-line (- arg)) + (with-no-warnings (previous-line arg)) (if (or (eq wdired-use-dired-vertical-movement t) (and wdired-use-dired-vertical-movement (< (current-column) diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 6e6aeb5fbb7..f6c94534a00 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -784,7 +784,6 @@ When this mode is active, `whitespace-buffer' is added to (defun whitespace-write-file-hook () "Hook function to be called on the buffer when whitespace check is enabled. This is meant to be added buffer-locally to `write-file-functions'." - (interactive) (let ((werr nil)) (if whitespace-auto-cleanup (whitespace-cleanup-internal) @@ -794,6 +793,21 @@ This is meant to be added buffer-locally to `write-file-functions'." buffer-file-name)))) nil) +(defun whitespace-unload-function () + "Unload the whitespace library." + (if (unintern "whitespace-unload-hook") + ;; if whitespace-unload-hook is defined, let's get rid of it + ;; and recursively call `unload-feature' + (progn (unload-feature 'whitespace) t) + ;; this only happens in the recursive call + (whitespace-global-mode -1) + (save-current-buffer + (dolist (buf (buffer-list)) + (set-buffer buf) + (remove-hook 'write-file-functions 'whitespace-write-file-hook t))) + ;; continue standard unloading + nil)) + (defun whitespace-unload-hook () (remove-hook 'find-file-hook 'whitespace-buffer) (remove-hook 'write-file-functions 'whitespace-write-file-hook t) |