diff options
Diffstat (limited to 'lisp')
90 files changed, 2343 insertions, 997 deletions
diff --git a/lisp/ChangeLog.trunk b/lisp/ChangeLog.trunk index e4d402afa76..d087982edee 100644 --- a/lisp/ChangeLog.trunk +++ b/lisp/ChangeLog.trunk @@ -1,3 +1,410 @@ +2011-03-21 Glenn Morris <rgm@gnu.org> + + * eshell/esh-opt.el (eshell-eval-using-options, eshell-process-args): + Doc fixes. + +2011-03-21 Chong Yidong <cyd@stupidchicken.com> + + * cus-theme.el: Add missing provide statement. + (customize-create-theme): Extract theme value correctly. + (custom-theme-visit-theme): Autoload. + (customize-create-theme): Prompt before inserting default faces. + +2011-03-20 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-menu.el (calc-units-menu): Add entries for logarithmic + units and musical notes. + +2011-03-20 Leo <sdl.web@gmail.com> + + * ido.el (ido-read-internal): Use completing-read-default. + (ido-completing-read): Fix compatibility with completing-read. + +2011-03-20 Christian Ohler <ohler@gnu.org> + + * emacs-lisp/ert.el (ert-run-tests-batch): Remove unused variable. + (ert-delete-all-tests): Use `called-interactively-p' rather than + `interactive-p'. + (ert--make-xrefs-region): Respect END. + +2011-03-19 Chong Yidong <cyd@stupidchicken.com> + + * dired-aux.el (dired-create-directory): Signal an error if the + directory already exists (Bug#8246). + + * facemenu.el (list-colors-display): Call list-faces-display + inside with-help-window. + (list-colors-print): Use display property to align the final + column, instead of checking window-width. + +2011-03-19 Eli Zaretskii <eliz@gnu.org> + + * emerge.el (emerge-metachars): Separate value for ms-dos and + windows-nt systems. + (emerge-protect-metachars): Quote correctly for ms-dos and + windows-nt systems. + +2011-03-19 Ralph Schleicher <rs@ralph-schleicher.de> + + * info.el (info-initialize): Replace all uses of `:' with + path-separator for compatibility with non-Unix systems. + Cache quoting of path-separator. (Bug#8258) + +2011-03-19 Juanma Barranquero <lekktu@gmail.com> + + * avoid.el (mouse-avoidance-mode, mouse-avoidance-nudge-dist) + (mouse-avoidance-threshold, mouse-avoidance-banish-destination) + (mouse-avoidance-mode): Fix typos in docstrings. + +2011-03-19 Chong Yidong <cyd@stupidchicken.com> + + * startup.el (package-subdirectory-regexp): Move from package.el. + Omit \\` and \\', and let callers add them. + + * emacs-lisp/package.el (package-strip-version) + (package-load-all-descriptors): Add \\` and \\' to + package-subdirectory-regexp before using it. + (package-untar-buffer): New arg DIR; ensure that file untars only + into this expected directory. Remove superfluous delete-region. + (package-unpack): Caller changed. + (package-tar-file-info): Use package-subdirectory-regexp. + +2011-03-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * vc/diff-mode.el (diff-mode-map): Shadow problematic bindings from + diff-mode-shared-map (bug#8284). + (diff-mode-shared-map): Re-introduce some bindings that were problematic. + +2011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * calendar/time-date.el (format-seconds): Use assoc instead of + assoc-string, since assoc-string doesn't exist in XEmacs. + +2011-03-17 Juanma Barranquero <lekktu@gmail.com> + + * custom.el (custom-known-themes): Reflow docstring. + (custom-theme-load-path): Fix typo in docstring. + (load-theme): Fix typo in error message. + (custom-available-themes, custom-variable-theme-value): + Use `let', not `let*'. + +2011-03-17 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/README: Mention inclusion of musical notes. + + * calc/calc-units.el (calc-lu-quant): Rename from + `calc-logunits-quantity'. + (calcFunc-lupquant): Rename from `calcFunc-powerquant'. + (calcFunc-lufquant): Rename from `calcFunc-fieldquant'. + (calc-db): Rename from `calc-dblevel'. + (calcFunc-dbpower): Rename from `calcFunc-dbpowerlevel'. + (calcFunc-dbfield): Rename from `calcFunc-dbfieldlevel'. + (calc-np): Rename from `calc-nplevel'. + (calcFunc-nppower): Rename from `calcFunc-nppowerlevel'. + (calcFunc-npfield): Rename from `calcFunc-npfieldlevel'. + (calc-lu-plus): Rename from `calc-logunits-add'. + (calcFunc-lupadd): Rename from `calcFunc-lupoweradd'. + (calcFunc-lufadd): Rename from `calcFunc-lufieldadd'. + (calc-lu-minus): Rename from `calc-logunits-sub'. + (calcFunc-lupsub): Rename from `calcFunc-lupowersub'. + (calcFunc-lufsub): Rename from `calcFunc-lufieldsub'. + (calc-lu-times): Rename from `calc-logunits-mul'. + (calcFunc-lupmul): Rename from `calcFunc-lupowermul'. + (calcFunc-lufmul): Rename from `calcFunc-lufieldmul'. + (calc-lu-divide): Rename from `calc-logunits-div'. + (calcFunc-lupdiv): Rename from `calcFunc-lupowerdiv'. + (calcFunc-lufdiv): Rename from `calcFunc-lufielddiv'. + + * calc/calc-ext.el (calc-init-extensions): Update the names of the + functions being autoloaded. + + * calc/calc.el (calc-lu-power-reference): Rename from + `calc-logunits-power-reference'. + (calc-lu-field-reference): Rename from + `calc-logunits-field-reference'. + + * calc/calc-help (calc-l-prefix-help): Mention musical note functions. + +2011-03-17 Stefan Monnier <monnier@iro.umontreal.ca> + + * minibuffer.el (completion-all-sorted-completions): + Use :completion-cycle-penalty text property if present. + +2011-03-16 Ken Manheimer <ken.manheimer@gmail.com> + + * allout.el (allout-yank-processing): Adjust for new rebulleting + regime so bullet being yanked is used without prompting the user + for a choice. + +2011-03-16 Juanma Barranquero <lekktu@gmail.com> + + * startup.el (command-line): Warn the user that _emacs is deprecated. + +2011-03-16 Juanma Barranquero <lekktu@gmail.com> + + * progmodes/delphi.el (delphi-search-path, delphi-indent-level) + (delphi-verbose, delphi-comment-face, delphi-string-face) + (delphi-keyword-face, delphi-ignore-changes, delphi-indent-line) + (delphi-mode-abbrev-table, delphi-debug-buffer, delphi-tab) + (delphi-find-unit, delphi-find-current-xdef, delphi-fill-comment) + (delphi-new-comment-line, delphi-font-lock-defaults) + (delphi-debug-mode-map, delphi-mode-syntax-table, delphi-mode): + Fix typos in docstrings. + +2011-03-15 Ken Manheimer <ken.manheimer@gmail.com> + + * allout.el (allout-make-topic-prefix, allout-rebullet-heading): + Invert the roles of character and string values for INSTEAD, so a + string is used for the more common case of a defaulting prompt. + +2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/ruby-mode.el (ruby-backward-sexp): + * progmodes/ebrowse.el (ebrowse-draw-file-member-info): + * play/gamegrid.el (gamegrid-make-face): + * play/bubbles.el (bubbles--grid-width, bubbles--grid-height) + (bubbles--colors, bubbles--shift-mode, bubbles--initialize-images): + * notifications.el (notifications-notify): + * net/xesam.el (xesam-search-engines): + * net/quickurl.el (quickurl-list-insert): + * vc/vc-hg.el (vc-hg-dir-printer): Fix use of case. + +2011-03-15 Chong Yidong <cyd@stupidchicken.com> + + * startup.el (command-line): Update package subdirectory regexp. + +2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * allout.el (allout-abbreviate-flattened-numbering) + (allout-mode-deactivate-hook): Fix up obsolescence "date". + + * subr.el (read-char-choice): Only show the cursor after the prompt, + not after the answer. + +2011-03-15 Kevin Ryde <user42@zip.com.au> + + * help-fns.el (variable-at-point): Skip leading quotes, if any + (bug#8253). + +2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/bytecomp.el (byte-compile-save-excursion): Change the + warning message. + +2011-03-14 Michael Albinus <michael.albinus@gmx.de> + + * shell.el (shell): When called interactively, offer to change the + shell file name on remote hosts. + +2011-03-13 Teodor Zlatanov <tzz@lifelogs.com> + + * net/ldap.el (ldap-search-internal): Add `auth-source-search' + integration for LDAP parameters. The host, base, user or binddn, + and secret tokens can be specified in a netrc file, for instance. + This is optional because an `auth-source' parameter must be + specified in the search attributes. + +2011-03-13 Juanma Barranquero <lekktu@gmail.com> + + * help.el (describe-mode): Link to the mode's definition (bug#8185). + +2011-03-12 Stefan Monnier <monnier@iro.umontreal.ca> + + * ebuff-menu.el (electric-buffer-menu-mode-map): Move initialization + into declaration. Remove redundant and harmful binding. + +2011-03-12 Eli Zaretskii <eliz@gnu.org> + + * files.el (file-ownership-preserved-p): Pass `integer' as an + explicit 2nd argument to `file-attributes'. If the file's owner + is the Administrators group on Windows, and the current user is + Administrator, consider that a match. + + * server.el (server-ensure-safe-dir): Consider server directory + safe on MS-Windows if its owner is the Administrators group while + the current Emacs user is Administrator. Use `=' to compare + numerical UIDs, since they could be integers or floats. + +2011-03-12 Juanma Barranquero <lekktu@gmail.com> + + * vc/vc-bzr.el (vc-bzr-state): Handle bzr 2.3.0 (follow-up to bug#8170). + +2011-03-12 Michael Albinus <michael.albinus@gmx.de> + + Sync with Tramp 2.2.1. + + * net/tramp-sh.el (tramp-methods): Exchange "%k" marker with options. + + * net/trampver.el: Update release number. + +2011-03-12 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/compile.el (compilation--previous-directory): Fix up + various nil/dead-marker mismatches (bug#8014). + (compilation-directory-properties, compilation-error-properties): + Don't call it at a position past the one we're about to change. + + * emacs-lisp/bytecomp.el (byte-compile-make-obsolete-variable): + Disable obsolescence warnings in the file that declares it. + +2011-03-11 Ken Manheimer <ken.manheimer@gmail.com> + + * allout-widgets.el (allout-widgets-tally): Initialize + allout-widgets-tally as a hash table rather than nil to prevent + mode-line redisplay warnings. + Also, clarify the module description and fix a comment typo. + +2011-03-11 Juanma Barranquero <lekktu@gmail.com> + + * help-fns.el (describe-variable): Don't complete keywords. + Suggested by Teodor Zlatanov <tzz@lifelogs.com>. + +2011-03-10 Chong Yidong <cyd@stupidchicken.com> + + * emacs-lisp/package.el (package-version-join): Impose a standard + string representation for pre/alpha/beta version lists. + (package-unpack-single): Standardize the directory name by passing + it through package-version-join. + (package-strip-rcs-id): Accept any version string that does not + signal an error in version-to-list. + +2011-03-10 Michael Albinus <michael.albinus@gmx.de> + + * simple.el (delete-trailing-whitespace): Return nil for the + benefit of `write-file-functions'. + +2011-03-10 Glenn Morris <rgm@gnu.org> + + * vc/vc-hg.el (vc-hg-pull, vc-hg-merge-branch): Use vc-hg-program. + + * vc/vc-git.el (vc-git-program): New option. + (vc-git-branches, vc-git-pull, vc-git-merge-branch, vc-git-command) + (vc-git--call): Use it. + + * eshell/esh-util.el (eshell-condition-case): Doc fix. + + * cus-edit.el (Custom-newline): If no button at point, look + for a subgroup button at start-of-line. (Bug#2298) + + * mail/rmail.el (rmail-msgend, rmail-msgbeg): Doc fixes. + +2011-03-10 Julien Danjou <julien@danjou.info> + + * avoid.el (mouse-avoidance-ignore-p): Do not move the cursor if + `cursor-type' is nil. + +2011-03-09 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc.el (calc-mode-map): Don't bind "C-_" to `calc-missing-key'. + +2011-03-09 Ken Manheimer <ken.manheimer@gmail.com> + + * allout.el Summary: Change so yank of distinctive-bullet items + preserves the existing header prefix, rebulleting it if necessary, + rather than replacing it. This is necessary for proper operation + of cooperative addons like allout-widgets. + (allout-make-topic-prefix, allout-rebullet-heading): Change + SOLICIT arg to INSTEAD, and interpret additionally a string value + as alternate bullet to be used, instead of prompting the user for + a bullet character. + +2011-03-09 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band): Do + not use `tramp-file-name-port', because this returns also + `tramp-default-port'. + +2011-03-09 Deniz Dogan <deniz.a.m.dogan@gmail.com> + + * net/rcirc.el (rcirc-handler-001): Remove useless + with-rcirc-process-buffer. + (rcirc-check-auth-status): Swap arguments to string-match. + +2011-03-09 Glenn Morris <rgm@gnu.org> + + * shell.el (shell-mode): + Set comint-input-ring-size from HISTSIZE. (Bug#7889) + + * progmodes/gdb-mi.el (gdb): Improve 2010-12-08 change. + Check for GDBHISTFILE, HISTSIZE, etc. (Bug#7889) + +2011-03-08 Chong Yidong <cyd@stupidchicken.com> + + * emacs-lisp/package.el (package-refresh-contents) + (package-menu-execute): Use condition-case-no-debug. + +2011-03-08 Michael Albinus <michael.albinus@gmx.de> + + * simple.el (shell-command-to-string): Use `process-file'. + + * emacs-lisp/package.el (package-tar-file-info): Handle also + remote files. + + * emacs-lisp/package-x.el (package-upload-buffer-internal): Use + `equal' for upload base check. + +2011-03-08 Arni Magnusson <arnima@hafro.is> (tiny change) + + * textmodes/texinfo.el (texinfo-environments): + Add deftypecv, deftypeivar, deftypemethod, deftypeop, html. (Bug#2783) + +2011-03-08 Glenn Morris <rgm@gnu.org> + + * cus-start.el (cursor-in-non-selected-windows): + Fix :set quoting oddness. (Bug#8192) + + * font-lock.el (lisp-font-lock-keywords-1): Don't highlight `)' + in some setf expressions. (Bug#2159) + +2011-03-08 Chong Yidong <cyd@stupidchicken.com> + + * custom.el (custom-available-themes): Return themes in + alphabetical order. + +2011-03-07 Chong Yidong <cyd@stupidchicken.com> + + * progmodes/cc-cmds.el (c-beginning-of-statement): Fix incorrect + application of patch from Alan Mackenzie (Bug#7595). + +2011-03-07 Deniz Dogan <deniz.a.m.dogan@gmail.com> + + * net/rcirc.el (rcirc-connect): Fix PASS bug. + +2011-03-07 Glenn Morris <rgm@gnu.org> + + * vc/vc.el (vc-next-action): Add missing space to y-or-n-p prompt. + Give an explicit error if failed to make writable. (Bug#6146) + +2011-03-07 Ed Reingold <reingold@emr.cs.iit.edu> + + * calendar/cal-hebrew.el (diary-hebrew-yahrzeit): + Add optional `after-sunset' argument. (Bug#8190) + +2011-03-07 Aaron S. Hawley <aaron.s.hawley@gmail.com> + + * play/morse.el (nato-alphabet, nato-region, denato-region): + New variable and functions. (Bug#2288) + (morse-region, unmorse-region): Barf if read-only. + +2011-03-06 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/gud.el (gdb-script-syntax-propertize-function): + Don't change the syntax of a \n that closes a comment (bug#8169). + +2011-03-06 Chong Yidong <cyd@stupidchicken.com> + + * emacs-lisp/package-x.el (package-archive-upload-base): Make it a + defcustom. + (package--update-file): Doc fix. Accept relative file names. + (package--archive-contents-from-file): Remove the argument, since + it's necessarily always "archive-contents". + (package-maint-add-news-item): Pass relative file name args to + package--update-file. + (package-upload-buffer-internal): Prompt for a destination if + package-archive-upload-base is invalid. Create the directory if + it does not exist. + (package-upload-buffer, package-upload-file): Doc fix. + 2011-03-06 Chong Yidong <cyd@stupidchicken.com> * isearch.el (isearch-mode-map): Bind C-y to isearch-yank-kill, @@ -11,8 +418,8 @@ 2011-03-06 Jay Belanger <jay.p.belanger@gmail.com> - * calc/calc-ext.el (calc-init-extensions): Rename - calc-logunits-dblevel and calc-logunits-nplevel to calc-dblevel + * calc/calc-ext.el (calc-init-extensions): + Rename calc-logunits-dblevel and calc-logunits-nplevel to calc-dblevel and calc-nplevel, respectively. Add keybindings for calc-spn, calc-midi and calc-freq. Add autoloads for calcFunc-spn, calcFunc-midi, calcFunc-freq, calc-spn, calc-midi and calc-freq. @@ -732,7 +1139,7 @@ 2011-02-17 Ken Manheimer <ken.manheimer@gmail.com> * lisp/allout-widgets.el (allout-widgets-icons-light-subdir) - (allout-widgets-icons-dark-subdir): Track relocations of icons + (allout-widgets-icons-dark-subdir): Track relocations of icons. * lisp/allout.el: Remove commentary about remove encryption passphrase mnemonic support and verification. (allout-encrypt-string): Recognize epg failure to decrypt gpg2 @@ -1109,10 +1516,9 @@ (allout-auto-activation-helper, allout-setup): New autoloads implement new custom set procedure for allout-auto-activation. - Also, explicitly invoke - (allout-setup) after allout-auto-activation is custom-defined, to - effect the settings in emacs sessions besides the few where - allout-auto-activation customization is donea. + Also, explicitly invoke (allout-setup) after allout-auto-activation + is custom-defined, to affect the settings in emacs sessions besides + the few where allout-auto-activation customization is done. (allout-auto-activation): Use allout-auto-activation-helper to :set. Revise the docstring. (allout-init): Reduce functionality to just customizing diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index cc5fd6d96fa..47f181ab76b 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -1,4 +1,4 @@ -;; allout-widgets.el --- Show allout outline structure with graphical widgets. +;; allout-widgets.el --- Visually highlight allout outline structure. ;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Ken Manheimer @@ -238,7 +238,7 @@ buffer, and tracking increases as new widgets are added and decreases as obsolete widgets are garbage collected." :type 'boolean :group 'allout-widgets-developer) -(defvar allout-widgets-tally nil +(defvar allout-widgets-tally (make-hash-table :test 'eq :weakness 'key) "Hash-table of existing allout widgets, for debugging. Table is maintained iff `allout-widgets-maintain-tally' is non-nil. diff --git a/lisp/allout.el b/lisp/allout.el index c75b7a22f9a..3fb8ed7ccd5 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -310,6 +310,7 @@ Auto-layout is not. With value nil, inhibit any automatic allout-mode activation." :set 'allout-auto-activation-helper + ;; FIXME: Using strings here is unusual and less efficient than symbols. :type '(choice (const :tag "On" t) (const :tag "Ask about layout" "ask") (const :tag "Mode only" "activate") @@ -752,7 +753,7 @@ Set this var to the bullet you want to use for file cross-references." ;;;_ = allout-flattened-numbering-abbreviation (define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering - 'allout-flattened-numbering-abbreviation "24.0") + 'allout-flattened-numbering-abbreviation "24.1") (defcustom allout-flattened-numbering-abbreviation nil "If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic numbers to minimal amount with some context. Otherwise, entire @@ -1402,7 +1403,7 @@ their settings before allout-mode was started." (defvar allout-mode-deactivate-hook nil "*Hook that's run when allout mode ends.") (define-obsolete-variable-alias 'allout-mode-deactivate-hook - 'allout-mode-off-hook "future") + 'allout-mode-off-hook "24.1") ;;;_ = allout-exposure-category (defvar allout-exposure-category nil "Symbol for use as allout invisible-text overlay category.") @@ -3465,13 +3466,13 @@ Offer one suitable for current depth DEPTH as default." (defun allout-make-topic-prefix (&optional prior-bullet new depth - solicit + instead number-control index) ;; Depth null means use current depth, non-null means we're either ;; opening a new topic after current topic, lower or higher, or we're ;; changing level of current topic. - ;; Solicit dominates specified bullet-char. + ;; Instead dominates specified bullet-char. ;;;_ . Doc string: "Generate a topic prefix suitable for optional arg DEPTH, or current depth. @@ -3492,15 +3493,18 @@ bullet or previous sibling. Third arg DEPTH forces the topic prefix to that depth, regardless of the current topics' depth. -If SOLICIT is non-nil, then the choice of bullet is solicited from -user. If it's a character, then that character is offered as the -default, otherwise the one suited to the context (according to -distinction or depth) is offered. (This overrides other options, -including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the -context-specific bullet is used. +If INSTEAD is: + +- nil, then the bullet char for the context is used, per distinction or depth +- a \(numeric) character, then character's string representation is used +- a string, then the user is asked for bullet with the first char as default +- anything else, the user is solicited with bullet char per context as default + +\(INSTEAD overrides other options, including, eg, a distinctive +PRIOR-BULLET.) Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet' -is non-nil *and* soliciting was not explicitly invoked. Then +is non-nil *and* no specific INSTEAD was specified. Then NUMBER-CONTROL non-nil forces prefix to either numbered or denumbered format, depending on the value of the sixth arg, INDEX. @@ -3549,8 +3553,13 @@ index for each successive sibling)." ;; Solicitation overrides numbering and other cases: ((progn (setq body (make-string (- depth 2) ?\ )) ;; The actual condition: - solicit) - (let* ((got (allout-solicit-alternate-bullet depth solicit))) + instead) + (let ((got (cond ((stringp instead) + (if (> (length instead) 0) + (allout-solicit-alternate-bullet + depth (substring instead 0 1)))) + ((characterp instead) (char-to-string instead)) + (t (allout-solicit-alternate-bullet depth))))) ;; Gotta check whether we're numbering and got a numbered bullet: (setq numbering (and allout-numbered-bullet (not (and number-control (not index))) @@ -3913,7 +3922,7 @@ Note that refill of indented paragraphs is not done." (allout-end-of-prefix) (setq from allout-recent-prefix-beginning to allout-recent-prefix-end) - (allout-rebullet-heading t ;;; solicit + (allout-rebullet-heading t ;;; instead nil ;;; depth nil ;;; number-control nil ;;; index @@ -3931,8 +3940,8 @@ Note that refill of indented paragraphs is not done." (message "Done.") (cond (on-bullet (goto-char (allout-current-bullet-pos))) (initial-col (move-to-column initial-col))))) -;;;_ > allout-rebullet-heading (&optional solicit ...) -(defun allout-rebullet-heading (&optional solicit +;;;_ > allout-rebullet-heading (&optional instead ...) +(defun allout-rebullet-heading (&optional instead new-depth number-control index @@ -3942,11 +3951,11 @@ Note that refill of indented paragraphs is not done." All args are optional. -If SOLICIT is non-nil, then the choice of bullet is solicited from -user. If it's a character, then that character is offered as the -default, otherwise the one suited to the context (according to -distinction or depth) is offered. If non-nil, then the -context-specific bullet is just used. +If INSTEAD is: +- nil, then the bullet char for the context is used, per distinction or depth +- a \(numeric) character, then character's string representation is used +- a string, then the user is asked for bullet with the first char as default +- anything else, the user is solicited with bullet char per context as default Second arg DEPTH forces the topic prefix to that depth, regardless of the topic's current depth. @@ -3981,7 +3990,7 @@ this function." (new-prefix (allout-make-topic-prefix current-bullet nil new-depth - solicit + instead number-control index))) @@ -4028,7 +4037,7 @@ this function." (cond ((numberp index) (1+ index)) ((not number-control) (allout-sibling-index)))) (if (allout-numbered-type-prefix) - (allout-rebullet-heading nil ;;; solicit + (allout-rebullet-heading nil ;;; instead new-depth ;;; new-depth number-control;;; number-control index ;;; index @@ -4145,7 +4154,7 @@ a topic and its immediate offspring is greater than one.)" (when (< relative-depth 0) (save-excursion (goto-char local-point) - (allout-rebullet-heading nil ;;; solicit + (allout-rebullet-heading nil ;;; instead (+ starting-depth relative-depth) nil ;;; number starting-index @@ -4203,7 +4212,7 @@ Returns final depth." ; Prime ascender for ascension: (setq ascender (1- allout-recent-depth)) (if (>= allout-recent-depth depth) - (allout-rebullet-heading nil ;;; solicit + (allout-rebullet-heading nil ;;; instead nil ;;; depth nil ;;; number-control nil ;;; index @@ -4230,7 +4239,7 @@ rebulleting each topic at this level." (use-bullet (equal '(16) denumber)) (more t)) (while more - (allout-rebullet-heading use-bullet ;;; solicit + (allout-rebullet-heading use-bullet ;;; instead depth ;;; depth t ;;; number-control index ;;; index @@ -4577,32 +4586,20 @@ however, are left exactly like normal, non-allout-specific yanks." (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)) - ; Delete base subj prefix, - ; leaving old one: - (allout-unprotected - (progn - (delete-region (point) (+ (point) - prefix-len - (- adjust-to-depth - subj-depth))) + ;; Remove new heading prefix: + (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)))))) + (while (looking-at "[0-9]") (delete-char 1)) + (if (looking-at " ") + (delete-char 1)))) + ;; Assert new topic's bullet - minimal effort if unchanged: + (allout-rebullet-heading (string-to-char prefix-bullet))) (exchange-point-and-mark)))) (if rectify-numbering (progn @@ -4613,7 +4610,7 @@ however, are left exactly like normal, non-allout-specific yanks." (goto-char subj-beg) (if (allout-goto-prefix-doublechecked) (allout-unprotected - (allout-rebullet-heading nil ;;; solicit + (allout-rebullet-heading nil ;;; instead (allout-depth) ;;; depth nil ;;; number-control nil ;;; index diff --git a/lisp/avoid.el b/lisp/avoid.el index fe47a0c4a33..038927105ec 100644 --- a/lisp/avoid.el +++ b/lisp/avoid.el @@ -76,7 +76,7 @@ ;;;###autoload (defcustom mouse-avoidance-mode nil - "Activate mouse avoidance mode. + "Activate Mouse Avoidance mode. See function `mouse-avoidance-mode' for possible values. Setting this variable directly does not take effect; use either \\[customize] or the function `mouse-avoidance-mode'." @@ -85,8 +85,7 @@ use either \\[customize] or the function `mouse-avoidance-mode'." (mouse-avoidance-mode (or value 'none))) :initialize 'custom-initialize-default :type '(choice (const :tag "none" nil) (const banish) (const jump) - (const animate) (const exile) (const proteus) - ) + (const animate) (const exile) (const proteus)) :group 'avoid :require 'avoid :version "20.3") @@ -94,7 +93,7 @@ use either \\[customize] or the function `mouse-avoidance-mode'." (defcustom mouse-avoidance-nudge-dist 15 "Average distance that mouse will be moved when approached by cursor. -Only applies in Mouse-Avoidance mode `jump' and its derivatives. +Only applies in Mouse Avoidance mode `jump' and its derivatives. For best results make this larger than `mouse-avoidance-threshold'." :type 'integer :group 'avoid) @@ -112,7 +111,7 @@ For best results make this larger than `mouse-avoidance-threshold'." (defcustom mouse-avoidance-threshold 5 "Mouse-pointer's flight distance. If the cursor gets closer than this, the mouse pointer will move away. -Only applies in mouse-avoidance-modes `animate' and `jump'." +Only applies in Mouse Avoidance modes `animate' and `jump'." :type 'integer :group 'avoid) @@ -183,7 +182,7 @@ Acceptable distance is defined by `mouse-avoidance-threshold'." mouse-avoidance-threshold)))))) (defun mouse-avoidance-banish-destination () - "The position to which Mouse-Avoidance mode `banish' moves the mouse. + "The position to which Mouse Avoidance mode `banish' moves the mouse. You can redefine this if you want the mouse banished to a different corner." (let* ((pos (window-edges))) (cons (- (nth 2 pos) 2) @@ -278,6 +277,7 @@ redefine this function to suit your own tastes." (defun mouse-avoidance-ignore-p () (let ((mp (mouse-position))) (or (not (frame-pointer-visible-p)) ; The pointer is hidden + (not cursor-type) ; There's no cursor executing-kbd-macro ; don't check inside macro (null (cadr mp)) ; don't move unless in an Emacs frame (not (eq (car mp) (selected-frame))) @@ -332,7 +332,7 @@ redefine this function to suit your own tastes." ;;;###autoload (defun mouse-avoidance-mode (&optional mode) - "Set cursor avoidance mode to MODE. + "Set Mouse Avoidance mode to MODE. MODE should be one of the symbols `banish', `exile', `jump', `animate', `cat-and-mouse', `proteus', or `none'. @@ -352,7 +352,7 @@ Effects of the different modes: Whenever the mouse is moved, the frame is also raised. -\(see `mouse-avoidance-threshold' for definition of \"too close\", +\(See `mouse-avoidance-threshold' for definition of \"too close\", and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for definition of \"random distance\".)" (interactive diff --git a/lisp/calc/README b/lisp/calc/README index 533b80baeb0..308b5115aa2 100644 --- a/lisp/calc/README +++ b/lisp/calc/README @@ -72,6 +72,8 @@ Summary of changes to "Calc" Emacs 24.1 +* Support for musical notes added. + * Support for logarithmic units added. * Calc no longer uses the tex prefix for TeX specific unit diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 11a26d6d125..9ea773fbb98 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -422,13 +422,13 @@ (define-key calc-mode-map "kT" 'calc-utpt) (define-key calc-mode-map "l" nil) - (define-key calc-mode-map "lq" 'calc-logunits-quantity) - (define-key calc-mode-map "ld" 'calc-dblevel) - (define-key calc-mode-map "ln" 'calc-nplevel) - (define-key calc-mode-map "l+" 'calc-logunits-add) - (define-key calc-mode-map "l-" 'calc-logunits-sub) - (define-key calc-mode-map "l*" 'calc-logunits-mul) - (define-key calc-mode-map "l/" 'calc-logunits-divide) + (define-key calc-mode-map "lq" 'calc-lu-quant) + (define-key calc-mode-map "ld" 'calc-db) + (define-key calc-mode-map "ln" 'calc-np) + (define-key calc-mode-map "l+" 'calc-lu-plus) + (define-key calc-mode-map "l-" 'calc-lu-minus) + (define-key calc-mode-map "l*" 'calc-lu-times) + (define-key calc-mode-map "l/" 'calc-lu-divide) (define-key calc-mode-map "ls" 'calc-spn) (define-key calc-mode-map "lm" 'calc-midi) (define-key calc-mode-map "lf" 'calc-freq) @@ -943,12 +943,11 @@ calc-store-value calc-var-name) ("calc-stuff" calc-explain-why calcFunc-clean calcFunc-pclean calcFunc-pfloat calcFunc-pfrac) - ("calc-units" calcFunc-usimplify calcFunc-lufieldadd -calcFunc-lupoweradd calcFunc-lufieldsub calcFunc-lupowersub -calcFunc-lufieldmul calcFunc-lupowermul calcFunc-lufielddiv -calcFunc-lupowerdiv calcFunc-fieldquant calcFunc-powerquant -calcFunc-dbfieldlevel calcFunc-dbpowerlevel calcFunc-npfieldlevel -calcFunc-nppowerlevel calcFunc-spn calcFunc-midi calcFunc-freq + ("calc-units" calcFunc-usimplify calcFunc-lufadd calcFunc-lupadd +calcFunc-lufsub calcFunc-lupsub calcFunc-lufmul calcFunc-lupmul +calcFunc-lufdiv calcFunc-lupdiv calcFunc-lufquant calcFunc-lupquant +calcFunc-dbfield calcFunc-dbpower calcFunc-npfield +calcFunc-nppower calcFunc-spn calcFunc-midi calcFunc-freq math-build-units-table math-build-units-table-buffer math-check-unit-name math-convert-temperature math-convert-units math-extract-units math-remove-units math-simplify-units @@ -1180,9 +1179,9 @@ calc-convert-temperature calc-convert-units calc-define-unit calc-enter-units-table calc-explain-units calc-extract-units calc-get-unit-definition calc-permanent-units calc-quick-units calc-remove-units calc-simplify-units calc-undefine-unit -calc-view-units-table calc-logunits-quantity calc-dblevel -calc-nplevel calc-logunits-add calc-logunits-sub -calc-logunits-mul calc-logunits-divide calc-spn calc-midi +calc-view-units-table calc-lu-quant calc-db +calc-np calc-lu-plus calc-lu-minus +calc-lu-times calc-lu-divide calc-spn calc-midi calc-freq) ("calc-vec" calc-arrange-vector calc-build-vector calc-cnorm diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index d688b31b3cb..427cf6ba233 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -673,7 +673,9 @@ C-w Describe how there is no warranty for Calc." (interactive) (calc-do-prefix-help '("Quantity, DB level, Np level" - "+, -, *, /") + "+, -, *, /" + "Scientific pitch notation, Midi number, Frequency" + ) "log units" ?l)) (defun calc-v-prefix-help () diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el index aaddf3e486e..d8099b0aadc 100644 --- a/lisp/calc/calc-menu.el +++ b/lisp/calc/calc-menu.el @@ -960,6 +960,111 @@ (require 'calc-units) (call-interactively 'calc-view-units-table)) :keys "u V"] + (list "Logarithmic Units" + ["Convert (1:) to dB (power)" + (progn + (require 'calc-units) + (call-interactively 'calc-db)) + :keys "l d" + :active (>= (calc-stack-size) 1)] + ["Convert (2:) to dB (power) with reference level (1:)" + (progn + (require 'calc-units) + (let ((calc-option-flag t)) + (call-interactively 'calc-db))) + :keys "O l d" + :active (>= (calc-stack-size) 2)] + ["Convert (1:) to Np (power)" + (progn + (require 'calc-units) + (call-interactively 'calc-np)) + :keys "l n" + :active (>= (calc-stack-size) 1)] + ["Convert (2:) to Np (power) with reference level (1:)" + (progn + (require 'calc-units) + (let ((calc-option-flag t)) + (call-interactively 'calc-np))) + :keys "O l n" + :active (>= (calc-stack-size) 2)] + ["Convert (1:) to power quantity" + (progn + (require 'calc-units) + (call-interactively 'calc-lu-quant)) + :keys "l q" + :active (>= (calc-stack-size) 1)] + ["Convert (2:) to power quantity with reference level (1:)" + (progn + (require 'calc-units) + (let ((calc-option-flag t)) + (call-interactively 'calc-lu-quant))) + :keys "O l q" + :active (>= (calc-stack-size) 2)] + "----" + ["Convert (1:) to dB (field)" + (progn + (require 'calc-units) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-db))) + :keys "H l d" + :active (>= (calc-stack-size) 1)] + ["Convert (2:) to dB (field) with reference level (1:)" + (progn + (require 'calc-units) + (let ((calc-option-flag t) + (calc-hyperbolic-flag t)) + (call-interactively 'calc-db))) + :keys "O H l d" + :active (>= (calc-stack-size) 2)] + ["Convert (1:) to Np (field)" + (progn + (require 'calc-units) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-np))) + :keys "H l n" + :active (>= (calc-stack-size) 1)] + ["Convert (2:) to Np (field) with reference level (1:)" + (progn + (require 'calc-units) + (let ((calc-option-flag t) + (calc-hyperbolic-flag t)) + (call-interactively 'calc-np))) + :keys "O H l d" + :active (>= (calc-stack-size) 2)] + ["Convert (1:) to field quantity" + (progn + (require 'calc-units) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-lu-quant))) + :keys "H l q" + :active (>= (calc-stack-size) 1)] + ["Convert (2:) to field quantity with reference level (1:)" + (progn + (require 'calc-units) + (let ((calc-option-flag t) + (calc-hyperbolic-flag)) + (call-interactively 'calc-lu-quant))) + :keys "O H l q" + :active (>= (calc-stack-size) 2)]) + (list "Musical Notes" + ["Convert (1:) to scientific pitch notation" + (progn + (require 'calc-units) + (call-interactively 'calc-spn)) + :keys "l s" + :active (>= (calc-stack-size) 1)] + ["Convert (1:) to midi number" + (progn + (require 'calc-units) + (call-interactively 'calc-midi)) + :keys "l m" + :active (>= (calc-stack-size) 1)] + ["Convert (1:) to frequency" + (progn + (require 'calc-units) + (call-interactively 'calc-freq)) + :keys "l f" + :active (>= (calc-stack-size) 1)]) "----" ["Help on Units" (calc-info-goto-node "Units")]) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 7f0adc9fe7e..43cb5828e85 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -1623,39 +1623,39 @@ In symbolic mode, return the list (^ a b)." coef))) units))))))) -(defun calcFunc-lufieldplus (a b) +(defun calcFunc-lufadd (a b) (math-logunits-add a b nil nil)) -(defun calcFunc-lupowerplus (a b) +(defun calcFunc-lupadd (a b) (math-logunits-add a b nil t)) -(defun calcFunc-lufieldminus (a b) +(defun calcFunc-lufsub (a b) (math-logunits-add a b t nil)) -(defun calcFunc-lupowerminus (a b) +(defun calcFunc-lupsub (a b) (math-logunits-add a b t t)) -(defun calc-logunits-add (arg) +(defun calc-lu-plus (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-inverse) (if (calc-is-hyperbolic) - (calc-binary-op "lu-" 'calcFunc-lufieldminus arg) - (calc-binary-op "lu-" 'calcFunc-lupowerminus arg)) + (calc-binary-op "lu-" 'calcFunc-lufsub arg) + (calc-binary-op "lu-" 'calcFunc-lupsub arg)) (if (calc-is-hyperbolic) - (calc-binary-op "lu+" 'calcFunc-lufieldplus arg) - (calc-binary-op "lu+" 'calcFunc-lupowerplus arg))))) + (calc-binary-op "lu+" 'calcFunc-lufadd arg) + (calc-binary-op "lu+" 'calcFunc-lupadd arg))))) -(defun calc-logunits-sub (arg) +(defun calc-lu-minus (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-inverse) (if (calc-is-hyperbolic) - (calc-binary-op "lu+" 'calcFunc-lufieldplus arg) - (calc-binary-op "lu+" 'calcFunc-lupowerplus arg)) + (calc-binary-op "lu+" 'calcFunc-lufadd arg) + (calc-binary-op "lu+" 'calcFunc-lupadd arg)) (if (calc-is-hyperbolic) - (calc-binary-op "lu-" 'calcFunc-lufieldminus arg) - (calc-binary-op "lu-" 'calcFunc-lupowerminus arg))))) + (calc-binary-op "lu-" 'calcFunc-lufsub arg) + (calc-binary-op "lu-" 'calcFunc-lupsub arg))))) (defun math-logunits-mul (a b power) (let (logunit coef units number) @@ -1719,39 +1719,39 @@ In symbolic mode, return the list (^ a b)." (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1))) units))))))))) -(defun calcFunc-lufieldtimes (a b) +(defun calcFunc-lufmul (a b) (math-logunits-mul a b nil)) -(defun calcFunc-lupowertimes (a b) +(defun calcFunc-lupmul (a b) (math-logunits-mul a b t)) -(defun calc-logunits-mul (arg) +(defun calc-lu-times (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-inverse) (if (calc-is-hyperbolic) - (calc-binary-op "lu/" 'calcFunc-lufielddiv arg) - (calc-binary-op "lu/" 'calcFunc-lupowerdiv arg)) + (calc-binary-op "lu/" 'calcFunc-lufdiv arg) + (calc-binary-op "lu/" 'calcFunc-lupdiv arg)) (if (calc-is-hyperbolic) - (calc-binary-op "lu*" 'calcFunc-lufieldtimes arg) - (calc-binary-op "lu*" 'calcFunc-lupowertimes arg))))) + (calc-binary-op "lu*" 'calcFunc-lufmul arg) + (calc-binary-op "lu*" 'calcFunc-lupmul arg))))) -(defun calcFunc-lufielddiv (a b) +(defun calcFunc-lufdiv (a b) (math-logunits-divide a b nil)) -(defun calcFunc-lupowerdiv (a b) +(defun calcFunc-lupdiv (a b) (math-logunits-divide a b t)) -(defun calc-logunits-divide (arg) +(defun calc-lu-divide (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-inverse) (if (calc-is-hyperbolic) - (calc-binary-op "lu*" 'calcFunc-lufieldtimes arg) - (calc-binary-op "lu*" 'calcFunc-lupowertimes arg)) + (calc-binary-op "lu*" 'calcFunc-lufmul arg) + (calc-binary-op "lu*" 'calcFunc-lupmul arg)) (if (calc-is-hyperbolic) - (calc-binary-op "lu/" 'calcFunc-lufielddiv arg) - (calc-binary-op "lu/" 'calcFunc-lupowerdiv arg))))) + (calc-binary-op "lu/" 'calcFunc-lufdiv arg) + (calc-binary-op "lu/" 'calcFunc-lupdiv arg))))) (defun math-logunits-quant (val ref power) (let* ((units (math-simplify (math-extract-units val))) @@ -1777,29 +1777,29 @@ In symbolic mode, return the list (^ a b)." coeff)))) runits))))) -(defvar calc-logunits-field-reference) -(defvar calc-logunits-power-reference) +(defvar calc-lu-field-reference) +(defvar calc-lu-power-reference) -(defun calcFunc-fieldquant (val &optional ref) +(defun calcFunc-lufquant (val &optional ref) (unless ref - (setq ref (math-read-expr calc-logunits-field-reference))) + (setq ref (math-read-expr calc-lu-field-reference))) (math-logunits-quant val ref nil)) -(defun calcFunc-powerquant (val &optional ref) +(defun calcFunc-lupquant (val &optional ref) (unless ref - (setq ref (math-read-expr calc-logunits-power-reference))) + (setq ref (math-read-expr calc-lu-power-reference))) (math-logunits-quant val ref t)) -(defun calc-logunits-quantity (arg) +(defun calc-lu-quant (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (if (calc-is-option) - (calc-binary-op "lupq" 'calcFunc-fieldquant arg) - (calc-unary-op "lupq" 'calcFunc-fieldquant arg)) + (calc-binary-op "lupq" 'calcFunc-lufquant arg) + (calc-unary-op "lupq" 'calcFunc-lufquant arg)) (if (calc-is-option) - (calc-binary-op "lufq" 'calcFunc-powerquant arg) - (calc-unary-op "lufq" 'calcFunc-powerquant arg))))) + (calc-binary-op "lufq" 'calcFunc-lupquant arg) + (calc-unary-op "lufq" 'calcFunc-lupquant arg))))) (defun math-logunits-level (val ref db power) "Compute the value of VAL in decibels or nepers." @@ -1817,47 +1817,47 @@ In symbolic mode, return the list (^ a b)." '(var Np var-Np))) units))) -(defun calcFunc-dbfieldlevel (val &optional ref) +(defun calcFunc-dbfield (val &optional ref) (unless ref - (setq ref (math-read-expr calc-logunits-field-reference))) + (setq ref (math-read-expr calc-lu-field-reference))) (math-logunits-level val ref t nil)) -(defun calcFunc-dbpowerlevel (val &optional ref) +(defun calcFunc-dbpower (val &optional ref) (unless ref - (setq ref (math-read-expr calc-logunits-power-reference))) + (setq ref (math-read-expr calc-lu-power-reference))) (math-logunits-level val ref t t)) -(defun calcFunc-npfieldlevel (val &optional ref) +(defun calcFunc-npfield (val &optional ref) (unless ref - (setq ref (math-read-expr calc-logunits-field-reference))) + (setq ref (math-read-expr calc-lu-field-reference))) (math-logunits-level val ref nil nil)) -(defun calcFunc-nppowerlevel (val &optional ref) +(defun calcFunc-nppower (val &optional ref) (unless ref - (setq ref (math-read-expr calc-logunits-power-reference))) + (setq ref (math-read-expr calc-lu-power-reference))) (math-logunits-level val ref nil t)) -(defun calc-dblevel (arg) +(defun calc-db (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (if (calc-is-option) - (calc-binary-op "ludb" 'calcFunc-dbfieldlevel arg) - (calc-unary-op "ludb" 'calcFunc-dbfieldlevel arg)) + (calc-binary-op "ludb" 'calcFunc-dbfield arg) + (calc-unary-op "ludb" 'calcFunc-dbfield arg)) (if (calc-is-option) - (calc-binary-op "ludb" 'calcFunc-dbpowerlevel arg) - (calc-unary-op "ludb" 'calcFunc-dbpowerlevel arg))))) + (calc-binary-op "ludb" 'calcFunc-dbpower arg) + (calc-unary-op "ludb" 'calcFunc-dbpower arg))))) -(defun calc-nplevel (arg) +(defun calc-np (arg) (interactive "P") (calc-slow-wrapper (if (calc-is-hyperbolic) (if (calc-is-option) - (calc-binary-op "lunp" 'calcFunc-npfieldlevel arg) - (calc-unary-op "lunp" 'calcFunc-npfieldlevel arg)) + (calc-binary-op "lunp" 'calcFunc-npfield arg) + (calc-unary-op "lunp" 'calcFunc-npfield arg)) (if (calc-is-option) - (calc-binary-op "lunp" 'calcFunc-nppowerlevel arg) - (calc-unary-op "lunp" 'calcFunc-nppowerlevel arg))))) + (calc-binary-op "lunp" 'calcFunc-nppower arg) + (calc-unary-op "lunp" 'calcFunc-nppower arg))))) ;;; Musical notes diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index f4d8983eb88..41f549cbe2c 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -434,13 +434,13 @@ by displaying the sub-formula in `calc-selected-face'." :group 'calc :type 'boolean) -(defcustom calc-logunits-field-reference +(defcustom calc-lu-field-reference "20 uPa" "The default reference level for logarithmic units (field)." :group 'calc :type '(string)) -(defcustom calc-logunits-power-reference +(defcustom calc-lu-power-reference "mW" "The default reference level for logarithmic units (power)." :group 'calc @@ -1084,7 +1084,7 @@ Used by `calc-user-invocation'.") "lOW") (mapc (lambda (x) (define-key map (char-to-string x) 'calc-missing-key)) (concat "ABCDEFGHIJKLMNOPQRSTUVXZabcdfghjkmoprstuvwxyz" - ":\\|!()[]<>{},;=~`\C-k\C-w\C-_")) + ":\\|!()[]<>{},;=~`\C-k\C-w")) (define-key map "\M-w" 'calc-missing-key) (define-key map "\M-k" 'calc-missing-key) (define-key map "\M-\C-w" 'calc-missing-key) diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index 63e7484e127..e5373a28756 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -879,21 +879,27 @@ use when highlighting the day in the calendar." (declare-function diary-ordinal-suffix "diary-lib" (n)) ;;;###diary-autoload -(defun diary-hebrew-yahrzeit (death-month death-day death-year &optional mark) +(defun diary-hebrew-yahrzeit (death-month death-day death-year + &optional mark after-sunset) "Yahrzeit diary entry--entry applies if date is Yahrzeit or the day before. Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed to be the name of the person. Although the date of death is specified by the civil calendar, the proper Hebrew calendar Yahrzeit is determined. +If the death occurred after local sunset on the given civil date, +the following civil date corresponds to the Hebrew date of +death--set the optional parameter AFTER-SUNSET non-nil in this case. + The order of the input parameters changes according to `calendar-date-style' \(e.g. to DEATH-DAY, DEATH-MONTH, DEATH-YEAR in the European style). An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." (let* ((h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (diary-make-date death-month death-day death-year)))) + (+ (calendar-absolute-from-gregorian + (diary-make-date death-month death-day death-year)) + (if after-sunset 1 0)))) (h-month (calendar-extract-month h-date)) (h-day (calendar-extract-day h-date)) (h-year (calendar-extract-year h-date)) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index a1bfad3a5f5..62203600612 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -308,13 +308,9 @@ This function does not work for SECONDS greater than `most-positive-fixnum'." (setq start (match-end 0) spec (match-string 1 string)) (unless (string-equal spec "%") - ;; `assoc-string' is not available in XEmacs. So when compiling - ;; Gnus (`time-date.el' is part of Gnus) with XEmacs, we get - ;; a warning here. But `format-seconds' is not used anywhere in - ;; Gnus so it's not a real problem. --rsteib - (or (setq match (assoc-string spec units t)) + (or (setq match (assoc (downcase spec) units)) (error "Bad format specifier: `%s'" spec)) - (if (assoc-string spec usedunits t) + (if (assoc (downcase spec) usedunits) (error "Multiple instances of specifier: `%s'" spec)) (if (string-equal (car match) "z") (setq zeroflag t) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 88821652784..203043ebd97 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4756,6 +4756,12 @@ The format is suitable for use with `easy-menu-define'." "Invoke button at POS, or refuse to allow editing of Custom buffer." (interactive "@d") (let ((button (get-char-property pos 'button))) + ;; If there is no button at point, then use the one at the start + ;; of the line, if it is a custom-group-link (bug#2298). + (or button + (if (setq button (get-char-property (line-beginning-position) 'button)) + (or (eq (widget-type button) 'custom-group-link) + (setq button nil)))) (if button (widget-apply-action button event) (error "You can't edit this part of the Custom buffer")))) diff --git a/lisp/cus-start.el b/lisp/cus-start.el index d2d99ee64fb..788731e4dbc 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -111,9 +111,9 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (cursor-in-non-selected-windows cursor boolean nil :tag "Cursor In Non-selected Windows" - :set #'(lambda (symbol value) - (set-default symbol value) - (force-mode-line-update t))) + :set (lambda (symbol value) + (set-default symbol value) + (force-mode-line-update t))) (transient-mark-mode editing-basics boolean nil :standard (not noninteractive) :initialize custom-initialize-delay diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index cdc066aa91a..4f9428d497b 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -100,6 +100,9 @@ named *Custom Theme*." (make-local-variable 'custom-theme-insert-face-marker) (make-local-variable 'custom-theme-insert-variable-marker) (make-local-variable 'custom-theme--listed-faces) + (when (called-interactively-p 'interactive) + (unless (y-or-n-p "Include basic face customizations in this theme? ") + (setq custom-theme--listed-faces nil))) (if (eq theme 'user) (widget-insert "This buffer contains all the Custom settings you have made. @@ -188,7 +191,7 @@ remove them from your saved Custom file.\n\n")) (while vars (if (eq (car vars) 'custom-enabled-themes) (progn (pop vars) (pop values)) - (custom-theme-add-var-1 (pop vars) (pop values))))) + (custom-theme-add-var-1 (pop vars) (eval (pop values)))))) (setq custom-theme-insert-variable-marker (point-marker)) (widget-insert " ") (widget-create 'push-button @@ -297,8 +300,9 @@ SPEC, if non-nil, should be a face spec to which to set the widget." ;;; Reading and writing +;;;###autoload (defun custom-theme-visit-theme (theme) - "Load the custom theme THEME's settings into the current buffer." + "Set up a Custom buffer to edit custom theme THEME." (interactive (list (intern (completing-read "Find custom theme: " @@ -663,4 +667,6 @@ Theme files are named *-theme.el in `")) (widget-toggle-action widget event) (setq custom-theme-allow-multiple-selections (widget-value widget))) +(provide 'cus-theme) + ;;; cus-theme.el ends here diff --git a/lisp/custom.el b/lisp/custom.el index d0d11610b91..d9bb4f954bc 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -792,10 +792,10 @@ E.g. dumped variables whose default depends on run-time information." (defvar custom-known-themes '(user changed) "Themes that have been defined with `deftheme'. The default value is the list (user changed). The theme `changed' -contains the settings before custom themes are applied. The -theme `user' contains all the settings the user customized and saved. -Additional themes declared with the `deftheme' macro will be added to -the front of this list.") +contains the settings before custom themes are applied. The theme +`user' contains all the settings the user customized and saved. +Additional themes declared with the `deftheme' macro will be added +to the front of this list.") (defsubst custom-theme-p (theme) "Non-nil when THEME has been defined." @@ -1074,7 +1074,7 @@ order. Each element in the list should be one of the following: named \"themes\" in `data-directory'). - a directory name (a string). -Each theme file is named NAME-theme.el, where THEME is the theme +Each theme file is named THEME-theme.el, where THEME is the theme name." :type '(repeat (choice (const :tag "custom-theme-directory" custom-theme-directory) @@ -1146,7 +1146,7 @@ Return t if THEME was successfully loaded, nil otherwise." '("" "c"))) hash) (unless fn - (error "Unable to find theme file for `%s'." theme)) + (error "Unable to find theme file for `%s'" theme)) (with-temp-buffer (insert-file-contents fn) (setq hash (sha1 (current-buffer))) @@ -1212,7 +1212,7 @@ NAME should be a symbol." (defun custom-available-themes () "Return a list of available Custom themes (symbols)." - (let* (sym themes) + (let (sym themes) (dolist (dir (custom-theme--load-path)) (when (file-directory-p dir) (dolist (file (file-expand-wildcards @@ -1222,7 +1222,7 @@ NAME should be a symbol." (setq sym (intern (match-string 1 file))) (custom-theme-name-valid-p sym) (push sym themes))))) - (delete-dups themes))) + (nreverse (delete-dups themes)))) (defun custom-theme--load-path () (let (lpath) @@ -1338,7 +1338,7 @@ That is to say, it specifies what the value should be according to currently enabled custom themes. This function returns nil if no custom theme specifies a value for VARIABLE." - (let* ((theme-value (get variable 'theme-value))) + (let ((theme-value (get variable 'theme-value))) (if theme-value (cdr (car theme-value))))) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index c533c81be0e..9ab1fcb0e2b 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1638,11 +1638,14 @@ Optional arg HOW-TO determiness how to treat the target. ;;;###autoload (defun dired-create-directory (directory) - "Create a directory called DIRECTORY." + "Create a directory called DIRECTORY. +If DIRECTORY already exists, signal an error." (interactive (list (read-file-name "Create directory: " (dired-current-directory)))) (let* ((expanded (directory-file-name (expand-file-name directory))) (try expanded) new) + (if (file-exists-p expanded) + (error "Cannot create directory %s: file exists" expanded)) ;; Find the topmost nonexistent parent dir (variable `new') (while (and try (not (file-exists-p try)) (not (equal new try))) (setq new try diff --git a/lisp/dired.el b/lisp/dired.el index c8343ba7561..d72e0aad55f 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -3629,7 +3629,7 @@ Ask means pop up a menu for the user to select one of copy, move or link." ;;;;;; dired-run-shell-command dired-do-shell-command dired-do-async-shell-command ;;;;;; dired-clean-directory dired-do-print dired-do-touch dired-do-chown ;;;;;; dired-do-chgrp dired-do-chmod dired-compare-directories dired-backup-diff -;;;;;; dired-diff) "dired-aux" "dired-aux.el" "154cdfbf451aedec60c5012b625ff329") +;;;;;; dired-diff) "dired-aux" "dired-aux.el" "2d805d6766bd7970cd446413b4ed4ce0") ;;; Generated autoloads from dired-aux.el (autoload 'dired-diff "dired-aux" "\ @@ -3860,6 +3860,7 @@ Not documented (autoload 'dired-create-directory "dired-aux" "\ Create a directory called DIRECTORY. +If DIRECTORY already exists, signal an error. \(fn DIRECTORY)" t nil) diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el index dd589cb58f7..a906cf8516a 100644 --- a/lisp/ebuff-menu.el +++ b/lisp/ebuff-menu.el @@ -34,7 +34,56 @@ ;; this depends on the format of list-buffers (from src/buffer.c) and ;; on stuff in lisp/buff-menu.el -(defvar electric-buffer-menu-mode-map nil) +(defvar electric-buffer-menu-mode-map + (let ((map (make-keymap))) + (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined) + (define-key map "\e" nil) + (define-key map "\C-z" 'suspend-frame) + (define-key map "v" 'Electric-buffer-menu-mode-view-buffer) + (define-key map (char-to-string help-char) 'Helper-help) + (define-key map "?" 'Helper-describe-bindings) + (define-key map "\C-c" nil) + (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit) + (define-key map "\C-]" 'Electric-buffer-menu-quit) + (define-key map "q" 'Electric-buffer-menu-quit) + (define-key map " " 'Electric-buffer-menu-select) + (define-key map "\C-m" 'Electric-buffer-menu-select) + (define-key map "\C-l" 'recenter) + (define-key map "s" 'Buffer-menu-save) + (define-key map "d" 'Buffer-menu-delete) + (define-key map "k" 'Buffer-menu-delete) + (define-key map "\C-d" 'Buffer-menu-delete-backwards) + ;; (define-key map "\C-k" 'Buffer-menu-delete) + (define-key map "\177" 'Buffer-menu-backup-unmark) + (define-key map "~" 'Buffer-menu-not-modified) + (define-key map "u" 'Buffer-menu-unmark) + (let ((i ?0)) + (while (<= i ?9) + (define-key map (char-to-string i) 'digit-argument) + (define-key map (concat "\e" (char-to-string i)) 'digit-argument) + (setq i (1+ i)))) + (define-key map "-" 'negative-argument) + (define-key map "\e-" 'negative-argument) + (define-key map "m" 'Buffer-menu-mark) + (define-key map "\C-u" 'universal-argument) + (define-key map "\C-p" 'previous-line) + (define-key map "\C-n" 'next-line) + (define-key map "p" 'previous-line) + (define-key map "n" 'next-line) + (define-key map "\C-v" 'scroll-up) + (define-key map "\ev" 'scroll-down) + (define-key map ">" 'scroll-right) + (define-key map "<" 'scroll-left) + (define-key map "\e\C-v" 'scroll-other-window) + (define-key map "\e>" 'end-of-buffer) + (define-key map "\e<" 'beginning-of-buffer) + (define-key map "\e\e" nil) + (define-key map "\e\e\e" 'Electric-buffer-menu-quit) + ;; This binding prevents the "escape => ESC" function-key-map mapping from + ;; kicking in! + ;; (define-key map [escape escape escape] 'Electric-buffer-menu-quit) + (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select) + map)) (defvar electric-buffer-menu-mode-hook nil "Normal hook run by `electric-buffer-list'.") @@ -167,55 +216,7 @@ Entry to this mode via command `electric-buffer-list' calls the value of ;; generally the same as Buffer-menu-mode-map ;; (except we don't indirect to global-map) (put 'Electric-buffer-menu-undefined 'suppress-keymap t) -(if electric-buffer-menu-mode-map - nil - (let ((map (make-keymap))) - (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined) - (define-key map "\e" nil) - (define-key map "\C-z" 'suspend-frame) - (define-key map "v" 'Electric-buffer-menu-mode-view-buffer) - (define-key map (char-to-string help-char) 'Helper-help) - (define-key map "?" 'Helper-describe-bindings) - (define-key map "\C-c" nil) - (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit) - (define-key map "\C-]" 'Electric-buffer-menu-quit) - (define-key map "q" 'Electric-buffer-menu-quit) - (define-key map " " 'Electric-buffer-menu-select) - (define-key map "\C-m" 'Electric-buffer-menu-select) - (define-key map "\C-l" 'recenter) - (define-key map "s" 'Buffer-menu-save) - (define-key map "d" 'Buffer-menu-delete) - (define-key map "k" 'Buffer-menu-delete) - (define-key map "\C-d" 'Buffer-menu-delete-backwards) - ;(define-key map "\C-k" 'Buffer-menu-delete) - (define-key map "\177" 'Buffer-menu-backup-unmark) - (define-key map "~" 'Buffer-menu-not-modified) - (define-key map "u" 'Buffer-menu-unmark) - (let ((i ?0)) - (while (<= i ?9) - (define-key map (char-to-string i) 'digit-argument) - (define-key map (concat "\e" (char-to-string i)) 'digit-argument) - (setq i (1+ i)))) - (define-key map "-" 'negative-argument) - (define-key map "\e-" 'negative-argument) - (define-key map "m" 'Buffer-menu-mark) - (define-key map "\C-u" 'universal-argument) - (define-key map "\C-p" 'previous-line) - (define-key map "\C-n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "n" 'next-line) - (define-key map "\C-v" 'scroll-up) - (define-key map "\ev" 'scroll-down) - (define-key map ">" 'scroll-right) - (define-key map "<" 'scroll-left) - (define-key map "\e\C-v" 'scroll-other-window) - (define-key map "\e>" 'end-of-buffer) - (define-key map "\e<" 'beginning-of-buffer) - (define-key map "\e\e" nil) - (define-key map "\e\e\e" 'Electric-buffer-menu-quit) - (define-key map [escape escape escape] 'Electric-buffer-menu-quit) - (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select) - (setq electric-buffer-menu-mode-map map))) + (defun Electric-buffer-menu-exit () (interactive) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c9a85edfca4..5a87f590020 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4071,7 +4071,8 @@ binding slots have been popped." (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious)) - (byte-compile-warn "`save-excursion' defeated by `set-buffer'")) + (byte-compile-warn + "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) @@ -4120,6 +4121,17 @@ binding slots have been popped." ,@decls ',(nth 1 form))))) +;; If foo.el declares `toto' as obsolete, it is likely that foo.el will +;; actually use `toto' in order for this obsolete variable to still work +;; correctly, so paradoxically, while byte-compiling foo.el, the presence +;; of a make-obsolete-variable call for `toto' is an indication that `toto' +;; should not trigger obsolete-warnings in foo.el. +(byte-defop-compiler-1 make-obsolete-variable) +(defun byte-compile-make-obsolete-variable (form) + (when (eq 'quote (car-safe (nth 1 form))) + (push (nth 1 (nth 1 form)) byte-compile-not-obsolete-vars)) + (byte-compile-normal-call form)) + (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. (when (and (symbolp (nth 1 form)) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 3a6878ed16b..8bcbd67f46b 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -282,7 +282,7 @@ Not documented ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "80cb83265399ce021c8c0c7d1a8562f2") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "c4734fbda33043d967624d39d80c3304") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -500,16 +500,16 @@ Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. -\(fn VARLIST BODY)" nil (quote macro)) +\(fn BINDINGS BODY)" nil (quote macro)) (autoload 'lexical-let* "cl-macs" "\ Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in -successive bindings within VARLIST, will create lexical closures +successive bindings within BINDINGS, will create lexical closures as in Common Lisp. This is similar to the behavior of `let*' in Common Lisp. -\(fn VARLIST BODY)" nil (quote macro)) +\(fn BINDINGS BODY)" nil (quote macro)) (autoload 'multiple-value-bind "cl-macs" "\ Collect multiple return values. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 5bd8fd01b1e..b2e20843856 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1482,9 +1482,8 @@ Returns the stats object." (let ((print-escape-newlines t) (print-level 5) (print-length 10)) - (let ((begin (point))) - (ert--pp-with-indentation-and-newline - (ert-test-result-with-condition-condition result)))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) (assert (looking-at "\n")) (delete-char 1) @@ -1603,7 +1602,7 @@ Nothing more than an interactive interface to `ert-make-test-unbound'." (defun ert-delete-all-tests () "Make all symbols in `obarray' name no test." (interactive) - (when (interactive-p) + (when (called-interactively-p 'any) (unless (y-or-n-p "Delete all tests? ") (error "Aborted"))) ;; We can't use `ert-select-tests' here since that gives us only @@ -1793,7 +1792,7 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'." BEGIN and END specify a region in the current buffer." (save-excursion (save-restriction - (narrow-to-region begin (point)) + (narrow-to-region begin end) ;; Inhibit optimization in `debugger-make-xrefs' that would ;; sometimes insert unrelated backtrace info into our buffer. (let ((debugger-previous-backtrace nil)) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 61f23abf0a7..cd4b5ee231c 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -27,21 +27,41 @@ ;;; Commentary: -;; This file currently contains parts of the package system most -;; people won't need, such as package uploading. +;; This file currently contains parts of the package system that many +;; won't need, such as package uploading. + +;; To upload to an archive, first set `package-archive-upload-base' to +;; some desired directory. For testing purposes, you can specify any +;; directory you want, but if you want the archive to be accessible to +;; others via http, this is typically a directory in the /var/www tree +;; (possibly one on a remote machine, accessed via Tramp). + +;; Then call M-x package-upload-file, which prompts for a file to +;; upload. Alternatively, M-x package-upload-buffer uploads the +;; current buffer, if it's visiting a package file. + +;; Once a package is uploaded, users can access it via the Package +;; Menu, by adding the archive to `package-archives'. ;;; Code: (require 'package) (defvar gnus-article-buffer) -;; Note that this only works if you have the password, which you -;; probably don't :-). -(defvar package-archive-upload-base nil - "Base location for uploading to package archive.") +(defcustom package-archive-upload-base "/path/to/archive" + "The base location of the archive to which packages are uploaded. +This should be an absolute directory name. If the archive is on +another machine, you may specify a remote name in the usual way, +e.g. \"/ssh:foo@example.com:/var/www/packages/\". +See Info node `(emacs)Remote Files'. + +Unlike `package-archives', you can't specify a HTTP URL." + :type 'directory + :group 'package + :version "24.1") (defvar package-update-news-on-upload nil - "Whether package upload should also update NEWS and RSS feeds.") + "Whether uploading a package should also update NEWS and RSS feeds.") (defun package--encode (string) "Encode a string by replacing some characters with XML entities." @@ -75,13 +95,18 @@ title " - " (package--encode text) " </li>\n")) -(defun package--update-file (file location text) +(defun package--update-file (file tag text) + "Update the package archive file named FILE. +FILE should be relative to `package-archive-upload-base'. +TAG is a string that can be found within the file; TEXT is +inserted after its first occurrence in the file." + (setq file (expand-file-name file package-archive-upload-base)) (save-excursion (let ((old-buffer (find-buffer-visiting file))) (with-current-buffer (let ((find-file-visit-truename t)) (or old-buffer (find-file-noselect file))) (goto-char (point-min)) - (search-forward location) + (search-forward tag) (forward-line) (insert text) (let ((file-precious-flag t)) @@ -105,30 +130,31 @@ Return the file contents, as a string, or nil if unsuccessful." (buffer-substring-no-properties (point-min) (point-max))) (kill-buffer buffer)))))) -(defun package--archive-contents-from-file (file) - "Parse the given archive-contents file." - (if (not (file-exists-p file)) - ;; no existing archive-contents, possibly a new ELPA repo. - (list package-archive-version) - (let ((dont-kill (find-buffer-visiting file))) - (with-current-buffer (let ((find-file-visit-truename t)) - (find-file-noselect file)) - (prog1 - (package-read-from-string - (buffer-substring-no-properties (point-min) (point-max))) - (unless dont-kill - (kill-buffer (current-buffer)))))))) +(defun package--archive-contents-from-file () + "Parse the archive-contents at `package-archive-upload-base'" + (let ((file (expand-file-name "archive-contents" + package-archive-upload-base))) + (if (not (file-exists-p file)) + ;; No existing archive-contents means a new archive. + (list package-archive-version) + (let ((dont-kill (find-buffer-visiting file))) + (with-current-buffer (let ((find-file-visit-truename t)) + (find-file-noselect file)) + (prog1 + (package-read-from-string + (buffer-substring-no-properties (point-min) (point-max))) + (unless dont-kill + (kill-buffer (current-buffer))))))))) (defun package-maint-add-news-item (title description archive-url) - "Add a news item to the ELPA web pages. + "Add a news item to the webpages associated with the package archive. TITLE is the title of the news item. -DESCRIPTION is the text of the news item. -You need administrative access to ELPA to use this." +DESCRIPTION is the text of the news item." (interactive "sTitle: \nsText: ") - (package--update-file (concat package-archive-upload-base "elpa.rss") + (package--update-file "elpa.rss" "<description>" (package--make-rss-entry title description archive-url)) - (package--update-file (concat package-archive-upload-base "news.html") + (package--update-file "news.html" "New entries go here" (package--make-html-entry title description))) @@ -144,8 +170,8 @@ PKG-INFO is the package info, see `package-buffer-info'. EXTENSION is the file extension, a string. It can be either \"el\" or \"tar\". -The variable `package-archive-upload-base' specifies the upload -destination. If this is nil, signal an error. +The upload destination is given by `package-archive-upload-base'. +If its value is invalid, prompt for a directory. Optional arg ARCHIVE-URL is the URL of the destination archive. If it is non-nil, compute the new \"archive-contents\" file @@ -156,85 +182,97 @@ addition, if `package-update-news-on-upload' is non-nil, call If ARCHIVE-URL is nil, compute the new \"archive-contents\" file from the \"archive-contents\" at `package-archive-upload-base', if it exists." - (unless package-archive-upload-base - (error "No destination specified in `package-archive-upload-base'")) - (save-excursion - (save-restriction - (let* ((file-type (cond - ((equal extension "el") 'single) - ((equal extension "tar") 'tar) - (t (error "Unknown extension `%s'" extension)))) - (file-name (aref pkg-info 0)) - (pkg-name (intern file-name)) - (requires (aref pkg-info 1)) - (desc (if (string= (aref pkg-info 2) "") - (read-string "Description of package: ") - (aref pkg-info 2))) - (pkg-version (aref pkg-info 3)) - (commentary (aref pkg-info 4)) - (split-version (version-to-list pkg-version)) - (pkg-buffer (current-buffer))) - - ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or - ;; from `package-archive-upload-base' otherwise. - (let ((contents (or (package--archive-contents-from-url archive-url) - (package--archive-contents-from-file - (concat package-archive-upload-base - "archive-contents")))) - (new-desc (vector split-version requires desc file-type))) - (if (> (car contents) package-archive-version) - (error "Unrecognized archive version %d" (car contents))) - (let ((elt (assq pkg-name (cdr contents)))) - (if elt - (if (version-list-<= split-version - (package-desc-vers (cdr elt))) - (error "New package has smaller version: %s" pkg-version) - (setcdr elt new-desc)) - (setq contents (cons (car contents) - (cons (cons pkg-name new-desc) - (cdr contents)))))) - - ;; Now CONTENTS is the updated archive contents. Upload - ;; this and the package itself. For now we assume ELPA is - ;; writable via file primitives. - (let ((print-level nil) - (print-length nil)) - (write-region (concat (pp-to-string contents) "\n") - nil - (concat package-archive-upload-base - "archive-contents"))) - - ;; If there is a commentary section, write it. - (when commentary - (write-region commentary nil - (concat package-archive-upload-base - (symbol-name pkg-name) "-readme.txt"))) - - (set-buffer pkg-buffer) - (write-region (point-min) (point-max) - (concat package-archive-upload-base - file-name "-" pkg-version - "." extension) - nil nil nil 'excl) - - ;; Write a news entry. - (and package-update-news-on-upload - archive-url - (package--update-news (concat file-name "." extension) - pkg-version desc archive-url)) - - ;; special-case "package": write a second copy so that the - ;; installer can easily find the latest version. - (if (string= file-name "package") - (write-region (point-min) (point-max) - (concat package-archive-upload-base - file-name "." extension) - nil nil nil 'ask))))))) + (let ((package-archive-upload-base package-archive-upload-base)) + ;; Check if `package-archive-upload-base' is valid. + (when (or (not (stringp package-archive-upload-base)) + (equal package-archive-upload-base + (car-safe + (get 'package-archive-upload-base 'standard-value)))) + (setq package-archive-upload-base + (read-directory-name + "Base directory for package archive: "))) + (unless (file-directory-p package-archive-upload-base) + (if (y-or-n-p (format "%s does not exist; create it? " + package-archive-upload-base)) + (make-directory package-archive-upload-base t) + (error "Aborted"))) + (save-excursion + (save-restriction + (let* ((file-type (cond + ((equal extension "el") 'single) + ((equal extension "tar") 'tar) + (t (error "Unknown extension `%s'" extension)))) + (file-name (aref pkg-info 0)) + (pkg-name (intern file-name)) + (requires (aref pkg-info 1)) + (desc (if (string= (aref pkg-info 2) "") + (read-string "Description of package: ") + (aref pkg-info 2))) + (pkg-version (aref pkg-info 3)) + (commentary (aref pkg-info 4)) + (split-version (version-to-list pkg-version)) + (pkg-buffer (current-buffer))) + + ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or + ;; from `package-archive-upload-base' otherwise. + (let ((contents (or (package--archive-contents-from-url archive-url) + (package--archive-contents-from-file))) + (new-desc (vector split-version requires desc file-type))) + (if (> (car contents) package-archive-version) + (error "Unrecognized archive version %d" (car contents))) + (let ((elt (assq pkg-name (cdr contents)))) + (if elt + (if (version-list-<= split-version + (package-desc-vers (cdr elt))) + (error "New package has smaller version: %s" pkg-version) + (setcdr elt new-desc)) + (setq contents (cons (car contents) + (cons (cons pkg-name new-desc) + (cdr contents)))))) + + ;; Now CONTENTS is the updated archive contents. Upload + ;; this and the package itself. For now we assume ELPA is + ;; writable via file primitives. + (let ((print-level nil) + (print-length nil)) + (write-region (concat (pp-to-string contents) "\n") + nil + (expand-file-name "archive-contents" + package-archive-upload-base))) + + ;; If there is a commentary section, write it. + (when commentary + (write-region commentary nil + (expand-file-name + (concat (symbol-name pkg-name) "-readme.txt") + package-archive-upload-base))) + + (set-buffer pkg-buffer) + (write-region (point-min) (point-max) + (expand-file-name + (concat file-name "-" pkg-version "." extension) + package-archive-upload-base) + nil nil nil 'excl) + + ;; Write a news entry. + (and package-update-news-on-upload + archive-url + (package--update-news (concat file-name "." extension) + pkg-version desc archive-url)) + + ;; special-case "package": write a second copy so that the + ;; installer can easily find the latest version. + (if (string= file-name "package") + (write-region (point-min) (point-max) + (expand-file-name + (concat file-name "." extension) + package-archive-upload-base) + nil nil nil 'ask)))))))) (defun package-upload-buffer () "Upload the current buffer as a single-file Emacs Lisp package. -The variable `package-archive-upload-base' specifies the upload -destination." +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one." (interactive) (save-excursion (save-restriction @@ -247,9 +285,8 @@ destination." Interactively, prompt for FILE. The package is considered a single-file package if FILE ends in \".el\", and a multi-file package if FILE ends in \".tar\". - -The variable `package-archive-upload-base' specifies the upload -destination." +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one." (interactive "fPackage file name: ") (with-temp-buffer (insert-file-contents-literally file) @@ -269,4 +306,4 @@ This should be invoked from the gnus *Summary* buffer." (provide 'package-x) -;;; package.el ends here +;;; package-x.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2552ad4eb68..5dc2938fe08 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -319,20 +319,39 @@ Like `package-alist', but maps package name to a second alist. The inner alist is keyed by version.") (put 'package-obsolete-alist 'risky-local-variable t) -(defconst package-subdirectory-regexp - "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$" - "Regular expression matching the name of a package subdirectory. -The first subexpression is the package name. -The second subexpression is the version string.") - -(defun package-version-join (l) - "Turn a list of version numbers into a version string." - (mapconcat 'int-to-string l ".")) +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -3) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply 'concat (nreverse str-list))))) (defun package-strip-version (dirname) "Strip the version from a combined package name and version. E.g., if given \"quux-23.0\", will return \"quux\"" - (if (string-match package-subdirectory-regexp dirname) + (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname) (match-string 1 dirname))) (defun package-load-descriptor (dir package) @@ -357,12 +376,13 @@ In each valid package subdirectory, this function loads the description file containing a call to `define-package', which updates `package-alist' and `package-obsolete-alist'." (let ((all (memq 'all package-load-list)) + (regexp (concat "\\`" package-subdirectory-regexp "\\'")) name version force) (dolist (dir (cons package-user-dir package-directory-list)) (when (file-directory-p dir) (dolist (subdir (directory-files dir)) (when (and (file-directory-p (expand-file-name subdir dir)) - (string-match package-subdirectory-regexp subdir)) + (string-match regexp subdir)) (setq name (intern (match-string 1 subdir)) version (match-string 2 subdir) force (assq name package-load-list)) @@ -554,30 +574,29 @@ EXTRA-PROPERTIES is currently unused." (package-autoload-ensure-default-file generated-autoload-file)) (update-directory-autoloads pkg-dir))) -(defun package-untar-buffer () +(defvar tar-parse-info) +(declare-function tar-untar-buffer "tar-mode" ()) + +(defun package-untar-buffer (dir) "Untar the current buffer. -This uses `tar-untar-buffer' if it is available. -Otherwise it uses an external `tar' program. -`default-directory' should be set by the caller." +This uses `tar-untar-buffer' from Tar mode. All files should +untar into a directory named DIR; otherwise, signal an error." (require 'tar-mode) - (if (fboundp 'tar-untar-buffer) - (progn - ;; tar-mode messes with narrowing, so we just let it have the - ;; whole buffer to play with. - (delete-region (point-min) (point)) - (tar-mode) - (tar-untar-buffer)) - ;; FIXME: check the result. - (call-process-region (point) (point-max) "tar" nil '(nil nil) nil - "xf" "-"))) + (tar-mode) + ;; Make sure everything extracts into DIR. + (let ((regexp (concat "\\`" (regexp-quote dir) "/"))) + (dolist (tar-data tar-parse-info) + (unless (string-match regexp (aref tar-data 2)) + (error "Package does not untar cleanly into directory %s/" dir)))) + (tar-untar-buffer)) (defun package-unpack (name version) - (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version) - package-user-dir))) + (let* ((dirname (concat (symbol-name name) "-" version)) + (pkg-dir (expand-file-name dirname package-user-dir))) (make-directory package-user-dir t) ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) - (package-untar-buffer) + (package-untar-buffer dirname) (package-generate-autoloads (symbol-name name) pkg-dir) (let ((load-path (cons pkg-dir load-path))) (byte-recompile-directory pkg-dir 0 t))))) @@ -592,7 +611,9 @@ Otherwise it uses an external `tar' program. (if (string= file-name "package") (package--write-file-no-coding (expand-file-name (concat file-name ".el") package-user-dir)) - (let* ((pkg-dir (expand-file-name (concat file-name "-" version) + (let* ((pkg-dir (expand-file-name (concat file-name "-" + (package-version-join + (version-to-list version))) package-user-dir)) (el-file (expand-file-name (concat file-name ".el") pkg-dir)) (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) @@ -848,15 +869,17 @@ The package is found on one of the archives in `package-archives'." ;; Try to activate it. (package-initialize)) -(defun package-strip-rcs-id (v-str) - "Strip RCS version ID from the version string. +(defun package-strip-rcs-id (str) + "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. Otherwise return nil." - (if v-str - (if (string-match "^[ \t]*[$]Revision:[ \t]\([0-9.]+\)[ \t]*[$]$" v-str) - (match-string 1 v-str) - (if (string-match "^[0-9.]*$" v-str) - v-str)))) + (when str + (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str) + (setq str (substring str (match-end 0)))) + (condition-case nil + (if (version-to-list str) + str) + (error nil)))) (defun package-buffer-info () "Return a vector describing the package in the current buffer. @@ -911,43 +934,47 @@ boundaries." "Find package information for a tar file. FILE is the name of the tar file to examine. The return result is a vector like `package-buffer-info'." - (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) - (error "Invalid package name `%s'" file)) - (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) - (pkg-version (match-string-no-properties 2 file)) - ;; Extract the package descriptor. - (pkg-def-contents (shell-command-to-string - ;; Requires GNU tar. - (concat "tar -xOf " file " " - pkg-name "-" pkg-version "/" - pkg-name "-pkg.el"))) - (pkg-def-parsed (package-read-from-string pkg-def-contents))) - (unless (eq (car pkg-def-parsed) 'define-package) - (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) - (let ((name-str (nth 1 pkg-def-parsed)) - (version-string (nth 2 pkg-def-parsed)) - (docstring (nth 3 pkg-def-parsed)) - (requires (nth 4 pkg-def-parsed)) - (readme (shell-command-to-string - ;; Requires GNU tar. - (concat "tar -xOf " file " " - pkg-name "-" pkg-version "/README")))) - (unless (equal pkg-version version-string) - (error "Package has inconsistent versions")) - (unless (equal pkg-name name-str) - (error "Package has inconsistent names")) - ;; Kind of a hack. - (if (string-match ": Not found in archive" readme) - (setq readme nil)) - ;; Turn string version numbers into list form. - (if (eq (car requires) 'quote) - (setq requires (car (cdr requires)))) - (setq requires - (mapcar (lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) - requires)) - (vector pkg-name requires docstring version-string readme)))) + (let ((default-directory (file-name-directory file)) + (file (file-name-nondirectory file))) + (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'") + file) + (error "Invalid package name `%s'" file)) + (let* ((pkg-name (match-string-no-properties 1 file)) + (pkg-version (match-string-no-properties 2 file)) + ;; Extract the package descriptor. + (pkg-def-contents (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + + pkg-name "-" pkg-version "/" + pkg-name "-pkg.el"))) + (pkg-def-parsed (package-read-from-string pkg-def-contents))) + (unless (eq (car pkg-def-parsed) 'define-package) + (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) + (let ((name-str (nth 1 pkg-def-parsed)) + (version-string (nth 2 pkg-def-parsed)) + (docstring (nth 3 pkg-def-parsed)) + (requires (nth 4 pkg-def-parsed)) + (readme (shell-command-to-string + ;; Requires GNU tar. + (concat "tar -xOf " file " " + pkg-name "-" pkg-version "/README")))) + (unless (equal pkg-version version-string) + (error "Package has inconsistent versions")) + (unless (equal pkg-name name-str) + (error "Package has inconsistent names")) + ;; Kind of a hack. + (if (string-match ": Not found in archive" readme) + (setq readme nil)) + ;; Turn string version numbers into list form. + (if (eq (car requires) 'quote) + (setq requires (car (cdr requires)))) + (setq requires + (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + requires)) + (vector pkg-name requires docstring version-string readme))))) ;;;###autoload (defun package-install-from-buffer (pkg-info type) @@ -1037,7 +1064,7 @@ makes them available for download." (unless (file-exists-p package-user-dir) (make-directory package-user-dir t)) (dolist (archive package-archives) - (condition-case nil + (condition-case-no-debug nil (package--download-one-archive archive "archive-contents") (error (message "Failed to download `%s' archive." (car archive))))) @@ -1465,7 +1492,7 @@ packages marked for deletion are removed." delete-list ", ")))) (dolist (elt delete-list) - (condition-case err + (condition-case-no-debug err (package-delete (car elt) (cdr elt)) (error (message (cadr err))))) (error "Aborted"))) diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index d7162406879..a9e8f11c39a 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -35,13 +35,51 @@ Eshell commands implemented in Lisp." ;;; User Functions: -(defmacro eshell-eval-using-options (name macro-args - options &rest body-forms) +(defmacro eshell-eval-using-options (name macro-args options &rest body-forms) "Process NAME's MACRO-ARGS using a set of command line OPTIONS. -After doing so, settings will be stored in local symbols as declared -by OPTIONS; FORMS will then be evaluated -- assuming all was OK. +After doing so, stores settings in local symbols as declared by OPTIONS; +then evaluates BODY-FORMS -- assuming all was OK. -The syntax of OPTIONS is: +OPTIONS is a list, beginning with one or more elements of the form: +\(SHORT LONG VALUE SYMBOL HELP-STRING) +Each of these elements represents a particular command-line switch. + +SHORT is either nil, or a character that can be used as a switch -SHORT. +LONG is either nil, or a string that can be used as a switch --LONG. +At least one of SHORT and LONG must be non-nil. +VALUE is the value associated with the option. It can be either: + t - the option needs a value to be specified after the switch; + nil - the option is given the value t; + anything else - specifies the actual value for the option. +SYMBOL is either nil, or the name of the Lisp symbol that will be bound +to VALUE. A nil SYMBOL calls `eshell-show-usage', and so is appropriate +for a \"--help\" type option. +HELP-STRING is a documentation string for the option. + +Any remaining elements of OPTIONS are :KEYWORD arguments. Some take +arguments, some do not. The recognized :KEYWORDS are: + +:external STRING + STRING is an external command to run if there are unknown switches. + +:usage STRING + STRING is the initial part of the command's documentation string. + It appears before the options are listed. + +:post-usage STRING + STRING is an optional trailing part of the command's documentation string. + It appears after the options, but before the final part of the + documentation about the associated external command (if there is one). + +:show-usage + If present, then show the usage message if the command is called with no + arguments. + +:preserve-args + If present, do not pass MACRO-ARGS through `eshell-flatten-list' +and `eshell-stringify-list'. + +For example, OPTIONS might look like: '((?C nil nil multi-column \"multi-column display\") (nil \"help\" nil nil \"show this usage display\") @@ -52,8 +90,9 @@ The syntax of OPTIONS is: Sort entries alphabetically across.\") `eshell-eval-using-options' returns the value of the last form in -BODY-FORMS. If instead an external command is run, the tag -`eshell-external' will be thrown with the new process for its value. +BODY-FORMS. If instead an external command is run (because of +an unknown option), the tag `eshell-external' will be thrown with +the new process for its value. Lastly, any remaining arguments will be available in a locally interned variable `args' (created using a `let' form)." @@ -200,7 +239,7 @@ switch is unrecognized." (defun eshell-process-args (name args options) "Process the given ARGS using OPTIONS. -This assumes that symbols have been intern'd by `eshell-with-options'." +This assumes that symbols have been intern'd by `eshell-eval-using-options'." (let ((ai 0) arg) (while (< ai (length args)) (setq arg (nth ai args)) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index dbe4f824deb..424d246a2b6 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -138,7 +138,8 @@ function `string-to-number'." (memq system-type '(ms-dos windows-nt))) (defmacro eshell-condition-case (tag form &rest handlers) - "Like `condition-case', but only if `eshell-pass-through-errors' is nil." + "If `eshell-handle-errors' is non-nil, this is `condition-case'. +Otherwise, evaluates FORM with no error handling." (if eshell-handle-errors `(condition-case ,tag ,form diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 97862afb678..fffe09a84a5 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -567,18 +567,12 @@ You can change the color sort order by customizing `list-colors-sort'." (with-help-window buffer-name (with-current-buffer standard-output (erase-buffer) + (list-colors-print list callback) + (set-buffer-modified-p nil) (setq truncate-lines t))) - (let ((buf (get-buffer buffer-name)) - (inhibit-read-only t)) - ;; Display buffer before generating content, to allow - ;; `list-colors-print' to get the right window-width. - (with-selected-window (or (get-buffer-window buf t) (selected-window)) - (with-current-buffer buf - (list-colors-print list callback) - (set-buffer-modified-p nil))) - (when callback - (pop-to-buffer buf) - (message "Click on a color to select it.")))) + (when callback + (pop-to-buffer buffer-name) + (message "Click on a color to select it."))) (defun list-colors-print (list &optional callback) (let ((callback-fn @@ -595,30 +589,19 @@ You can change the color sort order by customizing `list-colors-sort'." (let* ((opoint (point)) (color-values (color-values (car color))) (light-p (>= (apply 'max color-values) - (* (car (color-values "white")) .5))) - (max-len (max (- (window-width) 33) 20))) + (* (car (color-values "white")) .5)))) (insert (car color)) (indent-to 22) (put-text-property opoint (point) 'face `(:background ,(car color))) (put-text-property (prog1 (point) (insert " ") - (if (cdr color) - ;; Insert as many color names as possible, fitting max-len. - (let ((names (list (car color))) - (others (cdr color)) - (len (length (car color))) - newlen) - (while (and others - (< (setq newlen (+ len 2 (length (car others)))) - max-len)) - (setq len newlen) - (push (pop others) names)) - (insert (mapconcat 'identity (nreverse names) ", "))) - (insert (car color)))) + ;; Insert all color names. + (insert (mapconcat 'identity color ","))) (point) 'face (list :foreground (car color))) - (indent-to (max (- (window-width) 8) 44)) + (insert (propertize " " 'display '(space :align-to (- right 9)))) + (insert " ") (insert (propertize (apply 'format "#%02x%02x%02x" (mapcar (lambda (c) (lsh c -8)) diff --git a/lisp/files.el b/lisp/files.el index caf0a9752c5..38047f2fa43 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -3896,11 +3896,17 @@ See also `file-name-version-regexp'." (let ((handler (find-file-name-handler file 'file-ownership-preserved-p))) (if handler (funcall handler 'file-ownership-preserved-p file) - (let ((attributes (file-attributes file))) + (let ((attributes (file-attributes file 'integer))) ;; Return t if the file doesn't exist, since it's true that no ;; information would be lost by an (attempted) delete and create. (or (null attributes) - (= (nth 2 attributes) (user-uid))))))) + (= (nth 2 attributes) (user-uid)) + ;; Files created on Windows by Administrator (RID=500) + ;; have the Administrators group (RID=544) recorded as + ;; their owner. Rewriting them will still preserve the + ;; owner. + (and (eq system-type 'windows-nt) + (= (user-uid) 500) (= (nth 2 attributes) 544))))))) (defun file-name-sans-extension (filename) "Return FILENAME sans final \"extension\". diff --git a/lisp/font-lock.el b/lisp/font-lock.el index b7b617fcffe..988e821d7e2 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -2242,7 +2242,7 @@ in which C preprocessor directives are used. e.g. `asm-mode' and "\\)\\)\\>" ;; Any whitespace and defined object. "[ \t'\(]*" - "\\(setf[ \t]+\\sw+)\\|\\sw+\\)?") + "\\(setf[ \t]+\\sw+\\|\\sw+\\)?") (1 font-lock-keyword-face) (9 (cond ((match-beginning 3) font-lock-function-name-face) ((match-beginning 6) font-lock-variable-name-face) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index c14c79a92cb..7eca03bd93b 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,182 @@ +2011-03-18 Julien Danjou <julien@danjou.info> + + * gnus-util.el (gnus-buffer-live-p): Simplify gnus-buffer-live-p. + (gnus-buffer-live-p): Check that buffer is not nil. + +2011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el: Require mouse, which the build bot seems to say is + needed. + + * gravatar.el (gravatar-retrieve-synchronously): Use `url-retrieve' on + XEmacs, since it doesn't have url-retrieve-synchronously. + +2011-03-17 Antoine Levitt <antoine.levitt@gmail.com> + + * gnus-group.el (gnus-group-list-ticked): New function. + (gnus-group-make-menu-bar): Provide a menu entry for it. + (gnus-group-list-map): Provide a binding for it. + +2011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-visit-file): New command. + + * nnimap.el (nnimap-fetch-inbox): Rewrite slightly last patch. + +2011-03-17 Bjørn Mork <bjorn@mork.no> + + * nnimap.el (nnimap-fetch-inbox): Don't download bodies on ver4-capable + servers. + +2011-03-16 Julien Danjou <julien@danjou.info> + + * mm-uu.el (mm-uu-dissect-text-parts): Only dissect handle that are + inline. + + * gnus-art.el (article-hide-list-identifiers): Use + gnus-group-get-list-identifiers. + + * gnus-sum.el (gnus-group-get-list-identifiers): New function. + (gnus-summary-remove-list-identifiers): Use + gnus-group-get-list-identifiers to get regexp. + (gnus-select-newsgroup, gnus-summary-insert-subject) + (gnus-summary-insert-articles): Call + gnus-summary-remove-list-identifiers unconditionally. + +2011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-articles-to-read): Revert back to old behaviour if + we're selecting a group with unread articles. + + * nnimap.el (nnimap-open-connection-1): Allow `network-only', too. + + * gssapi.el: New file separated out from imap.el to provide a general + Kerberos 5 connection facility for Emacs. + + * message.el (message-elide-ellipsis): Document the format spec + ellipsis. + +2011-03-15 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-elide-region): Allow the ellipsis to say how many + lines were removed. + +2011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-win.el (gnus-configure-frame): Protect against trying to restore + window configurations containing buffers that are now dead. + + * nnimap.el (nnimap-parse-flags): Remove all MODSEQ entries before + parsing to avoid integer overflows. + (nnimap-parse-flags): Simplify the last change. + (nnimap-parse-flags): Store HIGHESTMODSEQ as a string, since it may be + too large for 32-bit Emacsen. + +2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * auth-source.el (auth-source-netrc-create): + * message.el (message-yank-original): Fix use of `case'. + +2011-03-15 Nelson Ferreira <nelson.ferreira@ieee.org> (tiny change) + + * gnus-art.el (gnus-article-treat-body-boundary): Fix boundary width on + XEmacs, which was one character too wide. + +2011-03-09 Antoine Levitt <antoine.levitt@gmail.com> + + * gnus-sum.el (gnus-articles-to-read): Use gnus-large-newsgroup as + default number of articles to display. + (gnus-articles-to-read): Use pretty names for prompt. + +2011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-int.el (gnus-open-server): Ditto. + + * gnus-start.el (gnus-activate-group): Give a backtrace if + debug-on-quit is set and the user hits `C-g'. + (gnus-read-active-file): Ditto. + + * gnus-group.el (gnus-group-read-ephemeral-group): Ditto. + +2011-03-15 Teodor Zlatanov <tzz@lifelogs.com> + + * message.el (message-yank-original): Use cond instead of CL case. + +2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * auth-source.el (auth-source-netrc-create): Use usual format for the + default in prompts. + +2011-03-13 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-netrc-create): Show the default in the + prompt when prompting for token creation. + +2011-03-12 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-format-prompt): Always convert the value + to a string to avoid evaluating non-string arguments. + (auth-source-netrc-create): Offer default properly, not as initial + content in `read-string'. + (auth-source-netrc-saver): Use a cache keyed by file name and MD5 hash + of line to determine if we've been run before. If so, don't run again, + but print a trivial message to indicate the cache was hit instead. + +2011-03-11 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el (gnus-sync-install-hooks, gnus-sync-unload-hook): + Don't install `gnus-sync-read' to any hooks by default. It's buggy. + The user will have to run `gnus-sync-read' manually and wait for Cloudy + Gnus. + +2011-03-11 Julien Danjou <julien@danjou.info> + + * mm-uu.el (mm-uu-type-alist): Add support for diff starting with "=== + modified file". + +2011-03-09 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-read-char-choice): New function to read a + character choice using `dropdown-list', `read-char-choice', or + `read-char'. It appends "[a/b/c] " to the prompt if the choices were + '(?a ?b ?c). The `dropdown-list' support is disabled for now. Use + `eval-when-compile' to load `dropdown-list'. Remove `dropdown-list'. + (auth-source-netrc-saver): Use it. + (auth-source-pick-first-password): New convenience function. + +2011-03-08 Teodor Zlatanov <tzz@lifelogs.com> + + * nnimap.el (nnimap-credentials): Keep the :save-function as the third + parameter in the credentials. + (nnimap-open-connection-1): Use it after a successful login. + (nnimap-credentials): Add IMAP-specific user and password prompt. + + * auth-source.el (auth-source-search): Add :require parameter, taking a + list. Document it and the :save-function return token. Pass :require + down. Change the CREATED message from a warning to a debug statement. + (auth-source-search-backends): Pass :require down. + (auth-source-netrc-search): Pass :require down. + (auth-source-netrc-parse): Use :require, if it's given, as a filter. + Change save prompt to indicate all modifications saved here are + deletions. + (auth-source-netrc-create): Take user login name as default in user + prompt. Move all the save functionality to a lexically bound function + under the :save-function token in the returned list. Set up clearer + default prompts for user, host, port, and secret. + (auth-source-netrc-saver): New function, intended to be wrapped for + :save-function. + +2011-03-07 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-table-horizontal-line): Change the defaults for the table + lines to be spaces instead. + +2011-03-07 Julien Danjou <julien@danjou.info> + + * sieve-manage.el (sieve-sasl-auth): Create auth-info if not found. + (sieve-sasl-auth): Check that auth-source-search did return something, + or just return an empty string. + 2011-03-05 Antoine Levitt <antoine.levitt@gmail.com> * gnus.el (gnus-interactive): Use read-directory-name. @@ -12,6 +191,13 @@ 2011-03-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + * gnus-start.el (gnus-group-change-level): Allow putting foreign groups + onto the list of killed groups, too. This makes killed nnimap groups, + for instance, more reliably not reappear. + + * nnimap.el (nnimap-request-thread): Don't bug out when we can't find + the parent. + * gnus-sum.el (gnus-update-read-articles): Fix typo. * gnus.el (gnus-valid-select-methods): Mark nnimap as a backend that @@ -24,8 +210,8 @@ 2011-03-05 Antoine Levitt <antoine.levitt@gmail.com> - * message.el (message-cite-reply-position, message-cite-style): New - variables. + * message.el (message-cite-reply-position, message-cite-style): + New variables. (message-yank-original): Use the new citation styles. 2011-03-04 Daiki Ueno <ueno@unixuser.org> @@ -139,14 +325,14 @@ 2011-02-23 Lars Ingebrigtsen <larsi@gnus.org> - * gnus-start.el (gnus-dribble-read-file): Set - buffer-save-without-query, since we always want to save the dribble + * gnus-start.el (gnus-dribble-read-file): + Set buffer-save-without-query, since we always want to save the dribble file, probably. * nnmail.el (nnmail-article-group): Allow a final "" split to work on nnimap. - * gnus-sum.el (gnus-user-date-format-alist): Renamed back again from + * gnus-sum.el (gnus-user-date-format-alist): Rename back again from -summary- since it's a user-visible variable. * nnimap.el (nnimap-retrieve-group-data-early): Don't do QRESYNC the @@ -392,8 +578,8 @@ 2011-02-14 Teodor Zlatanov <tzz@lifelogs.com> * auth-source.el (auth-source-backend-parse-parameters): Don't rely on - `plist-get' to accept non-list parameters (XEmacs issue). Fix - docstring. + `plist-get' to accept non-list parameters (XEmacs issue). + Fix docstring. (auth-source-secrets-search): Use `delete-dups', `append mapcar', and `butlast' instead of `remove-duplicates', `mapcan', and `subseq'. (auth-sources, auth-source-backend-parse, auth-source-secrets-search): @@ -433,8 +619,8 @@ 2011-02-13 Tassilo Horn <tassilo@member.fsf.org> (tiny change) - * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk): Fix - Gcc processing on imap. + * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk): + Fix Gcc processing on imap. 2011-02-10 Stefan Monnier <monnier@iro.umontreal.ca> @@ -522,8 +708,8 @@ 2011-02-06 Michael Albinus <michael.albinus@gmx.de> - * auth-source.el (top): Require 'eieio unconditionally. Autoload - `secrets-get-attributes' instead of `secrets-get-attribute'. + * auth-source.el (top): Require 'eieio unconditionally. + Autoload `secrets-get-attributes' instead of `secrets-get-attribute'. (auth-source-secrets-search): Limit search when `max' is greater than number of results. @@ -559,7 +745,7 @@ (auth-source-protocol-defaults, auth-source-user-or-password-imap) (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh) (auth-source-user-or-password-sftp) - (auth-source-user-or-password-smtp): Removed. + (auth-source-user-or-password-smtp): Remove. (auth-source-user-or-password): Deprecated and modified to be a wrapper around `auth-source-search'. Not tested thoroughly. @@ -725,16 +911,16 @@ * gnus-group.el (gnus-group-jump-to-group): Allow jumping to groups that Gnus doesn't know exists again. - * gnus-art.el (gnus-article-date-lapsed-new-header): Removed. + * gnus-art.el (gnus-article-date-lapsed-new-header): Remove. (gnus-treat-date-ut): Ditto. - (gnus-article-update-date-header): Renamed. - (gnus-treat-date-local): Removed. - (gnus-treat-date-english): Removed. - (gnus-treat-date-lapsed): Removed. - (gnus-treat-date-combined-lapsed): Removed. - (gnus-treat-date-original): Removed. - (gnus-treat-date-iso8601): Removed. - (gnus-treat-date-user-defined): Removed. + (gnus-article-update-date-header): Rename. + (gnus-treat-date-local): Remove. + (gnus-treat-date-english): Remove. + (gnus-treat-date-lapsed): Remove. + (gnus-treat-date-combined-lapsed): Remove. + (gnus-treat-date-original): Remove. + (gnus-treat-date-iso8601): Remove. + (gnus-treat-date-user-defined): Remove. (gnus-article-date-headers): New variable to control all the date header options. (article-date-ut): Rewrite to allow using the new way to format date diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index 500de10b71c..e0bea324a25 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -54,6 +54,8 @@ (autoload 'secrets-list-collections "secrets") (autoload 'secrets-search-items "secrets") +(autoload 'rfc2104-hash "rfc2104") + (defvar secrets-enabled) (defgroup auth-source nil @@ -286,6 +288,28 @@ If the value is not a list, symmetric encryption will be used." msg)) +;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q)) +(defun auth-source-read-char-choice (prompt choices) + "Read one of CHOICES by `read-char-choice', or `read-char'. +`dropdown-list' support is disabled because it doesn't work reliably. +Only one of CHOICES will be returned. The PROMPT is augmented +with \"[a/b/c] \" if CHOICES is '\(?a ?b ?c\)." + (when choices + (let* ((prompt-choices + (apply 'concat (loop for c in choices + collect (format "%c/" c)))) + (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] ")) + (full-prompt (concat prompt prompt-choices)) + k) + + (while (not (memq k choices)) + (setq k (cond + ((fboundp 'read-char-choice) + (read-char-choice full-prompt choices)) + (t (message "%s" full-prompt) + (setq k (read-char)))))) + k))) + ;; (auth-source-pick nil :host "any" :port 'imap :user "joe") ;; (auth-source-pick t :host "any" :port 'imap :user "joe") ;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") @@ -393,7 +417,7 @@ parameters." (defun* auth-source-search (&rest spec &key type max host user port secret - create delete + require create delete &allow-other-keys) "Search or modify authentication backends according to SPEC. @@ -487,6 +511,11 @@ should `catch' the backend-specific error as usual. Some backends (netrc, at least) will prompt the user rather than throw an error. +:require (A B C) means that only results that contain those +tokens will be returned. Thus for instance requiring :secret +will ensure that any results will actually have a :secret +property. + :delete t means to delete any found entries. nil by default. Use `auth-source-delete' in ELisp code instead of calling `auth-source-search' directly with this parameter. @@ -516,11 +545,17 @@ is a plist with keys :backend :host :port :user, plus any other keys provided by the backend (notably :secret). But note the exception for :max 0, which see above. +The token can hold a :save-function key. If you call that, the +user will be prompted to save the data to the backend. You can't +request that this should happen right after creation, because +`auth-source-search' has no way of knowing if the token is +actually useful. So the caller must arrange to call this function. + The token's :secret key can hold a function. In that case you must call it to obtain the actual value." (let* ((backends (mapcar 'auth-source-backend-parse auth-sources)) (max (or max 1)) - (ignored-keys '(:create :delete :max)) + (ignored-keys '(:require :create :delete :max)) (keys (loop for i below (length spec) by 2 unless (memq (nth i spec) ignored-keys) collect (nth i spec))) @@ -539,6 +574,10 @@ must call it to obtain the actual value." (or (eq t create) (listp create)) t "Invalid auth-source :create parameter (must be t or a list): %s %s") + (assert + (listp require) t + "Invalid auth-source :require parameter (must be a list): %s") + (setq filtered-backends (copy-sequence backends)) (dolist (backend backends) (dolist (key keys) @@ -562,8 +601,9 @@ must call it to obtain the actual value." spec ;; to exit early max - ;; create and delete - nil delete)) + ;; create is always nil here + nil delete + require)) (auth-source-do-debug "auth-source-search: found %d results (max %d) matching %S" @@ -577,9 +617,9 @@ must call it to obtain the actual value." spec ;; to exit early max - ;; create and delete - create delete)) - (auth-source-do-warn + create delete + require)) + (auth-source-do-debug "auth-source-search: CREATED %d results (max %d) matching %S" (length found) max spec)) @@ -589,18 +629,19 @@ must call it to obtain the actual value." found)) -(defun auth-source-search-backends (backends spec max create delete) +(defun auth-source-search-backends (backends spec max create delete require) (let (matches) (dolist (backend backends) (when (> max (length matches)) ; when we need more matches... - (let ((bmatches (apply - (slot-value backend 'search-function) - :backend backend - ;; note we're overriding whatever the spec - ;; has for :create and :delete - :create create - :delete delete - spec))) + (let* ((bmatches (apply + (slot-value backend 'search-function) + :backend backend + ;; note we're overriding whatever the spec + ;; has for :require, :create, and :delete + :require require + :create create + :delete delete + spec))) (when bmatches (auth-source-do-trivia "auth-source-search-backend: got %d (max %d) in %s:%s matching %S" @@ -713,7 +754,28 @@ while \(:host t) would find all host entries." (return 'no))) 'no)))) -;;; Backend specific parsing: netrc/authinfo backend +;;; (auth-source-pick-first-password :host "z.lifelogs.com") +;;; (auth-source-pick-first-password :port "imap") +(defun auth-source-pick-first-password (&rest spec) + "Pick the first secret found from applying SPEC to `auth-source-search'." + (let* ((result (nth 0 (apply 'auth-source-search (plist-put spec :max 1)))) + (secret (plist-get result :secret))) + + (if (functionp secret) + (funcall secret) + secret))) + +;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host"))) +(defun auth-source-format-prompt (prompt alist) + "Format PROMPT using %x (for any character x) specifiers in ALIST." + (dolist (cell alist) + (let ((c (nth 0 cell)) + (v (nth 1 cell))) + (when (and c v) + (setq prompt (replace-regexp-in-string (format "%%%c" c) + (format "%s" v) + prompt))))) + prompt) (defun auth-source-ensure-strings (values) (unless (listp values) @@ -724,12 +786,14 @@ while \(:host t) would find all host entries." value)) values)) +;;; Backend specific parsing: netrc/authinfo backend + (defvar auth-source-netrc-cache nil) ;;; (auth-source-netrc-parse "~/.authinfo.gpg") (defun* auth-source-netrc-parse (&rest spec - &key file max host user port delete + &key file max host user port delete require &allow-other-keys) "Parse FILE and return a list of all entries in the file. Note that the MAX parameter is used so we can exit the parse early." @@ -828,7 +892,15 @@ Note that the MAX parameter is used so we can exit the parse early." (or (aget alist "port") (aget alist "protocol") - t))) + t)) + (or + ;; the required list of keys is nil, or + (null require) + ;; every element of require is in the normalized list + (let ((normalized (nth 0 (auth-source-netrc-normalize + (list alist))))) + (loop for req in require + always (plist-get normalized req))))) (decf max) (push (nreverse alist) result) ;; to delete a line, we just comment it out @@ -853,7 +925,7 @@ Note that the MAX parameter is used so we can exit the parse early." (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) ;; ask AFTER we've successfully opened the file - (when (y-or-n-p (format "Save file %s? (%d modifications)" + (when (y-or-n-p (format "Save file %s? (%d deletions)" file modified)) (write-region (point-min) (point-max) file nil 'silent) (auth-source-do-debug @@ -893,7 +965,7 @@ Note that the MAX parameter is used so we can exit the parse early." (defun* auth-source-netrc-search (&rest spec - &key backend create delete + &key backend require create delete type max host user port &allow-other-keys) "Given a property list SPEC, return search matches from the :backend. @@ -905,6 +977,7 @@ See `auth-source-search' for details on SPEC." (let ((results (auth-source-netrc-normalize (auth-source-netrc-parse :max max + :require require :delete delete :file (oref backend source) :host (or host t) @@ -933,17 +1006,6 @@ See `auth-source-search' for details on SPEC." (nth 0 v) v)) -;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host"))) - -(defun auth-source-format-prompt (prompt alist) - "Format PROMPT using %x (for any character x) specifiers in ALIST." - (dolist (cell alist) - (let ((c (nth 0 cell)) - (v (nth 1 cell))) - (when (and c v) - (setq prompt (replace-regexp-in-string (format "%%%c" c) v prompt))))) - prompt) - ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B))) @@ -992,12 +1054,12 @@ See `auth-source-search' for details on SPEC." (data (auth-source-netrc-element-or-first data)) ;; this is the default to be offered (given-default (aget auth-source-creation-defaults r)) - ;; the default supplementals are simple: for the user, - ;; try (user-login-name), otherwise take given-default + ;; the default supplementals are simple: + ;; for the user, try `given-default' and then (user-login-name); + ;; otherwise take `given-default' (default (cond - ;; don't default the user name - ;; ((and (not given-default) (eq r 'user)) - ;; (user-login-name)) + ((and (not given-default) (eq r 'user)) + (user-login-name)) (t given-default))) (printable-defaults (list (cons 'user @@ -1020,10 +1082,10 @@ See `auth-source-search' for details on SPEC." "[any port]")))) (prompt (or (aget auth-source-creation-prompts r) (case r - ('secret "%p password for user %u, host %h: ") - ('user "%p user name: ") - ('host "%p host name for user %u: ") - ('port "%p port for user %u and host %h: ")) + (secret "%p password for %u@%h: ") + (user "%p user name for %h: ") + (host "%p host name for user %u: ") + (port "%p port for %u@%h: ")) (format "Enter %s (%%u@%%h:%%p): " r))) (prompt (auth-source-format-prompt prompt @@ -1031,14 +1093,20 @@ See `auth-source-search' for details on SPEC." (?h ,(aget printable-defaults 'host)) (?p ,(aget printable-defaults 'port)))))) - ;; store the data, prompting for the password if needed + ;; Store the data, prompting for the password if needed. (setq data (cond ((and (null data) (eq r 'secret)) - ;; special case prompt for passwords + ;; Special case prompt for passwords. (read-passwd prompt)) ((null data) - (read-string prompt default)) + (when default + (setq prompt + (if (string-match ": *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " (default " default "): ") + (concat prompt "(default " default ") ")))) + (read-string prompt nil nil default)) (t (or data default)))) (when data @@ -1049,7 +1117,7 @@ See `auth-source-search' for details on SPEC." (lambda () data)) data)))) - ;; when r is not an empty string... + ;; When r is not an empty string... (when (and (stringp data) (< 0 (length data))) ;; this function is not strictly necessary but I think it @@ -1062,79 +1130,99 @@ See `auth-source-search' for details on SPEC." (if (zerop (length add)) "" " ") ;; remap auth-source tokens to netrc (case r - ('user "login") - ('host "machine") - ('secret "password") - ('port "port") ; redundant but clearer + (user "login") + (host "machine") + (secret "password") + (port "port") ; redundant but clearer (t (symbol-name r))) ;; the value will be printed in %S format data)))) (setq add (concat add (funcall printer))))))) - (with-temp-buffer - (when (file-exists-p file) - (insert-file-contents file)) - (when auth-source-gpg-encrypt-to - ;; (see bug#7487) making `epa-file-encrypt-to' local to - ;; this buffer lets epa-file skip the key selection query - ;; (see the `local-variable-p' check in - ;; `epa-file-write-region'). - (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) - (make-local-variable 'epa-file-encrypt-to)) - (if (listp auth-source-gpg-encrypt-to) - (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) - (goto-char (point-max)) - - ;; ask AFTER we've successfully opened the file - (let ((prompt (format "Save auth info to file %s? %s: " - file - "y/n/N/e/?")) - (done (not (eq auth-source-save-behavior 'ask))) - (bufname "*auth-source Help*") - k) - (while (not done) - (message "%s" prompt) - (setq k (read-char)) - (case k - (?y (setq done t)) - (?? (save-excursion - (with-output-to-temp-buffer bufname - (princ - (concat "(y)es, save\n" - "(n)o but use the info\n" - "(N)o and don't ask to save again\n" - "(e)dit the line\n" - "(?) for help as you can see.\n")) - (set-buffer standard-output) - (help-mode)))) - (?n (setq add "" - done t)) - (?N (setq add "" - done t - auth-source-save-behavior nil)) - (?e (setq add (read-string "Line to add: " add))) - (t nil))) - - (when (get-buffer-window bufname) - (delete-window (get-buffer-window bufname))) - - ;; make sure the info is not saved - (when (null auth-source-save-behavior) - (setq add "")) - - (when (< 0 (length add)) - (progn - (unless (bolp) - (insert "\n")) - (insert add "\n") - (write-region (point-min) (point-max) file nil 'silent) - (auth-source-do-warn - "auth-source-netrc-create: wrote 1 new line to %s" - file) - nil)) - - (when (eq done t) - (list artificial)))))) + (plist-put + artificial + :save-function + (lexical-let ((file file) + (add add)) + (lambda () (auth-source-netrc-saver file add)))) + + (list artificial))) + +;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function)) +(defun auth-source-netrc-saver (file add) + "Save a line ADD in FILE, prompting along the way. +Respects `auth-source-save-behavior'. Uses +`auth-source-netrc-cache' to avoid prompting more than once." + (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add))) + (cached (assoc key auth-source-netrc-cache))) + + (if cached + (auth-source-do-trivia + "auth-source-netrc-saver: found previous run for key %s, returning" + key) + (with-temp-buffer + (when (file-exists-p file) + (insert-file-contents file)) + (when auth-source-gpg-encrypt-to + ;; (see bug#7487) making `epa-file-encrypt-to' local to + ;; this buffer lets epa-file skip the key selection query + ;; (see the `local-variable-p' check in + ;; `epa-file-write-region'). + (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) + (make-local-variable 'epa-file-encrypt-to)) + (if (listp auth-source-gpg-encrypt-to) + (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) + ;; we want the new data to be found first, so insert at beginning + (goto-char (point-min)) + + ;; Ask AFTER we've successfully opened the file. + (let ((prompt (format "Save auth info to file %s? " file)) + (done (not (eq auth-source-save-behavior 'ask))) + (bufname "*auth-source Help*") + k) + (while (not done) + (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??))) + (case k + (?y (setq done t)) + (?? (save-excursion + (with-output-to-temp-buffer bufname + (princ + (concat "(y)es, save\n" + "(n)o but use the info\n" + "(N)o and don't ask to save again\n" + "(e)dit the line\n" + "(?) for help as you can see.\n")) + ;; Why? Doesn't with-output-to-temp-buffer already do + ;; the exact same thing anyway? --Stef + (set-buffer standard-output) + (help-mode)))) + (?n (setq add "" + done t)) + (?N (setq add "" + done t + auth-source-save-behavior nil)) + (?e (setq add (read-string "Line to add: " add))) + (t nil))) + + (when (get-buffer-window bufname) + (delete-window (get-buffer-window bufname))) + + ;; Make sure the info is not saved. + (when (null auth-source-save-behavior) + (setq add "")) + + (when (< 0 (length add)) + (progn + (unless (bolp) + (insert "\n")) + (insert add "\n") + (write-region (point-min) (point-max) file nil 'silent) + (auth-source-do-debug + "auth-source-netrc-create: wrote 1 new line to %s" + file) + (message "Saved new authentication information to %s" file) + nil)))) + (aput 'auth-source-netrc-cache key "ran")))) ;;; Backend specific parsing: Secrets API backend diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index c64138b43d7..7c7e0531926 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -44,6 +44,7 @@ (require 'wid-edit) (require 'mm-uu) (require 'message) +(require 'mouse) (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") @@ -2337,10 +2338,12 @@ long lines if and only if arg is positive." (let ((start (point))) (insert "X-Boundary: ") (gnus-add-text-properties start (point) '(invisible t intangible t)) - (insert (let (str) - (while (>= (window-width) (length str)) + (insert (let (str (max (window-width))) + (if (featurep 'xemacs) + (setq max (1- max))) + (while (>= max (length str)) (setq str (concat str gnus-body-boundary-delimiter))) - (substring str 0 (window-width))) + (substring str 0 max)) "\n") (gnus-put-text-property start (point) 'gnus-decoration 'header))))) @@ -3074,10 +3077,7 @@ images if any to the browser, and deletes them when exiting the group The `gnus-list-identifiers' variable specifies what to do." (interactive) (let ((inhibit-point-motion-hooks t) - (regexp (or (gnus-parameter-list-identifier gnus-newsgroup-name) - (if (consp gnus-list-identifiers) - (mapconcat 'identity gnus-list-identifiers " *\\|") - gnus-list-identifiers))) + (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name)) (inhibit-read-only t)) (when regexp (save-excursion diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 9ed3cf02a49..c265538e19c 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -697,7 +697,8 @@ simple manner.") "M" gnus-group-list-all-matching "l" gnus-group-list-level "c" gnus-group-list-cached - "?" gnus-group-list-dormant) + "?" gnus-group-list-dormant + "!" gnus-group-list-ticked) (gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map) "k" gnus-group-list-limit @@ -849,7 +850,8 @@ simple manner.") ["List all groups matching..." gnus-group-list-all-matching t] ["List active file" gnus-group-list-active t] ["List groups with cached" gnus-group-list-cached t] - ["List groups with dormant" gnus-group-list-dormant t]) + ["List groups with dormant" gnus-group-list-dormant t] + ["List groups with ticked" gnus-group-list-ticked t]) ("Sort" ["Default sort" gnus-group-sort-groups t] ["Sort by method" gnus-group-sort-groups-by-method t] @@ -2313,9 +2315,10 @@ Return the name of the group if selection was successful." gnus-fetch-old-ephemeral-headers)) (gnus-group-read-group (or number t) t group select-articles)) group) - ;;(error nil) (quit - (message "Quit reading the ephemeral group") + (if debug-on-quit + (debug "Quit") + (message "Quit reading the ephemeral group")) nil))))) (defcustom gnus-gmane-group-download-format @@ -4535,6 +4538,28 @@ This command may read the active file." (goto-char (point-min)) (gnus-group-position-point)) +(defun gnus-group-list-ticked (level &optional lowest) + "List all groups with ticked articles. +If the prefix LEVEL is non-nil, it should be a number that says which +level to cut off listing groups. +If LOWEST, don't list groups with level lower than LOWEST. + +This command may read the active file." + (interactive "P") + (when level + (setq level (prefix-numeric-value level))) + (when (or (not level) (>= level gnus-level-zombie)) + (gnus-cache-open)) + (funcall gnus-group-prepare-function + (or level gnus-level-subscribed) + #'(lambda (info) + (let ((marks (gnus-info-marks info))) + (assq 'tick marks))) + lowest + 'ignore) + (goto-char (point-min)) + (gnus-group-position-point)) + (defun gnus-group-listed-groups () "Return a list of listed groups." (let (point groups) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index a67063bb970..ef15a479892 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -270,7 +270,9 @@ If it is down, start it up (again)." server (error-message-string err)) nil) (quit - (gnus-message 1 "Quit trying to open server %s" server) + (if debug-on-quit + (debug "Quit") + (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. diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index ebfa53f841e..afded87fe37 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1306,16 +1306,13 @@ for new groups, and subscribe the new groups as zombies." ((>= level gnus-level-zombie) ;; Remove from the hash table. (gnus-sethash group nil gnus-newsrc-hashtb) - ;; We do not enter foreign groups into the list of dead - ;; groups. - (unless (gnus-group-foreign-p group) - (if (= level gnus-level-zombie) - (push group gnus-zombie-list) - (if (= oldlevel gnus-level-killed) - ;; Remove from active hashtb. - (unintern group gnus-active-hashtb) - ;; Don't add it into killed-list if it was killed. - (push group gnus-killed-list))))) + (if (= level gnus-level-zombie) + (push group gnus-zombie-list) + (if (= oldlevel gnus-level-killed) + ;; Remove from active hashtb. + (unintern group gnus-active-hashtb) + ;; Don't add it into killed-list if it was killed. + (push group gnus-killed-list)))) (t ;; If the list is to be entered into the newsrc assoc, and ;; it was killed, we have to create an entry in the newsrc @@ -1465,9 +1462,10 @@ If SCAN, request a scan of that group as well." (inline (gnus-request-group group (or dont-sub-check dont-check) method (gnus-get-info group))) - ;;(error nil) (quit - (message "Quit activating %s" group) + (if debug-on-quit + (debug "Quit") + (message "Quit activating %s" group)) nil))) (unless dont-check (setq active (gnus-parse-active)) @@ -2007,7 +2005,9 @@ If SCAN, request a scan of that group as well." ;; We catch C-g so that we can continue past servers ;; that do not respond. (quit - (message "Quit reading the active file") + (if debug-on-quit + (debug "Quit") + (message "Quit reading the active file")) nil)))))))) (defun gnus-read-active-file-1 (method force) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a8786e39c7b..29a98b7d11d 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -5510,12 +5510,17 @@ or a straight list of headers." (cdr (assq number gnus-newsgroup-scored)) (memq number gnus-newsgroup-processable)))))) +(defun gnus-group-get-list-identifiers (group) + "Get list identifier regexp for GROUP." + (or (gnus-parameter-list-identifier group) + (if (consp gnus-list-identifiers) + (mapconcat 'identity gnus-list-identifiers " *\\|") + gnus-list-identifiers))) + (defun gnus-summary-remove-list-identifiers () "Remove list identifiers in `gnus-list-identifiers' from articles in the current group." - (let ((regexp (if (consp gnus-list-identifiers) - (mapconcat 'identity gnus-list-identifiers " *\\|") - gnus-list-identifiers)) - changed subject) + (let ((regexp (gnus-group-get-list-identifiers gnus-newsgroup-name)) + changed subject) (when regexp (setq regexp (concat "^\\(?:R[Ee]: +\\)*\\(" regexp " *\\)")) (dolist (header gnus-newsgroup-headers) @@ -5707,8 +5712,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (when gnus-agent (gnus-agent-get-undownloaded-list)) ;; Remove list identifiers from subject - (when gnus-list-identifiers - (gnus-summary-remove-list-identifiers)) + (gnus-summary-remove-list-identifiers) ;; Check whether auto-expire is to be done in this group. (setq gnus-newsgroup-auto-expire (gnus-group-auto-expirable-p group)) @@ -5798,7 +5802,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (defun gnus-articles-to-read (group &optional read-all) "Find out what articles the user wants to read." - (let* ((articles + (let* ((only-read-p t) + (articles ;; Select all articles if `read-all' is non-nil, or if there ;; are no unread articles. (if (or read-all @@ -5822,6 +5827,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-uncompress-range (gnus-active group))) (gnus-cache-articles-in-group group)) ;; Select only the "normal" subset of articles. + (setq only-read-p nil) (gnus-sorted-nunion (gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked) gnus-newsgroup-unreads))) @@ -5845,16 +5851,25 @@ If SELECT-ARTICLES, only select those articles from GROUP." (let* ((cursor-in-echo-area nil) (initial (gnus-parameter-large-newsgroup-initial gnus-newsgroup-name)) + (default (if only-read-p + (or initial gnus-large-newsgroup) + number)) (input (read-string - (format - "How many articles from %s (%s %d): " - (gnus-group-decoded-name gnus-newsgroup-name) - (if initial "max" "default") - number) - (if initial - (cons (number-to-string initial) - 0))))) + (if only-read-p + (format + "How many articles from %s (available %d, default %d): " + (gnus-group-decoded-name + (gnus-group-real-name gnus-newsgroup-name)) + number default) + (format + "How many articles from %s (%d available): " + (gnus-group-decoded-name + (gnus-group-real-name gnus-newsgroup-name)) + default)) + nil + nil + (number-to-string default)))) (if (string-match "^[ \t]*$" input) number input))) ((and (> scored marked) (< scored number) (> (- scored number) 20)) @@ -5862,7 +5877,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (read-string (format "%s %s (%d scored, %d total): " "How many articles from" - (gnus-group-decoded-name group) + (gnus-group-decoded-name + (gnus-group-real-name gnus-newsgroup-name)) scored number)))) (if (string-match "^[ \t]*$" input) number input))) @@ -6564,9 +6580,8 @@ the subject line on." (1+ (point-at-eol)) (gnus-delete-line)))))) ;; Remove list identifiers from subject. - (when gnus-list-identifiers - (let ((gnus-newsgroup-headers (list header))) - (gnus-summary-remove-list-identifiers))) + (let ((gnus-newsgroup-headers (list header))) + (gnus-summary-remove-list-identifiers)) (when old-header (mail-header-set-number header (mail-header-number old-header))) (setq gnus-newsgroup-sparse @@ -12670,8 +12685,7 @@ returned." (when gnus-agent (gnus-agent-get-undownloaded-list)) ;; Remove list identifiers from subject - (when gnus-list-identifiers - (gnus-summary-remove-list-identifiers)) + (gnus-summary-remove-list-identifiers) ;; First and last article in this newsgroup. (when gnus-newsgroup-headers (setq gnus-newsgroup-begin diff --git a/lisp/gnus/gnus-sync.el b/lisp/gnus/gnus-sync.el index 892b10a0d0e..fbdacdd2fbe 100644 --- a/lisp/gnus/gnus-sync.el +++ b/lisp/gnus/gnus-sync.el @@ -25,7 +25,8 @@ ;; This is the gnus-sync.el package. ;; It's due for a rewrite using gnus-after-set-mark-hook and -;; gnus-before-update-mark-hook. Until then please consider it +;; gnus-before-update-mark-hook, and my plan is to do this once No +;; Gnus development is done. Until then please consider it ;; experimental. ;; Put this in your startup file (~/.gnus.el for instance) @@ -42,7 +43,8 @@ ;; TODO: -;; - after gnus-sync-read, the message counts are wrong +;; - after gnus-sync-read, the message counts are wrong. So it's not +;; run automatically, you have to call it with M-x gnus-sync-read ;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to ;; catch the mark updates @@ -220,13 +222,13 @@ synchronized, I believe). Also see `gnus-variable-list'." "Install the sync hooks." (interactive) ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read) - (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) + ;; (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read) + (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save)) (defun gnus-sync-unload-hook () "Uninstall the sync hooks." (interactive) - ;; (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read) + (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read) (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save) (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 42dbd5948cf..3f66b45aaab 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -672,11 +672,9 @@ If N, return the Nth ancestor instead." (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) (match-string 1 references)))))) -(defun gnus-buffer-live-p (buffer) +(defsubst gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." - (and buffer - (get-buffer buffer) - (buffer-name (get-buffer buffer)))) + (and buffer (buffer-live-p (get-buffer buffer)))) (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 156f9a020fd..c38f57d96cb 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -268,8 +268,10 @@ See the Gnus manual for an explanation of the syntax used.") (error "Invalid buffer type: %s" type)) (let ((buf (gnus-get-buffer-create (gnus-window-to-buffer-helper buffer)))) - (if (eq buf (window-buffer (selected-window))) (set-buffer buf) - (switch-to-buffer buf))) + (when (buffer-name buf) + (if (eq buf (window-buffer (selected-window))) + (set-buffer buf) + (switch-to-buffer buf)))) (when (memq 'frame-focus split) (setq gnus-window-frame-focus window)) ;; We return the window if it has the `point' spec. diff --git a/lisp/gnus/gravatar.el b/lisp/gnus/gravatar.el index 0c97080d847..4b0c9a16283 100644 --- a/lisp/gnus/gravatar.el +++ b/lisp/gnus/gravatar.el @@ -129,8 +129,10 @@ You can provide a list of argument to pass to CB in CBARGS." "Retrieve MAIL-ADDRESS gravatar and returns it." (let ((url (gravatar-build-url mail-address))) (if (gravatar-cache-expired url) - (with-current-buffer (url-retrieve-synchronously url) - (when gravatar-automatic-caching + (with-current-buffer (if (featurep 'xemacs) + (url-retrieve url) + (url-retrieve-synchronously url)) + (when gravatar-automatic-caching (url-store-in-cache (current-buffer))) (let ((data (gravatar-data->image))) (kill-buffer (current-buffer)) diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el new file mode 100644 index 00000000000..3765fb84ee8 --- /dev/null +++ b/lisp/gnus/gssapi.el @@ -0,0 +1,105 @@ +;;; gssapi.el --- GSSAPI/Kerberos 5 interface for Emacs + +;; Copyright (C) 2011 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: network + +;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'format-spec) + +(defcustom gssapi-program (list + (concat "gsasl %s %p " + "--mechanism GSSAPI " + "--authentication-id %l") + "imtest -m gssapi -u %l -p %p %s") + "List of strings containing commands for GSSAPI (krb5) authentication. +%s is replaced with server hostname, %p with port to connect to, and +%l with the value of `imap-default-user'. The program should accept +IMAP commands on stdin and return responses to stdout. Each entry in +the list is tried until a successful connection is made." + :group 'network + :type '(repeat string)) + +(defun open-gssapi-stream (name buffer server port) + (let ((cmds gssapi-program) + cmd done) + (with-current-buffer buffer + (while (and (not done) + (setq cmd (pop cmds))) + (message "Opening GSSAPI connection with `%s'..." cmd) + (erase-buffer) + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (process (start-process + name buffer shell-file-name shell-command-switch + (format-spec + cmd + (format-spec-make + ?s server + ?p (number-to-string port) + ?l imap-default-user)))) + response) + (when process + (while (and (memq (process-status process) '(open run)) + (goto-char (point-min)) + ;; Athena IMTEST can output SSL verify errors + (or (while (looking-at "^verify error:num=") + (forward-line)) + t) + (or (while (looking-at "^TLS connection established") + (forward-line)) + t) + ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + (or (while (looking-at "^C:") + (forward-line)) + t) + ;; cyrus 1.6 imtest print "S: " before server greeting + (or (not (looking-at "S: ")) + (forward-char 3) + t) + ;; GNU SASL may print 'Trying ...' first. + (or (not (looking-at "Trying ")) + (forward-line) + t) + (not (and (looking-at "\\* \\(OK\\|PREAUTH\\|BYE\\) ") + ;; success in imtest 1.6: + (re-search-forward + (concat "^\\(\\(Authenticat.*\\)\\|\\(" + "Client authentication " + "finished.*\\)\\)") + nil t) + (setq response (match-string 1))))) + (accept-process-output process 1) + (sit-for 1)) + (erase-buffer) + (message "GSSAPI IMAP connection: %s" (or response "failed")) + (if (and response (let ((case-fold-search nil)) + (not (string-match "failed" response)))) + (setq done process) + (delete-process process) + nil)))) + done))) + +(provide 'gssapi) + +;;; gssapi.el ends here diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 08c59b00bfc..bb9215aca7c 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -49,6 +49,7 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) +(require 'format-spec) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ @@ -438,7 +439,10 @@ whitespace)." :group 'message-various) (defcustom message-elide-ellipsis "\n[...]\n\n" - "*The string which is inserted for elided text." + "*The string which is inserted for elided text. +This is a format-spec string, and you can use %l to say how many +lines were removed, and %c to say how many characters were +removed." :type 'string :link '(custom-manual "(message)Various Commands") :group 'message-various) @@ -3535,8 +3539,12 @@ Note that this should not be used in newsgroups." An ellipsis (from `message-elide-ellipsis') will be inserted where the text was killed." (interactive "r") - (kill-region b e) - (insert message-elide-ellipsis)) + (let ((lines (count-lines b e)) + (chars (- e b))) + (kill-region b e) + (insert (format-spec message-elide-ellipsis + `((?l . ,lines) + (?c . ,chars)))))) (defvar message-caesar-translation-table nil) @@ -3749,12 +3757,12 @@ prefix, and don't delete any headers." (insert-before-markers ?\n) (goto-char pt)))) (case message-cite-reply-position - ('above + (above (message-goto-body) (insert body-text) (insert (if (bolp) "\n" "\n\n")) (message-goto-body)) - ('below + (below (message-goto-signature))) ;; Add a `message-setup-very-last-hook' here? ;; Add `gnus-article-highlight-citation' here? diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 14b44198303..4f7b5ed26b3 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -158,6 +158,12 @@ This can be either \"inline\" or \"attachment\".") mm-uu-diff-extract nil mm-uu-diff-test) + (diff + "^=== modified file " + nil + mm-uu-diff-extract + nil + mm-uu-diff-test) (git-format-patch "^diff --git " "^-- " @@ -699,6 +705,8 @@ Assume text has been decoded if DECODED is non-nil." ;; Mutt still uses application/pgp even though ;; it has already been withdrawn. (string-match "\\`text/\\|\\`application/pgp\\'" type) + (equal (car (mm-handle-disposition handle)) + "inline") (setq children (with-current-buffer buffer diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index aa4ecbc3b0f..bcbe7b678d5 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -279,16 +279,21 @@ textual parts.") (current-buffer))) (defun nnimap-credentials (address ports) - (let ((found (nth 0 (auth-source-search :max 1 - :host address - :port ports - :create t)))) + (let* ((auth-source-creation-prompts + '((user . "IMAP user at %h: ") + (secret . "IMAP password for %u@%h: "))) + (found (nth 0 (auth-source-search :max 1 + :host address + :port ports + :require '(:user :secret) + :create t)))) (if found (list (plist-get found :user) (let ((secret (plist-get found :secret))) (if (functionp secret) (funcall secret) - secret))) + secret)) + (plist-get found :save-function)) nil))) (defun nnimap-keepalive () @@ -335,6 +340,7 @@ textual parts.") (ports (cond ((or (eq nnimap-stream 'network) + (eq nnimap-stream 'network-only) (eq nnimap-stream 'starttls)) (nnheader-message 7 "Opening connection to %s..." nnimap-address) @@ -396,7 +402,12 @@ textual parts.") (let ((nnimap-inhibit-logging t)) (setq login-result (nnimap-login (car credentials) (cadr credentials)))) - (unless (car login-result) + (if (car login-result) + ;; save the credentials if a save function exists + ;; (such a function will only be passed if a new + ;; token was created) + (when (functionp (nth 2 credentials)) + (funcall (nth 2 credentials))) ;; If the login failed, then forget the credentials ;; that are now possibly cached. (dolist (host (list (nnoo-current-server 'nnimap) @@ -1442,6 +1453,11 @@ textual parts.") ;; Change \Delete etc to %Delete, so that the reader can read it. (subst-char-in-region (point-min) (point-max) ?\\ ?% t) + ;; Remove any MODSEQ entries in the buffer, because they may contain + ;; numbers that are too large for 32-bit Emacsen. + (while (re-search-forward " MODSEQ ([0-9]+)" nil t) + (replace-match "" t t)) + (goto-char (point-min)) (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) @@ -1481,9 +1497,9 @@ textual parts.") (match-string 1))) (goto-char start) (setq highestmodseq - (and (search-forward "HIGHESTMODSEQ " + (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)" (or end (point-min)) t) - (read (current-buffer)))) + (match-string 1))) (goto-char end) (forward-line -1)) ;; The UID FETCH FLAGS was successful. @@ -1497,18 +1513,7 @@ textual parts.") (goto-char end)) (while (re-search-forward "^\\* [0-9]+ FETCH " start t) (let ((p (point))) - ;; FIXME: For FETCH lines like "* 2971 FETCH (FLAGS (%Recent) UID - ;; 12509 MODSEQ (13419098521433281274))" we get an - ;; overflow-error. The handler simply deletes that large number - ;; and reads again. But maybe there's a better fix... - (setq elems (condition-case nil (read (current-buffer)) - (overflow-error - ;; After an overflow-error, point is just after - ;; the too large number. So delete it and try - ;; again. - (delete-region (point) (progn (backward-word) (point))) - (goto-char p) - (read (current-buffer))))) + (setq elems (read (current-buffer))) (push (cons (cadr (memq 'UID elems)) (cadr (memq 'FLAGS elems))) articles))) @@ -1545,10 +1550,11 @@ textual parts.") refid refid value))))) (result (with-current-buffer (nnimap-buffer) (nnimap-command "UID SEARCH %s" cmd)))) - (gnus-fetch-headers - (and (car result) (delete 0 (mapcar #'string-to-number - (cdr (assoc "SEARCH" (cdr result)))))) - nil t))) + (when result + (gnus-fetch-headers + (and (car result) (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))) + nil t)))) (defun nnimap-possibly-change-group (group server) (let ((open-result t)) @@ -1663,6 +1669,8 @@ textual parts.") (goto-char (point-max))) openp) (quit + (when debug-on-quit + (debug "Quit")) ;; The user hit C-g while we were waiting: kill the process, in case ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind ;; NAT routers). @@ -1754,11 +1762,15 @@ textual parts.") (format "(UID %s%s)" (format (if (nnimap-ver4-p) - "BODY.PEEK[HEADER] BODY.PEEK" + "BODY.PEEK" "RFC822.PEEK")) - (if nnimap-split-download-body-default - "[]" - "[1]"))) + (cond + (nnimap-split-download-body-default + "[]") + ((nnimap-ver4-p) + "[HEADER]") + (t + "[1]")))) t)) (defun nnimap-split-incoming-mail () diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el index bb9695ebb72..113137a0046 100644 --- a/lisp/gnus/shr.el +++ b/lisp/gnus/shr.el @@ -53,17 +53,17 @@ fit these criteria." :group 'shr :type 'regexp) -(defcustom shr-table-horizontal-line ?- +(defcustom shr-table-horizontal-line ? "Character used to draw horizontal table lines." :group 'shr :type 'character) -(defcustom shr-table-vertical-line ?| +(defcustom shr-table-vertical-line ? "Character used to draw vertical table lines." :group 'shr :type 'character) -(defcustom shr-table-corner ?+ +(defcustom shr-table-corner ? "Character used to draw table corners." :group 'shr :type 'character) @@ -113,6 +113,15 @@ cid: URL as the argument.") ;; Public functions and commands. +(defun shr-visit-file (file) + (interactive "fHTML file name: ") + (pop-to-buffer "*html*") + (erase-buffer) + (shr-insert-document + (with-temp-buffer + (insert-file-contents file) + (libxml-parse-html-region (point-min) (point-max))))) + ;;;###autoload (defun shr-insert-document (dom) (setq shr-content-cache nil) diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index c9a0df20590..5c2e775a211 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -275,9 +275,10 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (with-current-buffer buffer (let* ((auth-info (auth-source-search :host sieve-manage-server :port "sieve" - :max 1)) - (user-name (plist-get (nth 0 auth-info) :user)) - (user-password (plist-get (nth 0 auth-info) :secret)) + :max 1 + :create t)) + (user-name (or (plist-get (nth 0 auth-info) :user) "")) + (user-password (or (plist-get (nth 0 auth-info) :secret) "")) (user-password (if (functionp user-password) (funcall user-password) user-password)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 8209cdebd3c..392e894965c 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -575,6 +575,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (with-syntax-table emacs-lisp-mode-syntax-table (or (condition-case () (save-excursion + (skip-chars-forward "'") (or (not (zerop (skip-syntax-backward "_w"))) (eq (char-syntax (following-char)) ?w) (eq (char-syntax (following-char)) ?_) diff --git a/lisp/help.el b/lisp/help.el index 9fcb06c559f..e148e5ef6ab 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -871,7 +871,17 @@ whose documentation describes the minor mode." (let ((start (point))) (insert (format-mode-line mode nil nil buffer)) (add-text-properties start (point) '(face bold))))) - (princ " mode:\n") + (princ " mode") + (let* ((mode major-mode) + (file-name (find-lisp-object-file-name mode nil))) + (when file-name + (princ (concat " defined in `" (file-name-nondirectory file-name) "'")) + ;; Make a hyperlink to the library. + (with-current-buffer standard-output + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def mode file-name))))) + (princ ":\n") (princ (documentation major-mode))))) ;; For the sake of IELM and maybe others nil) diff --git a/lisp/ido.el b/lisp/ido.el index 2e67e367a8f..2a5c7cf2f0e 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -1983,7 +1983,7 @@ If INITIAL is non-nil, it specifies the initial input string." (setq ido-exit nil) (setq ido-final-text (catch 'ido - (completing-read + (completing-read-default (ido-make-prompt item prompt) '(("dummy" . 1)) nil nil ; table predicate require-match (prog1 ido-text-init (setq ido-text-init nil)) ;initial-contents @@ -4740,13 +4740,13 @@ See `read-directory-name' for additional parameters." (concat ido-current-directory filename))))) ;;;###autoload -(defun ido-completing-read (prompt choices &optional predicate require-match initial-input hist def) +(defun ido-completing-read (prompt choices &optional predicate require-match initial-input hist def inherit-input-method) "Ido replacement for the built-in `completing-read'. Read a string in the minibuffer with ido-style completion. PROMPT is a string to prompt with; normally it ends in a colon and a space. CHOICES is a list of strings which are the possible completions. -PREDICATE is currently ignored; it is included to be compatible - with `completing-read'. +PREDICATE and INHERIT-INPUT-METHOD is currently ignored; it is included + to be compatible with `completing-read'. If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless the input is (or completes to) an element of CHOICES or is null. If the input is null, `ido-completing-read' returns DEF, or an empty diff --git a/lisp/info.el b/lisp/info.el index bc2062e72b2..fb753659737 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -594,15 +594,15 @@ in `Info-file-supports-index-cookies-list'." (defun info-initialize () "Initialize `Info-directory-list', if that hasn't been done yet." (unless Info-directory-list - (let ((path (getenv "INFOPATH"))) + (let ((path (getenv "INFOPATH")) + (sep (regexp-quote path-separator))) (setq Info-directory-list (prune-directory-list (if path - (if (string-match ":\\'" path) - (append (split-string (substring path 0 -1) - (regexp-quote path-separator)) + (if (string-match-p (concat sep "\\'") path) + (append (split-string (substring path 0 -1) sep) (Info-default-dirs)) - (split-string path (regexp-quote path-separator))) + (split-string path sep)) (Info-default-dirs))))))) ;;;###autoload diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 9a892f493d7..200aadda651 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -2306,11 +2306,11 @@ change; nil means current message." ;;;; *** Rmail Message Selection And Support *** (defun rmail-msgend (n) - "Return the start position for message number N." + "Return the end position for message number N." (marker-position (aref rmail-message-vector (1+ n)))) (defun rmail-msgbeg (n) - "Return the end position for message number N." + "Return the start position for message number N." (marker-position (aref rmail-message-vector n))) (defun rmail-apply-in-message (msgnum function &rest args) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 531a0e26eaf..4a2deb6b3bf 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -698,7 +698,15 @@ scroll the window of possible completions." (when last (setcdr last nil) ;; Prefer shorter completions. - (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2))))) + (setq all (sort all (lambda (c1 c2) + (let ((s1 (get-text-property + 0 :completion-cycle-penalty c1)) + (s2 (get-text-property + 0 :completion-cycle-penalty c2))) + (if (eq s1 s2) + (< (length c1) (length c2)) + (< (or s1 (length c1)) + (or s2 (length c2)))))))) ;; Prefer recently used completions. (let ((hist (symbol-value minibuffer-history-variable))) (setq all (sort all (lambda (c1 c2) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 3ccad277ffb..2caf8dec30f 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -36,6 +36,8 @@ (require 'custom) (eval-when-compile (require 'cl)) +(autoload 'auth-source-search "auth-source") + (defgroup ldap nil "Lightweight Directory Access Protocol." :version "21.1" @@ -480,6 +482,22 @@ Additional search parameters can be specified through "Perform a search on a LDAP server. SEARCH-PLIST is a property list describing the search request. Valid keys in that list are: + + `auth-source', if non-nil, will use `auth-source-search' and +will grab the :host, :secret, :base, and (:user or :binddn) +tokens into the `host', `passwd', `base', and `binddn' parameters +respectively if they are not provided in SEARCH-PLIST. So for +instance *each* of these netrc lines has the same effect if you +ask for the host \"ldapserver:2400\": + + machine ldapserver:2400 login myDN secret myPassword base myBase + machine ldapserver:2400 binddn myDN secret myPassword port ldap + login myDN secret myPassword base myBase + +but if you have more than one in your netrc file, only the first +matching one will be used. Note the \"port ldap\" part is NOT +required. + `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. @@ -500,19 +518,34 @@ not their associated values. 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*")) + (let* ((buf (get-buffer-create " *ldap-search*")) (bufval (get-buffer-create " *ldap-value*")) (host (or (plist-get search-plist 'host) ldap-default-host)) + ;; find entries with port "ldap" that match the requested host if any + (asfound (when (plist-get search-plist 'auth-source) + (nth 0 (auth-source-search :host (or host t) + :create t)))) + ;; if no host was requested, get it from the auth-source entry + (host (or host (plist-get asfound :host))) + ;; get the password from the auth-source + (passwd (or (plist-get search-plist 'passwd) + (plist-get asfound :secret))) + ;; convert the password from a function call if needed + (passwd (if (functionp passwd) (funcall passwd) passwd)) + ;; get the binddn from the search-list or from the + ;; auth-source user or binddn tokens + (binddn (or (plist-get search-plist 'binddn) + (plist-get asfound :user) + (plist-get asfound :binddn))) + (base (or (plist-get search-plist 'base) + (plist-get asfound :base) + ldap-default-base)) (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)) (auth (plist-get search-plist 'auth)) - (passwd (plist-get search-plist 'passwd)) (deref (plist-get search-plist 'deref)) (timelimit (plist-get search-plist 'timelimit)) (sizelimit (plist-get search-plist 'sizelimit)) diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index 4045a443640..c3da1707165 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -511,15 +511,15 @@ TYPE dictates what will be inserted, options are: (with-current-buffer quickurl-list-last-buffer (insert (case type - ('url (funcall quickurl-format-function url)) - ('naked-url (quickurl-url-url url)) - ('with-lookup (format "%s <URL:%s>" + (url (funcall quickurl-format-function url)) + (naked-url (quickurl-url-url url)) + (with-lookup (format "%s <URL:%s>" (quickurl-url-keyword url) (quickurl-url-url url))) - ('with-desc (format "%S <URL:%s>" + (with-desc (format "%S <URL:%s>" (quickurl-url-description url) (quickurl-url-url url))) - ('lookup (quickurl-url-keyword url))))) + (lookup (quickurl-url-keyword url))))) (error "No URL details on that line")) url)) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 1e3ee91092d..71aa0dd22bc 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -548,7 +548,7 @@ If ARG is non-nil, instead prompt for connection parameters." (add-hook 'auto-save-hook 'rcirc-log-write) ;; identify - (when password + (unless (zerop (length password)) (rcirc-send-string process (concat "PASS " password))) (rcirc-send-string process (concat "NICK " nick)) (rcirc-send-string process (concat "USER " user-name @@ -2449,8 +2449,7 @@ keywords when no KEYWORD is given." (if rcirc-auto-authenticate-flag (if rcirc-authenticate-before-join (progn - (with-rcirc-process-buffer process - (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t)) + (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) (rcirc-authenticate)) (rcirc-authenticate) (rcirc-join-channels process rcirc-startup-channels)) @@ -2515,7 +2514,7 @@ the only argument." (and ;; quakenet (string= sender "Q") (string= target rcirc-nick) - (string-match message "\\`You are now logged in as .+\\.\\'"))) + (string-match "\\`You are now logged in as .+\\.\\'" message))) (setq rcirc-user-authenticated t) (run-hook-with-args 'rcirc-authenticated-hook process) (remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t)))))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 63a4c19eccf..ec5c46b2897 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -90,7 +90,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-args (("%h") ("-l" "%u"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "rcp") - (tramp-copy-args (("%k" "-p") ("-r"))) + (tramp-copy-args (("-p" "%k") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) ;;;###tramp-autoload @@ -100,7 +100,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-args (("%h") ("-l" "%u"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "rcp") - (tramp-copy-args (("%k" "-p"))) + (tramp-copy-args (("-p" "%k"))) (tramp-copy-keep-date t))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -110,7 +110,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") @@ -126,7 +126,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "scp") - (tramp-copy-args (("-1") ("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") @@ -142,7 +142,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "scp") - (tramp-copy-args (("-2") ("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") @@ -160,7 +160,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r") + (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("-o" "ControlPath=%t.%%r@%%h:%%p") ("-o" "ControlMaster=auto"))) (tramp-copy-keep-date t) @@ -179,7 +179,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") @@ -202,7 +202,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "rsync") - (tramp-copy-args (("-e" "ssh") ("%k" "-t") ("-r"))) + (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-keep-tmpfile t) (tramp-copy-recursive t))) @@ -217,7 +217,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-async-args (("-q"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "rsync") - (tramp-copy-args (("%k" "-t") ("-r"))) + (tramp-copy-args (("-t" "%k") ("-r"))) (tramp-copy-env (("RSYNC_RSH") (,(concat "ssh" @@ -353,7 +353,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "pscp") - (tramp-copy-args (("-P" "%p") ("-scp") ("%k" "-p") + (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) @@ -366,7 +366,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) (tramp-remote-sh "/bin/sh") (tramp-copy-program "pscp") - (tramp-copy-args (("-P" "%p") ("-sftp") ("%k" "-p") + (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k") ("-q") ("-r"))) (tramp-copy-keep-date t) (tramp-copy-recursive t) @@ -378,7 +378,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) (tramp-remote-sh "/bin/sh -i") (tramp-copy-program "fcp") - (tramp-copy-args (("%k" "-p"))) + (tramp-copy-args (("-p" "%k"))) (tramp-copy-keep-date t))) ;;;###tramp-autoload @@ -2251,11 +2251,15 @@ The method used must be an out-of-band method." 'identity) (if t2 (tramp-make-copy-program-file-name v) newname))) - ;; Check for port number. Until now, there's no need for handling - ;; like method, user, host. - (setq host (tramp-file-name-real-host v) - port (tramp-file-name-port v) - port (or (and port (number-to-string port)) "")) + ;; Check for host and port number. We cannot use + ;; `tramp-file-name-port', because this returns also + ;; `tramp-default-port', which might clash with settings in + ;; "~/.ssh/config". + (setq host (tramp-file-name-host v) + port "") + (when (string-match tramp-host-with-port-regexp host) + (setq host (string-to-number (match-string 1 host)) + port (string-to-number (match-string 2 host)))) ;; Compose copy command. (setq spec (format-spec-make @@ -2270,7 +2274,7 @@ The method used must be an out-of-band method." copy-args (delete ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacemtent + ;; keep-date argument is non-nil), or a replacement ;; for the whole keep-date sublist. " " (dolist @@ -2281,7 +2285,7 @@ The method used must be an out-of-band method." (append copy-args (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (if (zerop (length (car y))) '(" ") y)))))) + (if (member "" y) '(" ") y)))))) copy-env (delq nil diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 1f3064c7066..462b8f11397 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -31,7 +31,7 @@ ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.2.1-pre" +(defconst tramp-version "2.2.1" "This version of Tramp.") ;;;###tramp-autoload @@ -44,7 +44,7 @@ (= emacs-major-version 21) (>= emacs-minor-version 4))) "ok" - (format "Tramp 2.2.1-pre is not fit for %s" + (format "Tramp 2.2.1 is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) diff --git a/lisp/net/xesam.el b/lisp/net/xesam.el index 21a22749408..64c26cfb2c9 100644 --- a/lisp/net/xesam.el +++ b/lisp/net/xesam.el @@ -414,18 +414,18 @@ If there is no registered search engine at all, the function returns `nil'." ;; Hopefully, this will change later. (setq hit-fields (case (intern vendor-id) - ('Beagle + (Beagle '("xesam:mimeType" "xesam:url")) - ('Strigi + (Strigi '("xesam:author" "xesam:cc" "xesam:charset" "xesam:contentType" "xesam:fileExtension" "xesam:id" "xesam:lineCount" "xesam:links" "xesam:mimeType" "xesam:name" "xesam:size" "xesam:sourceModified" "xesam:subject" "xesam:to" "xesam:url")) - ('TrackerXesamSession + (TrackerXesamSession '("xesam:relevancyRating" "xesam:url")) - ('Debbugs + (Debbugs '("xesam:keyword" "xesam:owner" "xesam:title" "xesam:url" "xesam:sourceModified" "xesam:mimeType" "debbugs:key")) diff --git a/lisp/notifications.el b/lisp/notifications.el index 893b9ed095f..adb9fdd641a 100644 --- a/lisp/notifications.el +++ b/lisp/notifications.el @@ -210,8 +210,8 @@ used to manipulate the notification item with (add-to-list 'hints `(:dict-entry "urgency" (:variant :byte ,(case urgency - ('low 0) - ('critical 2) + (low 0) + (critical 2) (t 1)))) t)) (when category (add-to-list 'hints `(:dict-entry diff --git a/lisp/org/ChangeLog b/lisp/org/ChangeLog index e75821b6860..44a2cb15b7e 100644 --- a/lisp/org/ChangeLog +++ b/lisp/org/ChangeLog @@ -1,3 +1,13 @@ +2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * org-src.el (org-src-switch-to-buffer): + * org-plot.el (org-plot/gnuplot-script, org-plot/gnuplot): + * org-mouse.el (org-mouse-agenda-type): + * org-freemind.el (org-freemind-node-to-org): + * ob-sql.el (org-babel-execute:sql): + * ob-exp.el (org-babel-exp-do-export, org-babel-exp-code): + * ob-ref.el (org-babel-ref-resolve): Fix use of case. + 2011-03-06 Juanma Barranquero <lekktu@gmail.com> * org.el (org-blank-before-new-entry, org-context-in-file-links) diff --git a/lisp/org/ob-exp.el b/lisp/org/ob-exp.el index 1be45198e0d..3215bcf4d8a 100644 --- a/lisp/org/ob-exp.el +++ b/lisp/org/ob-exp.el @@ -231,10 +231,10 @@ The function respects the value of the :exports header argument." (org-babel-exp-results info type 'silent)))) (clean () (org-babel-remove-result info))) (case (intern (or (cdr (assoc :exports (nth 2 info))) "code")) - ('none (silently) (clean) "") - ('code (silently) (clean) (org-babel-exp-code info type)) - ('results (org-babel-exp-results info type)) - ('both (concat (org-babel-exp-code info type) + (none (silently) (clean) "") + (code (silently) (clean) (org-babel-exp-code info type)) + (results (org-babel-exp-results info type)) + (both (concat (org-babel-exp-code info type) "\n\n" (org-babel-exp-results info type)))))) @@ -250,8 +250,8 @@ The code block is not evaluated." (name (nth 4 info)) (args (mapcar #'cdr (org-babel-get-header (nth 2 info) :var)))) (case type - ('inline (format "=%s=" body)) - ('block + (inline (format "=%s=" body)) + (block (let ((str (format "#+BEGIN_SRC %s %s\n%s%s#+END_SRC\n" lang switches body (if (and body (string-match "\n$" body)) @@ -265,7 +265,7 @@ The code block is not evaluated." (mapconcat #'identity args ", "))) str)) str)) - ('lob + (lob (let ((call-line (and (string-match "results=" (car args)) (substring (car args) (match-end 0))))) (cond diff --git a/lisp/org/ob-ref.el b/lisp/org/ob-ref.el index 7b06e90f924..96819df8ea1 100644 --- a/lisp/org/ob-ref.el +++ b/lisp/org/ob-ref.el @@ -147,12 +147,12 @@ the variable." (let ((params (append args '((:results . "silent"))))) (setq result (case type - ('results-line (org-babel-read-result)) - ('table (org-babel-read-table)) - ('list (org-babel-read-list)) - ('file (org-babel-read-link)) - ('source-block (org-babel-execute-src-block nil nil params)) - ('lob (org-babel-execute-src-block nil lob-info params))))) + (results-line (org-babel-read-result)) + (table (org-babel-read-table)) + (list (org-babel-read-list)) + (file (org-babel-read-link)) + (source-block (org-babel-execute-src-block nil nil params)) + (lob (org-babel-execute-src-block nil lob-info params))))) (if (symbolp result) (format "%S" result) (if (and index (listp result)) diff --git a/lisp/org/ob-sql.el b/lisp/org/ob-sql.el index 3bd10d6b2bd..49859d24a17 100644 --- a/lisp/org/ob-sql.el +++ b/lisp/org/ob-sql.el @@ -66,18 +66,18 @@ This function is called by `org-babel-execute-src-block'." (out-file (or (cdr (assoc :out-file params)) (org-babel-temp-file "sql-out-"))) (command (case (intern engine) - ('msosql (format "osql %s -s \"\t\" -i %s -o %s" - (or cmdline "") - (org-babel-process-file-name in-file) - (org-babel-process-file-name out-file))) - ('mysql (format "mysql %s -e \"source %s\" > %s" + (msosql (format "osql %s -s \"\t\" -i %s -o %s" (or cmdline "") - (org-babel-process-file-name in-file) - (org-babel-process-file-name out-file))) - ('postgresql (format "psql -A -P footer=off -F \"\t\" -f %s -o %s %s" - (org-babel-process-file-name in-file) - (org-babel-process-file-name out-file) - (or cmdline ""))) + (org-babel-process-file-name in-file) + (org-babel-process-file-name out-file))) + (mysql (format "mysql %s -e \"source %s\" > %s" + (or cmdline "") + (org-babel-process-file-name in-file) + (org-babel-process-file-name out-file))) + (postgresql (format "psql -A -P footer=off -F \"\t\" -f %s -o %s %s" + (org-babel-process-file-name in-file) + (org-babel-process-file-name out-file) + (or cmdline ""))) (t (error "no support for the %s sql engine" engine))))) (with-temp-file in-file (insert (org-babel-expand-body:sql body params))) diff --git a/lisp/org/org-freemind.el b/lisp/org/org-freemind.el index c85b4bac36a..dccdf449296 100644 --- a/lisp/org/org-freemind.el +++ b/lisp/org/org-freemind.el @@ -1172,8 +1172,8 @@ PATH should be a list of steps, where each step has the form (when (< 0 (- level skip-levels)) (dolist (attrib attributes) (case (car attrib) - ('TEXT (setq text (cdr attrib))) - ('text (setq text (cdr attrib))))) + (TEXT (setq text (cdr attrib))) + (text (setq text (cdr attrib))))) (unless text ;; There should be a richcontent node holding the text: (setq text (org-freemind-get-richcontent-node-text node))) @@ -1193,7 +1193,7 @@ PATH should be a list of steps, where each step has the form (setq text (replace-regexp-in-string "\n $" "" text)) (insert text)) (case qname - ('node + (node (insert (make-string (- level skip-levels) ?*) " " text "\n") (when note (insert ":COMMENT:\n" note "\n:END:\n")) diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el index d30f172f42f..cec19d89de1 100644 --- a/lisp/org/org-mouse.el +++ b/lisp/org/org-mouse.el @@ -476,11 +476,11 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" (defun org-mouse-agenda-type (type) (case type - ('tags "Tags: ") - ('todo "TODO: ") - ('tags-tree "Tags tree: ") - ('todo-tree "TODO tree: ") - ('occur-tree "Occur tree: ") + (tags "Tags: ") + (todo "TODO: ") + (tags-tree "Tags tree: ") + (todo-tree "TODO tree: ") + (occur-tree "Occur tree: ") (t "Agenda command ???"))) diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index c5f4bff24fa..10722403f7e 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -206,18 +206,18 @@ manner suitable for prepending to a user-specified script." (y-labels (plist-get params :ylabels)) (plot-str "'%s' using %s%d%s with %s title '%s'") (plot-cmd (case type - ('2d "plot") - ('3d "splot") - ('grid "splot"))) + (2d "plot") + (3d "splot") + (grid "splot"))) (script "reset") plot-lines) (flet ((add-to-script (line) (setf script (format "%s\n%s" script line)))) (when file ;; output file (add-to-script (format "set term %s" (file-name-extension file))) (add-to-script (format "set output '%s'" file))) (case type ;; type - ('2d ()) - ('3d (if map (add-to-script "set map"))) - ('grid (if map + (2d ()) + (3d (if map (add-to-script "set map"))) + (grid (if map (add-to-script "set pm3d map") (add-to-script "set pm3d")))) (when title (add-to-script (format "set title '%s'" title))) ;; title @@ -243,7 +243,7 @@ manner suitable for prepending to a user-specified script." "%Y-%m-%d-%H:%M:%S") "\""))) (unless preface (case type ;; plot command - ('2d (dotimes (col num-cols) + (2d (dotimes (col num-cols) (unless (and (equal type '2d) (or (and ind (equal (+ 1 col) ind)) (and deps (not (member (+ 1 col) deps))))) @@ -258,10 +258,10 @@ manner suitable for prepending to a user-specified script." with (or (nth col col-labels) (format "%d" (+ 1 col)))) plot-lines))))) - ('3d + (3d (setq plot-lines (list (format "'%s' matrix with %s title ''" data-file with)))) - ('grid + (grid (setq plot-lines (list (format "'%s' with %s title ''" data-file with))))) (add-to-script @@ -305,9 +305,9 @@ line directly before or after the table." (setf params (org-plot/collect-options params)))) ;; dump table to datafile (very different for grid) (case (plist-get params :plot-type) - ('2d (org-plot/gnuplot-to-data table data-file params)) - ('3d (org-plot/gnuplot-to-data table data-file params)) - ('grid (let ((y-labels (org-plot/gnuplot-to-grid-data + (2d (org-plot/gnuplot-to-data table data-file params)) + (3d (org-plot/gnuplot-to-data table data-file params)) + (grid (let ((y-labels (org-plot/gnuplot-to-grid-data table data-file params))) (when y-labels (plist-put params :ylabels y-labels))))) ;; check for timestamp ind column diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el index 98fdb75423d..bd1c3802044 100644 --- a/lisp/org/org-src.el +++ b/lisp/org/org-src.el @@ -335,26 +335,26 @@ buffer." (defun org-src-switch-to-buffer (buffer context) (case org-src-window-setup - ('current-window + (current-window (switch-to-buffer buffer)) - ('other-window + (other-window (switch-to-buffer-other-window buffer)) - ('other-frame + (other-frame (case context - ('exit + (exit (let ((frame (selected-frame))) (switch-to-buffer-other-frame buffer) (delete-frame frame))) - ('save + (save (kill-buffer (current-buffer)) (switch-to-buffer buffer)) (t (switch-to-buffer-other-frame buffer)))) - ('reorganize-frame + (reorganize-frame (if (eq context 'edit) (delete-other-windows)) (org-switch-to-buffer-other-window buffer) (if (eq context 'exit) (delete-other-windows))) - ('switch-invisibly + (switch-invisibly (set-buffer buffer)) (t (message "Invalid value %s for org-src-window-setup" diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index 8fea2cef6ad..0dc556007ba 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -719,57 +719,57 @@ static char * dot3d_xpm[] = { (defsubst bubbles--grid-width () "Return the grid width for the current game theme." (car (case bubbles-game-theme - ('easy + (easy bubbles--grid-small) - ('medium + (medium bubbles--grid-medium) - ('difficult + (difficult bubbles--grid-large) - ('hard + (hard bubbles--grid-huge) - ('user-defined + (user-defined bubbles-grid-size)))) (defsubst bubbles--grid-height () "Return the grid height for the current game theme." (cdr (case bubbles-game-theme - ('easy + (easy bubbles--grid-small) - ('medium + (medium bubbles--grid-medium) - ('difficult + (difficult bubbles--grid-large) - ('hard + (hard bubbles--grid-huge) - ('user-defined + (user-defined bubbles-grid-size)))) (defsubst bubbles--colors () "Return the color list for the current game theme." (case bubbles-game-theme - ('easy + (easy bubbles--colors-2) - ('medium + (medium bubbles--colors-3) - ('difficult + (difficult bubbles--colors-4) - ('hard + (hard bubbles--colors-5) - ('user-defined + (user-defined bubbles-colors))) (defsubst bubbles--shift-mode () "Return the shift mode for the current game theme." (case bubbles-game-theme - ('easy + (easy 'default) - ('medium + (medium 'default) - ('difficult + (difficult 'always) - ('hard + (hard 'always) - ('user-defined + (user-defined bubbles-shift-mode))) (defun bubbles-save-settings () @@ -1346,11 +1346,11 @@ Return t if new char is non-empty." (when (and (display-images-p) (not (eq bubbles-graphics-theme 'ascii))) (let ((template (case bubbles-graphics-theme - ('circles bubbles--image-template-circle) - ('balls bubbles--image-template-ball) - ('squares bubbles--image-template-square) - ('diamonds bubbles--image-template-diamond) - ('emacs bubbles--image-template-emacs)))) + (circles bubbles--image-template-circle) + (balls bubbles--image-template-ball) + (squares bubbles--image-template-square) + (diamonds bubbles--image-template-diamond) + (emacs bubbles--image-template-emacs)))) (setq bubbles--empty-image (create-image (replace-regexp-in-string "^\"\\(.*\\)\t.*c .*\",$" diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index d3d8350a43f..99e3b487437 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -213,19 +213,19 @@ static unsigned char gamegrid_bits[] = { (let ((data (gamegrid-match-spec-list data-spec-list)) (color (gamegrid-match-spec-list color-spec-list))) (case data - ('color-x + (color-x (gamegrid-make-color-x-face color)) - ('grid-x + (grid-x (unless gamegrid-grid-x-face (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face))) gamegrid-grid-x-face) - ('mono-x + (mono-x (unless gamegrid-mono-x-face (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face))) gamegrid-mono-x-face) - ('color-tty + (color-tty (gamegrid-make-color-tty-face color)) - ('mono-tty + (mono-tty (unless gamegrid-mono-tty-face (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face))) gamegrid-mono-tty-face)))) diff --git a/lisp/play/morse.el b/lisp/play/morse.el index d4a0224ede5..b88f1b264cb 100644 --- a/lisp/play/morse.el +++ b/lisp/play/morse.el @@ -25,6 +25,9 @@ ;; Converts text to Morse code and back with M-x morse-region and ;; M-x unmorse-region (though Morse code is no longer official :-(). +;; Converts text to NATO phonetic alphabet and back with M-x +;; nato-region and M-x denato-region. + ;;; Code: (defvar morse-code '(("a" . ".-") @@ -91,10 +94,64 @@ ("@" . ".--.-.")) "Morse code character set.") +(defvar nato-alphabet '(("a" . "Alfa") + ("b" . "Bravo") + ("c" . "Charlie") + ("d" . "Delta") + ("e" . "Echo") + ("f" . "Foxtrot") + ("g" . "Golf") + ("h" . "Hotel") + ("i" . "India") + ("j" . "Juliett") + ("k" . "Kilo") + ("l" . "Lima") + ("m" . "Mike") + ("n" . "November") + ("o" . "Oscar") + ("p" . "Papa") + ("q" . "Quebec") + ("r" . "Romeo") + ("s" . "Sierra") + ("t" . "Tango") + ("u" . "Uniform") + ("v" . "Victor") + ("w" . "Whiskey") + ("x" . "Xray") + ("y" . "Yankee") + ("z" . "Zulu") + ;; Numbers + ("0" . "Zero") + ("1" . "One") + ("2" . "Two") + ("3" . "Three") + ("4" . "Four") + ("5" . "Five") + ("6" . "Six") + ("7" . "Seven") + ("8" . "Eight") + ("9" . "Niner") + ;; Punctuation is not part of standard + ("=" . "Equals") + ("?" . "Query") + ("/" . "Slash") + ("," . "Comma") + ("." . "Stop") + (":" . "Colon") + ("'" . "Apostrophe") + ("-" . "Dash") + ("(" . "Open") + (")" . "Close") + ("@" . "At")) + "NATO phonetic alphabet. +See ''International Code of Signals'' (INTERCO), United States +Edition, 1969 Edition (Revised 2003) available from National +Geospatial-Intelligence Agency at http://www.nga.mil/") + ;;;###autoload (defun morse-region (beg end) "Convert all text in a given region to morse code." - (interactive "r") + (interactive "*r") (if (integerp end) (setq end (copy-marker end))) (save-excursion @@ -117,7 +174,7 @@ ;;;###autoload (defun unmorse-region (beg end) "Convert morse coded text in region to ordinary ASCII text." - (interactive "r") + (interactive "*r") (if (integerp end) (setq end (copy-marker end))) (save-excursion @@ -136,6 +193,53 @@ (if (looking-at "/") (delete-char 1)))))))) +;;;###autoload +(defun nato-region (beg end) + "Convert all text in a given region to NATO phonetic alphabet." + ;; Copied from morse-region. -- ashawley 2009-02-10 + (interactive "*r") + (if (integerp end) + (setq end (copy-marker end))) + (save-excursion + (let ((sep "") + str nato) + (goto-char beg) + (while (< (point) end) + (setq str (downcase (buffer-substring (point) (1+ (point))))) + (cond ((looking-at "\\s-+") + (goto-char (match-end 0)) + (setq sep "")) + ((setq nato (assoc str nato-alphabet)) + (delete-char 1) + (insert sep (cdr nato)) + (setq sep "-")) + (t + (forward-char 1) + (setq sep ""))))))) + +;;;###autoload +(defun denato-region (beg end) + "Convert NATO phonetic alphabet in region to ordinary ASCII text." + ;; Copied from unmorse-region. -- ashawley 2009-02-10 + (interactive "*r") + (if (integerp end) + (setq end (copy-marker end))) + (save-excursion + (let (str paren nato) + (goto-char beg) + (while (< (point) end) + (if (null (looking-at "[a-z]+")) + (forward-char 1) + (setq str (buffer-substring (match-beginning 0) (match-end 0))) + (if (null (setq nato (rassoc str nato-alphabet))) + (goto-char (match-end 0)) + (replace-match + (if (string-equal "(" (car nato)) + (if (setq paren (null paren)) "(" ")") + (car nato)) t) + (if (looking-at "-") + (delete-char 1)))))))) + (provide 'morse) ;;; morse.el ends here diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 5ac30bc28ce..0f873e678c3 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -2564,19 +2564,12 @@ be more \"DWIM:ey\"." ;; Are we about to move backwards into or out of a ;; preprocessor command? If so, locate its beginning. (when (eq (cdr res) 'macro-boundary) - (setq macro-fence - (save-excursion - (if macro-fence - (progn - (end-of-line) - (and (not (eobp)) - (progn (c-skip-ws-forward) - (c-beginning-of-macro)) - (progn (c-end-of-macro) - (point)))) - (and (not (eobp)) - (c-beginning-of-macro) - (progn (c-end-of-macro) (point))))))) + (save-excursion + (beginning-of-line) + (setq macro-fence + (and (not (bobp)) + (progn (c-skip-ws-backward) (c-beginning-of-macro)) + (point))))) ;; Are we about to move backwards into a literal? (when (memq (cdr res) '(macro-boundary literal)) (setq range (c-ascertain-preceding-literal))) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 88f418f934a..40383c6bc31 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -860,27 +860,29 @@ POS and RES.") (car compilation--previous-directory-cache))) (prev (previous-single-property-change - pos 'compilation-directory nil cache))) - (cond - ((null cache) - (setq compilation--previous-directory-cache - (cons (copy-marker pos) (copy-marker prev))) - prev) - ((eq prev cache) - (if cache - (set-marker (car compilation--previous-directory-cache) pos) - (setq compilation--previous-directory-cache - (cons (copy-marker pos) nil))) - (cdr compilation--previous-directory-cache)) - (t - (if cache - (progn - (set-marker (car compilation--previous-directory-cache) pos) - (setcdr compilation--previous-directory-cache - (copy-marker prev))) - (setq compilation--previous-directory-cache - (cons (copy-marker pos) (copy-marker prev)))) - prev))))) + pos 'compilation-directory nil cache)) + (res + (cond + ((null cache) + (setq compilation--previous-directory-cache + (cons (copy-marker pos) (if prev (copy-marker prev)))) + prev) + ((and prev (= prev cache)) + (if cache + (set-marker (car compilation--previous-directory-cache) pos) + (setq compilation--previous-directory-cache + (cons (copy-marker pos) nil))) + (cdr compilation--previous-directory-cache)) + (t + (if cache + (progn + (set-marker cache pos) + (setcdr compilation--previous-directory-cache + (copy-marker prev))) + (setq compilation--previous-directory-cache + (cons (copy-marker pos) (if prev (copy-marker prev))))) + prev)))) + (if (markerp res) (marker-position res) res)))) ;; Internal function for calculating the text properties of a directory ;; change message. The compilation-directory property is important, because it @@ -889,7 +891,7 @@ POS and RES.") (defun compilation-directory-properties (idx leave) (if leave (setq leave (match-end leave))) ;; find previous stack, and push onto it, or if `leave' pop it - (let ((dir (compilation--previous-directory (point)))) + (let ((dir (compilation--previous-directory (match-beginning 0)))) (setq dir (if dir (or (get-text-property (1- dir) 'compilation-directory) (get-text-property dir 'compilation-directory)))) `(font-lock-face ,(if leave @@ -948,7 +950,8 @@ POS and RES.") (match-string-no-properties file)))) (let ((dir (unless (file-name-absolute-p file) - (let ((pos (compilation--previous-directory (point)))) + (let ((pos (compilation--previous-directory + (match-beginning 0)))) (when pos (or (get-text-property (1- pos) 'compilation-directory) (get-text-property pos 'compilation-directory))))))) diff --git a/lisp/progmodes/delphi.el b/lisp/progmodes/delphi.el index c376b25fae0..0f823c806e0 100644 --- a/lisp/progmodes/delphi.el +++ b/lisp/progmodes/delphi.el @@ -26,14 +26,14 @@ ;; To enter Delphi mode when you find a Delphi source file, one must override ;; the auto-mode-alist to associate Delphi with .pas (and .dpr and .dpk) -;; files. Emacs, by default, will otherwise enter Pascal mode. E.g. +;; files. Emacs, by default, will otherwise enter Pascal mode. E.g. ;; ;; (autoload 'delphi-mode "delphi") ;; (setq auto-mode-alist ;; (cons '("\\.\\(pas\\|dpr\\|dpk\\)$" . delphi-mode) auto-mode-alist)) ;; To get keyword, comment, and string literal coloring, be sure that font-lock -;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or +;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or ;; one can put in .emacs: ;; ;; (add-hook 'delphi-mode-hook 'turn-on-font-lock) @@ -56,8 +56,8 @@ ;; When you have entered Delphi mode, you may get more info by pressing ;; C-h m. -;; This delphi mode implementation is fairly tolerant of syntax errors, relying -;; as much as possible on the indentation of the previous statement. This also +;; This Delphi mode implementation is fairly tolerant of syntax errors, relying +;; as much as possible on the indentation of the previous statement. This also ;; makes it faster and simpler, since there is less searching for properly ;; constructed beginnings. @@ -74,15 +74,16 @@ "True if in debug mode.") (defcustom delphi-search-path "." - "*Directories to search when finding external units. It is a list of -directory strings. If only a single directory, it can be a single -string instead of a list. If a directory ends in \"...\" then that -directory is recursively searched." + "*Directories to search when finding external units. +It is a list of directory strings. If only a single directory, +it can be a single string instead of a list. If a directory +ends in \"...\" then that directory is recursively searched." :type 'string :group 'delphi) (defcustom delphi-indent-level 3 - "*Indentation of Delphi statements with respect to containing block. E.g. + "*Indentation of Delphi statements with respect to containing block. +E.g. begin // This is an indent of 3. @@ -117,7 +118,7 @@ end; end;" :group 'delphi) (defcustom delphi-verbose t ; nil - "*If true then delphi token processing progress is reported to the user." + "*If true then Delphi token processing progress is reported to the user." :type 'boolean :group 'delphi) @@ -137,17 +138,17 @@ differs from the default." :group 'delphi) (defcustom delphi-comment-face 'font-lock-comment-face - "*Face used to color delphi comments." + "*Face used to color Delphi comments." :type 'face :group 'delphi) (defcustom delphi-string-face 'font-lock-string-face - "*Face used to color delphi strings." + "*Face used to color Delphi strings." :type 'face :group 'delphi) (defcustom delphi-keyword-face 'font-lock-keyword-face - "*Face used to color delphi keywords." + "*Face used to color Delphi keywords." :type 'face :group 'delphi) @@ -720,9 +721,9 @@ routine.") (delphi-progress-done))))) (defvar delphi-ignore-changes t - "Internal flag to control if the delphi-mode responds to buffer changes. -Defaults to t in case the delphi-after-change function is called on a -non-delphi buffer. Set to nil in a delphi buffer. To override, just do: + "Internal flag to control if the Delphi mode responds to buffer changes. +Defaults to t in case the `delphi-after-change' function is called on a +non-Delphi buffer. Set to nil in a Delphi buffer. To override, just do: (let ((delphi-ignore-changes t)) ...)") (defun delphi-after-change (change-start change-end old-length) @@ -1521,8 +1522,8 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do: indent))) (defun delphi-indent-line () - "Indent the current line according to the current language construct. If -before the indent, the point is moved to the indent." + "Indent the current line according to the current language construct. +If before the indent, the point is moved to the indent." (interactive) (delphi-save-match-data (let ((marked-point (point-marker)) ; Maintain our position reliably. @@ -1547,7 +1548,7 @@ before the indent, the point is moved to the indent." (set-marker marked-point nil)))) (defvar delphi-mode-abbrev-table nil - "Abbrev table in use in delphi-mode buffers.") + "Abbrev table in use in Delphi mode buffers.") (define-abbrev-table 'delphi-mode-abbrev-table ()) (defmacro delphi-ensure-buffer (buffer-var buffer-name) @@ -1568,7 +1569,7 @@ before the indent, the point is moved to the indent." ;; Debugging helpers: (defvar delphi-debug-buffer nil - "Buffer to write delphi-mode debug messages to. Created on demand.") + "Buffer to write Delphi mode debug messages to. Created on demand.") (defun delphi-debug-log (format-string &rest args) ;; Writes a message to the log buffer. @@ -1679,7 +1680,7 @@ before the indent, the point is moved to the indent." (defun delphi-tab () "Indent the region, when Transient Mark mode is enabled and the region is -active. Otherwise, indent the current line or insert a TAB, depending on the +active. Otherwise, indent the current line or insert a TAB, depending on the value of `delphi-tab-always-indents' and the current line position." (interactive) (cond ((use-region-p) @@ -1768,8 +1769,8 @@ value of `delphi-tab-always-indents' and the current line position." nil)) (defun delphi-find-unit (unit) - "Finds the specified delphi source file according to `delphi-search-path'. -If no extension is specified, .pas is assumed. Creates a buffer for the unit." + "Find the specified Delphi source file according to `delphi-search-path'. +If no extension is specified, .pas is assumed. Creates a buffer for the unit." (interactive "sDelphi unit name: ") (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit) unit @@ -1791,7 +1792,7 @@ If no extension is specified, .pas is assumed. Creates a buffer for the unit." "Find the definition of the identifier under the current point, searching in external units if necessary (as listed in the current unit's use clause). The set of directories to search for a unit is specified by the global variable -delphi-search-path." +`delphi-search-path'." (interactive) (error "delphi-find-current-xdef: not implemented yet")) @@ -1802,7 +1803,7 @@ it is a routine." (error "delphi-find-current-body: not implemented yet")) (defun delphi-fill-comment () - "Fills the text of the current comment, according to `fill-column'. + "Fill the text of the current comment, according to `fill-column'. An error is raised if not in a comment." (interactive) (save-excursion @@ -1888,8 +1889,8 @@ An error is raised if not in a comment." (delphi-progress-done))))))) (defun delphi-new-comment-line () - "If in a // comment, does a newline, indented such that one is still in the -comment block. If not in a // comment, just does a normal newline." + "If in a // comment, do a newline, indented such that one is still in the +comment block. If not in a // comment, just does a normal newline." (interactive) (let ((comment (delphi-current-token))) (if (not (eq 'comment-single-line (delphi-token-kind comment))) @@ -1923,7 +1924,7 @@ comment block. If not in a // comment, just does a normal newline." nil ; Syntax begin movement doesn't apply (font-lock-fontify-region-function . delphi-fontify-region) (font-lock-verbose . delphi-fontifying-progress-step)) - "Delphi mode font-lock defaults. Syntactic fontification is ignored.") + "Delphi mode font-lock defaults. Syntactic fontification is ignored.") (defvar delphi-debug-mode-map (let ((kmap (make-sparse-keymap))) @@ -1944,7 +1945,7 @@ comment block. If not in a // comment, just does a normal newline." ("x" delphi-debug-show-is-stable) )) kmap) - "Keystrokes for delphi-mode debug commands.") + "Keystrokes for Delphi mode debug commands.") (defvar delphi-mode-map (let ((kmap (make-sparse-keymap))) @@ -1964,7 +1965,7 @@ comment block. If not in a // comment, just does a normal newline." "Keymap used in Delphi mode.") (defconst delphi-mode-syntax-table (make-syntax-table) - "Delphi mode's syntax table. It is just a standard syntax table. + "Delphi mode's syntax table. It is just a standard syntax table. This is ok since we do our own keyword/comment/string face coloring.") ;;;###autoload @@ -1976,7 +1977,7 @@ This is ok since we do our own keyword/comment/string face coloring.") \\[delphi-fill-comment]\t- Fill the current comment. \\[delphi-new-comment-line]\t- If in a // comment, do a new comment line. -M-x indent-region also works for indenting a whole region. +\\[indent-region] also works for indenting a whole region. Customization: @@ -1996,21 +1997,21 @@ Customization: `delphi-search-path' (default .) Directories to search when finding external units. `delphi-verbose' (default nil) - If true then delphi token processing progress is reported to the user. + If true then Delphi token processing progress is reported to the user. Coloring: `delphi-comment-face' (default font-lock-comment-face) - Face used to color delphi comments. + Face used to color Delphi comments. `delphi-string-face' (default font-lock-string-face) - Face used to color delphi strings. + Face used to color Delphi strings. `delphi-keyword-face' (default font-lock-keyword-face) - Face used to color delphi keywords. + Face used to color Delphi keywords. `delphi-other-face' (default nil) Face used to color everything else. -Turning on Delphi mode calls the value of the variable delphi-mode-hook with -no args, if that value is non-nil." +Turning on Delphi mode calls the value of the variable `delphi-mode-hook' +with no args, if that value is non-nil." (interactive) (kill-all-local-variables) (use-local-map delphi-mode-map) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index d674484345a..87e5875c943 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -3566,12 +3566,12 @@ KIND is an additional string printed in the buffer." (insert kind) (indent-to 50) (insert (case (second info) - ('ebrowse-ts-member-functions "member function") - ('ebrowse-ts-member-variables "member variable") - ('ebrowse-ts-static-functions "static function") - ('ebrowse-ts-static-variables "static variable") - ('ebrowse-ts-friends (if globals-p "define" "friend")) - ('ebrowse-ts-types "type") + (ebrowse-ts-member-functions "member function") + (ebrowse-ts-member-variables "member variable") + (ebrowse-ts-static-functions "static function") + (ebrowse-ts-static-variables "static variable") + (ebrowse-ts-friends (if globals-p "define" "friend")) + (ebrowse-ts-types "type") (t "unknown")) "\n"))) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 25d1410621a..ab315f9eefd 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -648,21 +648,36 @@ detailed description of this mode. (set (make-local-variable 'gud-minor-mode) 'gdbmi) (setq comint-input-sender 'gdb-send) (when (ring-empty-p comint-input-ring) ; cf shell-mode - (let (hfile) - (when (catch 'done - (dolist (file '(".gdbinit" "~/.gdbinit")) - (if (file-readable-p (setq file (expand-file-name file))) - (with-temp-buffer - (insert-file-contents file) - (and (re-search-forward - "^ *set history filename *\\(.*\\)" nil t) - (file-readable-p - (setq hfile (expand-file-name - (match-string 1) - (file-name-directory file)))) - (throw 'done t)))))) - (set (make-local-variable 'comint-input-ring-file-name) hfile) - (comint-read-input-ring t)))) + (let ((hfile (expand-file-name (or (getenv "GBDHISTFILE") + (if (eq system-type 'ms-dos) + "_gdb_history" + ".gdb_history")))) + ;; gdb defaults to 256, but we'll default to comint-input-ring-size. + (hsize (getenv "HISTSIZE"))) + (dolist (file (append '("~/.gdbinit") + (unless (string-equal (expand-file-name ".") + (expand-file-name "~")) + '(".gdbinit")))) + (if (file-readable-p (setq file (expand-file-name file))) + (with-temp-buffer + (insert-file-contents file) + ;; TODO? check for "set history save\\( *on\\)?" and do + ;; not use history otherwise? + (while (re-search-forward + "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t) + (cond ((string-equal (match-string 1) "filename") + (setq hfile (expand-file-name + (match-string 2) + (file-name-directory file)))) + ((string-equal (match-string 1) "size") + (setq hsize (match-string 2)))))))) + (and (stringp hsize) + (integerp (setq hsize (string-to-number hsize))) + (> hsize 0) + (set (make-local-variable 'comint-input-ring-size) hsize)) + (if (stringp hfile) + (set (make-local-variable 'comint-input-ring-file-name) hfile)) + (comint-read-input-ring t))) (gud-def gud-tbreak "tbreak %f:%l" "\C-t" "Set temporary breakpoint at current line.") (gud-def gud-jump diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 53918b903ee..47cbdf19ed2 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -3127,7 +3127,9 @@ class of the file (using s to separate nested class ids)." ("^document\\s-.*\\(\n\\)" (1 "< b")) ("^end\\(\\>\\)" (1 (ignore - (unless (eq (match-beginning 0) (point-min)) + (when (and (> (match-beginning 0) (point-min)) + (eq 1 (nth 7 (save-excursion + (syntax-ppss (1- (match-beginning 0))))))) ;; We change the \n in front, which is more difficult, but results ;; in better highlighting. If the doc is empty, the single \n is ;; both the beginning and the end of the docstring, which can't be diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 9d40b4d8fd7..c8b156c5441 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -974,7 +974,7 @@ With ARG, do it many times. Negative ARG means move forward." (goto-char (scan-sexps (1+ (point)) -1)) (case (char-before) (?% (forward-char -1)) - ('(?q ?Q ?w ?W ?r ?x) + ((?q ?Q ?w ?W ?r ?x) (if (eq (char-before (1- (point))) ?%) (forward-char -2)))) nil) ((looking-at "\\s\"\\|\\\\\\S_") diff --git a/lisp/server.el b/lisp/server.el index 019a16a43d7..ce14f133f0a 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -486,7 +486,13 @@ See variable `server-auth-dir' for details." (file-name-as-directory dir)) :warning) (throw :safe t)) - (unless (eql uid (user-uid)) ; is the dir ours? + (unless (or (= uid (user-uid)) ; is the dir ours? + (and w32 + ;; Files created on Windows by + ;; Administrator (RID=500) have + ;; the Administrators (RID=544) + ;; group recorded as the owner. + (= uid 544) (= (user-uid) 500))) (throw :safe nil)) (when w32 ; on NTFS? (throw :safe t)) diff --git a/lisp/shell.el b/lisp/shell.el index 2f11cc6314c..dde81c6cb95 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -459,7 +459,12 @@ buffer." ;; shell-dependent assignments. (when (ring-empty-p comint-input-ring) (let ((shell (file-name-nondirectory (car - (process-command (get-buffer-process (current-buffer))))))) + (process-command (get-buffer-process (current-buffer)))))) + (hsize (getenv "HISTSIZE"))) + (and (stringp hsize) + (integerp (setq hsize (string-to-number hsize))) + (> hsize 0) + (set (make-local-variable 'comint-input-ring-size) hsize)) (setq comint-input-ring-file-name (or (getenv "HISTFILE") (cond ((string-equal shell "bash") "~/.bash_history") @@ -578,6 +583,21 @@ Otherwise, one argument `-i' is passed to the shell. (get-buffer-create (or buffer "*shell*")) ;; If the current buffer is a dead shell buffer, use it. (current-buffer))) + + ;; On remote hosts, the local `shell-file-name' might be useless. + (if (and (interactive-p) + (file-remote-p default-directory) + (null explicit-shell-file-name) + (null (getenv "ESHELL"))) + (with-current-buffer buffer + (set (make-local-variable 'explicit-shell-file-name) + (file-remote-p + (expand-file-name + (read-file-name + "Remote shell path: " default-directory shell-file-name + t shell-file-name)) + 'localname)))) + ;; Pop to buffer, so that the buffer's window will be correctly set ;; when we call comint (so that comint sets the COLUMNS env var properly). (pop-to-buffer buffer) diff --git a/lisp/simple.el b/lisp/simple.el index 7a191f0cc9a..e4c742b56f4 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -636,7 +636,9 @@ If the region is active, only delete whitespace within the region." (if (looking-at ".*\f") (goto-char (match-end 0)))) (delete-region (point) (match-end 0))) - (set-marker end-marker nil))))) + (set-marker end-marker nil)))) + ;; Return nil for the benefit of `write-file-functions'. + nil) (defun newline-and-indent () "Insert a newline, then indent according to major mode. @@ -2627,7 +2629,7 @@ specifies the value of ERROR-BUFFER." (with-output-to-string (with-current-buffer standard-output - (call-process shell-file-name nil t nil shell-command-switch command)))) + (process-file shell-file-name nil t nil shell-command-switch command)))) (defun process-file (program &optional infile buffer display &rest args) "Process files synchronously in a separate process. diff --git a/lisp/startup.el b/lisp/startup.el index 4dbf41d3ac6..765ca1540ee 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -392,6 +392,15 @@ Warning Warning!!! Pure space overflow !!!Warning Warning :type 'directory :initialize 'custom-initialize-delay) +(defconst package-subdirectory-regexp + "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" + "Regular expression matching the name of a package subdirectory. +The first subexpression is the package name. +The second subexpression is the version string. + +The regexp should not contain a starting \"\\`\" or a trailing + \"\\'\"; those are added automatically by callers.") + (defun normal-top-level-add-subdirs-to-load-path () "Add all subdirectories of current directory to `load-path'. More precisely, this uses only the subdirectories whose names @@ -1006,19 +1015,23 @@ opening the first frame (e.g. open a connection to an X server).") (if init-file-user (let ((user-init-file-1 (cond - ((eq system-type 'ms-dos) - (concat "~" init-file-user "/_emacs")) - ((eq system-type 'windows-nt) - ;; Prefer .emacs on Windows. - (if (directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$") - "~/.emacs" - ;; Also support _emacs for compatibility. - (if (directory-files "~" nil "^_emacs\\(\\.elc?\\)?$") - "~/_emacs" - ;; But default to .emacs if _emacs does not exist. - "~/.emacs"))) - (t - (concat "~" init-file-user "/.emacs"))))) + ((eq system-type 'ms-dos) + (concat "~" init-file-user "/_emacs")) + ((not (eq system-type 'windows-nt)) + (concat "~" init-file-user "/.emacs")) + ;; Else deal with the Windows situation + ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$") + ;; Prefer .emacs on Windows. + "~/.emacs") + ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$") + ;; Also support _emacs for compatibility, but warn about it. + (display-warning + 'initialization + "`_emacs' init file is deprecated, please use `.emacs'" + :warning) + "~/_emacs") + (t ;; But default to .emacs if _emacs does not exist. + "~/.emacs")))) ;; This tells `load' to store the file name found ;; into user-init-file. (setq user-init-file t) @@ -1190,9 +1203,9 @@ the `--debug-init' option to view a complete error backtrace." (when (file-directory-p dir) (dolist (subdir (directory-files dir)) (when (and (file-directory-p (expand-file-name subdir dir)) - ;; package-subdirectory-regexp from package.el - (string-match "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$" - subdir)) + (string-match + (concat "\\`" package-subdirectory-regexp "\\'") + subdir)) (throw 'package-dir-found t))))))) (package-initialize)) diff --git a/lisp/subr.el b/lisp/subr.el index 45cfb56bdc1..9f4e35fcbe0 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2066,24 +2066,24 @@ If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore keyboard-quit events while waiting for a valid input." (unless (consp chars) (error "Called `read-char-choice' without valid char choices")) - (let ((cursor-in-echo-area t) - (executing-kbd-macro executing-kbd-macro) - char done) - (while (not done) - (unless (get-text-property 0 'face prompt) - (setq prompt (propertize prompt 'face 'minibuffer-prompt))) - (setq char (let ((inhibit-quit inhibit-keyboard-quit)) - (read-key prompt))) - (cond - ((not (numberp char))) - ((memq char chars) - (setq done t)) - ((and executing-kbd-macro (= char -1)) - ;; read-event returns -1 if we are in a kbd macro and - ;; there are no more events in the macro. Attempt to - ;; get an event interactively. - (setq executing-kbd-macro nil)))) - ;; Display the question with the answer. + (let (char done) + (let ((cursor-in-echo-area t) + (executing-kbd-macro executing-kbd-macro)) + (while (not done) + (unless (get-text-property 0 'face prompt) + (setq prompt (propertize prompt 'face 'minibuffer-prompt))) + (setq char (let ((inhibit-quit inhibit-keyboard-quit)) + (read-key prompt))) + (cond + ((not (numberp char))) + ((memq char chars) + (setq done t)) + ((and executing-kbd-macro (= char -1)) + ;; read-event returns -1 if we are in a kbd macro and + ;; there are no more events in the macro. Attempt to + ;; get an event interactively. + (setq executing-kbd-macro nil))))) + ;; Display the question with the answer. But without cursor-in-echo-area. (message "%s%s" prompt (char-to-string char)) char)) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index dfd12a005a9..7e9ce9aff6d 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -318,11 +318,12 @@ chapter." (defconst texinfo-environments '("cartouche" "copying" "defcv" "deffn" "defivar" "defmac" - "defmethod" "defop" "defopt" "defspec" "deftp" "deftypefn" - "deftypefun" "deftypevar" "deftypevr" "defun" "defvar" + "defmethod" "defop" "defopt" "defspec" "deftp" "deftypecv" + "deftypefn" "deftypefun" "deftypeivar" "deftypemethod" + "deftypeop" "deftypevar" "deftypevr" "defun" "defvar" "defvr" "description" "detailmenu" "direntry" "display" "documentdescription" "enumerate" "example" "flushleft" - "flushright" "format" "ftable" "group" "ifclear" "ifset" + "flushright" "format" "ftable" "group" "html" "ifclear" "ifset" "ifhtml" "ifinfo" "ifnothtml" "ifnotinfo" "ifnotplaintext" "ifnottex" "ifplaintext" "iftex" "ignore" "itemize" "lisp" "macro" "menu" "multitable" "quotation" "smalldisplay" diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index f55629b3ea1..50f20cea779 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -122,8 +122,7 @@ when editing big diffs)." ("\C-m" . diff-goto-source) ([mouse-2] . diff-goto-source) ;; From XEmacs' diff-mode. - ;; Standard M-w is useful, so don't change M-W. - ;;("W" . widen) + ("W" . widen) ;;("." . diff-goto-source) ;display-buffer ;;("f" . diff-goto-source) ;find-file ("o" . diff-goto-source) ;other-window @@ -135,17 +134,21 @@ when editing big diffs)." ;; Not useful if you have to metafy them. ;;(" " . scroll-up) ;;("\177" . scroll-down) - ;; Standard M-a is useful, so don't change M-A. - ;;("A" . diff-ediff-patch) - ;; Standard M-r is useful, so don't change M-r or M-R. - ;;("r" . diff-restrict-view) - ;;("R" . diff-reverse-direction) - ) + ("A" . diff-ediff-patch) + ("r" . diff-restrict-view) + ("R" . diff-reverse-direction)) "Basic keymap for `diff-mode', bound to various prefix keys." :inherit special-mode-map) (easy-mmode-defmap diff-mode-map - `(("\e" . ,diff-mode-shared-map) + `(("\e" . ,(let ((map (make-sparse-keymap))) + ;; We want to inherit most bindings from diff-mode-shared-map, + ;; but not all since they may hide useful M-<foo> global + ;; bindings when editing. + (set-keymap-parent map diff-mode-shared-map) + (dolist (key '("A" "r" "R" "g" "q" "W")) + (define-key map key nil)) + map)) ;; From compilation-minor-mode. ("\C-c\C-c" . diff-goto-source) ;; By analogy with the global C-x 4 a binding. diff --git a/lisp/vc/emerge.el b/lisp/vc/emerge.el index 601b6b1e597..5435a840ac9 100644 --- a/lisp/vc/emerge.el +++ b/lisp/vc/emerge.el @@ -3176,21 +3176,26 @@ See also `auto-save-file-name-p'." ;; Metacharacters that have to be protected from the shell when executing ;; a diff/diff3 command. -(defcustom emerge-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]" - "Characters that must be quoted with \\ when used in a shell command line. +(defcustom emerge-metachars + (if (memq system-type '(ms-dos windows-nt)) + "[ \t\"<>|?*^&=]" + "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]") + "Characters that must be quoted when used in a shell command line. More precisely, a [...] regexp to match any one such character." :type 'regexp :group 'emerge) ;; Quote metacharacters (using \) when executing a diff/diff3 command. (defun emerge-protect-metachars (s) - (let ((limit 0)) - (while (string-match emerge-metachars s limit) - (setq s (concat (substring s 0 (match-beginning 0)) - "\\" - (substring s (match-beginning 0)))) - (setq limit (1+ (match-end 0))))) - s) + (if (memq system-type '(ms-dos windows-nt)) + (shell-quote-argument s) + (let ((limit 0)) + (while (string-match emerge-metachars s limit) + (setq s (concat (substring s 0 (match-beginning 0)) + "\\" + (substring s (match-beginning 0)))) + (setq limit (1+ (match-end 0))))) + s)) (provide 'emerge) diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index a0a16601ed7..21cb86a9840 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -435,8 +435,13 @@ If any error occurred in running `bzr status', then return nil." (defun vc-bzr-state (file) (lexical-let ((result (vc-bzr-status file))) (when (consp result) - (when (cdr result) - (message "Warnings in `bzr' output: %s" (cdr result))) + (let ((warnings (cdr result))) + (when warnings + ;; bzr 2.3.0 returns info about shelves, which is not really a warning + (when (string-match "[1-9]+ shel\\(f\\|ves\\) exists?\\..*?\n" warnings) + (setq warnings (replace-match "" nil nil warnings))) + (unless (string= warnings "") + (message "Warnings in `bzr' output: %s" warnings)))) (cdr (assq (car result) '((added . added) (kindchanged . edited) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index d4970207b94..01b6f2fc26e 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -104,7 +104,7 @@ See `run-hooks'." ;; We pass a filename to create-file-buffer because it is what ;; the function expects, and also what uniquify needs (if active) (with-current-buffer (create-file-buffer (expand-file-name bname dir)) - (cd dir) + (setq default-directory dir) (vc-setup-buffer (current-buffer)) ;; Reset the vc-parent-buffer-name so that it does not appear ;; in the mode-line. @@ -1002,7 +1002,7 @@ specific headers." (generate-new-buffer (format " *VC-%s* tmp status" backend)))) (lexical-let ((buffer (current-buffer))) (with-current-buffer vc-dir-process-buffer - (cd def-dir) + (setq default-directory def-dir) (erase-buffer) (vc-call-backend backend 'dir-status-files def-dir files default-state @@ -1067,7 +1067,7 @@ Throw an error if another update process is in progress." (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) "") (lexical-let ((buffer (current-buffer))) (with-current-buffer vc-dir-process-buffer - (cd def-dir) + (setq default-directory def-dir) (erase-buffer) (vc-call-backend backend 'dir-status def-dir diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 3b4d0e5f421..711a573ba99 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -119,6 +119,12 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." :version "23.1" :group 'vc) +(defcustom vc-git-program "git" + "Name of the Git executable (excluding any arguments)." + :version "24.1" + :type 'string + :group 'vc) + (defcustom vc-git-root-log-format '("%d%h..: %an %ad %s" ;; The first shy group matches the characters drawn by --graph. @@ -554,7 +560,7 @@ or an empty string if none." "Return the existing branches, as a list of strings. The car of the list is the current branch." (with-temp-buffer - (call-process "git" nil t nil "branch") + (call-process vc-git-program nil t nil "branch") (goto-char (point-min)) (let (current-branch branches) (while (not (eobp)) @@ -633,13 +639,13 @@ for the Git command to run." (let* ((root (vc-git-root default-directory)) (buffer (format "*vc-git : %s*" (expand-file-name root))) (command "pull") - (git-program "git") + (git-program vc-git-program) args) ;; If necessary, prompt for the exact command. (when prompt (setq args (split-string (read-shell-command "Git pull command: " - "git pull" + (format "%s pull" git-program) 'vc-git-history) " " t)) (setq git-program (car args) @@ -663,7 +669,7 @@ This prompts for a branch to merge from." branches (cons "FETCH_HEAD" branches)) nil t))) - (apply 'vc-do-async-command buffer root "git" "merge" + (apply 'vc-do-async-command buffer root vc-git-program "merge" (list merge-source)) (vc-set-async-update buffer))) @@ -1083,8 +1089,10 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-command (buffer okstatus file-or-list &rest flags) "A wrapper around `vc-do-command' for use in vc-git.el. -The difference to vc-do-command is that this function always invokes `git'." - (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags)) +The difference to vc-do-command is that this function always invokes +`vc-git-program'." + (apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program + file-or-list flags)) (defun vc-git--empty-db-p () "Check if the git db is empty (no commit done yet)." @@ -1095,7 +1103,7 @@ The difference to vc-do-command is that this function always invokes `git'." ;; We don't need to care the arguments. If there is a file name, it ;; is always a relative one. This works also for remote ;; directories. - (apply 'process-file "git" nil buffer nil command args)) + (apply 'process-file vc-git-program nil buffer nil command args)) (defun vc-git--out-ok (command &rest args) (zerop (apply 'vc-git--call '(t nil) command args))) diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index d283c39362a..0516abbf024 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -529,9 +529,9 @@ REV is the revision to check out into WORKFILE." (insert (propertize (format " (%s %s)" (case (vc-hg-extra-fileinfo->rename-state extra) - ('copied "copied from") - ('renamed-from "renamed from") - ('renamed-to "renamed to")) + (copied "copied from") + (renamed-from "renamed from") + (renamed-to "renamed to")) (vc-hg-extra-fileinfo->extra-name extra)) 'face 'font-lock-comment-face))))) @@ -663,14 +663,15 @@ then attempts to update the working directory." (let* ((root (vc-hg-root default-directory)) (buffer (format "*vc-hg : %s*" (expand-file-name root))) (command "pull") - (hg-program "hg") + (hg-program vc-hg-program) ;; Fixme: before updating the working copy to the latest ;; state, should check if it's visiting an old revision. (args '("-u"))) ;; If necessary, prompt for the exact command. (when prompt (setq args (split-string - (read-shell-command "Run Hg (like this): " "hg pull -u" + (read-shell-command "Run Hg (like this): " + (format "%s pull -u" hg-program) 'vc-hg-history) " " t)) (setq hg-program (car args) @@ -685,7 +686,7 @@ then attempts to update the working directory." This runs the command \"hg merge\"." (let* ((root (vc-hg-root default-directory)) (buffer (format "*vc-hg : %s*" (expand-file-name root)))) - (apply 'vc-do-async-command buffer root "hg" '("merge")) + (apply 'vc-do-async-command buffer root vc-hg-program '("merge")) (vc-set-async-update buffer))) ;;; Internal functions diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 200291bd925..7f55ffdbdad 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -1115,9 +1115,12 @@ merge in the changes into your working copy." (dolist (file files) (unless (file-writable-p file) ;; Make the file+buffer read-write. - (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue?" file)) + (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue? " file)) (error "Aborted")) - (set-file-modes file (logior (file-modes file) 128)) + ;; Maybe we somehow lost permissions on the directory. + (condition-case nil + (set-file-modes file (logior (file-modes file) 128)) + (error (error "Unable to make file writable"))) (let ((visited (get-file-buffer file))) (when visited (with-current-buffer visited |