aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorStefan Monnier2011-03-21 12:42:16 -0400
committerStefan Monnier2011-03-21 12:42:16 -0400
commitcafdcef32d55cbb44389d7e322e7f973cbb72dfd (patch)
tree7ee0c41ea8a589650ce6f4311fb10e61a63807b9 /lisp
parenta08a25d7aaf251aa18f2ef747be53734bc55cae9 (diff)
parent4e05e67e4cd0bc1b0a4ef3176a4d0d91c6b3738e (diff)
downloademacs-cafdcef32d55cbb44389d7e322e7f973cbb72dfd.tar.gz
emacs-cafdcef32d55cbb44389d7e322e7f973cbb72dfd.zip
Merge from trunk
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog.trunk420
-rw-r--r--lisp/allout-widgets.el4
-rw-r--r--lisp/allout.el99
-rw-r--r--lisp/avoid.el16
-rw-r--r--lisp/calc/README2
-rw-r--r--lisp/calc/calc-ext.el31
-rw-r--r--lisp/calc/calc-help.el4
-rw-r--r--lisp/calc/calc-menu.el105
-rw-r--r--lisp/calc/calc-units.el114
-rw-r--r--lisp/calc/calc.el6
-rw-r--r--lisp/calendar/cal-hebrew.el12
-rw-r--r--lisp/calendar/time-date.el8
-rw-r--r--lisp/cus-edit.el6
-rw-r--r--lisp/cus-start.el6
-rw-r--r--lisp/cus-theme.el10
-rw-r--r--lisp/custom.el18
-rw-r--r--lisp/dired-aux.el5
-rw-r--r--lisp/dired.el3
-rw-r--r--lisp/ebuff-menu.el101
-rw-r--r--lisp/emacs-lisp/bytecomp.el14
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el8
-rw-r--r--lisp/emacs-lisp/ert.el9
-rw-r--r--lisp/emacs-lisp/package-x.el255
-rw-r--r--lisp/emacs-lisp/package.el177
-rw-r--r--lisp/eshell/esh-opt.el55
-rw-r--r--lisp/eshell/esh-util.el3
-rw-r--r--lisp/facemenu.el37
-rw-r--r--lisp/files.el10
-rw-r--r--lisp/font-lock.el2
-rw-r--r--lisp/gnus/ChangeLog228
-rw-r--r--lisp/gnus/auth-source.el314
-rw-r--r--lisp/gnus/gnus-art.el14
-rw-r--r--lisp/gnus/gnus-group.el33
-rw-r--r--lisp/gnus/gnus-int.el4
-rw-r--r--lisp/gnus/gnus-start.el26
-rw-r--r--lisp/gnus/gnus-sum.el56
-rw-r--r--lisp/gnus/gnus-sync.el12
-rw-r--r--lisp/gnus/gnus-util.el6
-rw-r--r--lisp/gnus/gnus-win.el6
-rw-r--r--lisp/gnus/gravatar.el6
-rw-r--r--lisp/gnus/gssapi.el105
-rw-r--r--lisp/gnus/message.el18
-rw-r--r--lisp/gnus/mm-uu.el8
-rw-r--r--lisp/gnus/nnimap.el68
-rw-r--r--lisp/gnus/shr.el15
-rw-r--r--lisp/gnus/sieve-manage.el7
-rw-r--r--lisp/help-fns.el1
-rw-r--r--lisp/help.el12
-rw-r--r--lisp/ido.el8
-rw-r--r--lisp/info.el10
-rw-r--r--lisp/mail/rmail.el4
-rw-r--r--lisp/minibuffer.el10
-rw-r--r--lisp/net/ldap.el43
-rw-r--r--lisp/net/quickurl.el10
-rw-r--r--lisp/net/rcirc.el7
-rw-r--r--lisp/net/tramp-sh.el42
-rw-r--r--lisp/net/trampver.el4
-rw-r--r--lisp/net/xesam.el8
-rw-r--r--lisp/notifications.el4
-rw-r--r--lisp/org/ChangeLog10
-rw-r--r--lisp/org/ob-exp.el14
-rw-r--r--lisp/org/ob-ref.el12
-rw-r--r--lisp/org/ob-sql.el22
-rw-r--r--lisp/org/org-freemind.el6
-rw-r--r--lisp/org/org-mouse.el10
-rw-r--r--lisp/org/org-plot.el24
-rw-r--r--lisp/org/org-src.el14
-rw-r--r--lisp/play/bubbles.el50
-rw-r--r--lisp/play/gamegrid.el10
-rw-r--r--lisp/play/morse.el108
-rw-r--r--lisp/progmodes/cc-cmds.el19
-rw-r--r--lisp/progmodes/compile.el49
-rw-r--r--lisp/progmodes/delphi.el75
-rw-r--r--lisp/progmodes/ebrowse.el12
-rw-r--r--lisp/progmodes/gdb-mi.el45
-rw-r--r--lisp/progmodes/gud.el4
-rw-r--r--lisp/progmodes/ruby-mode.el2
-rw-r--r--lisp/server.el8
-rw-r--r--lisp/shell.el22
-rw-r--r--lisp/simple.el6
-rw-r--r--lisp/startup.el45
-rw-r--r--lisp/subr.el36
-rw-r--r--lisp/textmodes/texinfo.el7
-rw-r--r--lisp/vc/diff-mode.el21
-rw-r--r--lisp/vc/emerge.el23
-rw-r--r--lisp/vc/vc-bzr.el9
-rw-r--r--lisp/vc/vc-dir.el6
-rw-r--r--lisp/vc/vc-git.el22
-rw-r--r--lisp/vc/vc-hg.el13
-rw-r--r--lisp/vc/vc.el7
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 @@
12011-03-21 Glenn Morris <rgm@gnu.org>
2
3 * eshell/esh-opt.el (eshell-eval-using-options, eshell-process-args):
4 Doc fixes.
5
62011-03-21 Chong Yidong <cyd@stupidchicken.com>
7
8 * cus-theme.el: Add missing provide statement.
9 (customize-create-theme): Extract theme value correctly.
10 (custom-theme-visit-theme): Autoload.
11 (customize-create-theme): Prompt before inserting default faces.
12
132011-03-20 Jay Belanger <jay.p.belanger@gmail.com>
14
15 * calc/calc-menu.el (calc-units-menu): Add entries for logarithmic
16 units and musical notes.
17
182011-03-20 Leo <sdl.web@gmail.com>
19
20 * ido.el (ido-read-internal): Use completing-read-default.
21 (ido-completing-read): Fix compatibility with completing-read.
22
232011-03-20 Christian Ohler <ohler@gnu.org>
24
25 * emacs-lisp/ert.el (ert-run-tests-batch): Remove unused variable.
26 (ert-delete-all-tests): Use `called-interactively-p' rather than
27 `interactive-p'.
28 (ert--make-xrefs-region): Respect END.
29
302011-03-19 Chong Yidong <cyd@stupidchicken.com>
31
32 * dired-aux.el (dired-create-directory): Signal an error if the
33 directory already exists (Bug#8246).
34
35 * facemenu.el (list-colors-display): Call list-faces-display
36 inside with-help-window.
37 (list-colors-print): Use display property to align the final
38 column, instead of checking window-width.
39
402011-03-19 Eli Zaretskii <eliz@gnu.org>
41
42 * emerge.el (emerge-metachars): Separate value for ms-dos and
43 windows-nt systems.
44 (emerge-protect-metachars): Quote correctly for ms-dos and
45 windows-nt systems.
46
472011-03-19 Ralph Schleicher <rs@ralph-schleicher.de>
48
49 * info.el (info-initialize): Replace all uses of `:' with
50 path-separator for compatibility with non-Unix systems.
51 Cache quoting of path-separator. (Bug#8258)
52
532011-03-19 Juanma Barranquero <lekktu@gmail.com>
54
55 * avoid.el (mouse-avoidance-mode, mouse-avoidance-nudge-dist)
56 (mouse-avoidance-threshold, mouse-avoidance-banish-destination)
57 (mouse-avoidance-mode): Fix typos in docstrings.
58
592011-03-19 Chong Yidong <cyd@stupidchicken.com>
60
61 * startup.el (package-subdirectory-regexp): Move from package.el.
62 Omit \\` and \\', and let callers add them.
63
64 * emacs-lisp/package.el (package-strip-version)
65 (package-load-all-descriptors): Add \\` and \\' to
66 package-subdirectory-regexp before using it.
67 (package-untar-buffer): New arg DIR; ensure that file untars only
68 into this expected directory. Remove superfluous delete-region.
69 (package-unpack): Caller changed.
70 (package-tar-file-info): Use package-subdirectory-regexp.
71
722011-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
73
74 * vc/diff-mode.el (diff-mode-map): Shadow problematic bindings from
75 diff-mode-shared-map (bug#8284).
76 (diff-mode-shared-map): Re-introduce some bindings that were problematic.
77
782011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
79
80 * calendar/time-date.el (format-seconds): Use assoc instead of
81 assoc-string, since assoc-string doesn't exist in XEmacs.
82
832011-03-17 Juanma Barranquero <lekktu@gmail.com>
84
85 * custom.el (custom-known-themes): Reflow docstring.
86 (custom-theme-load-path): Fix typo in docstring.
87 (load-theme): Fix typo in error message.
88 (custom-available-themes, custom-variable-theme-value):
89 Use `let', not `let*'.
90
912011-03-17 Jay Belanger <jay.p.belanger@gmail.com>
92
93 * calc/README: Mention inclusion of musical notes.
94
95 * calc/calc-units.el (calc-lu-quant): Rename from
96 `calc-logunits-quantity'.
97 (calcFunc-lupquant): Rename from `calcFunc-powerquant'.
98 (calcFunc-lufquant): Rename from `calcFunc-fieldquant'.
99 (calc-db): Rename from `calc-dblevel'.
100 (calcFunc-dbpower): Rename from `calcFunc-dbpowerlevel'.
101 (calcFunc-dbfield): Rename from `calcFunc-dbfieldlevel'.
102 (calc-np): Rename from `calc-nplevel'.
103 (calcFunc-nppower): Rename from `calcFunc-nppowerlevel'.
104 (calcFunc-npfield): Rename from `calcFunc-npfieldlevel'.
105 (calc-lu-plus): Rename from `calc-logunits-add'.
106 (calcFunc-lupadd): Rename from `calcFunc-lupoweradd'.
107 (calcFunc-lufadd): Rename from `calcFunc-lufieldadd'.
108 (calc-lu-minus): Rename from `calc-logunits-sub'.
109 (calcFunc-lupsub): Rename from `calcFunc-lupowersub'.
110 (calcFunc-lufsub): Rename from `calcFunc-lufieldsub'.
111 (calc-lu-times): Rename from `calc-logunits-mul'.
112 (calcFunc-lupmul): Rename from `calcFunc-lupowermul'.
113 (calcFunc-lufmul): Rename from `calcFunc-lufieldmul'.
114 (calc-lu-divide): Rename from `calc-logunits-div'.
115 (calcFunc-lupdiv): Rename from `calcFunc-lupowerdiv'.
116 (calcFunc-lufdiv): Rename from `calcFunc-lufielddiv'.
117
118 * calc/calc-ext.el (calc-init-extensions): Update the names of the
119 functions being autoloaded.
120
121 * calc/calc.el (calc-lu-power-reference): Rename from
122 `calc-logunits-power-reference'.
123 (calc-lu-field-reference): Rename from
124 `calc-logunits-field-reference'.
125
126 * calc/calc-help (calc-l-prefix-help): Mention musical note functions.
127
1282011-03-17 Stefan Monnier <monnier@iro.umontreal.ca>
129
130 * minibuffer.el (completion-all-sorted-completions):
131 Use :completion-cycle-penalty text property if present.
132
1332011-03-16 Ken Manheimer <ken.manheimer@gmail.com>
134
135 * allout.el (allout-yank-processing): Adjust for new rebulleting
136 regime so bullet being yanked is used without prompting the user
137 for a choice.
138
1392011-03-16 Juanma Barranquero <lekktu@gmail.com>
140
141 * startup.el (command-line): Warn the user that _emacs is deprecated.
142
1432011-03-16 Juanma Barranquero <lekktu@gmail.com>
144
145 * progmodes/delphi.el (delphi-search-path, delphi-indent-level)
146 (delphi-verbose, delphi-comment-face, delphi-string-face)
147 (delphi-keyword-face, delphi-ignore-changes, delphi-indent-line)
148 (delphi-mode-abbrev-table, delphi-debug-buffer, delphi-tab)
149 (delphi-find-unit, delphi-find-current-xdef, delphi-fill-comment)
150 (delphi-new-comment-line, delphi-font-lock-defaults)
151 (delphi-debug-mode-map, delphi-mode-syntax-table, delphi-mode):
152 Fix typos in docstrings.
153
1542011-03-15 Ken Manheimer <ken.manheimer@gmail.com>
155
156 * allout.el (allout-make-topic-prefix, allout-rebullet-heading):
157 Invert the roles of character and string values for INSTEAD, so a
158 string is used for the more common case of a defaulting prompt.
159
1602011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
161
162 * progmodes/ruby-mode.el (ruby-backward-sexp):
163 * progmodes/ebrowse.el (ebrowse-draw-file-member-info):
164 * play/gamegrid.el (gamegrid-make-face):
165 * play/bubbles.el (bubbles--grid-width, bubbles--grid-height)
166 (bubbles--colors, bubbles--shift-mode, bubbles--initialize-images):
167 * notifications.el (notifications-notify):
168 * net/xesam.el (xesam-search-engines):
169 * net/quickurl.el (quickurl-list-insert):
170 * vc/vc-hg.el (vc-hg-dir-printer): Fix use of case.
171
1722011-03-15 Chong Yidong <cyd@stupidchicken.com>
173
174 * startup.el (command-line): Update package subdirectory regexp.
175
1762011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
177
178 * allout.el (allout-abbreviate-flattened-numbering)
179 (allout-mode-deactivate-hook): Fix up obsolescence "date".
180
181 * subr.el (read-char-choice): Only show the cursor after the prompt,
182 not after the answer.
183
1842011-03-15 Kevin Ryde <user42@zip.com.au>
185
186 * help-fns.el (variable-at-point): Skip leading quotes, if any
187 (bug#8253).
188
1892011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
190
191 * emacs-lisp/bytecomp.el (byte-compile-save-excursion): Change the
192 warning message.
193
1942011-03-14 Michael Albinus <michael.albinus@gmx.de>
195
196 * shell.el (shell): When called interactively, offer to change the
197 shell file name on remote hosts.
198
1992011-03-13 Teodor Zlatanov <tzz@lifelogs.com>
200
201 * net/ldap.el (ldap-search-internal): Add `auth-source-search'
202 integration for LDAP parameters. The host, base, user or binddn,
203 and secret tokens can be specified in a netrc file, for instance.
204 This is optional because an `auth-source' parameter must be
205 specified in the search attributes.
206
2072011-03-13 Juanma Barranquero <lekktu@gmail.com>
208
209 * help.el (describe-mode): Link to the mode's definition (bug#8185).
210
2112011-03-12 Stefan Monnier <monnier@iro.umontreal.ca>
212
213 * ebuff-menu.el (electric-buffer-menu-mode-map): Move initialization
214 into declaration. Remove redundant and harmful binding.
215
2162011-03-12 Eli Zaretskii <eliz@gnu.org>
217
218 * files.el (file-ownership-preserved-p): Pass `integer' as an
219 explicit 2nd argument to `file-attributes'. If the file's owner
220 is the Administrators group on Windows, and the current user is
221 Administrator, consider that a match.
222
223 * server.el (server-ensure-safe-dir): Consider server directory
224 safe on MS-Windows if its owner is the Administrators group while
225 the current Emacs user is Administrator. Use `=' to compare
226 numerical UIDs, since they could be integers or floats.
227
2282011-03-12 Juanma Barranquero <lekktu@gmail.com>
229
230 * vc/vc-bzr.el (vc-bzr-state): Handle bzr 2.3.0 (follow-up to bug#8170).
231
2322011-03-12 Michael Albinus <michael.albinus@gmx.de>
233
234 Sync with Tramp 2.2.1.
235
236 * net/tramp-sh.el (tramp-methods): Exchange "%k" marker with options.
237
238 * net/trampver.el: Update release number.
239
2402011-03-12 Stefan Monnier <monnier@iro.umontreal.ca>
241
242 * progmodes/compile.el (compilation--previous-directory): Fix up
243 various nil/dead-marker mismatches (bug#8014).
244 (compilation-directory-properties, compilation-error-properties):
245 Don't call it at a position past the one we're about to change.
246
247 * emacs-lisp/bytecomp.el (byte-compile-make-obsolete-variable):
248 Disable obsolescence warnings in the file that declares it.
249
2502011-03-11 Ken Manheimer <ken.manheimer@gmail.com>
251
252 * allout-widgets.el (allout-widgets-tally): Initialize
253 allout-widgets-tally as a hash table rather than nil to prevent
254 mode-line redisplay warnings.
255 Also, clarify the module description and fix a comment typo.
256
2572011-03-11 Juanma Barranquero <lekktu@gmail.com>
258
259 * help-fns.el (describe-variable): Don't complete keywords.
260 Suggested by Teodor Zlatanov <tzz@lifelogs.com>.
261
2622011-03-10 Chong Yidong <cyd@stupidchicken.com>
263
264 * emacs-lisp/package.el (package-version-join): Impose a standard
265 string representation for pre/alpha/beta version lists.
266 (package-unpack-single): Standardize the directory name by passing
267 it through package-version-join.
268 (package-strip-rcs-id): Accept any version string that does not
269 signal an error in version-to-list.
270
2712011-03-10 Michael Albinus <michael.albinus@gmx.de>
272
273 * simple.el (delete-trailing-whitespace): Return nil for the
274 benefit of `write-file-functions'.
275
2762011-03-10 Glenn Morris <rgm@gnu.org>
277
278 * vc/vc-hg.el (vc-hg-pull, vc-hg-merge-branch): Use vc-hg-program.
279
280 * vc/vc-git.el (vc-git-program): New option.
281 (vc-git-branches, vc-git-pull, vc-git-merge-branch, vc-git-command)
282 (vc-git--call): Use it.
283
284 * eshell/esh-util.el (eshell-condition-case): Doc fix.
285
286 * cus-edit.el (Custom-newline): If no button at point, look
287 for a subgroup button at start-of-line. (Bug#2298)
288
289 * mail/rmail.el (rmail-msgend, rmail-msgbeg): Doc fixes.
290
2912011-03-10 Julien Danjou <julien@danjou.info>
292
293 * avoid.el (mouse-avoidance-ignore-p): Do not move the cursor if
294 `cursor-type' is nil.
295
2962011-03-09 Jay Belanger <jay.p.belanger@gmail.com>
297
298 * calc/calc.el (calc-mode-map): Don't bind "C-_" to `calc-missing-key'.
299
3002011-03-09 Ken Manheimer <ken.manheimer@gmail.com>
301
302 * allout.el Summary: Change so yank of distinctive-bullet items
303 preserves the existing header prefix, rebulleting it if necessary,
304 rather than replacing it. This is necessary for proper operation
305 of cooperative addons like allout-widgets.
306 (allout-make-topic-prefix, allout-rebullet-heading): Change
307 SOLICIT arg to INSTEAD, and interpret additionally a string value
308 as alternate bullet to be used, instead of prompting the user for
309 a bullet character.
310
3112011-03-09 Michael Albinus <michael.albinus@gmx.de>
312
313 * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band): Do
314 not use `tramp-file-name-port', because this returns also
315 `tramp-default-port'.
316
3172011-03-09 Deniz Dogan <deniz.a.m.dogan@gmail.com>
318
319 * net/rcirc.el (rcirc-handler-001): Remove useless
320 with-rcirc-process-buffer.
321 (rcirc-check-auth-status): Swap arguments to string-match.
322
3232011-03-09 Glenn Morris <rgm@gnu.org>
324
325 * shell.el (shell-mode):
326 Set comint-input-ring-size from HISTSIZE. (Bug#7889)
327
328 * progmodes/gdb-mi.el (gdb): Improve 2010-12-08 change.
329 Check for GDBHISTFILE, HISTSIZE, etc. (Bug#7889)
330
3312011-03-08 Chong Yidong <cyd@stupidchicken.com>
332
333 * emacs-lisp/package.el (package-refresh-contents)
334 (package-menu-execute): Use condition-case-no-debug.
335
3362011-03-08 Michael Albinus <michael.albinus@gmx.de>
337
338 * simple.el (shell-command-to-string): Use `process-file'.
339
340 * emacs-lisp/package.el (package-tar-file-info): Handle also
341 remote files.
342
343 * emacs-lisp/package-x.el (package-upload-buffer-internal): Use
344 `equal' for upload base check.
345
3462011-03-08 Arni Magnusson <arnima@hafro.is> (tiny change)
347
348 * textmodes/texinfo.el (texinfo-environments):
349 Add deftypecv, deftypeivar, deftypemethod, deftypeop, html. (Bug#2783)
350
3512011-03-08 Glenn Morris <rgm@gnu.org>
352
353 * cus-start.el (cursor-in-non-selected-windows):
354 Fix :set quoting oddness. (Bug#8192)
355
356 * font-lock.el (lisp-font-lock-keywords-1): Don't highlight `)'
357 in some setf expressions. (Bug#2159)
358
3592011-03-08 Chong Yidong <cyd@stupidchicken.com>
360
361 * custom.el (custom-available-themes): Return themes in
362 alphabetical order.
363
3642011-03-07 Chong Yidong <cyd@stupidchicken.com>
365
366 * progmodes/cc-cmds.el (c-beginning-of-statement): Fix incorrect
367 application of patch from Alan Mackenzie (Bug#7595).
368
3692011-03-07 Deniz Dogan <deniz.a.m.dogan@gmail.com>
370
371 * net/rcirc.el (rcirc-connect): Fix PASS bug.
372
3732011-03-07 Glenn Morris <rgm@gnu.org>
374
375 * vc/vc.el (vc-next-action): Add missing space to y-or-n-p prompt.
376 Give an explicit error if failed to make writable. (Bug#6146)
377
3782011-03-07 Ed Reingold <reingold@emr.cs.iit.edu>
379
380 * calendar/cal-hebrew.el (diary-hebrew-yahrzeit):
381 Add optional `after-sunset' argument. (Bug#8190)
382
3832011-03-07 Aaron S. Hawley <aaron.s.hawley@gmail.com>
384
385 * play/morse.el (nato-alphabet, nato-region, denato-region):
386 New variable and functions. (Bug#2288)
387 (morse-region, unmorse-region): Barf if read-only.
388
3892011-03-06 Stefan Monnier <monnier@iro.umontreal.ca>
390
391 * progmodes/gud.el (gdb-script-syntax-propertize-function):
392 Don't change the syntax of a \n that closes a comment (bug#8169).
393
3942011-03-06 Chong Yidong <cyd@stupidchicken.com>
395
396 * emacs-lisp/package-x.el (package-archive-upload-base): Make it a
397 defcustom.
398 (package--update-file): Doc fix. Accept relative file names.
399 (package--archive-contents-from-file): Remove the argument, since
400 it's necessarily always "archive-contents".
401 (package-maint-add-news-item): Pass relative file name args to
402 package--update-file.
403 (package-upload-buffer-internal): Prompt for a destination if
404 package-archive-upload-base is invalid. Create the directory if
405 it does not exist.
406 (package-upload-buffer, package-upload-file): Doc fix.
407
12011-03-06 Chong Yidong <cyd@stupidchicken.com> 4082011-03-06 Chong Yidong <cyd@stupidchicken.com>
2 409
3 * isearch.el (isearch-mode-map): Bind C-y to isearch-yank-kill, 410 * isearch.el (isearch-mode-map): Bind C-y to isearch-yank-kill,
@@ -11,8 +418,8 @@
11 418
122011-03-06 Jay Belanger <jay.p.belanger@gmail.com> 4192011-03-06 Jay Belanger <jay.p.belanger@gmail.com>
13 420
14 * calc/calc-ext.el (calc-init-extensions): Rename 421 * calc/calc-ext.el (calc-init-extensions):
15 calc-logunits-dblevel and calc-logunits-nplevel to calc-dblevel 422 Rename calc-logunits-dblevel and calc-logunits-nplevel to calc-dblevel
16 and calc-nplevel, respectively. Add keybindings for calc-spn, 423 and calc-nplevel, respectively. Add keybindings for calc-spn,
17 calc-midi and calc-freq. Add autoloads for calcFunc-spn, 424 calc-midi and calc-freq. Add autoloads for calcFunc-spn,
18 calcFunc-midi, calcFunc-freq, calc-spn, calc-midi and calc-freq. 425 calcFunc-midi, calcFunc-freq, calc-spn, calc-midi and calc-freq.
@@ -732,7 +1139,7 @@
7322011-02-17 Ken Manheimer <ken.manheimer@gmail.com> 11392011-02-17 Ken Manheimer <ken.manheimer@gmail.com>
733 1140
734 * lisp/allout-widgets.el (allout-widgets-icons-light-subdir) 1141 * lisp/allout-widgets.el (allout-widgets-icons-light-subdir)
735 (allout-widgets-icons-dark-subdir): Track relocations of icons 1142 (allout-widgets-icons-dark-subdir): Track relocations of icons.
736 * lisp/allout.el: Remove commentary about remove encryption 1143 * lisp/allout.el: Remove commentary about remove encryption
737 passphrase mnemonic support and verification. 1144 passphrase mnemonic support and verification.
738 (allout-encrypt-string): Recognize epg failure to decrypt gpg2 1145 (allout-encrypt-string): Recognize epg failure to decrypt gpg2
@@ -1109,10 +1516,9 @@
1109 1516
1110 (allout-auto-activation-helper, allout-setup): New autoloads 1517 (allout-auto-activation-helper, allout-setup): New autoloads
1111 implement new custom set procedure for allout-auto-activation. 1518 implement new custom set procedure for allout-auto-activation.
1112 Also, explicitly invoke 1519 Also, explicitly invoke (allout-setup) after allout-auto-activation
1113 (allout-setup) after allout-auto-activation is custom-defined, to 1520 is custom-defined, to affect the settings in emacs sessions besides
1114 effect the settings in emacs sessions besides the few where 1521 the few where allout-auto-activation customization is done.
1115 allout-auto-activation customization is donea.
1116 (allout-auto-activation): Use allout-auto-activation-helper to 1522 (allout-auto-activation): Use allout-auto-activation-helper to
1117 :set. Revise the docstring. 1523 :set. Revise the docstring.
1118 (allout-init): Reduce functionality to just customizing 1524 (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 @@
1;; allout-widgets.el --- Show allout outline structure with graphical widgets. 1;; allout-widgets.el --- Visually highlight allout outline structure.
2 2
3;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Ken Manheimer 3;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Ken Manheimer
4 4
@@ -238,7 +238,7 @@ buffer, and tracking increases as new widgets are added and
238decreases as obsolete widgets are garbage collected." 238decreases as obsolete widgets are garbage collected."
239 :type 'boolean 239 :type 'boolean
240 :group 'allout-widgets-developer) 240 :group 'allout-widgets-developer)
241(defvar allout-widgets-tally nil 241(defvar allout-widgets-tally (make-hash-table :test 'eq :weakness 'key)
242 "Hash-table of existing allout widgets, for debugging. 242 "Hash-table of existing allout widgets, for debugging.
243 243
244Table is maintained iff `allout-widgets-maintain-tally' is non-nil. 244Table 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.
310 310
311With value nil, inhibit any automatic allout-mode activation." 311With value nil, inhibit any automatic allout-mode activation."
312 :set 'allout-auto-activation-helper 312 :set 'allout-auto-activation-helper
313 ;; FIXME: Using strings here is unusual and less efficient than symbols.
313 :type '(choice (const :tag "On" t) 314 :type '(choice (const :tag "On" t)
314 (const :tag "Ask about layout" "ask") 315 (const :tag "Ask about layout" "ask")
315 (const :tag "Mode only" "activate") 316 (const :tag "Mode only" "activate")
@@ -752,7 +753,7 @@ Set this var to the bullet you want to use for file cross-references."
752 753
753;;;_ = allout-flattened-numbering-abbreviation 754;;;_ = allout-flattened-numbering-abbreviation
754(define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering 755(define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering
755 'allout-flattened-numbering-abbreviation "24.0") 756 'allout-flattened-numbering-abbreviation "24.1")
756(defcustom allout-flattened-numbering-abbreviation nil 757(defcustom allout-flattened-numbering-abbreviation nil
757 "If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic 758 "If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic
758numbers to minimal amount with some context. Otherwise, entire 759numbers to minimal amount with some context. Otherwise, entire
@@ -1402,7 +1403,7 @@ their settings before allout-mode was started."
1402(defvar allout-mode-deactivate-hook nil 1403(defvar allout-mode-deactivate-hook nil
1403 "*Hook that's run when allout mode ends.") 1404 "*Hook that's run when allout mode ends.")
1404(define-obsolete-variable-alias 'allout-mode-deactivate-hook 1405(define-obsolete-variable-alias 'allout-mode-deactivate-hook
1405 'allout-mode-off-hook "future") 1406 'allout-mode-off-hook "24.1")
1406;;;_ = allout-exposure-category 1407;;;_ = allout-exposure-category
1407(defvar allout-exposure-category nil 1408(defvar allout-exposure-category nil
1408 "Symbol for use as allout invisible-text overlay category.") 1409 "Symbol for use as allout invisible-text overlay category.")
@@ -3465,13 +3466,13 @@ Offer one suitable for current depth DEPTH as default."
3465(defun allout-make-topic-prefix (&optional prior-bullet 3466(defun allout-make-topic-prefix (&optional prior-bullet
3466 new 3467 new
3467 depth 3468 depth
3468 solicit 3469 instead
3469 number-control 3470 number-control
3470 index) 3471 index)
3471 ;; Depth null means use current depth, non-null means we're either 3472 ;; Depth null means use current depth, non-null means we're either
3472 ;; opening a new topic after current topic, lower or higher, or we're 3473 ;; opening a new topic after current topic, lower or higher, or we're
3473 ;; changing level of current topic. 3474 ;; changing level of current topic.
3474 ;; Solicit dominates specified bullet-char. 3475 ;; Instead dominates specified bullet-char.
3475;;;_ . Doc string: 3476;;;_ . Doc string:
3476 "Generate a topic prefix suitable for optional arg DEPTH, or current depth. 3477 "Generate a topic prefix suitable for optional arg DEPTH, or current depth.
3477 3478
@@ -3492,15 +3493,18 @@ bullet or previous sibling.
3492Third arg DEPTH forces the topic prefix to that depth, regardless of 3493Third arg DEPTH forces the topic prefix to that depth, regardless of
3493the current topics' depth. 3494the current topics' depth.
3494 3495
3495If SOLICIT is non-nil, then the choice of bullet is solicited from 3496If INSTEAD is:
3496user. If it's a character, then that character is offered as the 3497
3497default, otherwise the one suited to the context (according to 3498- nil, then the bullet char for the context is used, per distinction or depth
3498distinction or depth) is offered. (This overrides other options, 3499- a \(numeric) character, then character's string representation is used
3499including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the 3500- a string, then the user is asked for bullet with the first char as default
3500context-specific bullet is used. 3501- anything else, the user is solicited with bullet char per context as default
3502
3503\(INSTEAD overrides other options, including, eg, a distinctive
3504PRIOR-BULLET.)
3501 3505
3502Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet' 3506Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet'
3503is non-nil *and* soliciting was not explicitly invoked. Then 3507is non-nil *and* no specific INSTEAD was specified. Then
3504NUMBER-CONTROL non-nil forces prefix to either numbered or 3508NUMBER-CONTROL non-nil forces prefix to either numbered or
3505denumbered format, depending on the value of the sixth arg, INDEX. 3509denumbered format, depending on the value of the sixth arg, INDEX.
3506 3510
@@ -3549,8 +3553,13 @@ index for each successive sibling)."
3549 ;; Solicitation overrides numbering and other cases: 3553 ;; Solicitation overrides numbering and other cases:
3550 ((progn (setq body (make-string (- depth 2) ?\ )) 3554 ((progn (setq body (make-string (- depth 2) ?\ ))
3551 ;; The actual condition: 3555 ;; The actual condition:
3552 solicit) 3556 instead)
3553 (let* ((got (allout-solicit-alternate-bullet depth solicit))) 3557 (let ((got (cond ((stringp instead)
3558 (if (> (length instead) 0)
3559 (allout-solicit-alternate-bullet
3560 depth (substring instead 0 1))))
3561 ((characterp instead) (char-to-string instead))
3562 (t (allout-solicit-alternate-bullet depth)))))
3554 ;; Gotta check whether we're numbering and got a numbered bullet: 3563 ;; Gotta check whether we're numbering and got a numbered bullet:
3555 (setq numbering (and allout-numbered-bullet 3564 (setq numbering (and allout-numbered-bullet
3556 (not (and number-control (not index))) 3565 (not (and number-control (not index)))
@@ -3913,7 +3922,7 @@ Note that refill of indented paragraphs is not done."
3913 (allout-end-of-prefix) 3922 (allout-end-of-prefix)
3914 (setq from allout-recent-prefix-beginning 3923 (setq from allout-recent-prefix-beginning
3915 to allout-recent-prefix-end) 3924 to allout-recent-prefix-end)
3916 (allout-rebullet-heading t ;;; solicit 3925 (allout-rebullet-heading t ;;; instead
3917 nil ;;; depth 3926 nil ;;; depth
3918 nil ;;; number-control 3927 nil ;;; number-control
3919 nil ;;; index 3928 nil ;;; index
@@ -3931,8 +3940,8 @@ Note that refill of indented paragraphs is not done."
3931 (message "Done.") 3940 (message "Done.")
3932 (cond (on-bullet (goto-char (allout-current-bullet-pos))) 3941 (cond (on-bullet (goto-char (allout-current-bullet-pos)))
3933 (initial-col (move-to-column initial-col))))) 3942 (initial-col (move-to-column initial-col)))))
3934;;;_ > allout-rebullet-heading (&optional solicit ...) 3943;;;_ > allout-rebullet-heading (&optional instead ...)
3935(defun allout-rebullet-heading (&optional solicit 3944(defun allout-rebullet-heading (&optional instead
3936 new-depth 3945 new-depth
3937 number-control 3946 number-control
3938 index 3947 index
@@ -3942,11 +3951,11 @@ Note that refill of indented paragraphs is not done."
3942 3951
3943All args are optional. 3952All args are optional.
3944 3953
3945If SOLICIT is non-nil, then the choice of bullet is solicited from 3954If INSTEAD is:
3946user. If it's a character, then that character is offered as the 3955- nil, then the bullet char for the context is used, per distinction or depth
3947default, otherwise the one suited to the context (according to 3956- a \(numeric) character, then character's string representation is used
3948distinction or depth) is offered. If non-nil, then the 3957- a string, then the user is asked for bullet with the first char as default
3949context-specific bullet is just used. 3958- anything else, the user is solicited with bullet char per context as default
3950 3959
3951Second arg DEPTH forces the topic prefix to that depth, regardless 3960Second arg DEPTH forces the topic prefix to that depth, regardless
3952of the topic's current depth. 3961of the topic's current depth.
@@ -3981,7 +3990,7 @@ this function."
3981 (new-prefix (allout-make-topic-prefix current-bullet 3990 (new-prefix (allout-make-topic-prefix current-bullet
3982 nil 3991 nil
3983 new-depth 3992 new-depth
3984 solicit 3993 instead
3985 number-control 3994 number-control
3986 index))) 3995 index)))
3987 3996
@@ -4028,7 +4037,7 @@ this function."
4028 (cond ((numberp index) (1+ index)) 4037 (cond ((numberp index) (1+ index))
4029 ((not number-control) (allout-sibling-index)))) 4038 ((not number-control) (allout-sibling-index))))
4030 (if (allout-numbered-type-prefix) 4039 (if (allout-numbered-type-prefix)
4031 (allout-rebullet-heading nil ;;; solicit 4040 (allout-rebullet-heading nil ;;; instead
4032 new-depth ;;; new-depth 4041 new-depth ;;; new-depth
4033 number-control;;; number-control 4042 number-control;;; number-control
4034 index ;;; index 4043 index ;;; index
@@ -4145,7 +4154,7 @@ a topic and its immediate offspring is greater than one.)"
4145 (when (< relative-depth 0) 4154 (when (< relative-depth 0)
4146 (save-excursion 4155 (save-excursion
4147 (goto-char local-point) 4156 (goto-char local-point)
4148 (allout-rebullet-heading nil ;;; solicit 4157 (allout-rebullet-heading nil ;;; instead
4149 (+ starting-depth relative-depth) 4158 (+ starting-depth relative-depth)
4150 nil ;;; number 4159 nil ;;; number
4151 starting-index 4160 starting-index
@@ -4203,7 +4212,7 @@ Returns final depth."
4203 ; Prime ascender for ascension: 4212 ; Prime ascender for ascension:
4204 (setq ascender (1- allout-recent-depth)) 4213 (setq ascender (1- allout-recent-depth))
4205 (if (>= allout-recent-depth depth) 4214 (if (>= allout-recent-depth depth)
4206 (allout-rebullet-heading nil ;;; solicit 4215 (allout-rebullet-heading nil ;;; instead
4207 nil ;;; depth 4216 nil ;;; depth
4208 nil ;;; number-control 4217 nil ;;; number-control
4209 nil ;;; index 4218 nil ;;; index
@@ -4230,7 +4239,7 @@ rebulleting each topic at this level."
4230 (use-bullet (equal '(16) denumber)) 4239 (use-bullet (equal '(16) denumber))
4231 (more t)) 4240 (more t))
4232 (while more 4241 (while more
4233 (allout-rebullet-heading use-bullet ;;; solicit 4242 (allout-rebullet-heading use-bullet ;;; instead
4234 depth ;;; depth 4243 depth ;;; depth
4235 t ;;; number-control 4244 t ;;; number-control
4236 index ;;; index 4245 index ;;; index
@@ -4577,32 +4586,20 @@ however, are left exactly like normal, non-allout-specific yanks."
4577 (progn (widen) 4586 (progn (widen)
4578 (forward-char -1) 4587 (forward-char -1)
4579 (narrow-to-region subj-beg (point)))))) 4588 (narrow-to-region subj-beg (point))))))
4580 ;; Preserve new bullet if it's a distinctive one, otherwise 4589 ;; Remove new heading prefix:
4581 ;; use old one: 4590 (allout-unprotected
4582 (if (string-match (regexp-quote prefix-bullet) 4591 (progn
4583 allout-distinctive-bullets-string) 4592 (delete-region (point) (+ (point)
4584 ; Delete from bullet of old to 4593 prefix-len
4585 ; before bullet of new: 4594 (- adjust-to-depth
4586 (progn 4595 subj-depth)))
4587 (beginning-of-line)
4588 (allout-unprotected
4589 (delete-region (point) subj-beg))
4590 (set-marker (allout-mark-marker t) subj-end)
4591 (goto-char subj-beg)
4592 (allout-end-of-prefix))
4593 ; Delete base subj prefix,
4594 ; leaving old one:
4595 (allout-unprotected
4596 (progn
4597 (delete-region (point) (+ (point)
4598 prefix-len
4599 (- adjust-to-depth
4600 subj-depth)))
4601 ; and delete residual subj 4596 ; and delete residual subj
4602 ; prefix digits and space: 4597 ; prefix digits and space:
4603 (while (looking-at "[0-9]") (delete-char 1)) 4598 (while (looking-at "[0-9]") (delete-char 1))
4604 (if (looking-at " ") 4599 (if (looking-at " ")
4605 (delete-char 1)))))) 4600 (delete-char 1))))
4601 ;; Assert new topic's bullet - minimal effort if unchanged:
4602 (allout-rebullet-heading (string-to-char prefix-bullet)))
4606 (exchange-point-and-mark)))) 4603 (exchange-point-and-mark))))
4607 (if rectify-numbering 4604 (if rectify-numbering
4608 (progn 4605 (progn
@@ -4613,7 +4610,7 @@ however, are left exactly like normal, non-allout-specific yanks."
4613 (goto-char subj-beg) 4610 (goto-char subj-beg)
4614 (if (allout-goto-prefix-doublechecked) 4611 (if (allout-goto-prefix-doublechecked)
4615 (allout-unprotected 4612 (allout-unprotected
4616 (allout-rebullet-heading nil ;;; solicit 4613 (allout-rebullet-heading nil ;;; instead
4617 (allout-depth) ;;; depth 4614 (allout-depth) ;;; depth
4618 nil ;;; number-control 4615 nil ;;; number-control
4619 nil ;;; index 4616 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 @@
76 76
77;;;###autoload 77;;;###autoload
78(defcustom mouse-avoidance-mode nil 78(defcustom mouse-avoidance-mode nil
79 "Activate mouse avoidance mode. 79 "Activate Mouse Avoidance mode.
80See function `mouse-avoidance-mode' for possible values. 80See function `mouse-avoidance-mode' for possible values.
81Setting this variable directly does not take effect; 81Setting this variable directly does not take effect;
82use either \\[customize] or the function `mouse-avoidance-mode'." 82use either \\[customize] or the function `mouse-avoidance-mode'."
@@ -85,8 +85,7 @@ use either \\[customize] or the function `mouse-avoidance-mode'."
85 (mouse-avoidance-mode (or value 'none))) 85 (mouse-avoidance-mode (or value 'none)))
86 :initialize 'custom-initialize-default 86 :initialize 'custom-initialize-default
87 :type '(choice (const :tag "none" nil) (const banish) (const jump) 87 :type '(choice (const :tag "none" nil) (const banish) (const jump)
88 (const animate) (const exile) (const proteus) 88 (const animate) (const exile) (const proteus))
89 )
90 :group 'avoid 89 :group 'avoid
91 :require 'avoid 90 :require 'avoid
92 :version "20.3") 91 :version "20.3")
@@ -94,7 +93,7 @@ use either \\[customize] or the function `mouse-avoidance-mode'."
94 93
95(defcustom mouse-avoidance-nudge-dist 15 94(defcustom mouse-avoidance-nudge-dist 15
96 "Average distance that mouse will be moved when approached by cursor. 95 "Average distance that mouse will be moved when approached by cursor.
97Only applies in Mouse-Avoidance mode `jump' and its derivatives. 96Only applies in Mouse Avoidance mode `jump' and its derivatives.
98For best results make this larger than `mouse-avoidance-threshold'." 97For best results make this larger than `mouse-avoidance-threshold'."
99 :type 'integer 98 :type 'integer
100 :group 'avoid) 99 :group 'avoid)
@@ -112,7 +111,7 @@ For best results make this larger than `mouse-avoidance-threshold'."
112(defcustom mouse-avoidance-threshold 5 111(defcustom mouse-avoidance-threshold 5
113 "Mouse-pointer's flight distance. 112 "Mouse-pointer's flight distance.
114If the cursor gets closer than this, the mouse pointer will move away. 113If the cursor gets closer than this, the mouse pointer will move away.
115Only applies in mouse-avoidance-modes `animate' and `jump'." 114Only applies in Mouse Avoidance modes `animate' and `jump'."
116 :type 'integer 115 :type 'integer
117 :group 'avoid) 116 :group 'avoid)
118 117
@@ -183,7 +182,7 @@ Acceptable distance is defined by `mouse-avoidance-threshold'."
183 mouse-avoidance-threshold)))))) 182 mouse-avoidance-threshold))))))
184 183
185(defun mouse-avoidance-banish-destination () 184(defun mouse-avoidance-banish-destination ()
186 "The position to which Mouse-Avoidance mode `banish' moves the mouse. 185 "The position to which Mouse Avoidance mode `banish' moves the mouse.
187You can redefine this if you want the mouse banished to a different corner." 186You can redefine this if you want the mouse banished to a different corner."
188 (let* ((pos (window-edges))) 187 (let* ((pos (window-edges)))
189 (cons (- (nth 2 pos) 2) 188 (cons (- (nth 2 pos) 2)
@@ -278,6 +277,7 @@ redefine this function to suit your own tastes."
278(defun mouse-avoidance-ignore-p () 277(defun mouse-avoidance-ignore-p ()
279 (let ((mp (mouse-position))) 278 (let ((mp (mouse-position)))
280 (or (not (frame-pointer-visible-p)) ; The pointer is hidden 279 (or (not (frame-pointer-visible-p)) ; The pointer is hidden
280 (not cursor-type) ; There's no cursor
281 executing-kbd-macro ; don't check inside macro 281 executing-kbd-macro ; don't check inside macro
282 (null (cadr mp)) ; don't move unless in an Emacs frame 282 (null (cadr mp)) ; don't move unless in an Emacs frame
283 (not (eq (car mp) (selected-frame))) 283 (not (eq (car mp) (selected-frame)))
@@ -332,7 +332,7 @@ redefine this function to suit your own tastes."
332 332
333;;;###autoload 333;;;###autoload
334(defun mouse-avoidance-mode (&optional mode) 334(defun mouse-avoidance-mode (&optional mode)
335 "Set cursor avoidance mode to MODE. 335 "Set Mouse Avoidance mode to MODE.
336MODE should be one of the symbols `banish', `exile', `jump', `animate', 336MODE should be one of the symbols `banish', `exile', `jump', `animate',
337`cat-and-mouse', `proteus', or `none'. 337`cat-and-mouse', `proteus', or `none'.
338 338
@@ -352,7 +352,7 @@ Effects of the different modes:
352 352
353Whenever the mouse is moved, the frame is also raised. 353Whenever the mouse is moved, the frame is also raised.
354 354
355\(see `mouse-avoidance-threshold' for definition of \"too close\", 355\(See `mouse-avoidance-threshold' for definition of \"too close\",
356and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for 356and `mouse-avoidance-nudge-dist' and `mouse-avoidance-nudge-var' for
357definition of \"random distance\".)" 357definition of \"random distance\".)"
358 (interactive 358 (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"
72 72
73Emacs 24.1 73Emacs 24.1
74 74
75* Support for musical notes added.
76
75* Support for logarithmic units added. 77* Support for logarithmic units added.
76 78
77* Calc no longer uses the tex prefix for TeX specific unit 79* 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 @@
422 (define-key calc-mode-map "kT" 'calc-utpt) 422 (define-key calc-mode-map "kT" 'calc-utpt)
423 423
424 (define-key calc-mode-map "l" nil) 424 (define-key calc-mode-map "l" nil)
425 (define-key calc-mode-map "lq" 'calc-logunits-quantity) 425 (define-key calc-mode-map "lq" 'calc-lu-quant)
426 (define-key calc-mode-map "ld" 'calc-dblevel) 426 (define-key calc-mode-map "ld" 'calc-db)
427 (define-key calc-mode-map "ln" 'calc-nplevel) 427 (define-key calc-mode-map "ln" 'calc-np)
428 (define-key calc-mode-map "l+" 'calc-logunits-add) 428 (define-key calc-mode-map "l+" 'calc-lu-plus)
429 (define-key calc-mode-map "l-" 'calc-logunits-sub) 429 (define-key calc-mode-map "l-" 'calc-lu-minus)
430 (define-key calc-mode-map "l*" 'calc-logunits-mul) 430 (define-key calc-mode-map "l*" 'calc-lu-times)
431 (define-key calc-mode-map "l/" 'calc-logunits-divide) 431 (define-key calc-mode-map "l/" 'calc-lu-divide)
432 (define-key calc-mode-map "ls" 'calc-spn) 432 (define-key calc-mode-map "ls" 'calc-spn)
433 (define-key calc-mode-map "lm" 'calc-midi) 433 (define-key calc-mode-map "lm" 'calc-midi)
434 (define-key calc-mode-map "lf" 'calc-freq) 434 (define-key calc-mode-map "lf" 'calc-freq)
@@ -943,12 +943,11 @@ calc-store-value calc-var-name)
943 ("calc-stuff" calc-explain-why calcFunc-clean 943 ("calc-stuff" calc-explain-why calcFunc-clean
944calcFunc-pclean calcFunc-pfloat calcFunc-pfrac) 944calcFunc-pclean calcFunc-pfloat calcFunc-pfrac)
945 945
946 ("calc-units" calcFunc-usimplify calcFunc-lufieldadd 946 ("calc-units" calcFunc-usimplify calcFunc-lufadd calcFunc-lupadd
947calcFunc-lupoweradd calcFunc-lufieldsub calcFunc-lupowersub 947calcFunc-lufsub calcFunc-lupsub calcFunc-lufmul calcFunc-lupmul
948calcFunc-lufieldmul calcFunc-lupowermul calcFunc-lufielddiv 948calcFunc-lufdiv calcFunc-lupdiv calcFunc-lufquant calcFunc-lupquant
949calcFunc-lupowerdiv calcFunc-fieldquant calcFunc-powerquant 949calcFunc-dbfield calcFunc-dbpower calcFunc-npfield
950calcFunc-dbfieldlevel calcFunc-dbpowerlevel calcFunc-npfieldlevel 950calcFunc-nppower calcFunc-spn calcFunc-midi calcFunc-freq
951calcFunc-nppowerlevel calcFunc-spn calcFunc-midi calcFunc-freq
952math-build-units-table math-build-units-table-buffer 951math-build-units-table math-build-units-table-buffer
953math-check-unit-name math-convert-temperature math-convert-units 952math-check-unit-name math-convert-temperature math-convert-units
954math-extract-units math-remove-units math-simplify-units 953math-extract-units math-remove-units math-simplify-units
@@ -1180,9 +1179,9 @@ calc-convert-temperature calc-convert-units calc-define-unit
1180calc-enter-units-table calc-explain-units calc-extract-units 1179calc-enter-units-table calc-explain-units calc-extract-units
1181calc-get-unit-definition calc-permanent-units calc-quick-units 1180calc-get-unit-definition calc-permanent-units calc-quick-units
1182calc-remove-units calc-simplify-units calc-undefine-unit 1181calc-remove-units calc-simplify-units calc-undefine-unit
1183calc-view-units-table calc-logunits-quantity calc-dblevel 1182calc-view-units-table calc-lu-quant calc-db
1184calc-nplevel calc-logunits-add calc-logunits-sub 1183calc-np calc-lu-plus calc-lu-minus
1185calc-logunits-mul calc-logunits-divide calc-spn calc-midi 1184calc-lu-times calc-lu-divide calc-spn calc-midi
1186calc-freq) 1185calc-freq)
1187 1186
1188 ("calc-vec" calc-arrange-vector calc-build-vector calc-cnorm 1187 ("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."
673 (interactive) 673 (interactive)
674 (calc-do-prefix-help 674 (calc-do-prefix-help
675 '("Quantity, DB level, Np level" 675 '("Quantity, DB level, Np level"
676 "+, -, *, /") 676 "+, -, *, /"
677 "Scientific pitch notation, Midi number, Frequency"
678 )
677 "log units" ?l)) 679 "log units" ?l))
678 680
679(defun calc-v-prefix-help () 681(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 @@
960 (require 'calc-units) 960 (require 'calc-units)
961 (call-interactively 'calc-view-units-table)) 961 (call-interactively 'calc-view-units-table))
962 :keys "u V"] 962 :keys "u V"]
963 (list "Logarithmic Units"
964 ["Convert (1:) to dB (power)"
965 (progn
966 (require 'calc-units)
967 (call-interactively 'calc-db))
968 :keys "l d"
969 :active (>= (calc-stack-size) 1)]
970 ["Convert (2:) to dB (power) with reference level (1:)"
971 (progn
972 (require 'calc-units)
973 (let ((calc-option-flag t))
974 (call-interactively 'calc-db)))
975 :keys "O l d"
976 :active (>= (calc-stack-size) 2)]
977 ["Convert (1:) to Np (power)"
978 (progn
979 (require 'calc-units)
980 (call-interactively 'calc-np))
981 :keys "l n"
982 :active (>= (calc-stack-size) 1)]
983 ["Convert (2:) to Np (power) with reference level (1:)"
984 (progn
985 (require 'calc-units)
986 (let ((calc-option-flag t))
987 (call-interactively 'calc-np)))
988 :keys "O l n"
989 :active (>= (calc-stack-size) 2)]
990 ["Convert (1:) to power quantity"
991 (progn
992 (require 'calc-units)
993 (call-interactively 'calc-lu-quant))
994 :keys "l q"
995 :active (>= (calc-stack-size) 1)]
996 ["Convert (2:) to power quantity with reference level (1:)"
997 (progn
998 (require 'calc-units)
999 (let ((calc-option-flag t))
1000 (call-interactively 'calc-lu-quant)))
1001 :keys "O l q"
1002 :active (>= (calc-stack-size) 2)]
1003 "----"
1004 ["Convert (1:) to dB (field)"
1005 (progn
1006 (require 'calc-units)
1007 (let ((calc-hyperbolic-flag t))
1008 (call-interactively 'calc-db)))
1009 :keys "H l d"
1010 :active (>= (calc-stack-size) 1)]
1011 ["Convert (2:) to dB (field) with reference level (1:)"
1012 (progn
1013 (require 'calc-units)
1014 (let ((calc-option-flag t)
1015 (calc-hyperbolic-flag t))
1016 (call-interactively 'calc-db)))
1017 :keys "O H l d"
1018 :active (>= (calc-stack-size) 2)]
1019 ["Convert (1:) to Np (field)"
1020 (progn
1021 (require 'calc-units)
1022 (let ((calc-hyperbolic-flag t))
1023 (call-interactively 'calc-np)))
1024 :keys "H l n"
1025 :active (>= (calc-stack-size) 1)]
1026 ["Convert (2:) to Np (field) with reference level (1:)"
1027 (progn
1028 (require 'calc-units)
1029 (let ((calc-option-flag t)
1030 (calc-hyperbolic-flag t))
1031 (call-interactively 'calc-np)))
1032 :keys "O H l d"
1033 :active (>= (calc-stack-size) 2)]
1034 ["Convert (1:) to field quantity"
1035 (progn
1036 (require 'calc-units)
1037 (let ((calc-hyperbolic-flag t))
1038 (call-interactively 'calc-lu-quant)))
1039 :keys "H l q"
1040 :active (>= (calc-stack-size) 1)]
1041 ["Convert (2:) to field quantity with reference level (1:)"
1042 (progn
1043 (require 'calc-units)
1044 (let ((calc-option-flag t)
1045 (calc-hyperbolic-flag))
1046 (call-interactively 'calc-lu-quant)))
1047 :keys "O H l q"
1048 :active (>= (calc-stack-size) 2)])
1049 (list "Musical Notes"
1050 ["Convert (1:) to scientific pitch notation"
1051 (progn
1052 (require 'calc-units)
1053 (call-interactively 'calc-spn))
1054 :keys "l s"
1055 :active (>= (calc-stack-size) 1)]
1056 ["Convert (1:) to midi number"
1057 (progn
1058 (require 'calc-units)
1059 (call-interactively 'calc-midi))
1060 :keys "l m"
1061 :active (>= (calc-stack-size) 1)]
1062 ["Convert (1:) to frequency"
1063 (progn
1064 (require 'calc-units)
1065 (call-interactively 'calc-freq))
1066 :keys "l f"
1067 :active (>= (calc-stack-size) 1)])
963 "----" 1068 "----"
964 ["Help on Units" 1069 ["Help on Units"
965 (calc-info-goto-node "Units")]) 1070 (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)."
1623 coef))) 1623 coef)))
1624 units))))))) 1624 units)))))))
1625 1625
1626(defun calcFunc-lufieldplus (a b) 1626(defun calcFunc-lufadd (a b)
1627 (math-logunits-add a b nil nil)) 1627 (math-logunits-add a b nil nil))
1628 1628
1629(defun calcFunc-lupowerplus (a b) 1629(defun calcFunc-lupadd (a b)
1630 (math-logunits-add a b nil t)) 1630 (math-logunits-add a b nil t))
1631 1631
1632(defun calcFunc-lufieldminus (a b) 1632(defun calcFunc-lufsub (a b)
1633 (math-logunits-add a b t nil)) 1633 (math-logunits-add a b t nil))
1634 1634
1635(defun calcFunc-lupowerminus (a b) 1635(defun calcFunc-lupsub (a b)
1636 (math-logunits-add a b t t)) 1636 (math-logunits-add a b t t))
1637 1637
1638(defun calc-logunits-add (arg) 1638(defun calc-lu-plus (arg)
1639 (interactive "P") 1639 (interactive "P")
1640 (calc-slow-wrapper 1640 (calc-slow-wrapper
1641 (if (calc-is-inverse) 1641 (if (calc-is-inverse)
1642 (if (calc-is-hyperbolic) 1642 (if (calc-is-hyperbolic)
1643 (calc-binary-op "lu-" 'calcFunc-lufieldminus arg) 1643 (calc-binary-op "lu-" 'calcFunc-lufsub arg)
1644 (calc-binary-op "lu-" 'calcFunc-lupowerminus arg)) 1644 (calc-binary-op "lu-" 'calcFunc-lupsub arg))
1645 (if (calc-is-hyperbolic) 1645 (if (calc-is-hyperbolic)
1646 (calc-binary-op "lu+" 'calcFunc-lufieldplus arg) 1646 (calc-binary-op "lu+" 'calcFunc-lufadd arg)
1647 (calc-binary-op "lu+" 'calcFunc-lupowerplus arg))))) 1647 (calc-binary-op "lu+" 'calcFunc-lupadd arg)))))
1648 1648
1649(defun calc-logunits-sub (arg) 1649(defun calc-lu-minus (arg)
1650 (interactive "P") 1650 (interactive "P")
1651 (calc-slow-wrapper 1651 (calc-slow-wrapper
1652 (if (calc-is-inverse) 1652 (if (calc-is-inverse)
1653 (if (calc-is-hyperbolic) 1653 (if (calc-is-hyperbolic)
1654 (calc-binary-op "lu+" 'calcFunc-lufieldplus arg) 1654 (calc-binary-op "lu+" 'calcFunc-lufadd arg)
1655 (calc-binary-op "lu+" 'calcFunc-lupowerplus arg)) 1655 (calc-binary-op "lu+" 'calcFunc-lupadd arg))
1656 (if (calc-is-hyperbolic) 1656 (if (calc-is-hyperbolic)
1657 (calc-binary-op "lu-" 'calcFunc-lufieldminus arg) 1657 (calc-binary-op "lu-" 'calcFunc-lufsub arg)
1658 (calc-binary-op "lu-" 'calcFunc-lupowerminus arg))))) 1658 (calc-binary-op "lu-" 'calcFunc-lupsub arg)))))
1659 1659
1660(defun math-logunits-mul (a b power) 1660(defun math-logunits-mul (a b power)
1661 (let (logunit coef units number) 1661 (let (logunit coef units number)
@@ -1719,39 +1719,39 @@ In symbolic mode, return the list (^ a b)."
1719 (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1))) 1719 (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1)))
1720 units))))))))) 1720 units)))))))))
1721 1721
1722(defun calcFunc-lufieldtimes (a b) 1722(defun calcFunc-lufmul (a b)
1723 (math-logunits-mul a b nil)) 1723 (math-logunits-mul a b nil))
1724 1724
1725(defun calcFunc-lupowertimes (a b) 1725(defun calcFunc-lupmul (a b)
1726 (math-logunits-mul a b t)) 1726 (math-logunits-mul a b t))
1727 1727
1728(defun calc-logunits-mul (arg) 1728(defun calc-lu-times (arg)
1729 (interactive "P") 1729 (interactive "P")
1730 (calc-slow-wrapper 1730 (calc-slow-wrapper
1731 (if (calc-is-inverse) 1731 (if (calc-is-inverse)
1732 (if (calc-is-hyperbolic) 1732 (if (calc-is-hyperbolic)
1733 (calc-binary-op "lu/" 'calcFunc-lufielddiv arg) 1733 (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
1734 (calc-binary-op "lu/" 'calcFunc-lupowerdiv arg)) 1734 (calc-binary-op "lu/" 'calcFunc-lupdiv arg))
1735 (if (calc-is-hyperbolic) 1735 (if (calc-is-hyperbolic)
1736 (calc-binary-op "lu*" 'calcFunc-lufieldtimes arg) 1736 (calc-binary-op "lu*" 'calcFunc-lufmul arg)
1737 (calc-binary-op "lu*" 'calcFunc-lupowertimes arg))))) 1737 (calc-binary-op "lu*" 'calcFunc-lupmul arg)))))
1738 1738
1739(defun calcFunc-lufielddiv (a b) 1739(defun calcFunc-lufdiv (a b)
1740 (math-logunits-divide a b nil)) 1740 (math-logunits-divide a b nil))
1741 1741
1742(defun calcFunc-lupowerdiv (a b) 1742(defun calcFunc-lupdiv (a b)
1743 (math-logunits-divide a b t)) 1743 (math-logunits-divide a b t))
1744 1744
1745(defun calc-logunits-divide (arg) 1745(defun calc-lu-divide (arg)
1746 (interactive "P") 1746 (interactive "P")
1747 (calc-slow-wrapper 1747 (calc-slow-wrapper
1748 (if (calc-is-inverse) 1748 (if (calc-is-inverse)
1749 (if (calc-is-hyperbolic) 1749 (if (calc-is-hyperbolic)
1750 (calc-binary-op "lu*" 'calcFunc-lufieldtimes arg) 1750 (calc-binary-op "lu*" 'calcFunc-lufmul arg)
1751 (calc-binary-op "lu*" 'calcFunc-lupowertimes arg)) 1751 (calc-binary-op "lu*" 'calcFunc-lupmul arg))
1752 (if (calc-is-hyperbolic) 1752 (if (calc-is-hyperbolic)
1753 (calc-binary-op "lu/" 'calcFunc-lufielddiv arg) 1753 (calc-binary-op "lu/" 'calcFunc-lufdiv arg)
1754 (calc-binary-op "lu/" 'calcFunc-lupowerdiv arg))))) 1754 (calc-binary-op "lu/" 'calcFunc-lupdiv arg)))))
1755 1755
1756(defun math-logunits-quant (val ref power) 1756(defun math-logunits-quant (val ref power)
1757 (let* ((units (math-simplify (math-extract-units val))) 1757 (let* ((units (math-simplify (math-extract-units val)))
@@ -1777,29 +1777,29 @@ In symbolic mode, return the list (^ a b)."
1777 coeff)))) 1777 coeff))))
1778 runits))))) 1778 runits)))))
1779 1779
1780(defvar calc-logunits-field-reference) 1780(defvar calc-lu-field-reference)
1781(defvar calc-logunits-power-reference) 1781(defvar calc-lu-power-reference)
1782 1782
1783(defun calcFunc-fieldquant (val &optional ref) 1783(defun calcFunc-lufquant (val &optional ref)
1784 (unless ref 1784 (unless ref
1785 (setq ref (math-read-expr calc-logunits-field-reference))) 1785 (setq ref (math-read-expr calc-lu-field-reference)))
1786 (math-logunits-quant val ref nil)) 1786 (math-logunits-quant val ref nil))
1787 1787
1788(defun calcFunc-powerquant (val &optional ref) 1788(defun calcFunc-lupquant (val &optional ref)
1789 (unless ref 1789 (unless ref
1790 (setq ref (math-read-expr calc-logunits-power-reference))) 1790 (setq ref (math-read-expr calc-lu-power-reference)))
1791 (math-logunits-quant val ref t)) 1791 (math-logunits-quant val ref t))
1792 1792
1793(defun calc-logunits-quantity (arg) 1793(defun calc-lu-quant (arg)
1794 (interactive "P") 1794 (interactive "P")
1795 (calc-slow-wrapper 1795 (calc-slow-wrapper
1796 (if (calc-is-hyperbolic) 1796 (if (calc-is-hyperbolic)
1797 (if (calc-is-option) 1797 (if (calc-is-option)
1798 (calc-binary-op "lupq" 'calcFunc-fieldquant arg) 1798 (calc-binary-op "lupq" 'calcFunc-lufquant arg)
1799 (calc-unary-op "lupq" 'calcFunc-fieldquant arg)) 1799 (calc-unary-op "lupq" 'calcFunc-lufquant arg))
1800 (if (calc-is-option) 1800 (if (calc-is-option)
1801 (calc-binary-op "lufq" 'calcFunc-powerquant arg) 1801 (calc-binary-op "lufq" 'calcFunc-lupquant arg)
1802 (calc-unary-op "lufq" 'calcFunc-powerquant arg))))) 1802 (calc-unary-op "lufq" 'calcFunc-lupquant arg)))))
1803 1803
1804(defun math-logunits-level (val ref db power) 1804(defun math-logunits-level (val ref db power)
1805 "Compute the value of VAL in decibels or nepers." 1805 "Compute the value of VAL in decibels or nepers."
@@ -1817,47 +1817,47 @@ In symbolic mode, return the list (^ a b)."
1817 '(var Np var-Np))) 1817 '(var Np var-Np)))
1818 units))) 1818 units)))
1819 1819
1820(defun calcFunc-dbfieldlevel (val &optional ref) 1820(defun calcFunc-dbfield (val &optional ref)
1821 (unless ref 1821 (unless ref
1822 (setq ref (math-read-expr calc-logunits-field-reference))) 1822 (setq ref (math-read-expr calc-lu-field-reference)))
1823 (math-logunits-level val ref t nil)) 1823 (math-logunits-level val ref t nil))
1824 1824
1825(defun calcFunc-dbpowerlevel (val &optional ref) 1825(defun calcFunc-dbpower (val &optional ref)
1826 (unless ref 1826 (unless ref
1827 (setq ref (math-read-expr calc-logunits-power-reference))) 1827 (setq ref (math-read-expr calc-lu-power-reference)))
1828 (math-logunits-level val ref t t)) 1828 (math-logunits-level val ref t t))
1829 1829
1830(defun calcFunc-npfieldlevel (val &optional ref) 1830(defun calcFunc-npfield (val &optional ref)
1831 (unless ref 1831 (unless ref
1832 (setq ref (math-read-expr calc-logunits-field-reference))) 1832 (setq ref (math-read-expr calc-lu-field-reference)))
1833 (math-logunits-level val ref nil nil)) 1833 (math-logunits-level val ref nil nil))
1834 1834
1835(defun calcFunc-nppowerlevel (val &optional ref) 1835(defun calcFunc-nppower (val &optional ref)
1836 (unless ref 1836 (unless ref
1837 (setq ref (math-read-expr calc-logunits-power-reference))) 1837 (setq ref (math-read-expr calc-lu-power-reference)))
1838 (math-logunits-level val ref nil t)) 1838 (math-logunits-level val ref nil t))
1839 1839
1840(defun calc-dblevel (arg) 1840(defun calc-db (arg)
1841 (interactive "P") 1841 (interactive "P")
1842 (calc-slow-wrapper 1842 (calc-slow-wrapper
1843 (if (calc-is-hyperbolic) 1843 (if (calc-is-hyperbolic)
1844 (if (calc-is-option) 1844 (if (calc-is-option)
1845 (calc-binary-op "ludb" 'calcFunc-dbfieldlevel arg) 1845 (calc-binary-op "ludb" 'calcFunc-dbfield arg)
1846 (calc-unary-op "ludb" 'calcFunc-dbfieldlevel arg)) 1846 (calc-unary-op "ludb" 'calcFunc-dbfield arg))
1847 (if (calc-is-option) 1847 (if (calc-is-option)
1848 (calc-binary-op "ludb" 'calcFunc-dbpowerlevel arg) 1848 (calc-binary-op "ludb" 'calcFunc-dbpower arg)
1849 (calc-unary-op "ludb" 'calcFunc-dbpowerlevel arg))))) 1849 (calc-unary-op "ludb" 'calcFunc-dbpower arg)))))
1850 1850
1851(defun calc-nplevel (arg) 1851(defun calc-np (arg)
1852 (interactive "P") 1852 (interactive "P")
1853 (calc-slow-wrapper 1853 (calc-slow-wrapper
1854 (if (calc-is-hyperbolic) 1854 (if (calc-is-hyperbolic)
1855 (if (calc-is-option) 1855 (if (calc-is-option)
1856 (calc-binary-op "lunp" 'calcFunc-npfieldlevel arg) 1856 (calc-binary-op "lunp" 'calcFunc-npfield arg)
1857 (calc-unary-op "lunp" 'calcFunc-npfieldlevel arg)) 1857 (calc-unary-op "lunp" 'calcFunc-npfield arg))
1858 (if (calc-is-option) 1858 (if (calc-is-option)
1859 (calc-binary-op "lunp" 'calcFunc-nppowerlevel arg) 1859 (calc-binary-op "lunp" 'calcFunc-nppower arg)
1860 (calc-unary-op "lunp" 'calcFunc-nppowerlevel arg))))) 1860 (calc-unary-op "lunp" 'calcFunc-nppower arg)))))
1861 1861
1862;;; Musical notes 1862;;; Musical notes
1863 1863
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'."
434 :group 'calc 434 :group 'calc
435 :type 'boolean) 435 :type 'boolean)
436 436
437(defcustom calc-logunits-field-reference 437(defcustom calc-lu-field-reference
438 "20 uPa" 438 "20 uPa"
439 "The default reference level for logarithmic units (field)." 439 "The default reference level for logarithmic units (field)."
440 :group 'calc 440 :group 'calc
441 :type '(string)) 441 :type '(string))
442 442
443(defcustom calc-logunits-power-reference 443(defcustom calc-lu-power-reference
444 "mW" 444 "mW"
445 "The default reference level for logarithmic units (power)." 445 "The default reference level for logarithmic units (power)."
446 :group 'calc 446 :group 'calc
@@ -1084,7 +1084,7 @@ Used by `calc-user-invocation'.")
1084 "lOW") 1084 "lOW")
1085 (mapc (lambda (x) (define-key map (char-to-string x) 'calc-missing-key)) 1085 (mapc (lambda (x) (define-key map (char-to-string x) 'calc-missing-key))
1086 (concat "ABCDEFGHIJKLMNOPQRSTUVXZabcdfghjkmoprstuvwxyz" 1086 (concat "ABCDEFGHIJKLMNOPQRSTUVXZabcdfghjkmoprstuvwxyz"
1087 ":\\|!()[]<>{},;=~`\C-k\C-w\C-_")) 1087 ":\\|!()[]<>{},;=~`\C-k\C-w"))
1088 (define-key map "\M-w" 'calc-missing-key) 1088 (define-key map "\M-w" 'calc-missing-key)
1089 (define-key map "\M-k" 'calc-missing-key) 1089 (define-key map "\M-k" 'calc-missing-key)
1090 (define-key map "\M-\C-w" 'calc-missing-key) 1090 (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."
879(declare-function diary-ordinal-suffix "diary-lib" (n)) 879(declare-function diary-ordinal-suffix "diary-lib" (n))
880 880
881;;;###diary-autoload 881;;;###diary-autoload
882(defun diary-hebrew-yahrzeit (death-month death-day death-year &optional mark) 882(defun diary-hebrew-yahrzeit (death-month death-day death-year
883 &optional mark after-sunset)
883 "Yahrzeit diary entry--entry applies if date is Yahrzeit or the day before. 884 "Yahrzeit diary entry--entry applies if date is Yahrzeit or the day before.
884Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary 885Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary
885entry is assumed to be the name of the person. Although the date 886entry is assumed to be the name of the person. Although the date
886of death is specified by the civil calendar, the proper Hebrew 887of death is specified by the civil calendar, the proper Hebrew
887calendar Yahrzeit is determined. 888calendar Yahrzeit is determined.
888 889
890If the death occurred after local sunset on the given civil date,
891the following civil date corresponds to the Hebrew date of
892death--set the optional parameter AFTER-SUNSET non-nil in this case.
893
889The order of the input parameters changes according to `calendar-date-style' 894The order of the input parameters changes according to `calendar-date-style'
890\(e.g. to DEATH-DAY, DEATH-MONTH, DEATH-YEAR in the European style). 895\(e.g. to DEATH-DAY, DEATH-MONTH, DEATH-YEAR in the European style).
891 896
892An optional parameter MARK specifies a face or single-character string to 897An optional parameter MARK specifies a face or single-character string to
893use when highlighting the day in the calendar." 898use when highlighting the day in the calendar."
894 (let* ((h-date (calendar-hebrew-from-absolute 899 (let* ((h-date (calendar-hebrew-from-absolute
895 (calendar-absolute-from-gregorian 900 (+ (calendar-absolute-from-gregorian
896 (diary-make-date death-month death-day death-year)))) 901 (diary-make-date death-month death-day death-year))
902 (if after-sunset 1 0))))
897 (h-month (calendar-extract-month h-date)) 903 (h-month (calendar-extract-month h-date))
898 (h-day (calendar-extract-day h-date)) 904 (h-day (calendar-extract-day h-date))
899 (h-year (calendar-extract-year h-date)) 905 (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'."
308 (setq start (match-end 0) 308 (setq start (match-end 0)
309 spec (match-string 1 string)) 309 spec (match-string 1 string))
310 (unless (string-equal spec "%") 310 (unless (string-equal spec "%")
311 ;; `assoc-string' is not available in XEmacs. So when compiling 311 (or (setq match (assoc (downcase spec) units))
312 ;; Gnus (`time-date.el' is part of Gnus) with XEmacs, we get
313 ;; a warning here. But `format-seconds' is not used anywhere in
314 ;; Gnus so it's not a real problem. --rsteib
315 (or (setq match (assoc-string spec units t))
316 (error "Bad format specifier: `%s'" spec)) 312 (error "Bad format specifier: `%s'" spec))
317 (if (assoc-string spec usedunits t) 313 (if (assoc (downcase spec) usedunits)
318 (error "Multiple instances of specifier: `%s'" spec)) 314 (error "Multiple instances of specifier: `%s'" spec))
319 (if (string-equal (car match) "z") 315 (if (string-equal (car match) "z")
320 (setq zeroflag t) 316 (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'."
4756 "Invoke button at POS, or refuse to allow editing of Custom buffer." 4756 "Invoke button at POS, or refuse to allow editing of Custom buffer."
4757 (interactive "@d") 4757 (interactive "@d")
4758 (let ((button (get-char-property pos 'button))) 4758 (let ((button (get-char-property pos 'button)))
4759 ;; If there is no button at point, then use the one at the start
4760 ;; of the line, if it is a custom-group-link (bug#2298).
4761 (or button
4762 (if (setq button (get-char-property (line-beginning-position) 'button))
4763 (or (eq (widget-type button) 'custom-group-link)
4764 (setq button nil))))
4759 (if button 4765 (if button
4760 (widget-apply-action button event) 4766 (widget-apply-action button event)
4761 (error "You can't edit this part of the Custom buffer")))) 4767 (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
111 (cursor-in-non-selected-windows 111 (cursor-in-non-selected-windows
112 cursor boolean nil 112 cursor boolean nil
113 :tag "Cursor In Non-selected Windows" 113 :tag "Cursor In Non-selected Windows"
114 :set #'(lambda (symbol value) 114 :set (lambda (symbol value)
115 (set-default symbol value) 115 (set-default symbol value)
116 (force-mode-line-update t))) 116 (force-mode-line-update t)))
117 (transient-mark-mode editing-basics boolean nil 117 (transient-mark-mode editing-basics boolean nil
118 :standard (not noninteractive) 118 :standard (not noninteractive)
119 :initialize custom-initialize-delay 119 :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*."
100 (make-local-variable 'custom-theme-insert-face-marker) 100 (make-local-variable 'custom-theme-insert-face-marker)
101 (make-local-variable 'custom-theme-insert-variable-marker) 101 (make-local-variable 'custom-theme-insert-variable-marker)
102 (make-local-variable 'custom-theme--listed-faces) 102 (make-local-variable 'custom-theme--listed-faces)
103 (when (called-interactively-p 'interactive)
104 (unless (y-or-n-p "Include basic face customizations in this theme? ")
105 (setq custom-theme--listed-faces nil)))
103 106
104 (if (eq theme 'user) 107 (if (eq theme 'user)
105 (widget-insert "This buffer contains all the Custom settings you have made. 108 (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"))
188 (while vars 191 (while vars
189 (if (eq (car vars) 'custom-enabled-themes) 192 (if (eq (car vars) 'custom-enabled-themes)
190 (progn (pop vars) (pop values)) 193 (progn (pop vars) (pop values))
191 (custom-theme-add-var-1 (pop vars) (pop values))))) 194 (custom-theme-add-var-1 (pop vars) (eval (pop values))))))
192 (setq custom-theme-insert-variable-marker (point-marker)) 195 (setq custom-theme-insert-variable-marker (point-marker))
193 (widget-insert " ") 196 (widget-insert " ")
194 (widget-create 'push-button 197 (widget-create 'push-button
@@ -297,8 +300,9 @@ SPEC, if non-nil, should be a face spec to which to set the widget."
297 300
298;;; Reading and writing 301;;; Reading and writing
299 302
303;;;###autoload
300(defun custom-theme-visit-theme (theme) 304(defun custom-theme-visit-theme (theme)
301 "Load the custom theme THEME's settings into the current buffer." 305 "Set up a Custom buffer to edit custom theme THEME."
302 (interactive 306 (interactive
303 (list 307 (list
304 (intern (completing-read "Find custom theme: " 308 (intern (completing-read "Find custom theme: "
@@ -663,4 +667,6 @@ Theme files are named *-theme.el in `"))
663 (widget-toggle-action widget event) 667 (widget-toggle-action widget event)
664 (setq custom-theme-allow-multiple-selections (widget-value widget))) 668 (setq custom-theme-allow-multiple-selections (widget-value widget)))
665 669
670(provide 'cus-theme)
671
666;;; cus-theme.el ends here 672;;; 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."
792(defvar custom-known-themes '(user changed) 792(defvar custom-known-themes '(user changed)
793 "Themes that have been defined with `deftheme'. 793 "Themes that have been defined with `deftheme'.
794The default value is the list (user changed). The theme `changed' 794The default value is the list (user changed). The theme `changed'
795contains the settings before custom themes are applied. The 795contains the settings before custom themes are applied. The theme
796theme `user' contains all the settings the user customized and saved. 796`user' contains all the settings the user customized and saved.
797Additional themes declared with the `deftheme' macro will be added to 797Additional themes declared with the `deftheme' macro will be added
798the front of this list.") 798to the front of this list.")
799 799
800(defsubst custom-theme-p (theme) 800(defsubst custom-theme-p (theme)
801 "Non-nil when THEME has been defined." 801 "Non-nil when THEME has been defined."
@@ -1074,7 +1074,7 @@ order. Each element in the list should be one of the following:
1074 named \"themes\" in `data-directory'). 1074 named \"themes\" in `data-directory').
1075- a directory name (a string). 1075- a directory name (a string).
1076 1076
1077Each theme file is named NAME-theme.el, where THEME is the theme 1077Each theme file is named THEME-theme.el, where THEME is the theme
1078name." 1078name."
1079 :type '(repeat (choice (const :tag "custom-theme-directory" 1079 :type '(repeat (choice (const :tag "custom-theme-directory"
1080 custom-theme-directory) 1080 custom-theme-directory)
@@ -1146,7 +1146,7 @@ Return t if THEME was successfully loaded, nil otherwise."
1146 '("" "c"))) 1146 '("" "c")))
1147 hash) 1147 hash)
1148 (unless fn 1148 (unless fn
1149 (error "Unable to find theme file for `%s'." theme)) 1149 (error "Unable to find theme file for `%s'" theme))
1150 (with-temp-buffer 1150 (with-temp-buffer
1151 (insert-file-contents fn) 1151 (insert-file-contents fn)
1152 (setq hash (sha1 (current-buffer))) 1152 (setq hash (sha1 (current-buffer)))
@@ -1212,7 +1212,7 @@ NAME should be a symbol."
1212 1212
1213(defun custom-available-themes () 1213(defun custom-available-themes ()
1214 "Return a list of available Custom themes (symbols)." 1214 "Return a list of available Custom themes (symbols)."
1215 (let* (sym themes) 1215 (let (sym themes)
1216 (dolist (dir (custom-theme--load-path)) 1216 (dolist (dir (custom-theme--load-path))
1217 (when (file-directory-p dir) 1217 (when (file-directory-p dir)
1218 (dolist (file (file-expand-wildcards 1218 (dolist (file (file-expand-wildcards
@@ -1222,7 +1222,7 @@ NAME should be a symbol."
1222 (setq sym (intern (match-string 1 file))) 1222 (setq sym (intern (match-string 1 file)))
1223 (custom-theme-name-valid-p sym) 1223 (custom-theme-name-valid-p sym)
1224 (push sym themes))))) 1224 (push sym themes)))))
1225 (delete-dups themes))) 1225 (nreverse (delete-dups themes))))
1226 1226
1227(defun custom-theme--load-path () 1227(defun custom-theme--load-path ()
1228 (let (lpath) 1228 (let (lpath)
@@ -1338,7 +1338,7 @@ That is to say, it specifies what the value should be according to
1338currently enabled custom themes. 1338currently enabled custom themes.
1339 1339
1340This function returns nil if no custom theme specifies a value for VARIABLE." 1340This function returns nil if no custom theme specifies a value for VARIABLE."
1341 (let* ((theme-value (get variable 'theme-value))) 1341 (let ((theme-value (get variable 'theme-value)))
1342 (if theme-value 1342 (if theme-value
1343 (cdr (car theme-value))))) 1343 (cdr (car theme-value)))))
1344 1344
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.
1638 1638
1639;;;###autoload 1639;;;###autoload
1640(defun dired-create-directory (directory) 1640(defun dired-create-directory (directory)
1641 "Create a directory called DIRECTORY." 1641 "Create a directory called DIRECTORY.
1642If DIRECTORY already exists, signal an error."
1642 (interactive 1643 (interactive
1643 (list (read-file-name "Create directory: " (dired-current-directory)))) 1644 (list (read-file-name "Create directory: " (dired-current-directory))))
1644 (let* ((expanded (directory-file-name (expand-file-name directory))) 1645 (let* ((expanded (directory-file-name (expand-file-name directory)))
1645 (try expanded) new) 1646 (try expanded) new)
1647 (if (file-exists-p expanded)
1648 (error "Cannot create directory %s: file exists" expanded))
1646 ;; Find the topmost nonexistent parent dir (variable `new') 1649 ;; Find the topmost nonexistent parent dir (variable `new')
1647 (while (and try (not (file-exists-p try)) (not (equal new try))) 1650 (while (and try (not (file-exists-p try)) (not (equal new try)))
1648 (setq new try 1651 (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."
3629;;;;;; dired-run-shell-command dired-do-shell-command dired-do-async-shell-command 3629;;;;;; dired-run-shell-command dired-do-shell-command dired-do-async-shell-command
3630;;;;;; dired-clean-directory dired-do-print dired-do-touch dired-do-chown 3630;;;;;; dired-clean-directory dired-do-print dired-do-touch dired-do-chown
3631;;;;;; dired-do-chgrp dired-do-chmod dired-compare-directories dired-backup-diff 3631;;;;;; dired-do-chgrp dired-do-chmod dired-compare-directories dired-backup-diff
3632;;;;;; dired-diff) "dired-aux" "dired-aux.el" "154cdfbf451aedec60c5012b625ff329") 3632;;;;;; dired-diff) "dired-aux" "dired-aux.el" "2d805d6766bd7970cd446413b4ed4ce0")
3633;;; Generated autoloads from dired-aux.el 3633;;; Generated autoloads from dired-aux.el
3634 3634
3635(autoload 'dired-diff "dired-aux" "\ 3635(autoload 'dired-diff "dired-aux" "\
@@ -3860,6 +3860,7 @@ Not documented
3860 3860
3861(autoload 'dired-create-directory "dired-aux" "\ 3861(autoload 'dired-create-directory "dired-aux" "\
3862Create a directory called DIRECTORY. 3862Create a directory called DIRECTORY.
3863If DIRECTORY already exists, signal an error.
3863 3864
3864\(fn DIRECTORY)" t nil) 3865\(fn DIRECTORY)" t nil)
3865 3866
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 @@
34;; this depends on the format of list-buffers (from src/buffer.c) and 34;; this depends on the format of list-buffers (from src/buffer.c) and
35;; on stuff in lisp/buff-menu.el 35;; on stuff in lisp/buff-menu.el
36 36
37(defvar electric-buffer-menu-mode-map nil) 37(defvar electric-buffer-menu-mode-map
38 (let ((map (make-keymap)))
39 (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined)
40 (define-key map "\e" nil)
41 (define-key map "\C-z" 'suspend-frame)
42 (define-key map "v" 'Electric-buffer-menu-mode-view-buffer)
43 (define-key map (char-to-string help-char) 'Helper-help)
44 (define-key map "?" 'Helper-describe-bindings)
45 (define-key map "\C-c" nil)
46 (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit)
47 (define-key map "\C-]" 'Electric-buffer-menu-quit)
48 (define-key map "q" 'Electric-buffer-menu-quit)
49 (define-key map " " 'Electric-buffer-menu-select)
50 (define-key map "\C-m" 'Electric-buffer-menu-select)
51 (define-key map "\C-l" 'recenter)
52 (define-key map "s" 'Buffer-menu-save)
53 (define-key map "d" 'Buffer-menu-delete)
54 (define-key map "k" 'Buffer-menu-delete)
55 (define-key map "\C-d" 'Buffer-menu-delete-backwards)
56 ;; (define-key map "\C-k" 'Buffer-menu-delete)
57 (define-key map "\177" 'Buffer-menu-backup-unmark)
58 (define-key map "~" 'Buffer-menu-not-modified)
59 (define-key map "u" 'Buffer-menu-unmark)
60 (let ((i ?0))
61 (while (<= i ?9)
62 (define-key map (char-to-string i) 'digit-argument)
63 (define-key map (concat "\e" (char-to-string i)) 'digit-argument)
64 (setq i (1+ i))))
65 (define-key map "-" 'negative-argument)
66 (define-key map "\e-" 'negative-argument)
67 (define-key map "m" 'Buffer-menu-mark)
68 (define-key map "\C-u" 'universal-argument)
69 (define-key map "\C-p" 'previous-line)
70 (define-key map "\C-n" 'next-line)
71 (define-key map "p" 'previous-line)
72 (define-key map "n" 'next-line)
73 (define-key map "\C-v" 'scroll-up)
74 (define-key map "\ev" 'scroll-down)
75 (define-key map ">" 'scroll-right)
76 (define-key map "<" 'scroll-left)
77 (define-key map "\e\C-v" 'scroll-other-window)
78 (define-key map "\e>" 'end-of-buffer)
79 (define-key map "\e<" 'beginning-of-buffer)
80 (define-key map "\e\e" nil)
81 (define-key map "\e\e\e" 'Electric-buffer-menu-quit)
82 ;; This binding prevents the "escape => ESC" function-key-map mapping from
83 ;; kicking in!
84 ;; (define-key map [escape escape escape] 'Electric-buffer-menu-quit)
85 (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select)
86 map))
38 87
39(defvar electric-buffer-menu-mode-hook nil 88(defvar electric-buffer-menu-mode-hook nil
40 "Normal hook run by `electric-buffer-list'.") 89 "Normal hook run by `electric-buffer-list'.")
@@ -167,55 +216,7 @@ Entry to this mode via command `electric-buffer-list' calls the value of
167;; generally the same as Buffer-menu-mode-map 216;; generally the same as Buffer-menu-mode-map
168;; (except we don't indirect to global-map) 217;; (except we don't indirect to global-map)
169(put 'Electric-buffer-menu-undefined 'suppress-keymap t) 218(put 'Electric-buffer-menu-undefined 'suppress-keymap t)
170(if electric-buffer-menu-mode-map 219
171 nil
172 (let ((map (make-keymap)))
173 (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined)
174 (define-key map "\e" nil)
175 (define-key map "\C-z" 'suspend-frame)
176 (define-key map "v" 'Electric-buffer-menu-mode-view-buffer)
177 (define-key map (char-to-string help-char) 'Helper-help)
178 (define-key map "?" 'Helper-describe-bindings)
179 (define-key map "\C-c" nil)
180 (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit)
181 (define-key map "\C-]" 'Electric-buffer-menu-quit)
182 (define-key map "q" 'Electric-buffer-menu-quit)
183 (define-key map " " 'Electric-buffer-menu-select)
184 (define-key map "\C-m" 'Electric-buffer-menu-select)
185 (define-key map "\C-l" 'recenter)
186 (define-key map "s" 'Buffer-menu-save)
187 (define-key map "d" 'Buffer-menu-delete)
188 (define-key map "k" 'Buffer-menu-delete)
189 (define-key map "\C-d" 'Buffer-menu-delete-backwards)
190 ;(define-key map "\C-k" 'Buffer-menu-delete)
191 (define-key map "\177" 'Buffer-menu-backup-unmark)
192 (define-key map "~" 'Buffer-menu-not-modified)
193 (define-key map "u" 'Buffer-menu-unmark)
194 (let ((i ?0))
195 (while (<= i ?9)
196 (define-key map (char-to-string i) 'digit-argument)
197 (define-key map (concat "\e" (char-to-string i)) 'digit-argument)
198 (setq i (1+ i))))
199 (define-key map "-" 'negative-argument)
200 (define-key map "\e-" 'negative-argument)
201 (define-key map "m" 'Buffer-menu-mark)
202 (define-key map "\C-u" 'universal-argument)
203 (define-key map "\C-p" 'previous-line)
204 (define-key map "\C-n" 'next-line)
205 (define-key map "p" 'previous-line)
206 (define-key map "n" 'next-line)
207 (define-key map "\C-v" 'scroll-up)
208 (define-key map "\ev" 'scroll-down)
209 (define-key map ">" 'scroll-right)
210 (define-key map "<" 'scroll-left)
211 (define-key map "\e\C-v" 'scroll-other-window)
212 (define-key map "\e>" 'end-of-buffer)
213 (define-key map "\e<" 'beginning-of-buffer)
214 (define-key map "\e\e" nil)
215 (define-key map "\e\e\e" 'Electric-buffer-menu-quit)
216 (define-key map [escape escape escape] 'Electric-buffer-menu-quit)
217 (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select)
218 (setq electric-buffer-menu-mode-map map)))
219 220
220(defun Electric-buffer-menu-exit () 221(defun Electric-buffer-menu-exit ()
221 (interactive) 222 (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."
4071(defun byte-compile-save-excursion (form) 4071(defun byte-compile-save-excursion (form)
4072 (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) 4072 (if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
4073 (byte-compile-warning-enabled-p 'suspicious)) 4073 (byte-compile-warning-enabled-p 'suspicious))
4074 (byte-compile-warn "`save-excursion' defeated by `set-buffer'")) 4074 (byte-compile-warn
4075 "Use `with-current-buffer' rather than save-excursion+set-buffer"))
4075 (byte-compile-out 'byte-save-excursion 0) 4076 (byte-compile-out 'byte-save-excursion 0)
4076 (byte-compile-body-do-effect (cdr form)) 4077 (byte-compile-body-do-effect (cdr form))
4077 (byte-compile-out 'byte-unbind 1)) 4078 (byte-compile-out 'byte-unbind 1))
@@ -4120,6 +4121,17 @@ binding slots have been popped."
4120 ,@decls 4121 ,@decls
4121 ',(nth 1 form))))) 4122 ',(nth 1 form)))))
4122 4123
4124;; If foo.el declares `toto' as obsolete, it is likely that foo.el will
4125;; actually use `toto' in order for this obsolete variable to still work
4126;; correctly, so paradoxically, while byte-compiling foo.el, the presence
4127;; of a make-obsolete-variable call for `toto' is an indication that `toto'
4128;; should not trigger obsolete-warnings in foo.el.
4129(byte-defop-compiler-1 make-obsolete-variable)
4130(defun byte-compile-make-obsolete-variable (form)
4131 (when (eq 'quote (car-safe (nth 1 form)))
4132 (push (nth 1 (nth 1 form)) byte-compile-not-obsolete-vars))
4133 (byte-compile-normal-call form))
4134
4123(defun byte-compile-defvar (form) 4135(defun byte-compile-defvar (form)
4124 ;; This is not used for file-level defvar/consts with doc strings. 4136 ;; This is not used for file-level defvar/consts with doc strings.
4125 (when (and (symbolp (nth 1 form)) 4137 (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
282;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist 282;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
283;;;;;; do* do loop return-from return block etypecase typecase ecase 283;;;;;; do* do loop return-from return block etypecase typecase ecase
284;;;;;; case load-time-value eval-when destructuring-bind function* 284;;;;;; case load-time-value eval-when destructuring-bind function*
285;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "80cb83265399ce021c8c0c7d1a8562f2") 285;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "c4734fbda33043d967624d39d80c3304")
286;;; Generated autoloads from cl-macs.el 286;;; Generated autoloads from cl-macs.el
287 287
288(autoload 'gensym "cl-macs" "\ 288(autoload 'gensym "cl-macs" "\
@@ -500,16 +500,16 @@ Like `let', but lexically scoped.
500The main visible difference is that lambdas inside BODY will create 500The main visible difference is that lambdas inside BODY will create
501lexical closures as in Common Lisp. 501lexical closures as in Common Lisp.
502 502
503\(fn VARLIST BODY)" nil (quote macro)) 503\(fn BINDINGS BODY)" nil (quote macro))
504 504
505(autoload 'lexical-let* "cl-macs" "\ 505(autoload 'lexical-let* "cl-macs" "\
506Like `let*', but lexically scoped. 506Like `let*', but lexically scoped.
507The main visible difference is that lambdas inside BODY, and in 507The main visible difference is that lambdas inside BODY, and in
508successive bindings within VARLIST, will create lexical closures 508successive bindings within BINDINGS, will create lexical closures
509as in Common Lisp. This is similar to the behavior of `let*' in 509as in Common Lisp. This is similar to the behavior of `let*' in
510Common Lisp. 510Common Lisp.
511 511
512\(fn VARLIST BODY)" nil (quote macro)) 512\(fn BINDINGS BODY)" nil (quote macro))
513 513
514(autoload 'multiple-value-bind "cl-macs" "\ 514(autoload 'multiple-value-bind "cl-macs" "\
515Collect multiple return values. 515Collect 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."
1482 (let ((print-escape-newlines t) 1482 (let ((print-escape-newlines t)
1483 (print-level 5) 1483 (print-level 5)
1484 (print-length 10)) 1484 (print-length 10))
1485 (let ((begin (point))) 1485 (ert--pp-with-indentation-and-newline
1486 (ert--pp-with-indentation-and-newline 1486 (ert-test-result-with-condition-condition result)))
1487 (ert-test-result-with-condition-condition result))))
1488 (goto-char (1- (point-max))) 1487 (goto-char (1- (point-max)))
1489 (assert (looking-at "\n")) 1488 (assert (looking-at "\n"))
1490 (delete-char 1) 1489 (delete-char 1)
@@ -1603,7 +1602,7 @@ Nothing more than an interactive interface to `ert-make-test-unbound'."
1603(defun ert-delete-all-tests () 1602(defun ert-delete-all-tests ()
1604 "Make all symbols in `obarray' name no test." 1603 "Make all symbols in `obarray' name no test."
1605 (interactive) 1604 (interactive)
1606 (when (interactive-p) 1605 (when (called-interactively-p 'any)
1607 (unless (y-or-n-p "Delete all tests? ") 1606 (unless (y-or-n-p "Delete all tests? ")
1608 (error "Aborted"))) 1607 (error "Aborted")))
1609 ;; We can't use `ert-select-tests' here since that gives us only 1608 ;; 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'."
1793BEGIN and END specify a region in the current buffer." 1792BEGIN and END specify a region in the current buffer."
1794 (save-excursion 1793 (save-excursion
1795 (save-restriction 1794 (save-restriction
1796 (narrow-to-region begin (point)) 1795 (narrow-to-region begin end)
1797 ;; Inhibit optimization in `debugger-make-xrefs' that would 1796 ;; Inhibit optimization in `debugger-make-xrefs' that would
1798 ;; sometimes insert unrelated backtrace info into our buffer. 1797 ;; sometimes insert unrelated backtrace info into our buffer.
1799 (let ((debugger-previous-backtrace nil)) 1798 (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 @@
27 27
28;;; Commentary: 28;;; Commentary:
29 29
30;; This file currently contains parts of the package system most 30;; This file currently contains parts of the package system that many
31;; people won't need, such as package uploading. 31;; won't need, such as package uploading.
32
33;; To upload to an archive, first set `package-archive-upload-base' to
34;; some desired directory. For testing purposes, you can specify any
35;; directory you want, but if you want the archive to be accessible to
36;; others via http, this is typically a directory in the /var/www tree
37;; (possibly one on a remote machine, accessed via Tramp).
38
39;; Then call M-x package-upload-file, which prompts for a file to
40;; upload. Alternatively, M-x package-upload-buffer uploads the
41;; current buffer, if it's visiting a package file.
42
43;; Once a package is uploaded, users can access it via the Package
44;; Menu, by adding the archive to `package-archives'.
32 45
33;;; Code: 46;;; Code:
34 47
35(require 'package) 48(require 'package)
36(defvar gnus-article-buffer) 49(defvar gnus-article-buffer)
37 50
38;; Note that this only works if you have the password, which you 51(defcustom package-archive-upload-base "/path/to/archive"
39;; probably don't :-). 52 "The base location of the archive to which packages are uploaded.
40(defvar package-archive-upload-base nil 53This should be an absolute directory name. If the archive is on
41 "Base location for uploading to package archive.") 54another machine, you may specify a remote name in the usual way,
55e.g. \"/ssh:foo@example.com:/var/www/packages/\".
56See Info node `(emacs)Remote Files'.
57
58Unlike `package-archives', you can't specify a HTTP URL."
59 :type 'directory
60 :group 'package
61 :version "24.1")
42 62
43(defvar package-update-news-on-upload nil 63(defvar package-update-news-on-upload nil
44 "Whether package upload should also update NEWS and RSS feeds.") 64 "Whether uploading a package should also update NEWS and RSS feeds.")
45 65
46(defun package--encode (string) 66(defun package--encode (string)
47 "Encode a string by replacing some characters with XML entities." 67 "Encode a string by replacing some characters with XML entities."
@@ -75,13 +95,18 @@
75 title " - " (package--encode text) 95 title " - " (package--encode text)
76 " </li>\n")) 96 " </li>\n"))
77 97
78(defun package--update-file (file location text) 98(defun package--update-file (file tag text)
99 "Update the package archive file named FILE.
100FILE should be relative to `package-archive-upload-base'.
101TAG is a string that can be found within the file; TEXT is
102inserted after its first occurrence in the file."
103 (setq file (expand-file-name file package-archive-upload-base))
79 (save-excursion 104 (save-excursion
80 (let ((old-buffer (find-buffer-visiting file))) 105 (let ((old-buffer (find-buffer-visiting file)))
81 (with-current-buffer (let ((find-file-visit-truename t)) 106 (with-current-buffer (let ((find-file-visit-truename t))
82 (or old-buffer (find-file-noselect file))) 107 (or old-buffer (find-file-noselect file)))
83 (goto-char (point-min)) 108 (goto-char (point-min))
84 (search-forward location) 109 (search-forward tag)
85 (forward-line) 110 (forward-line)
86 (insert text) 111 (insert text)
87 (let ((file-precious-flag t)) 112 (let ((file-precious-flag t))
@@ -105,30 +130,31 @@ Return the file contents, as a string, or nil if unsuccessful."
105 (buffer-substring-no-properties (point-min) (point-max))) 130 (buffer-substring-no-properties (point-min) (point-max)))
106 (kill-buffer buffer)))))) 131 (kill-buffer buffer))))))
107 132
108(defun package--archive-contents-from-file (file) 133(defun package--archive-contents-from-file ()
109 "Parse the given archive-contents file." 134 "Parse the archive-contents at `package-archive-upload-base'"
110 (if (not (file-exists-p file)) 135 (let ((file (expand-file-name "archive-contents"
111 ;; no existing archive-contents, possibly a new ELPA repo. 136 package-archive-upload-base)))
112 (list package-archive-version) 137 (if (not (file-exists-p file))
113 (let ((dont-kill (find-buffer-visiting file))) 138 ;; No existing archive-contents means a new archive.
114 (with-current-buffer (let ((find-file-visit-truename t)) 139 (list package-archive-version)
115 (find-file-noselect file)) 140 (let ((dont-kill (find-buffer-visiting file)))
116 (prog1 141 (with-current-buffer (let ((find-file-visit-truename t))
117 (package-read-from-string 142 (find-file-noselect file))
118 (buffer-substring-no-properties (point-min) (point-max))) 143 (prog1
119 (unless dont-kill 144 (package-read-from-string
120 (kill-buffer (current-buffer)))))))) 145 (buffer-substring-no-properties (point-min) (point-max)))
146 (unless dont-kill
147 (kill-buffer (current-buffer)))))))))
121 148
122(defun package-maint-add-news-item (title description archive-url) 149(defun package-maint-add-news-item (title description archive-url)
123 "Add a news item to the ELPA web pages. 150 "Add a news item to the webpages associated with the package archive.
124TITLE is the title of the news item. 151TITLE is the title of the news item.
125DESCRIPTION is the text of the news item. 152DESCRIPTION is the text of the news item."
126You need administrative access to ELPA to use this."
127 (interactive "sTitle: \nsText: ") 153 (interactive "sTitle: \nsText: ")
128 (package--update-file (concat package-archive-upload-base "elpa.rss") 154 (package--update-file "elpa.rss"
129 "<description>" 155 "<description>"
130 (package--make-rss-entry title description archive-url)) 156 (package--make-rss-entry title description archive-url))
131 (package--update-file (concat package-archive-upload-base "news.html") 157 (package--update-file "news.html"
132 "New entries go here" 158 "New entries go here"
133 (package--make-html-entry title description))) 159 (package--make-html-entry title description)))
134 160
@@ -144,8 +170,8 @@ PKG-INFO is the package info, see `package-buffer-info'.
144EXTENSION is the file extension, a string. It can be either 170EXTENSION is the file extension, a string. It can be either
145\"el\" or \"tar\". 171\"el\" or \"tar\".
146 172
147The variable `package-archive-upload-base' specifies the upload 173The upload destination is given by `package-archive-upload-base'.
148destination. If this is nil, signal an error. 174If its value is invalid, prompt for a directory.
149 175
150Optional arg ARCHIVE-URL is the URL of the destination archive. 176Optional arg ARCHIVE-URL is the URL of the destination archive.
151If it is non-nil, compute the new \"archive-contents\" file 177If 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
156If ARCHIVE-URL is nil, compute the new \"archive-contents\" file 182If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
157from the \"archive-contents\" at `package-archive-upload-base', 183from the \"archive-contents\" at `package-archive-upload-base',
158if it exists." 184if it exists."
159 (unless package-archive-upload-base 185 (let ((package-archive-upload-base package-archive-upload-base))
160 (error "No destination specified in `package-archive-upload-base'")) 186 ;; Check if `package-archive-upload-base' is valid.
161 (save-excursion 187 (when (or (not (stringp package-archive-upload-base))
162 (save-restriction 188 (equal package-archive-upload-base
163 (let* ((file-type (cond 189 (car-safe
164 ((equal extension "el") 'single) 190 (get 'package-archive-upload-base 'standard-value))))
165 ((equal extension "tar") 'tar) 191 (setq package-archive-upload-base
166 (t (error "Unknown extension `%s'" extension)))) 192 (read-directory-name
167 (file-name (aref pkg-info 0)) 193 "Base directory for package archive: ")))
168 (pkg-name (intern file-name)) 194 (unless (file-directory-p package-archive-upload-base)
169 (requires (aref pkg-info 1)) 195 (if (y-or-n-p (format "%s does not exist; create it? "
170 (desc (if (string= (aref pkg-info 2) "") 196 package-archive-upload-base))
171 (read-string "Description of package: ") 197 (make-directory package-archive-upload-base t)
172 (aref pkg-info 2))) 198 (error "Aborted")))
173 (pkg-version (aref pkg-info 3)) 199 (save-excursion
174 (commentary (aref pkg-info 4)) 200 (save-restriction
175 (split-version (version-to-list pkg-version)) 201 (let* ((file-type (cond
176 (pkg-buffer (current-buffer))) 202 ((equal extension "el") 'single)
177 203 ((equal extension "tar") 'tar)
178 ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or 204 (t (error "Unknown extension `%s'" extension))))
179 ;; from `package-archive-upload-base' otherwise. 205 (file-name (aref pkg-info 0))
180 (let ((contents (or (package--archive-contents-from-url archive-url) 206 (pkg-name (intern file-name))
181 (package--archive-contents-from-file 207 (requires (aref pkg-info 1))
182 (concat package-archive-upload-base 208 (desc (if (string= (aref pkg-info 2) "")
183 "archive-contents")))) 209 (read-string "Description of package: ")
184 (new-desc (vector split-version requires desc file-type))) 210 (aref pkg-info 2)))
185 (if (> (car contents) package-archive-version) 211 (pkg-version (aref pkg-info 3))
186 (error "Unrecognized archive version %d" (car contents))) 212 (commentary (aref pkg-info 4))
187 (let ((elt (assq pkg-name (cdr contents)))) 213 (split-version (version-to-list pkg-version))
188 (if elt 214 (pkg-buffer (current-buffer)))
189 (if (version-list-<= split-version 215
190 (package-desc-vers (cdr elt))) 216 ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
191 (error "New package has smaller version: %s" pkg-version) 217 ;; from `package-archive-upload-base' otherwise.
192 (setcdr elt new-desc)) 218 (let ((contents (or (package--archive-contents-from-url archive-url)
193 (setq contents (cons (car contents) 219 (package--archive-contents-from-file)))
194 (cons (cons pkg-name new-desc) 220 (new-desc (vector split-version requires desc file-type)))
195 (cdr contents)))))) 221 (if (> (car contents) package-archive-version)
196 222 (error "Unrecognized archive version %d" (car contents)))
197 ;; Now CONTENTS is the updated archive contents. Upload 223 (let ((elt (assq pkg-name (cdr contents))))
198 ;; this and the package itself. For now we assume ELPA is 224 (if elt
199 ;; writable via file primitives. 225 (if (version-list-<= split-version
200 (let ((print-level nil) 226 (package-desc-vers (cdr elt)))
201 (print-length nil)) 227 (error "New package has smaller version: %s" pkg-version)
202 (write-region (concat (pp-to-string contents) "\n") 228 (setcdr elt new-desc))
203 nil 229 (setq contents (cons (car contents)
204 (concat package-archive-upload-base 230 (cons (cons pkg-name new-desc)
205 "archive-contents"))) 231 (cdr contents))))))
206 232
207 ;; If there is a commentary section, write it. 233 ;; Now CONTENTS is the updated archive contents. Upload
208 (when commentary 234 ;; this and the package itself. For now we assume ELPA is
209 (write-region commentary nil 235 ;; writable via file primitives.
210 (concat package-archive-upload-base 236 (let ((print-level nil)
211 (symbol-name pkg-name) "-readme.txt"))) 237 (print-length nil))
212 238 (write-region (concat (pp-to-string contents) "\n")
213 (set-buffer pkg-buffer) 239 nil
214 (write-region (point-min) (point-max) 240 (expand-file-name "archive-contents"
215 (concat package-archive-upload-base 241 package-archive-upload-base)))
216 file-name "-" pkg-version 242
217 "." extension) 243 ;; If there is a commentary section, write it.
218 nil nil nil 'excl) 244 (when commentary
219 245 (write-region commentary nil
220 ;; Write a news entry. 246 (expand-file-name
221 (and package-update-news-on-upload 247 (concat (symbol-name pkg-name) "-readme.txt")
222 archive-url 248 package-archive-upload-base)))
223 (package--update-news (concat file-name "." extension) 249
224 pkg-version desc archive-url)) 250 (set-buffer pkg-buffer)
225 251 (write-region (point-min) (point-max)
226 ;; special-case "package": write a second copy so that the 252 (expand-file-name
227 ;; installer can easily find the latest version. 253 (concat file-name "-" pkg-version "." extension)
228 (if (string= file-name "package") 254 package-archive-upload-base)
229 (write-region (point-min) (point-max) 255 nil nil nil 'excl)
230 (concat package-archive-upload-base 256
231 file-name "." extension) 257 ;; Write a news entry.
232 nil nil nil 'ask))))))) 258 (and package-update-news-on-upload
259 archive-url
260 (package--update-news (concat file-name "." extension)
261 pkg-version desc archive-url))
262
263 ;; special-case "package": write a second copy so that the
264 ;; installer can easily find the latest version.
265 (if (string= file-name "package")
266 (write-region (point-min) (point-max)
267 (expand-file-name
268 (concat file-name "." extension)
269 package-archive-upload-base)
270 nil nil nil 'ask))))))))
233 271
234(defun package-upload-buffer () 272(defun package-upload-buffer ()
235 "Upload the current buffer as a single-file Emacs Lisp package. 273 "Upload the current buffer as a single-file Emacs Lisp package.
236The variable `package-archive-upload-base' specifies the upload 274If `package-archive-upload-base' does not specify a valid upload
237destination." 275destination, prompt for one."
238 (interactive) 276 (interactive)
239 (save-excursion 277 (save-excursion
240 (save-restriction 278 (save-restriction
@@ -247,9 +285,8 @@ destination."
247Interactively, prompt for FILE. The package is considered a 285Interactively, prompt for FILE. The package is considered a
248single-file package if FILE ends in \".el\", and a multi-file 286single-file package if FILE ends in \".el\", and a multi-file
249package if FILE ends in \".tar\". 287package if FILE ends in \".tar\".
250 288If `package-archive-upload-base' does not specify a valid upload
251The variable `package-archive-upload-base' specifies the upload 289destination, prompt for one."
252destination."
253 (interactive "fPackage file name: ") 290 (interactive "fPackage file name: ")
254 (with-temp-buffer 291 (with-temp-buffer
255 (insert-file-contents-literally file) 292 (insert-file-contents-literally file)
@@ -269,4 +306,4 @@ This should be invoked from the gnus *Summary* buffer."
269 306
270(provide 'package-x) 307(provide 'package-x)
271 308
272;;; package.el ends here 309;;; 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.
319The inner alist is keyed by version.") 319The inner alist is keyed by version.")
320(put 'package-obsolete-alist 'risky-local-variable t) 320(put 'package-obsolete-alist 'risky-local-variable t)
321 321
322(defconst package-subdirectory-regexp 322(defun package-version-join (vlist)
323 "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$" 323 "Return the version string corresponding to the list VLIST.
324 "Regular expression matching the name of a package subdirectory. 324This is, approximately, the inverse of `version-to-list'.
325The first subexpression is the package name. 325\(Actually, it returns only one of the possible inverses, since
326The second subexpression is the version string.") 326`version-to-list' is a many-to-one operation.)"
327 327 (if (null vlist)
328(defun package-version-join (l) 328 ""
329 "Turn a list of version numbers into a version string." 329 (let ((str-list (list "." (int-to-string (car vlist)))))
330 (mapconcat 'int-to-string l ".")) 330 (dolist (num (cdr vlist))
331 (cond
332 ((>= num 0)
333 (push (int-to-string num) str-list)
334 (push "." str-list))
335 ((< num -3)
336 (error "Invalid version list `%s'" vlist))
337 (t
338 ;; pre, or beta, or alpha
339 (cond ((equal "." (car str-list))
340 (pop str-list))
341 ((not (string-match "[0-9]+" (car str-list)))
342 (error "Invalid version list `%s'" vlist)))
343 (push (cond ((= num -1) "pre")
344 ((= num -2) "beta")
345 ((= num -3) "alpha"))
346 str-list))))
347 (if (equal "." (car str-list))
348 (pop str-list))
349 (apply 'concat (nreverse str-list)))))
331 350
332(defun package-strip-version (dirname) 351(defun package-strip-version (dirname)
333 "Strip the version from a combined package name and version. 352 "Strip the version from a combined package name and version.
334E.g., if given \"quux-23.0\", will return \"quux\"" 353E.g., if given \"quux-23.0\", will return \"quux\""
335 (if (string-match package-subdirectory-regexp dirname) 354 (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname)
336 (match-string 1 dirname))) 355 (match-string 1 dirname)))
337 356
338(defun package-load-descriptor (dir package) 357(defun package-load-descriptor (dir package)
@@ -357,12 +376,13 @@ In each valid package subdirectory, this function loads the
357description file containing a call to `define-package', which 376description file containing a call to `define-package', which
358updates `package-alist' and `package-obsolete-alist'." 377updates `package-alist' and `package-obsolete-alist'."
359 (let ((all (memq 'all package-load-list)) 378 (let ((all (memq 'all package-load-list))
379 (regexp (concat "\\`" package-subdirectory-regexp "\\'"))
360 name version force) 380 name version force)
361 (dolist (dir (cons package-user-dir package-directory-list)) 381 (dolist (dir (cons package-user-dir package-directory-list))
362 (when (file-directory-p dir) 382 (when (file-directory-p dir)
363 (dolist (subdir (directory-files dir)) 383 (dolist (subdir (directory-files dir))
364 (when (and (file-directory-p (expand-file-name subdir dir)) 384 (when (and (file-directory-p (expand-file-name subdir dir))
365 (string-match package-subdirectory-regexp subdir)) 385 (string-match regexp subdir))
366 (setq name (intern (match-string 1 subdir)) 386 (setq name (intern (match-string 1 subdir))
367 version (match-string 2 subdir) 387 version (match-string 2 subdir)
368 force (assq name package-load-list)) 388 force (assq name package-load-list))
@@ -554,30 +574,29 @@ EXTRA-PROPERTIES is currently unused."
554 (package-autoload-ensure-default-file generated-autoload-file)) 574 (package-autoload-ensure-default-file generated-autoload-file))
555 (update-directory-autoloads pkg-dir))) 575 (update-directory-autoloads pkg-dir)))
556 576
557(defun package-untar-buffer () 577(defvar tar-parse-info)
578(declare-function tar-untar-buffer "tar-mode" ())
579
580(defun package-untar-buffer (dir)
558 "Untar the current buffer. 581 "Untar the current buffer.
559This uses `tar-untar-buffer' if it is available. 582This uses `tar-untar-buffer' from Tar mode. All files should
560Otherwise it uses an external `tar' program. 583untar into a directory named DIR; otherwise, signal an error."
561`default-directory' should be set by the caller."
562 (require 'tar-mode) 584 (require 'tar-mode)
563 (if (fboundp 'tar-untar-buffer) 585 (tar-mode)
564 (progn 586 ;; Make sure everything extracts into DIR.
565 ;; tar-mode messes with narrowing, so we just let it have the 587 (let ((regexp (concat "\\`" (regexp-quote dir) "/")))
566 ;; whole buffer to play with. 588 (dolist (tar-data tar-parse-info)
567 (delete-region (point-min) (point)) 589 (unless (string-match regexp (aref tar-data 2))
568 (tar-mode) 590 (error "Package does not untar cleanly into directory %s/" dir))))
569 (tar-untar-buffer)) 591 (tar-untar-buffer))
570 ;; FIXME: check the result.
571 (call-process-region (point) (point-max) "tar" nil '(nil nil) nil
572 "xf" "-")))
573 592
574(defun package-unpack (name version) 593(defun package-unpack (name version)
575 (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version) 594 (let* ((dirname (concat (symbol-name name) "-" version))
576 package-user-dir))) 595 (pkg-dir (expand-file-name dirname package-user-dir)))
577 (make-directory package-user-dir t) 596 (make-directory package-user-dir t)
578 ;; FIXME: should we delete PKG-DIR if it exists? 597 ;; FIXME: should we delete PKG-DIR if it exists?
579 (let* ((default-directory (file-name-as-directory package-user-dir))) 598 (let* ((default-directory (file-name-as-directory package-user-dir)))
580 (package-untar-buffer) 599 (package-untar-buffer dirname)
581 (package-generate-autoloads (symbol-name name) pkg-dir) 600 (package-generate-autoloads (symbol-name name) pkg-dir)
582 (let ((load-path (cons pkg-dir load-path))) 601 (let ((load-path (cons pkg-dir load-path)))
583 (byte-recompile-directory pkg-dir 0 t))))) 602 (byte-recompile-directory pkg-dir 0 t)))))
@@ -592,7 +611,9 @@ Otherwise it uses an external `tar' program.
592 (if (string= file-name "package") 611 (if (string= file-name "package")
593 (package--write-file-no-coding 612 (package--write-file-no-coding
594 (expand-file-name (concat file-name ".el") package-user-dir)) 613 (expand-file-name (concat file-name ".el") package-user-dir))
595 (let* ((pkg-dir (expand-file-name (concat file-name "-" version) 614 (let* ((pkg-dir (expand-file-name (concat file-name "-"
615 (package-version-join
616 (version-to-list version)))
596 package-user-dir)) 617 package-user-dir))
597 (el-file (expand-file-name (concat file-name ".el") pkg-dir)) 618 (el-file (expand-file-name (concat file-name ".el") pkg-dir))
598 (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) 619 (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'."
848 ;; Try to activate it. 869 ;; Try to activate it.
849 (package-initialize)) 870 (package-initialize))
850 871
851(defun package-strip-rcs-id (v-str) 872(defun package-strip-rcs-id (str)
852 "Strip RCS version ID from the version string. 873 "Strip RCS version ID from the version string STR.
853If the result looks like a dotted numeric version, return it. 874If the result looks like a dotted numeric version, return it.
854Otherwise return nil." 875Otherwise return nil."
855 (if v-str 876 (when str
856 (if (string-match "^[ \t]*[$]Revision:[ \t]\([0-9.]+\)[ \t]*[$]$" v-str) 877 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
857 (match-string 1 v-str) 878 (setq str (substring str (match-end 0))))
858 (if (string-match "^[0-9.]*$" v-str) 879 (condition-case nil
859 v-str)))) 880 (if (version-to-list str)
881 str)
882 (error nil))))
860 883
861(defun package-buffer-info () 884(defun package-buffer-info ()
862 "Return a vector describing the package in the current buffer. 885 "Return a vector describing the package in the current buffer.
@@ -911,43 +934,47 @@ boundaries."
911 "Find package information for a tar file. 934 "Find package information for a tar file.
912FILE is the name of the tar file to examine. 935FILE is the name of the tar file to examine.
913The return result is a vector like `package-buffer-info'." 936The return result is a vector like `package-buffer-info'."
914 (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) 937 (let ((default-directory (file-name-directory file))
915 (error "Invalid package name `%s'" file)) 938 (file (file-name-nondirectory file)))
916 (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) 939 (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'")
917 (pkg-version (match-string-no-properties 2 file)) 940 file)
918 ;; Extract the package descriptor. 941 (error "Invalid package name `%s'" file))
919 (pkg-def-contents (shell-command-to-string 942 (let* ((pkg-name (match-string-no-properties 1 file))
920 ;; Requires GNU tar. 943 (pkg-version (match-string-no-properties 2 file))
921 (concat "tar -xOf " file " " 944 ;; Extract the package descriptor.
922 pkg-name "-" pkg-version "/" 945 (pkg-def-contents (shell-command-to-string
923 pkg-name "-pkg.el"))) 946 ;; Requires GNU tar.
924 (pkg-def-parsed (package-read-from-string pkg-def-contents))) 947 (concat "tar -xOf " file " "
925 (unless (eq (car pkg-def-parsed) 'define-package) 948
926 (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) 949 pkg-name "-" pkg-version "/"
927 (let ((name-str (nth 1 pkg-def-parsed)) 950 pkg-name "-pkg.el")))
928 (version-string (nth 2 pkg-def-parsed)) 951 (pkg-def-parsed (package-read-from-string pkg-def-contents)))
929 (docstring (nth 3 pkg-def-parsed)) 952 (unless (eq (car pkg-def-parsed) 'define-package)
930 (requires (nth 4 pkg-def-parsed)) 953 (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
931 (readme (shell-command-to-string 954 (let ((name-str (nth 1 pkg-def-parsed))
932 ;; Requires GNU tar. 955 (version-string (nth 2 pkg-def-parsed))
933 (concat "tar -xOf " file " " 956 (docstring (nth 3 pkg-def-parsed))
934 pkg-name "-" pkg-version "/README")))) 957 (requires (nth 4 pkg-def-parsed))
935 (unless (equal pkg-version version-string) 958 (readme (shell-command-to-string
936 (error "Package has inconsistent versions")) 959 ;; Requires GNU tar.
937 (unless (equal pkg-name name-str) 960 (concat "tar -xOf " file " "
938 (error "Package has inconsistent names")) 961 pkg-name "-" pkg-version "/README"))))
939 ;; Kind of a hack. 962 (unless (equal pkg-version version-string)
940 (if (string-match ": Not found in archive" readme) 963 (error "Package has inconsistent versions"))
941 (setq readme nil)) 964 (unless (equal pkg-name name-str)
942 ;; Turn string version numbers into list form. 965 (error "Package has inconsistent names"))
943 (if (eq (car requires) 'quote) 966 ;; Kind of a hack.
944 (setq requires (car (cdr requires)))) 967 (if (string-match ": Not found in archive" readme)
945 (setq requires 968 (setq readme nil))
946 (mapcar (lambda (elt) 969 ;; Turn string version numbers into list form.
947 (list (car elt) 970 (if (eq (car requires) 'quote)
948 (version-to-list (cadr elt)))) 971 (setq requires (car (cdr requires))))
949 requires)) 972 (setq requires
950 (vector pkg-name requires docstring version-string readme)))) 973 (mapcar (lambda (elt)
974 (list (car elt)
975 (version-to-list (cadr elt))))
976 requires))
977 (vector pkg-name requires docstring version-string readme)))))
951 978
952;;;###autoload 979;;;###autoload
953(defun package-install-from-buffer (pkg-info type) 980(defun package-install-from-buffer (pkg-info type)
@@ -1037,7 +1064,7 @@ makes them available for download."
1037 (unless (file-exists-p package-user-dir) 1064 (unless (file-exists-p package-user-dir)
1038 (make-directory package-user-dir t)) 1065 (make-directory package-user-dir t))
1039 (dolist (archive package-archives) 1066 (dolist (archive package-archives)
1040 (condition-case nil 1067 (condition-case-no-debug nil
1041 (package--download-one-archive archive "archive-contents") 1068 (package--download-one-archive archive "archive-contents")
1042 (error (message "Failed to download `%s' archive." 1069 (error (message "Failed to download `%s' archive."
1043 (car archive))))) 1070 (car archive)))))
@@ -1465,7 +1492,7 @@ packages marked for deletion are removed."
1465 delete-list 1492 delete-list
1466 ", ")))) 1493 ", "))))
1467 (dolist (elt delete-list) 1494 (dolist (elt delete-list)
1468 (condition-case err 1495 (condition-case-no-debug err
1469 (package-delete (car elt) (cdr elt)) 1496 (package-delete (car elt) (cdr elt))
1470 (error (message (cadr err))))) 1497 (error (message (cadr err)))))
1471 (error "Aborted"))) 1498 (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."
35 35
36;;; User Functions: 36;;; User Functions:
37 37
38(defmacro eshell-eval-using-options (name macro-args 38(defmacro eshell-eval-using-options (name macro-args options &rest body-forms)
39 options &rest body-forms)
40 "Process NAME's MACRO-ARGS using a set of command line OPTIONS. 39 "Process NAME's MACRO-ARGS using a set of command line OPTIONS.
41After doing so, settings will be stored in local symbols as declared 40After doing so, stores settings in local symbols as declared by OPTIONS;
42by OPTIONS; FORMS will then be evaluated -- assuming all was OK. 41then evaluates BODY-FORMS -- assuming all was OK.
43 42
44The syntax of OPTIONS is: 43OPTIONS is a list, beginning with one or more elements of the form:
44\(SHORT LONG VALUE SYMBOL HELP-STRING)
45Each of these elements represents a particular command-line switch.
46
47SHORT is either nil, or a character that can be used as a switch -SHORT.
48LONG is either nil, or a string that can be used as a switch --LONG.
49At least one of SHORT and LONG must be non-nil.
50VALUE is the value associated with the option. It can be either:
51 t - the option needs a value to be specified after the switch;
52 nil - the option is given the value t;
53 anything else - specifies the actual value for the option.
54SYMBOL is either nil, or the name of the Lisp symbol that will be bound
55to VALUE. A nil SYMBOL calls `eshell-show-usage', and so is appropriate
56for a \"--help\" type option.
57HELP-STRING is a documentation string for the option.
58
59Any remaining elements of OPTIONS are :KEYWORD arguments. Some take
60arguments, some do not. The recognized :KEYWORDS are:
61
62:external STRING
63 STRING is an external command to run if there are unknown switches.
64
65:usage STRING
66 STRING is the initial part of the command's documentation string.
67 It appears before the options are listed.
68
69:post-usage STRING
70 STRING is an optional trailing part of the command's documentation string.
71 It appears after the options, but before the final part of the
72 documentation about the associated external command (if there is one).
73
74:show-usage
75 If present, then show the usage message if the command is called with no
76 arguments.
77
78:preserve-args
79 If present, do not pass MACRO-ARGS through `eshell-flatten-list'
80and `eshell-stringify-list'.
81
82For example, OPTIONS might look like:
45 83
46 '((?C nil nil multi-column \"multi-column display\") 84 '((?C nil nil multi-column \"multi-column display\")
47 (nil \"help\" nil nil \"show this usage display\") 85 (nil \"help\" nil nil \"show this usage display\")
@@ -52,8 +90,9 @@ The syntax of OPTIONS is:
52 Sort entries alphabetically across.\") 90 Sort entries alphabetically across.\")
53 91
54`eshell-eval-using-options' returns the value of the last form in 92`eshell-eval-using-options' returns the value of the last form in
55BODY-FORMS. If instead an external command is run, the tag 93BODY-FORMS. If instead an external command is run (because of
56`eshell-external' will be thrown with the new process for its value. 94an unknown option), the tag `eshell-external' will be thrown with
95the new process for its value.
57 96
58Lastly, any remaining arguments will be available in a locally 97Lastly, any remaining arguments will be available in a locally
59interned variable `args' (created using a `let' form)." 98interned variable `args' (created using a `let' form)."
@@ -200,7 +239,7 @@ switch is unrecognized."
200 239
201(defun eshell-process-args (name args options) 240(defun eshell-process-args (name args options)
202 "Process the given ARGS using OPTIONS. 241 "Process the given ARGS using OPTIONS.
203This assumes that symbols have been intern'd by `eshell-with-options'." 242This assumes that symbols have been intern'd by `eshell-eval-using-options'."
204 (let ((ai 0) arg) 243 (let ((ai 0) arg)
205 (while (< ai (length args)) 244 (while (< ai (length args))
206 (setq arg (nth ai args)) 245 (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'."
138 (memq system-type '(ms-dos windows-nt))) 138 (memq system-type '(ms-dos windows-nt)))
139 139
140(defmacro eshell-condition-case (tag form &rest handlers) 140(defmacro eshell-condition-case (tag form &rest handlers)
141 "Like `condition-case', but only if `eshell-pass-through-errors' is nil." 141 "If `eshell-handle-errors' is non-nil, this is `condition-case'.
142Otherwise, evaluates FORM with no error handling."
142 (if eshell-handle-errors 143 (if eshell-handle-errors
143 `(condition-case ,tag 144 `(condition-case ,tag
144 ,form 145 ,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'."
567 (with-help-window buffer-name 567 (with-help-window buffer-name
568 (with-current-buffer standard-output 568 (with-current-buffer standard-output
569 (erase-buffer) 569 (erase-buffer)
570 (list-colors-print list callback)
571 (set-buffer-modified-p nil)
570 (setq truncate-lines t))) 572 (setq truncate-lines t)))
571 (let ((buf (get-buffer buffer-name)) 573 (when callback
572 (inhibit-read-only t)) 574 (pop-to-buffer buffer-name)
573 ;; Display buffer before generating content, to allow 575 (message "Click on a color to select it.")))
574 ;; `list-colors-print' to get the right window-width.
575 (with-selected-window (or (get-buffer-window buf t) (selected-window))
576 (with-current-buffer buf
577 (list-colors-print list callback)
578 (set-buffer-modified-p nil)))
579 (when callback
580 (pop-to-buffer buf)
581 (message "Click on a color to select it."))))
582 576
583(defun list-colors-print (list &optional callback) 577(defun list-colors-print (list &optional callback)
584 (let ((callback-fn 578 (let ((callback-fn
@@ -595,30 +589,19 @@ You can change the color sort order by customizing `list-colors-sort'."
595 (let* ((opoint (point)) 589 (let* ((opoint (point))
596 (color-values (color-values (car color))) 590 (color-values (color-values (car color)))
597 (light-p (>= (apply 'max color-values) 591 (light-p (>= (apply 'max color-values)
598 (* (car (color-values "white")) .5))) 592 (* (car (color-values "white")) .5))))
599 (max-len (max (- (window-width) 33) 20)))
600 (insert (car color)) 593 (insert (car color))
601 (indent-to 22) 594 (indent-to 22)
602 (put-text-property opoint (point) 'face `(:background ,(car color))) 595 (put-text-property opoint (point) 'face `(:background ,(car color)))
603 (put-text-property 596 (put-text-property
604 (prog1 (point) 597 (prog1 (point)
605 (insert " ") 598 (insert " ")
606 (if (cdr color) 599 ;; Insert all color names.
607 ;; Insert as many color names as possible, fitting max-len. 600 (insert (mapconcat 'identity color ",")))
608 (let ((names (list (car color)))
609 (others (cdr color))
610 (len (length (car color)))
611 newlen)
612 (while (and others
613 (< (setq newlen (+ len 2 (length (car others))))
614 max-len))
615 (setq len newlen)
616 (push (pop others) names))
617 (insert (mapconcat 'identity (nreverse names) ", ")))
618 (insert (car color))))
619 (point) 601 (point)
620 'face (list :foreground (car color))) 602 'face (list :foreground (car color)))
621 (indent-to (max (- (window-width) 8) 44)) 603 (insert (propertize " " 'display '(space :align-to (- right 9))))
604 (insert " ")
622 (insert (propertize 605 (insert (propertize
623 (apply 'format "#%02x%02x%02x" 606 (apply 'format "#%02x%02x%02x"
624 (mapcar (lambda (c) (lsh c -8)) 607 (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'."
3896 (let ((handler (find-file-name-handler file 'file-ownership-preserved-p))) 3896 (let ((handler (find-file-name-handler file 'file-ownership-preserved-p)))
3897 (if handler 3897 (if handler
3898 (funcall handler 'file-ownership-preserved-p file) 3898 (funcall handler 'file-ownership-preserved-p file)
3899 (let ((attributes (file-attributes file))) 3899 (let ((attributes (file-attributes file 'integer)))
3900 ;; Return t if the file doesn't exist, since it's true that no 3900 ;; Return t if the file doesn't exist, since it's true that no
3901 ;; information would be lost by an (attempted) delete and create. 3901 ;; information would be lost by an (attempted) delete and create.
3902 (or (null attributes) 3902 (or (null attributes)
3903 (= (nth 2 attributes) (user-uid))))))) 3903 (= (nth 2 attributes) (user-uid))
3904 ;; Files created on Windows by Administrator (RID=500)
3905 ;; have the Administrators group (RID=544) recorded as
3906 ;; their owner. Rewriting them will still preserve the
3907 ;; owner.
3908 (and (eq system-type 'windows-nt)
3909 (= (user-uid) 500) (= (nth 2 attributes) 544)))))))
3904 3910
3905(defun file-name-sans-extension (filename) 3911(defun file-name-sans-extension (filename)
3906 "Return FILENAME sans final \"extension\". 3912 "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
2242 "\\)\\)\\>" 2242 "\\)\\)\\>"
2243 ;; Any whitespace and defined object. 2243 ;; Any whitespace and defined object.
2244 "[ \t'\(]*" 2244 "[ \t'\(]*"
2245 "\\(setf[ \t]+\\sw+)\\|\\sw+\\)?") 2245 "\\(setf[ \t]+\\sw+\\|\\sw+\\)?")
2246 (1 font-lock-keyword-face) 2246 (1 font-lock-keyword-face)
2247 (9 (cond ((match-beginning 3) font-lock-function-name-face) 2247 (9 (cond ((match-beginning 3) font-lock-function-name-face)
2248 ((match-beginning 6) font-lock-variable-name-face) 2248 ((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 @@
12011-03-18 Julien Danjou <julien@danjou.info>
2
3 * gnus-util.el (gnus-buffer-live-p): Simplify gnus-buffer-live-p.
4 (gnus-buffer-live-p): Check that buffer is not nil.
5
62011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
7
8 * gnus-art.el: Require mouse, which the build bot seems to say is
9 needed.
10
11 * gravatar.el (gravatar-retrieve-synchronously): Use `url-retrieve' on
12 XEmacs, since it doesn't have url-retrieve-synchronously.
13
142011-03-17 Antoine Levitt <antoine.levitt@gmail.com>
15
16 * gnus-group.el (gnus-group-list-ticked): New function.
17 (gnus-group-make-menu-bar): Provide a menu entry for it.
18 (gnus-group-list-map): Provide a binding for it.
19
202011-03-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
21
22 * shr.el (shr-visit-file): New command.
23
24 * nnimap.el (nnimap-fetch-inbox): Rewrite slightly last patch.
25
262011-03-17 Bjørn Mork <bjorn@mork.no>
27
28 * nnimap.el (nnimap-fetch-inbox): Don't download bodies on ver4-capable
29 servers.
30
312011-03-16 Julien Danjou <julien@danjou.info>
32
33 * mm-uu.el (mm-uu-dissect-text-parts): Only dissect handle that are
34 inline.
35
36 * gnus-art.el (article-hide-list-identifiers): Use
37 gnus-group-get-list-identifiers.
38
39 * gnus-sum.el (gnus-group-get-list-identifiers): New function.
40 (gnus-summary-remove-list-identifiers): Use
41 gnus-group-get-list-identifiers to get regexp.
42 (gnus-select-newsgroup, gnus-summary-insert-subject)
43 (gnus-summary-insert-articles): Call
44 gnus-summary-remove-list-identifiers unconditionally.
45
462011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
47
48 * gnus-sum.el (gnus-articles-to-read): Revert back to old behaviour if
49 we're selecting a group with unread articles.
50
51 * nnimap.el (nnimap-open-connection-1): Allow `network-only', too.
52
53 * gssapi.el: New file separated out from imap.el to provide a general
54 Kerberos 5 connection facility for Emacs.
55
56 * message.el (message-elide-ellipsis): Document the format spec
57 ellipsis.
58
592011-03-15 Reiner Steib <Reiner.Steib@gmx.de>
60
61 * message.el (message-elide-region): Allow the ellipsis to say how many
62 lines were removed.
63
642011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
65
66 * gnus-win.el (gnus-configure-frame): Protect against trying to restore
67 window configurations containing buffers that are now dead.
68
69 * nnimap.el (nnimap-parse-flags): Remove all MODSEQ entries before
70 parsing to avoid integer overflows.
71 (nnimap-parse-flags): Simplify the last change.
72 (nnimap-parse-flags): Store HIGHESTMODSEQ as a string, since it may be
73 too large for 32-bit Emacsen.
74
752011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
76
77 * auth-source.el (auth-source-netrc-create):
78 * message.el (message-yank-original): Fix use of `case'.
79
802011-03-15 Nelson Ferreira <nelson.ferreira@ieee.org> (tiny change)
81
82 * gnus-art.el (gnus-article-treat-body-boundary): Fix boundary width on
83 XEmacs, which was one character too wide.
84
852011-03-09 Antoine Levitt <antoine.levitt@gmail.com>
86
87 * gnus-sum.el (gnus-articles-to-read): Use gnus-large-newsgroup as
88 default number of articles to display.
89 (gnus-articles-to-read): Use pretty names for prompt.
90
912011-03-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
92
93 * gnus-int.el (gnus-open-server): Ditto.
94
95 * gnus-start.el (gnus-activate-group): Give a backtrace if
96 debug-on-quit is set and the user hits `C-g'.
97 (gnus-read-active-file): Ditto.
98
99 * gnus-group.el (gnus-group-read-ephemeral-group): Ditto.
100
1012011-03-15 Teodor Zlatanov <tzz@lifelogs.com>
102
103 * message.el (message-yank-original): Use cond instead of CL case.
104
1052011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
106
107 * auth-source.el (auth-source-netrc-create): Use usual format for the
108 default in prompts.
109
1102011-03-13 Teodor Zlatanov <tzz@lifelogs.com>
111
112 * auth-source.el (auth-source-netrc-create): Show the default in the
113 prompt when prompting for token creation.
114
1152011-03-12 Teodor Zlatanov <tzz@lifelogs.com>
116
117 * auth-source.el (auth-source-format-prompt): Always convert the value
118 to a string to avoid evaluating non-string arguments.
119 (auth-source-netrc-create): Offer default properly, not as initial
120 content in `read-string'.
121 (auth-source-netrc-saver): Use a cache keyed by file name and MD5 hash
122 of line to determine if we've been run before. If so, don't run again,
123 but print a trivial message to indicate the cache was hit instead.
124
1252011-03-11 Teodor Zlatanov <tzz@lifelogs.com>
126
127 * gnus-sync.el (gnus-sync-install-hooks, gnus-sync-unload-hook):
128 Don't install `gnus-sync-read' to any hooks by default. It's buggy.
129 The user will have to run `gnus-sync-read' manually and wait for Cloudy
130 Gnus.
131
1322011-03-11 Julien Danjou <julien@danjou.info>
133
134 * mm-uu.el (mm-uu-type-alist): Add support for diff starting with "===
135 modified file".
136
1372011-03-09 Teodor Zlatanov <tzz@lifelogs.com>
138
139 * auth-source.el (auth-source-read-char-choice): New function to read a
140 character choice using `dropdown-list', `read-char-choice', or
141 `read-char'. It appends "[a/b/c] " to the prompt if the choices were
142 '(?a ?b ?c). The `dropdown-list' support is disabled for now. Use
143 `eval-when-compile' to load `dropdown-list'. Remove `dropdown-list'.
144 (auth-source-netrc-saver): Use it.
145 (auth-source-pick-first-password): New convenience function.
146
1472011-03-08 Teodor Zlatanov <tzz@lifelogs.com>
148
149 * nnimap.el (nnimap-credentials): Keep the :save-function as the third
150 parameter in the credentials.
151 (nnimap-open-connection-1): Use it after a successful login.
152 (nnimap-credentials): Add IMAP-specific user and password prompt.
153
154 * auth-source.el (auth-source-search): Add :require parameter, taking a
155 list. Document it and the :save-function return token. Pass :require
156 down. Change the CREATED message from a warning to a debug statement.
157 (auth-source-search-backends): Pass :require down.
158 (auth-source-netrc-search): Pass :require down.
159 (auth-source-netrc-parse): Use :require, if it's given, as a filter.
160 Change save prompt to indicate all modifications saved here are
161 deletions.
162 (auth-source-netrc-create): Take user login name as default in user
163 prompt. Move all the save functionality to a lexically bound function
164 under the :save-function token in the returned list. Set up clearer
165 default prompts for user, host, port, and secret.
166 (auth-source-netrc-saver): New function, intended to be wrapped for
167 :save-function.
168
1692011-03-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
170
171 * shr.el (shr-table-horizontal-line): Change the defaults for the table
172 lines to be spaces instead.
173
1742011-03-07 Julien Danjou <julien@danjou.info>
175
176 * sieve-manage.el (sieve-sasl-auth): Create auth-info if not found.
177 (sieve-sasl-auth): Check that auth-source-search did return something,
178 or just return an empty string.
179
12011-03-05 Antoine Levitt <antoine.levitt@gmail.com> 1802011-03-05 Antoine Levitt <antoine.levitt@gmail.com>
2 181
3 * gnus.el (gnus-interactive): Use read-directory-name. 182 * gnus.el (gnus-interactive): Use read-directory-name.
@@ -12,6 +191,13 @@
12 191
132011-03-05 Lars Magne Ingebrigtsen <larsi@gnus.org> 1922011-03-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
14 193
194 * gnus-start.el (gnus-group-change-level): Allow putting foreign groups
195 onto the list of killed groups, too. This makes killed nnimap groups,
196 for instance, more reliably not reappear.
197
198 * nnimap.el (nnimap-request-thread): Don't bug out when we can't find
199 the parent.
200
15 * gnus-sum.el (gnus-update-read-articles): Fix typo. 201 * gnus-sum.el (gnus-update-read-articles): Fix typo.
16 202
17 * gnus.el (gnus-valid-select-methods): Mark nnimap as a backend that 203 * gnus.el (gnus-valid-select-methods): Mark nnimap as a backend that
@@ -24,8 +210,8 @@
24 210
252011-03-05 Antoine Levitt <antoine.levitt@gmail.com> 2112011-03-05 Antoine Levitt <antoine.levitt@gmail.com>
26 212
27 * message.el (message-cite-reply-position, message-cite-style): New 213 * message.el (message-cite-reply-position, message-cite-style):
28 variables. 214 New variables.
29 (message-yank-original): Use the new citation styles. 215 (message-yank-original): Use the new citation styles.
30 216
312011-03-04 Daiki Ueno <ueno@unixuser.org> 2172011-03-04 Daiki Ueno <ueno@unixuser.org>
@@ -139,14 +325,14 @@
139 325
1402011-02-23 Lars Ingebrigtsen <larsi@gnus.org> 3262011-02-23 Lars Ingebrigtsen <larsi@gnus.org>
141 327
142 * gnus-start.el (gnus-dribble-read-file): Set 328 * gnus-start.el (gnus-dribble-read-file):
143 buffer-save-without-query, since we always want to save the dribble 329 Set buffer-save-without-query, since we always want to save the dribble
144 file, probably. 330 file, probably.
145 331
146 * nnmail.el (nnmail-article-group): Allow a final "" split to work on 332 * nnmail.el (nnmail-article-group): Allow a final "" split to work on
147 nnimap. 333 nnimap.
148 334
149 * gnus-sum.el (gnus-user-date-format-alist): Renamed back again from 335 * gnus-sum.el (gnus-user-date-format-alist): Rename back again from
150 -summary- since it's a user-visible variable. 336 -summary- since it's a user-visible variable.
151 337
152 * nnimap.el (nnimap-retrieve-group-data-early): Don't do QRESYNC the 338 * nnimap.el (nnimap-retrieve-group-data-early): Don't do QRESYNC the
@@ -392,8 +578,8 @@
3922011-02-14 Teodor Zlatanov <tzz@lifelogs.com> 5782011-02-14 Teodor Zlatanov <tzz@lifelogs.com>
393 579
394 * auth-source.el (auth-source-backend-parse-parameters): Don't rely on 580 * auth-source.el (auth-source-backend-parse-parameters): Don't rely on
395 `plist-get' to accept non-list parameters (XEmacs issue). Fix 581 `plist-get' to accept non-list parameters (XEmacs issue).
396 docstring. 582 Fix docstring.
397 (auth-source-secrets-search): Use `delete-dups', `append mapcar', and 583 (auth-source-secrets-search): Use `delete-dups', `append mapcar', and
398 `butlast' instead of `remove-duplicates', `mapcan', and `subseq'. 584 `butlast' instead of `remove-duplicates', `mapcan', and `subseq'.
399 (auth-sources, auth-source-backend-parse, auth-source-secrets-search): 585 (auth-sources, auth-source-backend-parse, auth-source-secrets-search):
@@ -433,8 +619,8 @@
433 619
4342011-02-13 Tassilo Horn <tassilo@member.fsf.org> (tiny change) 6202011-02-13 Tassilo Horn <tassilo@member.fsf.org> (tiny change)
435 621
436 * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk): Fix 622 * nnimap.el (nnimap-request-accept-article, nnimap-process-quirk):
437 Gcc processing on imap. 623 Fix Gcc processing on imap.
438 624
4392011-02-10 Stefan Monnier <monnier@iro.umontreal.ca> 6252011-02-10 Stefan Monnier <monnier@iro.umontreal.ca>
440 626
@@ -522,8 +708,8 @@
522 708
5232011-02-06 Michael Albinus <michael.albinus@gmx.de> 7092011-02-06 Michael Albinus <michael.albinus@gmx.de>
524 710
525 * auth-source.el (top): Require 'eieio unconditionally. Autoload 711 * auth-source.el (top): Require 'eieio unconditionally.
526 `secrets-get-attributes' instead of `secrets-get-attribute'. 712 Autoload `secrets-get-attributes' instead of `secrets-get-attribute'.
527 (auth-source-secrets-search): Limit search when `max' is greater than 713 (auth-source-secrets-search): Limit search when `max' is greater than
528 number of results. 714 number of results.
529 715
@@ -559,7 +745,7 @@
559 (auth-source-protocol-defaults, auth-source-user-or-password-imap) 745 (auth-source-protocol-defaults, auth-source-user-or-password-imap)
560 (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh) 746 (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh)
561 (auth-source-user-or-password-sftp) 747 (auth-source-user-or-password-sftp)
562 (auth-source-user-or-password-smtp): Removed. 748 (auth-source-user-or-password-smtp): Remove.
563 (auth-source-user-or-password): Deprecated and modified to be a wrapper 749 (auth-source-user-or-password): Deprecated and modified to be a wrapper
564 around `auth-source-search'. Not tested thoroughly. 750 around `auth-source-search'. Not tested thoroughly.
565 751
@@ -725,16 +911,16 @@
725 * gnus-group.el (gnus-group-jump-to-group): Allow jumping to groups 911 * gnus-group.el (gnus-group-jump-to-group): Allow jumping to groups
726 that Gnus doesn't know exists again. 912 that Gnus doesn't know exists again.
727 913
728 * gnus-art.el (gnus-article-date-lapsed-new-header): Removed. 914 * gnus-art.el (gnus-article-date-lapsed-new-header): Remove.
729 (gnus-treat-date-ut): Ditto. 915 (gnus-treat-date-ut): Ditto.
730 (gnus-article-update-date-header): Renamed. 916 (gnus-article-update-date-header): Rename.
731 (gnus-treat-date-local): Removed. 917 (gnus-treat-date-local): Remove.
732 (gnus-treat-date-english): Removed. 918 (gnus-treat-date-english): Remove.
733 (gnus-treat-date-lapsed): Removed. 919 (gnus-treat-date-lapsed): Remove.
734 (gnus-treat-date-combined-lapsed): Removed. 920 (gnus-treat-date-combined-lapsed): Remove.
735 (gnus-treat-date-original): Removed. 921 (gnus-treat-date-original): Remove.
736 (gnus-treat-date-iso8601): Removed. 922 (gnus-treat-date-iso8601): Remove.
737 (gnus-treat-date-user-defined): Removed. 923 (gnus-treat-date-user-defined): Remove.
738 (gnus-article-date-headers): New variable to control all the date 924 (gnus-article-date-headers): New variable to control all the date
739 header options. 925 header options.
740 (article-date-ut): Rewrite to allow using the new way to format date 926 (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 @@
54(autoload 'secrets-list-collections "secrets") 54(autoload 'secrets-list-collections "secrets")
55(autoload 'secrets-search-items "secrets") 55(autoload 'secrets-search-items "secrets")
56 56
57(autoload 'rfc2104-hash "rfc2104")
58
57(defvar secrets-enabled) 59(defvar secrets-enabled)
58 60
59(defgroup auth-source nil 61(defgroup auth-source nil
@@ -286,6 +288,28 @@ If the value is not a list, symmetric encryption will be used."
286 msg)) 288 msg))
287 289
288 290
291;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
292(defun auth-source-read-char-choice (prompt choices)
293 "Read one of CHOICES by `read-char-choice', or `read-char'.
294`dropdown-list' support is disabled because it doesn't work reliably.
295Only one of CHOICES will be returned. The PROMPT is augmented
296with \"[a/b/c] \" if CHOICES is '\(?a ?b ?c\)."
297 (when choices
298 (let* ((prompt-choices
299 (apply 'concat (loop for c in choices
300 collect (format "%c/" c))))
301 (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
302 (full-prompt (concat prompt prompt-choices))
303 k)
304
305 (while (not (memq k choices))
306 (setq k (cond
307 ((fboundp 'read-char-choice)
308 (read-char-choice full-prompt choices))
309 (t (message "%s" full-prompt)
310 (setq k (read-char))))))
311 k)))
312
289;; (auth-source-pick nil :host "any" :port 'imap :user "joe") 313;; (auth-source-pick nil :host "any" :port 'imap :user "joe")
290;; (auth-source-pick t :host "any" :port 'imap :user "joe") 314;; (auth-source-pick t :host "any" :port 'imap :user "joe")
291;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") 315;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
@@ -393,7 +417,7 @@ parameters."
393 417
394(defun* auth-source-search (&rest spec 418(defun* auth-source-search (&rest spec
395 &key type max host user port secret 419 &key type max host user port secret
396 create delete 420 require create delete
397 &allow-other-keys) 421 &allow-other-keys)
398 "Search or modify authentication backends according to SPEC. 422 "Search or modify authentication backends according to SPEC.
399 423
@@ -487,6 +511,11 @@ should `catch' the backend-specific error as usual. Some
487backends (netrc, at least) will prompt the user rather than throw 511backends (netrc, at least) will prompt the user rather than throw
488an error. 512an error.
489 513
514:require (A B C) means that only results that contain those
515tokens will be returned. Thus for instance requiring :secret
516will ensure that any results will actually have a :secret
517property.
518
490:delete t means to delete any found entries. nil by default. 519:delete t means to delete any found entries. nil by default.
491Use `auth-source-delete' in ELisp code instead of calling 520Use `auth-source-delete' in ELisp code instead of calling
492`auth-source-search' directly with this parameter. 521`auth-source-search' directly with this parameter.
@@ -516,11 +545,17 @@ is a plist with keys :backend :host :port :user, plus any other
516keys provided by the backend (notably :secret). But note the 545keys provided by the backend (notably :secret). But note the
517exception for :max 0, which see above. 546exception for :max 0, which see above.
518 547
548The token can hold a :save-function key. If you call that, the
549user will be prompted to save the data to the backend. You can't
550request that this should happen right after creation, because
551`auth-source-search' has no way of knowing if the token is
552actually useful. So the caller must arrange to call this function.
553
519The token's :secret key can hold a function. In that case you 554The token's :secret key can hold a function. In that case you
520must call it to obtain the actual value." 555must call it to obtain the actual value."
521 (let* ((backends (mapcar 'auth-source-backend-parse auth-sources)) 556 (let* ((backends (mapcar 'auth-source-backend-parse auth-sources))
522 (max (or max 1)) 557 (max (or max 1))
523 (ignored-keys '(:create :delete :max)) 558 (ignored-keys '(:require :create :delete :max))
524 (keys (loop for i below (length spec) by 2 559 (keys (loop for i below (length spec) by 2
525 unless (memq (nth i spec) ignored-keys) 560 unless (memq (nth i spec) ignored-keys)
526 collect (nth i spec))) 561 collect (nth i spec)))
@@ -539,6 +574,10 @@ must call it to obtain the actual value."
539 (or (eq t create) (listp create)) t 574 (or (eq t create) (listp create)) t
540 "Invalid auth-source :create parameter (must be t or a list): %s %s") 575 "Invalid auth-source :create parameter (must be t or a list): %s %s")
541 576
577 (assert
578 (listp require) t
579 "Invalid auth-source :require parameter (must be a list): %s")
580
542 (setq filtered-backends (copy-sequence backends)) 581 (setq filtered-backends (copy-sequence backends))
543 (dolist (backend backends) 582 (dolist (backend backends)
544 (dolist (key keys) 583 (dolist (key keys)
@@ -562,8 +601,9 @@ must call it to obtain the actual value."
562 spec 601 spec
563 ;; to exit early 602 ;; to exit early
564 max 603 max
565 ;; create and delete 604 ;; create is always nil here
566 nil delete)) 605 nil delete
606 require))
567 607
568 (auth-source-do-debug 608 (auth-source-do-debug
569 "auth-source-search: found %d results (max %d) matching %S" 609 "auth-source-search: found %d results (max %d) matching %S"
@@ -577,9 +617,9 @@ must call it to obtain the actual value."
577 spec 617 spec
578 ;; to exit early 618 ;; to exit early
579 max 619 max
580 ;; create and delete 620 create delete
581 create delete)) 621 require))
582 (auth-source-do-warn 622 (auth-source-do-debug
583 "auth-source-search: CREATED %d results (max %d) matching %S" 623 "auth-source-search: CREATED %d results (max %d) matching %S"
584 (length found) max spec)) 624 (length found) max spec))
585 625
@@ -589,18 +629,19 @@ must call it to obtain the actual value."
589 629
590 found)) 630 found))
591 631
592(defun auth-source-search-backends (backends spec max create delete) 632(defun auth-source-search-backends (backends spec max create delete require)
593 (let (matches) 633 (let (matches)
594 (dolist (backend backends) 634 (dolist (backend backends)
595 (when (> max (length matches)) ; when we need more matches... 635 (when (> max (length matches)) ; when we need more matches...
596 (let ((bmatches (apply 636 (let* ((bmatches (apply
597 (slot-value backend 'search-function) 637 (slot-value backend 'search-function)
598 :backend backend 638 :backend backend
599 ;; note we're overriding whatever the spec 639 ;; note we're overriding whatever the spec
600 ;; has for :create and :delete 640 ;; has for :require, :create, and :delete
601 :create create 641 :require require
602 :delete delete 642 :create create
603 spec))) 643 :delete delete
644 spec)))
604 (when bmatches 645 (when bmatches
605 (auth-source-do-trivia 646 (auth-source-do-trivia
606 "auth-source-search-backend: got %d (max %d) in %s:%s matching %S" 647 "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."
713 (return 'no))) 754 (return 'no)))
714 'no)))) 755 'no))))
715 756
716;;; Backend specific parsing: netrc/authinfo backend 757;;; (auth-source-pick-first-password :host "z.lifelogs.com")
758;;; (auth-source-pick-first-password :port "imap")
759(defun auth-source-pick-first-password (&rest spec)
760 "Pick the first secret found from applying SPEC to `auth-source-search'."
761 (let* ((result (nth 0 (apply 'auth-source-search (plist-put spec :max 1))))
762 (secret (plist-get result :secret)))
763
764 (if (functionp secret)
765 (funcall secret)
766 secret)))
767
768;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
769(defun auth-source-format-prompt (prompt alist)
770 "Format PROMPT using %x (for any character x) specifiers in ALIST."
771 (dolist (cell alist)
772 (let ((c (nth 0 cell))
773 (v (nth 1 cell)))
774 (when (and c v)
775 (setq prompt (replace-regexp-in-string (format "%%%c" c)
776 (format "%s" v)
777 prompt)))))
778 prompt)
717 779
718(defun auth-source-ensure-strings (values) 780(defun auth-source-ensure-strings (values)
719 (unless (listp values) 781 (unless (listp values)
@@ -724,12 +786,14 @@ while \(:host t) would find all host entries."
724 value)) 786 value))
725 values)) 787 values))
726 788
789;;; Backend specific parsing: netrc/authinfo backend
790
727(defvar auth-source-netrc-cache nil) 791(defvar auth-source-netrc-cache nil)
728 792
729;;; (auth-source-netrc-parse "~/.authinfo.gpg") 793;;; (auth-source-netrc-parse "~/.authinfo.gpg")
730(defun* auth-source-netrc-parse (&rest 794(defun* auth-source-netrc-parse (&rest
731 spec 795 spec
732 &key file max host user port delete 796 &key file max host user port delete require
733 &allow-other-keys) 797 &allow-other-keys)
734 "Parse FILE and return a list of all entries in the file. 798 "Parse FILE and return a list of all entries in the file.
735Note that the MAX parameter is used so we can exit the parse early." 799Note 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."
828 (or 892 (or
829 (aget alist "port") 893 (aget alist "port")
830 (aget alist "protocol") 894 (aget alist "protocol")
831 t))) 895 t))
896 (or
897 ;; the required list of keys is nil, or
898 (null require)
899 ;; every element of require is in the normalized list
900 (let ((normalized (nth 0 (auth-source-netrc-normalize
901 (list alist)))))
902 (loop for req in require
903 always (plist-get normalized req)))))
832 (decf max) 904 (decf max)
833 (push (nreverse alist) result) 905 (push (nreverse alist) result)
834 ;; to delete a line, we just comment it out 906 ;; 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."
853 (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) 925 (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
854 926
855 ;; ask AFTER we've successfully opened the file 927 ;; ask AFTER we've successfully opened the file
856 (when (y-or-n-p (format "Save file %s? (%d modifications)" 928 (when (y-or-n-p (format "Save file %s? (%d deletions)"
857 file modified)) 929 file modified))
858 (write-region (point-min) (point-max) file nil 'silent) 930 (write-region (point-min) (point-max) file nil 'silent)
859 (auth-source-do-debug 931 (auth-source-do-debug
@@ -893,7 +965,7 @@ Note that the MAX parameter is used so we can exit the parse early."
893 965
894(defun* auth-source-netrc-search (&rest 966(defun* auth-source-netrc-search (&rest
895 spec 967 spec
896 &key backend create delete 968 &key backend require create delete
897 type max host user port 969 type max host user port
898 &allow-other-keys) 970 &allow-other-keys)
899"Given a property list SPEC, return search matches from the :backend. 971"Given a property list SPEC, return search matches from the :backend.
@@ -905,6 +977,7 @@ See `auth-source-search' for details on SPEC."
905 (let ((results (auth-source-netrc-normalize 977 (let ((results (auth-source-netrc-normalize
906 (auth-source-netrc-parse 978 (auth-source-netrc-parse
907 :max max 979 :max max
980 :require require
908 :delete delete 981 :delete delete
909 :file (oref backend source) 982 :file (oref backend source)
910 :host (or host t) 983 :host (or host t)
@@ -933,17 +1006,6 @@ See `auth-source-search' for details on SPEC."
933 (nth 0 v) 1006 (nth 0 v)
934 v)) 1007 v))
935 1008
936;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
937
938(defun auth-source-format-prompt (prompt alist)
939 "Format PROMPT using %x (for any character x) specifiers in ALIST."
940 (dolist (cell alist)
941 (let ((c (nth 0 cell))
942 (v (nth 1 cell)))
943 (when (and c v)
944 (setq prompt (replace-regexp-in-string (format "%%%c" c) v prompt)))))
945 prompt)
946
947;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) 1009;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
948;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B))) 1010;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
949 1011
@@ -992,12 +1054,12 @@ See `auth-source-search' for details on SPEC."
992 (data (auth-source-netrc-element-or-first data)) 1054 (data (auth-source-netrc-element-or-first data))
993 ;; this is the default to be offered 1055 ;; this is the default to be offered
994 (given-default (aget auth-source-creation-defaults r)) 1056 (given-default (aget auth-source-creation-defaults r))
995 ;; the default supplementals are simple: for the user, 1057 ;; the default supplementals are simple:
996 ;; try (user-login-name), otherwise take given-default 1058 ;; for the user, try `given-default' and then (user-login-name);
1059 ;; otherwise take `given-default'
997 (default (cond 1060 (default (cond
998 ;; don't default the user name 1061 ((and (not given-default) (eq r 'user))
999 ;; ((and (not given-default) (eq r 'user)) 1062 (user-login-name))
1000 ;; (user-login-name))
1001 (t given-default))) 1063 (t given-default)))
1002 (printable-defaults (list 1064 (printable-defaults (list
1003 (cons 'user 1065 (cons 'user
@@ -1020,10 +1082,10 @@ See `auth-source-search' for details on SPEC."
1020 "[any port]")))) 1082 "[any port]"))))
1021 (prompt (or (aget auth-source-creation-prompts r) 1083 (prompt (or (aget auth-source-creation-prompts r)
1022 (case r 1084 (case r
1023 ('secret "%p password for user %u, host %h: ") 1085 (secret "%p password for %u@%h: ")
1024 ('user "%p user name: ") 1086 (user "%p user name for %h: ")
1025 ('host "%p host name for user %u: ") 1087 (host "%p host name for user %u: ")
1026 ('port "%p port for user %u and host %h: ")) 1088 (port "%p port for %u@%h: "))
1027 (format "Enter %s (%%u@%%h:%%p): " r))) 1089 (format "Enter %s (%%u@%%h:%%p): " r)))
1028 (prompt (auth-source-format-prompt 1090 (prompt (auth-source-format-prompt
1029 prompt 1091 prompt
@@ -1031,14 +1093,20 @@ See `auth-source-search' for details on SPEC."
1031 (?h ,(aget printable-defaults 'host)) 1093 (?h ,(aget printable-defaults 'host))
1032 (?p ,(aget printable-defaults 'port)))))) 1094 (?p ,(aget printable-defaults 'port))))))
1033 1095
1034 ;; store the data, prompting for the password if needed 1096 ;; Store the data, prompting for the password if needed.
1035 (setq data 1097 (setq data
1036 (cond 1098 (cond
1037 ((and (null data) (eq r 'secret)) 1099 ((and (null data) (eq r 'secret))
1038 ;; special case prompt for passwords 1100 ;; Special case prompt for passwords.
1039 (read-passwd prompt)) 1101 (read-passwd prompt))
1040 ((null data) 1102 ((null data)
1041 (read-string prompt default)) 1103 (when default
1104 (setq prompt
1105 (if (string-match ": *\\'" prompt)
1106 (concat (substring prompt 0 (match-beginning 0))
1107 " (default " default "): ")
1108 (concat prompt "(default " default ") "))))
1109 (read-string prompt nil nil default))
1042 (t (or data default)))) 1110 (t (or data default))))
1043 1111
1044 (when data 1112 (when data
@@ -1049,7 +1117,7 @@ See `auth-source-search' for details on SPEC."
1049 (lambda () data)) 1117 (lambda () data))
1050 data)))) 1118 data))))
1051 1119
1052 ;; when r is not an empty string... 1120 ;; When r is not an empty string...
1053 (when (and (stringp data) 1121 (when (and (stringp data)
1054 (< 0 (length data))) 1122 (< 0 (length data)))
1055 ;; this function is not strictly necessary but I think it 1123 ;; this function is not strictly necessary but I think it
@@ -1062,79 +1130,99 @@ See `auth-source-search' for details on SPEC."
1062 (if (zerop (length add)) "" " ") 1130 (if (zerop (length add)) "" " ")
1063 ;; remap auth-source tokens to netrc 1131 ;; remap auth-source tokens to netrc
1064 (case r 1132 (case r
1065 ('user "login") 1133 (user "login")
1066 ('host "machine") 1134 (host "machine")
1067 ('secret "password") 1135 (secret "password")
1068 ('port "port") ; redundant but clearer 1136 (port "port") ; redundant but clearer
1069 (t (symbol-name r))) 1137 (t (symbol-name r)))
1070 ;; the value will be printed in %S format 1138 ;; the value will be printed in %S format
1071 data)))) 1139 data))))
1072 (setq add (concat add (funcall printer))))))) 1140 (setq add (concat add (funcall printer)))))))
1073 1141
1074 (with-temp-buffer 1142 (plist-put
1075 (when (file-exists-p file) 1143 artificial
1076 (insert-file-contents file)) 1144 :save-function
1077 (when auth-source-gpg-encrypt-to 1145 (lexical-let ((file file)
1078 ;; (see bug#7487) making `epa-file-encrypt-to' local to 1146 (add add))
1079 ;; this buffer lets epa-file skip the key selection query 1147 (lambda () (auth-source-netrc-saver file add))))
1080 ;; (see the `local-variable-p' check in 1148
1081 ;; `epa-file-write-region'). 1149 (list artificial)))
1082 (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) 1150
1083 (make-local-variable 'epa-file-encrypt-to)) 1151;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function))
1084 (if (listp auth-source-gpg-encrypt-to) 1152(defun auth-source-netrc-saver (file add)
1085 (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) 1153 "Save a line ADD in FILE, prompting along the way.
1086 (goto-char (point-max)) 1154Respects `auth-source-save-behavior'. Uses
1087 1155`auth-source-netrc-cache' to avoid prompting more than once."
1088 ;; ask AFTER we've successfully opened the file 1156 (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add)))
1089 (let ((prompt (format "Save auth info to file %s? %s: " 1157 (cached (assoc key auth-source-netrc-cache)))
1090 file 1158
1091 "y/n/N/e/?")) 1159 (if cached
1092 (done (not (eq auth-source-save-behavior 'ask))) 1160 (auth-source-do-trivia
1093 (bufname "*auth-source Help*") 1161 "auth-source-netrc-saver: found previous run for key %s, returning"
1094 k) 1162 key)
1095 (while (not done) 1163 (with-temp-buffer
1096 (message "%s" prompt) 1164 (when (file-exists-p file)
1097 (setq k (read-char)) 1165 (insert-file-contents file))
1098 (case k 1166 (when auth-source-gpg-encrypt-to
1099 (?y (setq done t)) 1167 ;; (see bug#7487) making `epa-file-encrypt-to' local to
1100 (?? (save-excursion 1168 ;; this buffer lets epa-file skip the key selection query
1101 (with-output-to-temp-buffer bufname 1169 ;; (see the `local-variable-p' check in
1102 (princ 1170 ;; `epa-file-write-region').
1103 (concat "(y)es, save\n" 1171 (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
1104 "(n)o but use the info\n" 1172 (make-local-variable 'epa-file-encrypt-to))
1105 "(N)o and don't ask to save again\n" 1173 (if (listp auth-source-gpg-encrypt-to)
1106 "(e)dit the line\n" 1174 (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
1107 "(?) for help as you can see.\n")) 1175 ;; we want the new data to be found first, so insert at beginning
1108 (set-buffer standard-output) 1176 (goto-char (point-min))
1109 (help-mode)))) 1177
1110 (?n (setq add "" 1178 ;; Ask AFTER we've successfully opened the file.
1111 done t)) 1179 (let ((prompt (format "Save auth info to file %s? " file))
1112 (?N (setq add "" 1180 (done (not (eq auth-source-save-behavior 'ask)))
1113 done t 1181 (bufname "*auth-source Help*")
1114 auth-source-save-behavior nil)) 1182 k)
1115 (?e (setq add (read-string "Line to add: " add))) 1183 (while (not done)
1116 (t nil))) 1184 (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
1117 1185 (case k
1118 (when (get-buffer-window bufname) 1186 (?y (setq done t))
1119 (delete-window (get-buffer-window bufname))) 1187 (?? (save-excursion
1120 1188 (with-output-to-temp-buffer bufname
1121 ;; make sure the info is not saved 1189 (princ
1122 (when (null auth-source-save-behavior) 1190 (concat "(y)es, save\n"
1123 (setq add "")) 1191 "(n)o but use the info\n"
1124 1192 "(N)o and don't ask to save again\n"
1125 (when (< 0 (length add)) 1193 "(e)dit the line\n"
1126 (progn 1194 "(?) for help as you can see.\n"))
1127 (unless (bolp) 1195 ;; Why? Doesn't with-output-to-temp-buffer already do
1128 (insert "\n")) 1196 ;; the exact same thing anyway? --Stef
1129 (insert add "\n") 1197 (set-buffer standard-output)
1130 (write-region (point-min) (point-max) file nil 'silent) 1198 (help-mode))))
1131 (auth-source-do-warn 1199 (?n (setq add ""
1132 "auth-source-netrc-create: wrote 1 new line to %s" 1200 done t))
1133 file) 1201 (?N (setq add ""
1134 nil)) 1202 done t
1135 1203 auth-source-save-behavior nil))
1136 (when (eq done t) 1204 (?e (setq add (read-string "Line to add: " add)))
1137 (list artificial)))))) 1205 (t nil)))
1206
1207 (when (get-buffer-window bufname)
1208 (delete-window (get-buffer-window bufname)))
1209
1210 ;; Make sure the info is not saved.
1211 (when (null auth-source-save-behavior)
1212 (setq add ""))
1213
1214 (when (< 0 (length add))
1215 (progn
1216 (unless (bolp)
1217 (insert "\n"))
1218 (insert add "\n")
1219 (write-region (point-min) (point-max) file nil 'silent)
1220 (auth-source-do-debug
1221 "auth-source-netrc-create: wrote 1 new line to %s"
1222 file)
1223 (message "Saved new authentication information to %s" file)
1224 nil))))
1225 (aput 'auth-source-netrc-cache key "ran"))))
1138 1226
1139;;; Backend specific parsing: Secrets API backend 1227;;; Backend specific parsing: Secrets API backend
1140 1228
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 @@
44(require 'wid-edit) 44(require 'wid-edit)
45(require 'mm-uu) 45(require 'mm-uu)
46(require 'message) 46(require 'message)
47(require 'mouse)
47 48
48(autoload 'gnus-msg-mail "gnus-msg" nil t) 49(autoload 'gnus-msg-mail "gnus-msg" nil t)
49(autoload 'gnus-button-mailto "gnus-msg") 50(autoload 'gnus-button-mailto "gnus-msg")
@@ -2337,10 +2338,12 @@ long lines if and only if arg is positive."
2337 (let ((start (point))) 2338 (let ((start (point)))
2338 (insert "X-Boundary: ") 2339 (insert "X-Boundary: ")
2339 (gnus-add-text-properties start (point) '(invisible t intangible t)) 2340 (gnus-add-text-properties start (point) '(invisible t intangible t))
2340 (insert (let (str) 2341 (insert (let (str (max (window-width)))
2341 (while (>= (window-width) (length str)) 2342 (if (featurep 'xemacs)
2343 (setq max (1- max)))
2344 (while (>= max (length str))
2342 (setq str (concat str gnus-body-boundary-delimiter))) 2345 (setq str (concat str gnus-body-boundary-delimiter)))
2343 (substring str 0 (window-width))) 2346 (substring str 0 max))
2344 "\n") 2347 "\n")
2345 (gnus-put-text-property start (point) 'gnus-decoration 'header))))) 2348 (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
2346 2349
@@ -3074,10 +3077,7 @@ images if any to the browser, and deletes them when exiting the group
3074The `gnus-list-identifiers' variable specifies what to do." 3077The `gnus-list-identifiers' variable specifies what to do."
3075 (interactive) 3078 (interactive)
3076 (let ((inhibit-point-motion-hooks t) 3079 (let ((inhibit-point-motion-hooks t)
3077 (regexp (or (gnus-parameter-list-identifier gnus-newsgroup-name) 3080 (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
3078 (if (consp gnus-list-identifiers)
3079 (mapconcat 'identity gnus-list-identifiers " *\\|")
3080 gnus-list-identifiers)))
3081 (inhibit-read-only t)) 3081 (inhibit-read-only t))
3082 (when regexp 3082 (when regexp
3083 (save-excursion 3083 (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.")
697 "M" gnus-group-list-all-matching 697 "M" gnus-group-list-all-matching
698 "l" gnus-group-list-level 698 "l" gnus-group-list-level
699 "c" gnus-group-list-cached 699 "c" gnus-group-list-cached
700 "?" gnus-group-list-dormant) 700 "?" gnus-group-list-dormant
701 "!" gnus-group-list-ticked)
701 702
702(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map) 703(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map)
703 "k" gnus-group-list-limit 704 "k" gnus-group-list-limit
@@ -849,7 +850,8 @@ simple manner.")
849 ["List all groups matching..." gnus-group-list-all-matching t] 850 ["List all groups matching..." gnus-group-list-all-matching t]
850 ["List active file" gnus-group-list-active t] 851 ["List active file" gnus-group-list-active t]
851 ["List groups with cached" gnus-group-list-cached t] 852 ["List groups with cached" gnus-group-list-cached t]
852 ["List groups with dormant" gnus-group-list-dormant t]) 853 ["List groups with dormant" gnus-group-list-dormant t]
854 ["List groups with ticked" gnus-group-list-ticked t])
853 ("Sort" 855 ("Sort"
854 ["Default sort" gnus-group-sort-groups t] 856 ["Default sort" gnus-group-sort-groups t]
855 ["Sort by method" gnus-group-sort-groups-by-method t] 857 ["Sort by method" gnus-group-sort-groups-by-method t]
@@ -2313,9 +2315,10 @@ Return the name of the group if selection was successful."
2313 gnus-fetch-old-ephemeral-headers)) 2315 gnus-fetch-old-ephemeral-headers))
2314 (gnus-group-read-group (or number t) t group select-articles)) 2316 (gnus-group-read-group (or number t) t group select-articles))
2315 group) 2317 group)
2316 ;;(error nil)
2317 (quit 2318 (quit
2318 (message "Quit reading the ephemeral group") 2319 (if debug-on-quit
2320 (debug "Quit")
2321 (message "Quit reading the ephemeral group"))
2319 nil))))) 2322 nil)))))
2320 2323
2321(defcustom gnus-gmane-group-download-format 2324(defcustom gnus-gmane-group-download-format
@@ -4535,6 +4538,28 @@ This command may read the active file."
4535 (goto-char (point-min)) 4538 (goto-char (point-min))
4536 (gnus-group-position-point)) 4539 (gnus-group-position-point))
4537 4540
4541(defun gnus-group-list-ticked (level &optional lowest)
4542 "List all groups with ticked articles.
4543If the prefix LEVEL is non-nil, it should be a number that says which
4544level to cut off listing groups.
4545If LOWEST, don't list groups with level lower than LOWEST.
4546
4547This command may read the active file."
4548 (interactive "P")
4549 (when level
4550 (setq level (prefix-numeric-value level)))
4551 (when (or (not level) (>= level gnus-level-zombie))
4552 (gnus-cache-open))
4553 (funcall gnus-group-prepare-function
4554 (or level gnus-level-subscribed)
4555 #'(lambda (info)
4556 (let ((marks (gnus-info-marks info)))
4557 (assq 'tick marks)))
4558 lowest
4559 'ignore)
4560 (goto-char (point-min))
4561 (gnus-group-position-point))
4562
4538(defun gnus-group-listed-groups () 4563(defun gnus-group-listed-groups ()
4539 "Return a list of listed groups." 4564 "Return a list of listed groups."
4540 (let (point groups) 4565 (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)."
270 server (error-message-string err)) 270 server (error-message-string err))
271 nil) 271 nil)
272 (quit 272 (quit
273 (gnus-message 1 "Quit trying to open server %s" server) 273 (if debug-on-quit
274 (debug "Quit")
275 (gnus-message 1 "Quit trying to open server %s" server))
274 nil))) 276 nil)))
275 open-offline) 277 open-offline)
276 ;; If this hasn't been opened before, we add it to the list. 278 ;; 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."
1306 ((>= level gnus-level-zombie) 1306 ((>= level gnus-level-zombie)
1307 ;; Remove from the hash table. 1307 ;; Remove from the hash table.
1308 (gnus-sethash group nil gnus-newsrc-hashtb) 1308 (gnus-sethash group nil gnus-newsrc-hashtb)
1309 ;; We do not enter foreign groups into the list of dead 1309 (if (= level gnus-level-zombie)
1310 ;; groups. 1310 (push group gnus-zombie-list)
1311 (unless (gnus-group-foreign-p group) 1311 (if (= oldlevel gnus-level-killed)
1312 (if (= level gnus-level-zombie) 1312 ;; Remove from active hashtb.
1313 (push group gnus-zombie-list) 1313 (unintern group gnus-active-hashtb)
1314 (if (= oldlevel gnus-level-killed) 1314 ;; Don't add it into killed-list if it was killed.
1315 ;; Remove from active hashtb. 1315 (push group gnus-killed-list))))
1316 (unintern group gnus-active-hashtb)
1317 ;; Don't add it into killed-list if it was killed.
1318 (push group gnus-killed-list)))))
1319 (t 1316 (t
1320 ;; If the list is to be entered into the newsrc assoc, and 1317 ;; If the list is to be entered into the newsrc assoc, and
1321 ;; it was killed, we have to create an entry in the newsrc 1318 ;; 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."
1465 (inline (gnus-request-group group (or dont-sub-check dont-check) 1462 (inline (gnus-request-group group (or dont-sub-check dont-check)
1466 method 1463 method
1467 (gnus-get-info group))) 1464 (gnus-get-info group)))
1468 ;;(error nil)
1469 (quit 1465 (quit
1470 (message "Quit activating %s" group) 1466 (if debug-on-quit
1467 (debug "Quit")
1468 (message "Quit activating %s" group))
1471 nil))) 1469 nil)))
1472 (unless dont-check 1470 (unless dont-check
1473 (setq active (gnus-parse-active)) 1471 (setq active (gnus-parse-active))
@@ -2007,7 +2005,9 @@ If SCAN, request a scan of that group as well."
2007 ;; We catch C-g so that we can continue past servers 2005 ;; We catch C-g so that we can continue past servers
2008 ;; that do not respond. 2006 ;; that do not respond.
2009 (quit 2007 (quit
2010 (message "Quit reading the active file") 2008 (if debug-on-quit
2009 (debug "Quit")
2010 (message "Quit reading the active file"))
2011 nil)))))))) 2011 nil))))))))
2012 2012
2013(defun gnus-read-active-file-1 (method force) 2013(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."
5510 (cdr (assq number gnus-newsgroup-scored)) 5510 (cdr (assq number gnus-newsgroup-scored))
5511 (memq number gnus-newsgroup-processable)))))) 5511 (memq number gnus-newsgroup-processable))))))
5512 5512
5513(defun gnus-group-get-list-identifiers (group)
5514 "Get list identifier regexp for GROUP."
5515 (or (gnus-parameter-list-identifier group)
5516 (if (consp gnus-list-identifiers)
5517 (mapconcat 'identity gnus-list-identifiers " *\\|")
5518 gnus-list-identifiers)))
5519
5513(defun gnus-summary-remove-list-identifiers () 5520(defun gnus-summary-remove-list-identifiers ()
5514 "Remove list identifiers in `gnus-list-identifiers' from articles in the current group." 5521 "Remove list identifiers in `gnus-list-identifiers' from articles in the current group."
5515 (let ((regexp (if (consp gnus-list-identifiers) 5522 (let ((regexp (gnus-group-get-list-identifiers gnus-newsgroup-name))
5516 (mapconcat 'identity gnus-list-identifiers " *\\|") 5523 changed subject)
5517 gnus-list-identifiers))
5518 changed subject)
5519 (when regexp 5524 (when regexp
5520 (setq regexp (concat "^\\(?:R[Ee]: +\\)*\\(" regexp " *\\)")) 5525 (setq regexp (concat "^\\(?:R[Ee]: +\\)*\\(" regexp " *\\)"))
5521 (dolist (header gnus-newsgroup-headers) 5526 (dolist (header gnus-newsgroup-headers)
@@ -5707,8 +5712,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5707 (when gnus-agent 5712 (when gnus-agent
5708 (gnus-agent-get-undownloaded-list)) 5713 (gnus-agent-get-undownloaded-list))
5709 ;; Remove list identifiers from subject 5714 ;; Remove list identifiers from subject
5710 (when gnus-list-identifiers 5715 (gnus-summary-remove-list-identifiers)
5711 (gnus-summary-remove-list-identifiers))
5712 ;; Check whether auto-expire is to be done in this group. 5716 ;; Check whether auto-expire is to be done in this group.
5713 (setq gnus-newsgroup-auto-expire 5717 (setq gnus-newsgroup-auto-expire
5714 (gnus-group-auto-expirable-p group)) 5718 (gnus-group-auto-expirable-p group))
@@ -5798,7 +5802,8 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5798 5802
5799(defun gnus-articles-to-read (group &optional read-all) 5803(defun gnus-articles-to-read (group &optional read-all)
5800 "Find out what articles the user wants to read." 5804 "Find out what articles the user wants to read."
5801 (let* ((articles 5805 (let* ((only-read-p t)
5806 (articles
5802 ;; Select all articles if `read-all' is non-nil, or if there 5807 ;; Select all articles if `read-all' is non-nil, or if there
5803 ;; are no unread articles. 5808 ;; are no unread articles.
5804 (if (or read-all 5809 (if (or read-all
@@ -5822,6 +5827,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5822 (gnus-uncompress-range (gnus-active group))) 5827 (gnus-uncompress-range (gnus-active group)))
5823 (gnus-cache-articles-in-group group)) 5828 (gnus-cache-articles-in-group group))
5824 ;; Select only the "normal" subset of articles. 5829 ;; Select only the "normal" subset of articles.
5830 (setq only-read-p nil)
5825 (gnus-sorted-nunion 5831 (gnus-sorted-nunion
5826 (gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked) 5832 (gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked)
5827 gnus-newsgroup-unreads))) 5833 gnus-newsgroup-unreads)))
@@ -5845,16 +5851,25 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5845 (let* ((cursor-in-echo-area nil) 5851 (let* ((cursor-in-echo-area nil)
5846 (initial (gnus-parameter-large-newsgroup-initial 5852 (initial (gnus-parameter-large-newsgroup-initial
5847 gnus-newsgroup-name)) 5853 gnus-newsgroup-name))
5854 (default (if only-read-p
5855 (or initial gnus-large-newsgroup)
5856 number))
5848 (input 5857 (input
5849 (read-string 5858 (read-string
5850 (format 5859 (if only-read-p
5851 "How many articles from %s (%s %d): " 5860 (format
5852 (gnus-group-decoded-name gnus-newsgroup-name) 5861 "How many articles from %s (available %d, default %d): "
5853 (if initial "max" "default") 5862 (gnus-group-decoded-name
5854 number) 5863 (gnus-group-real-name gnus-newsgroup-name))
5855 (if initial 5864 number default)
5856 (cons (number-to-string initial) 5865 (format
5857 0))))) 5866 "How many articles from %s (%d available): "
5867 (gnus-group-decoded-name
5868 (gnus-group-real-name gnus-newsgroup-name))
5869 default))
5870 nil
5871 nil
5872 (number-to-string default))))
5858 (if (string-match "^[ \t]*$" input) number input))) 5873 (if (string-match "^[ \t]*$" input) number input)))
5859 ((and (> scored marked) (< scored number) 5874 ((and (> scored marked) (< scored number)
5860 (> (- scored number) 20)) 5875 (> (- scored number) 20))
@@ -5862,7 +5877,8 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5862 (read-string 5877 (read-string
5863 (format "%s %s (%d scored, %d total): " 5878 (format "%s %s (%d scored, %d total): "
5864 "How many articles from" 5879 "How many articles from"
5865 (gnus-group-decoded-name group) 5880 (gnus-group-decoded-name
5881 (gnus-group-real-name gnus-newsgroup-name))
5866 scored number)))) 5882 scored number))))
5867 (if (string-match "^[ \t]*$" input) 5883 (if (string-match "^[ \t]*$" input)
5868 number input))) 5884 number input)))
@@ -6564,9 +6580,8 @@ the subject line on."
6564 (1+ (point-at-eol)) 6580 (1+ (point-at-eol))
6565 (gnus-delete-line)))))) 6581 (gnus-delete-line))))))
6566 ;; Remove list identifiers from subject. 6582 ;; Remove list identifiers from subject.
6567 (when gnus-list-identifiers 6583 (let ((gnus-newsgroup-headers (list header)))
6568 (let ((gnus-newsgroup-headers (list header))) 6584 (gnus-summary-remove-list-identifiers))
6569 (gnus-summary-remove-list-identifiers)))
6570 (when old-header 6585 (when old-header
6571 (mail-header-set-number header (mail-header-number old-header))) 6586 (mail-header-set-number header (mail-header-number old-header)))
6572 (setq gnus-newsgroup-sparse 6587 (setq gnus-newsgroup-sparse
@@ -12670,8 +12685,7 @@ returned."
12670 (when gnus-agent 12685 (when gnus-agent
12671 (gnus-agent-get-undownloaded-list)) 12686 (gnus-agent-get-undownloaded-list))
12672 ;; Remove list identifiers from subject 12687 ;; Remove list identifiers from subject
12673 (when gnus-list-identifiers 12688 (gnus-summary-remove-list-identifiers)
12674 (gnus-summary-remove-list-identifiers))
12675 ;; First and last article in this newsgroup. 12689 ;; First and last article in this newsgroup.
12676 (when gnus-newsgroup-headers 12690 (when gnus-newsgroup-headers
12677 (setq gnus-newsgroup-begin 12691 (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 @@
25;; This is the gnus-sync.el package. 25;; This is the gnus-sync.el package.
26 26
27;; It's due for a rewrite using gnus-after-set-mark-hook and 27;; It's due for a rewrite using gnus-after-set-mark-hook and
28;; gnus-before-update-mark-hook. Until then please consider it 28;; gnus-before-update-mark-hook, and my plan is to do this once No
29;; Gnus development is done. Until then please consider it
29;; experimental. 30;; experimental.
30 31
31;; Put this in your startup file (~/.gnus.el for instance) 32;; Put this in your startup file (~/.gnus.el for instance)
@@ -42,7 +43,8 @@
42 43
43;; TODO: 44;; TODO:
44 45
45;; - after gnus-sync-read, the message counts are wrong 46;; - after gnus-sync-read, the message counts are wrong. So it's not
47;; run automatically, you have to call it with M-x gnus-sync-read
46 48
47;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to 49;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to
48;; catch the mark updates 50;; catch the mark updates
@@ -220,13 +222,13 @@ synchronized, I believe). Also see `gnus-variable-list'."
220 "Install the sync hooks." 222 "Install the sync hooks."
221 (interactive) 223 (interactive)
222 ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read) 224 ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
223 (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save) 225 ;; (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)
224 (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) 226 (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save))
225 227
226(defun gnus-sync-unload-hook () 228(defun gnus-sync-unload-hook ()
227 "Uninstall the sync hooks." 229 "Uninstall the sync hooks."
228 (interactive) 230 (interactive)
229 ;; (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read) 231 (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read)
230 (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save) 232 (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
231 (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) 233 (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
232 234
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."
672 (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) 672 (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
673 (match-string 1 references)))))) 673 (match-string 1 references))))))
674 674
675(defun gnus-buffer-live-p (buffer) 675(defsubst gnus-buffer-live-p (buffer)
676 "Say whether BUFFER is alive or not." 676 "Say whether BUFFER is alive or not."
677 (and buffer 677 (and buffer (buffer-live-p (get-buffer buffer))))
678 (get-buffer buffer)
679 (buffer-name (get-buffer buffer))))
680 678
681(defun gnus-horizontal-recenter () 679(defun gnus-horizontal-recenter ()
682 "Recenter the current buffer horizontally." 680 "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.")
268 (error "Invalid buffer type: %s" type)) 268 (error "Invalid buffer type: %s" type))
269 (let ((buf (gnus-get-buffer-create 269 (let ((buf (gnus-get-buffer-create
270 (gnus-window-to-buffer-helper buffer)))) 270 (gnus-window-to-buffer-helper buffer))))
271 (if (eq buf (window-buffer (selected-window))) (set-buffer buf) 271 (when (buffer-name buf)
272 (switch-to-buffer buf))) 272 (if (eq buf (window-buffer (selected-window)))
273 (set-buffer buf)
274 (switch-to-buffer buf))))
273 (when (memq 'frame-focus split) 275 (when (memq 'frame-focus split)
274 (setq gnus-window-frame-focus window)) 276 (setq gnus-window-frame-focus window))
275 ;; We return the window if it has the `point' spec. 277 ;; 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."
129 "Retrieve MAIL-ADDRESS gravatar and returns it." 129 "Retrieve MAIL-ADDRESS gravatar and returns it."
130 (let ((url (gravatar-build-url mail-address))) 130 (let ((url (gravatar-build-url mail-address)))
131 (if (gravatar-cache-expired url) 131 (if (gravatar-cache-expired url)
132 (with-current-buffer (url-retrieve-synchronously url) 132 (with-current-buffer (if (featurep 'xemacs)
133 (when gravatar-automatic-caching 133 (url-retrieve url)
134 (url-retrieve-synchronously url))
135 (when gravatar-automatic-caching
134 (url-store-in-cache (current-buffer))) 136 (url-store-in-cache (current-buffer)))
135 (let ((data (gravatar-data->image))) 137 (let ((data (gravatar-data->image)))
136 (kill-buffer (current-buffer)) 138 (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 @@
1;;; gssapi.el --- GSSAPI/Kerberos 5 interface for Emacs
2
3;; Copyright (C) 2011 Free Software Foundation, Inc.
4
5;; Author: Simon Josefsson <simon@josefsson.org>
6;; Lars Magne Ingebrigtsen <larsi@gnus.org>
7;; Keywords: network
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;;; Code:
27
28(require 'format-spec)
29
30(defcustom gssapi-program (list
31 (concat "gsasl %s %p "
32 "--mechanism GSSAPI "
33 "--authentication-id %l")
34 "imtest -m gssapi -u %l -p %p %s")
35 "List of strings containing commands for GSSAPI (krb5) authentication.
36%s is replaced with server hostname, %p with port to connect to, and
37%l with the value of `imap-default-user'. The program should accept
38IMAP commands on stdin and return responses to stdout. Each entry in
39the list is tried until a successful connection is made."
40 :group 'network
41 :type '(repeat string))
42
43(defun open-gssapi-stream (name buffer server port)
44 (let ((cmds gssapi-program)
45 cmd done)
46 (with-current-buffer buffer
47 (while (and (not done)
48 (setq cmd (pop cmds)))
49 (message "Opening GSSAPI connection with `%s'..." cmd)
50 (erase-buffer)
51 (let* ((coding-system-for-read 'binary)
52 (coding-system-for-write 'binary)
53 (process (start-process
54 name buffer shell-file-name shell-command-switch
55 (format-spec
56 cmd
57 (format-spec-make
58 ?s server
59 ?p (number-to-string port)
60 ?l imap-default-user))))
61 response)
62 (when process
63 (while (and (memq (process-status process) '(open run))
64 (goto-char (point-min))
65 ;; Athena IMTEST can output SSL verify errors
66 (or (while (looking-at "^verify error:num=")
67 (forward-line))
68 t)
69 (or (while (looking-at "^TLS connection established")
70 (forward-line))
71 t)
72 ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
73 (or (while (looking-at "^C:")
74 (forward-line))
75 t)
76 ;; cyrus 1.6 imtest print "S: " before server greeting
77 (or (not (looking-at "S: "))
78 (forward-char 3)
79 t)
80 ;; GNU SASL may print 'Trying ...' first.
81 (or (not (looking-at "Trying "))
82 (forward-line)
83 t)
84 (not (and (looking-at "\\* \\(OK\\|PREAUTH\\|BYE\\) ")
85 ;; success in imtest 1.6:
86 (re-search-forward
87 (concat "^\\(\\(Authenticat.*\\)\\|\\("
88 "Client authentication "
89 "finished.*\\)\\)")
90 nil t)
91 (setq response (match-string 1)))))
92 (accept-process-output process 1)
93 (sit-for 1))
94 (erase-buffer)
95 (message "GSSAPI IMAP connection: %s" (or response "failed"))
96 (if (and response (let ((case-fold-search nil))
97 (not (string-match "failed" response))))
98 (setq done process)
99 (delete-process process)
100 nil))))
101 done)))
102
103(provide 'gssapi)
104
105;;; 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 @@
49(require 'mail-parse) 49(require 'mail-parse)
50(require 'mml) 50(require 'mml)
51(require 'rfc822) 51(require 'rfc822)
52(require 'format-spec)
52 53
53(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ 54(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
54 55
@@ -438,7 +439,10 @@ whitespace)."
438 :group 'message-various) 439 :group 'message-various)
439 440
440(defcustom message-elide-ellipsis "\n[...]\n\n" 441(defcustom message-elide-ellipsis "\n[...]\n\n"
441 "*The string which is inserted for elided text." 442 "*The string which is inserted for elided text.
443This is a format-spec string, and you can use %l to say how many
444lines were removed, and %c to say how many characters were
445removed."
442 :type 'string 446 :type 'string
443 :link '(custom-manual "(message)Various Commands") 447 :link '(custom-manual "(message)Various Commands")
444 :group 'message-various) 448 :group 'message-various)
@@ -3535,8 +3539,12 @@ Note that this should not be used in newsgroups."
3535An ellipsis (from `message-elide-ellipsis') will be inserted where the 3539An ellipsis (from `message-elide-ellipsis') will be inserted where the
3536text was killed." 3540text was killed."
3537 (interactive "r") 3541 (interactive "r")
3538 (kill-region b e) 3542 (let ((lines (count-lines b e))
3539 (insert message-elide-ellipsis)) 3543 (chars (- e b)))
3544 (kill-region b e)
3545 (insert (format-spec message-elide-ellipsis
3546 `((?l . ,lines)
3547 (?c . ,chars))))))
3540 3548
3541(defvar message-caesar-translation-table nil) 3549(defvar message-caesar-translation-table nil)
3542 3550
@@ -3749,12 +3757,12 @@ prefix, and don't delete any headers."
3749 (insert-before-markers ?\n) 3757 (insert-before-markers ?\n)
3750 (goto-char pt)))) 3758 (goto-char pt))))
3751 (case message-cite-reply-position 3759 (case message-cite-reply-position
3752 ('above 3760 (above
3753 (message-goto-body) 3761 (message-goto-body)
3754 (insert body-text) 3762 (insert body-text)
3755 (insert (if (bolp) "\n" "\n\n")) 3763 (insert (if (bolp) "\n" "\n\n"))
3756 (message-goto-body)) 3764 (message-goto-body))
3757 ('below 3765 (below
3758 (message-goto-signature))) 3766 (message-goto-signature)))
3759 ;; Add a `message-setup-very-last-hook' here? 3767 ;; Add a `message-setup-very-last-hook' here?
3760 ;; Add `gnus-article-highlight-citation' here? 3768 ;; 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\".")
158 mm-uu-diff-extract 158 mm-uu-diff-extract
159 nil 159 nil
160 mm-uu-diff-test) 160 mm-uu-diff-test)
161 (diff
162 "^=== modified file "
163 nil
164 mm-uu-diff-extract
165 nil
166 mm-uu-diff-test)
161 (git-format-patch 167 (git-format-patch
162 "^diff --git " 168 "^diff --git "
163 "^-- " 169 "^-- "
@@ -699,6 +705,8 @@ Assume text has been decoded if DECODED is non-nil."
699 ;; Mutt still uses application/pgp even though 705 ;; Mutt still uses application/pgp even though
700 ;; it has already been withdrawn. 706 ;; it has already been withdrawn.
701 (string-match "\\`text/\\|\\`application/pgp\\'" type) 707 (string-match "\\`text/\\|\\`application/pgp\\'" type)
708 (equal (car (mm-handle-disposition handle))
709 "inline")
702 (setq 710 (setq
703 children 711 children
704 (with-current-buffer buffer 712 (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.")
279 (current-buffer))) 279 (current-buffer)))
280 280
281(defun nnimap-credentials (address ports) 281(defun nnimap-credentials (address ports)
282 (let ((found (nth 0 (auth-source-search :max 1 282 (let* ((auth-source-creation-prompts
283 :host address 283 '((user . "IMAP user at %h: ")
284 :port ports 284 (secret . "IMAP password for %u@%h: ")))
285 :create t)))) 285 (found (nth 0 (auth-source-search :max 1
286 :host address
287 :port ports
288 :require '(:user :secret)
289 :create t))))
286 (if found 290 (if found
287 (list (plist-get found :user) 291 (list (plist-get found :user)
288 (let ((secret (plist-get found :secret))) 292 (let ((secret (plist-get found :secret)))
289 (if (functionp secret) 293 (if (functionp secret)
290 (funcall secret) 294 (funcall secret)
291 secret))) 295 secret))
296 (plist-get found :save-function))
292 nil))) 297 nil)))
293 298
294(defun nnimap-keepalive () 299(defun nnimap-keepalive ()
@@ -335,6 +340,7 @@ textual parts.")
335 (ports 340 (ports
336 (cond 341 (cond
337 ((or (eq nnimap-stream 'network) 342 ((or (eq nnimap-stream 'network)
343 (eq nnimap-stream 'network-only)
338 (eq nnimap-stream 'starttls)) 344 (eq nnimap-stream 'starttls))
339 (nnheader-message 7 "Opening connection to %s..." 345 (nnheader-message 7 "Opening connection to %s..."
340 nnimap-address) 346 nnimap-address)
@@ -396,7 +402,12 @@ textual parts.")
396 (let ((nnimap-inhibit-logging t)) 402 (let ((nnimap-inhibit-logging t))
397 (setq login-result 403 (setq login-result
398 (nnimap-login (car credentials) (cadr credentials)))) 404 (nnimap-login (car credentials) (cadr credentials))))
399 (unless (car login-result) 405 (if (car login-result)
406 ;; save the credentials if a save function exists
407 ;; (such a function will only be passed if a new
408 ;; token was created)
409 (when (functionp (nth 2 credentials))
410 (funcall (nth 2 credentials)))
400 ;; If the login failed, then forget the credentials 411 ;; If the login failed, then forget the credentials
401 ;; that are now possibly cached. 412 ;; that are now possibly cached.
402 (dolist (host (list (nnoo-current-server 'nnimap) 413 (dolist (host (list (nnoo-current-server 'nnimap)
@@ -1442,6 +1453,11 @@ textual parts.")
1442 ;; Change \Delete etc to %Delete, so that the reader can read it. 1453 ;; Change \Delete etc to %Delete, so that the reader can read it.
1443 (subst-char-in-region (point-min) (point-max) 1454 (subst-char-in-region (point-min) (point-max)
1444 ?\\ ?% t) 1455 ?\\ ?% t)
1456 ;; Remove any MODSEQ entries in the buffer, because they may contain
1457 ;; numbers that are too large for 32-bit Emacsen.
1458 (while (re-search-forward " MODSEQ ([0-9]+)" nil t)
1459 (replace-match "" t t))
1460 (goto-char (point-min))
1445 (let (start end articles groups uidnext elems permanent-flags 1461 (let (start end articles groups uidnext elems permanent-flags
1446 uidvalidity vanished highestmodseq) 1462 uidvalidity vanished highestmodseq)
1447 (dolist (elem sequences) 1463 (dolist (elem sequences)
@@ -1481,9 +1497,9 @@ textual parts.")
1481 (match-string 1))) 1497 (match-string 1)))
1482 (goto-char start) 1498 (goto-char start)
1483 (setq highestmodseq 1499 (setq highestmodseq
1484 (and (search-forward "HIGHESTMODSEQ " 1500 (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)"
1485 (or end (point-min)) t) 1501 (or end (point-min)) t)
1486 (read (current-buffer)))) 1502 (match-string 1)))
1487 (goto-char end) 1503 (goto-char end)
1488 (forward-line -1)) 1504 (forward-line -1))
1489 ;; The UID FETCH FLAGS was successful. 1505 ;; The UID FETCH FLAGS was successful.
@@ -1497,18 +1513,7 @@ textual parts.")
1497 (goto-char end)) 1513 (goto-char end))
1498 (while (re-search-forward "^\\* [0-9]+ FETCH " start t) 1514 (while (re-search-forward "^\\* [0-9]+ FETCH " start t)
1499 (let ((p (point))) 1515 (let ((p (point)))
1500 ;; FIXME: For FETCH lines like "* 2971 FETCH (FLAGS (%Recent) UID 1516 (setq elems (read (current-buffer)))
1501 ;; 12509 MODSEQ (13419098521433281274))" we get an
1502 ;; overflow-error. The handler simply deletes that large number
1503 ;; and reads again. But maybe there's a better fix...
1504 (setq elems (condition-case nil (read (current-buffer))
1505 (overflow-error
1506 ;; After an overflow-error, point is just after
1507 ;; the too large number. So delete it and try
1508 ;; again.
1509 (delete-region (point) (progn (backward-word) (point)))
1510 (goto-char p)
1511 (read (current-buffer)))))
1512 (push (cons (cadr (memq 'UID elems)) 1517 (push (cons (cadr (memq 'UID elems))
1513 (cadr (memq 'FLAGS elems))) 1518 (cadr (memq 'FLAGS elems)))
1514 articles))) 1519 articles)))
@@ -1545,10 +1550,11 @@ textual parts.")
1545 refid refid value))))) 1550 refid refid value)))))
1546 (result (with-current-buffer (nnimap-buffer) 1551 (result (with-current-buffer (nnimap-buffer)
1547 (nnimap-command "UID SEARCH %s" cmd)))) 1552 (nnimap-command "UID SEARCH %s" cmd))))
1548 (gnus-fetch-headers 1553 (when result
1549 (and (car result) (delete 0 (mapcar #'string-to-number 1554 (gnus-fetch-headers
1550 (cdr (assoc "SEARCH" (cdr result)))))) 1555 (and (car result) (delete 0 (mapcar #'string-to-number
1551 nil t))) 1556 (cdr (assoc "SEARCH" (cdr result))))))
1557 nil t))))
1552 1558
1553(defun nnimap-possibly-change-group (group server) 1559(defun nnimap-possibly-change-group (group server)
1554 (let ((open-result t)) 1560 (let ((open-result t))
@@ -1663,6 +1669,8 @@ textual parts.")
1663 (goto-char (point-max))) 1669 (goto-char (point-max)))
1664 openp) 1670 openp)
1665 (quit 1671 (quit
1672 (when debug-on-quit
1673 (debug "Quit"))
1666 ;; The user hit C-g while we were waiting: kill the process, in case 1674 ;; The user hit C-g while we were waiting: kill the process, in case
1667 ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind 1675 ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind
1668 ;; NAT routers). 1676 ;; NAT routers).
@@ -1754,11 +1762,15 @@ textual parts.")
1754 (format "(UID %s%s)" 1762 (format "(UID %s%s)"
1755 (format 1763 (format
1756 (if (nnimap-ver4-p) 1764 (if (nnimap-ver4-p)
1757 "BODY.PEEK[HEADER] BODY.PEEK" 1765 "BODY.PEEK"
1758 "RFC822.PEEK")) 1766 "RFC822.PEEK"))
1759 (if nnimap-split-download-body-default 1767 (cond
1760 "[]" 1768 (nnimap-split-download-body-default
1761 "[1]"))) 1769 "[]")
1770 ((nnimap-ver4-p)
1771 "[HEADER]")
1772 (t
1773 "[1]"))))
1762 t)) 1774 t))
1763 1775
1764(defun nnimap-split-incoming-mail () 1776(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."
53 :group 'shr 53 :group 'shr
54 :type 'regexp) 54 :type 'regexp)
55 55
56(defcustom shr-table-horizontal-line ?- 56(defcustom shr-table-horizontal-line ?
57 "Character used to draw horizontal table lines." 57 "Character used to draw horizontal table lines."
58 :group 'shr 58 :group 'shr
59 :type 'character) 59 :type 'character)
60 60
61(defcustom shr-table-vertical-line ?| 61(defcustom shr-table-vertical-line ?
62 "Character used to draw vertical table lines." 62 "Character used to draw vertical table lines."
63 :group 'shr 63 :group 'shr
64 :type 'character) 64 :type 'character)
65 65
66(defcustom shr-table-corner ?+ 66(defcustom shr-table-corner ?
67 "Character used to draw table corners." 67 "Character used to draw table corners."
68 :group 'shr 68 :group 'shr
69 :type 'character) 69 :type 'character)
@@ -113,6 +113,15 @@ cid: URL as the argument.")
113 113
114;; Public functions and commands. 114;; Public functions and commands.
115 115
116(defun shr-visit-file (file)
117 (interactive "fHTML file name: ")
118 (pop-to-buffer "*html*")
119 (erase-buffer)
120 (shr-insert-document
121 (with-temp-buffer
122 (insert-file-contents file)
123 (libxml-parse-html-region (point-min) (point-max)))))
124
116;;;###autoload 125;;;###autoload
117(defun shr-insert-document (dom) 126(defun shr-insert-document (dom)
118 (setq shr-content-cache nil) 127 (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'.")
275 (with-current-buffer buffer 275 (with-current-buffer buffer
276 (let* ((auth-info (auth-source-search :host sieve-manage-server 276 (let* ((auth-info (auth-source-search :host sieve-manage-server
277 :port "sieve" 277 :port "sieve"
278 :max 1)) 278 :max 1
279 (user-name (plist-get (nth 0 auth-info) :user)) 279 :create t))
280 (user-password (plist-get (nth 0 auth-info) :secret)) 280 (user-name (or (plist-get (nth 0 auth-info) :user) ""))
281 (user-password (or (plist-get (nth 0 auth-info) :secret) ""))
281 (user-password (if (functionp user-password) 282 (user-password (if (functionp user-password)
282 (funcall user-password) 283 (funcall user-password)
283 user-password)) 284 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."
575 (with-syntax-table emacs-lisp-mode-syntax-table 575 (with-syntax-table emacs-lisp-mode-syntax-table
576 (or (condition-case () 576 (or (condition-case ()
577 (save-excursion 577 (save-excursion
578 (skip-chars-forward "'")
578 (or (not (zerop (skip-syntax-backward "_w"))) 579 (or (not (zerop (skip-syntax-backward "_w")))
579 (eq (char-syntax (following-char)) ?w) 580 (eq (char-syntax (following-char)) ?w)
580 (eq (char-syntax (following-char)) ?_) 581 (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."
871 (let ((start (point))) 871 (let ((start (point)))
872 (insert (format-mode-line mode nil nil buffer)) 872 (insert (format-mode-line mode nil nil buffer))
873 (add-text-properties start (point) '(face bold))))) 873 (add-text-properties start (point) '(face bold)))))
874 (princ " mode:\n") 874 (princ " mode")
875 (let* ((mode major-mode)
876 (file-name (find-lisp-object-file-name mode nil)))
877 (when file-name
878 (princ (concat " defined in `" (file-name-nondirectory file-name) "'"))
879 ;; Make a hyperlink to the library.
880 (with-current-buffer standard-output
881 (save-excursion
882 (re-search-backward "`\\([^`']+\\)'" nil t)
883 (help-xref-button 1 'help-function-def mode file-name)))))
884 (princ ":\n")
875 (princ (documentation major-mode))))) 885 (princ (documentation major-mode)))))
876 ;; For the sake of IELM and maybe others 886 ;; For the sake of IELM and maybe others
877 nil) 887 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."
1983 (setq ido-exit nil) 1983 (setq ido-exit nil)
1984 (setq ido-final-text 1984 (setq ido-final-text
1985 (catch 'ido 1985 (catch 'ido
1986 (completing-read 1986 (completing-read-default
1987 (ido-make-prompt item prompt) 1987 (ido-make-prompt item prompt)
1988 '(("dummy" . 1)) nil nil ; table predicate require-match 1988 '(("dummy" . 1)) nil nil ; table predicate require-match
1989 (prog1 ido-text-init (setq ido-text-init nil)) ;initial-contents 1989 (prog1 ido-text-init (setq ido-text-init nil)) ;initial-contents
@@ -4740,13 +4740,13 @@ See `read-directory-name' for additional parameters."
4740 (concat ido-current-directory filename))))) 4740 (concat ido-current-directory filename)))))
4741 4741
4742;;;###autoload 4742;;;###autoload
4743(defun ido-completing-read (prompt choices &optional predicate require-match initial-input hist def) 4743(defun ido-completing-read (prompt choices &optional predicate require-match initial-input hist def inherit-input-method)
4744 "Ido replacement for the built-in `completing-read'. 4744 "Ido replacement for the built-in `completing-read'.
4745Read a string in the minibuffer with ido-style completion. 4745Read a string in the minibuffer with ido-style completion.
4746PROMPT is a string to prompt with; normally it ends in a colon and a space. 4746PROMPT is a string to prompt with; normally it ends in a colon and a space.
4747CHOICES is a list of strings which are the possible completions. 4747CHOICES is a list of strings which are the possible completions.
4748PREDICATE is currently ignored; it is included to be compatible 4748PREDICATE and INHERIT-INPUT-METHOD is currently ignored; it is included
4749 with `completing-read'. 4749 to be compatible with `completing-read'.
4750If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless 4750If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
4751 the input is (or completes to) an element of CHOICES or is null. 4751 the input is (or completes to) an element of CHOICES or is null.
4752 If the input is null, `ido-completing-read' returns DEF, or an empty 4752 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'."
594(defun info-initialize () 594(defun info-initialize ()
595 "Initialize `Info-directory-list', if that hasn't been done yet." 595 "Initialize `Info-directory-list', if that hasn't been done yet."
596 (unless Info-directory-list 596 (unless Info-directory-list
597 (let ((path (getenv "INFOPATH"))) 597 (let ((path (getenv "INFOPATH"))
598 (sep (regexp-quote path-separator)))
598 (setq Info-directory-list 599 (setq Info-directory-list
599 (prune-directory-list 600 (prune-directory-list
600 (if path 601 (if path
601 (if (string-match ":\\'" path) 602 (if (string-match-p (concat sep "\\'") path)
602 (append (split-string (substring path 0 -1) 603 (append (split-string (substring path 0 -1) sep)
603 (regexp-quote path-separator))
604 (Info-default-dirs)) 604 (Info-default-dirs))
605 (split-string path (regexp-quote path-separator))) 605 (split-string path sep))
606 (Info-default-dirs))))))) 606 (Info-default-dirs)))))))
607 607
608;;;###autoload 608;;;###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."
2306;;;; *** Rmail Message Selection And Support *** 2306;;;; *** Rmail Message Selection And Support ***
2307 2307
2308(defun rmail-msgend (n) 2308(defun rmail-msgend (n)
2309 "Return the start position for message number N." 2309 "Return the end position for message number N."
2310 (marker-position (aref rmail-message-vector (1+ n)))) 2310 (marker-position (aref rmail-message-vector (1+ n))))
2311 2311
2312(defun rmail-msgbeg (n) 2312(defun rmail-msgbeg (n)
2313 "Return the end position for message number N." 2313 "Return the start position for message number N."
2314 (marker-position (aref rmail-message-vector n))) 2314 (marker-position (aref rmail-message-vector n)))
2315 2315
2316(defun rmail-apply-in-message (msgnum function &rest args) 2316(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."
698 (when last 698 (when last
699 (setcdr last nil) 699 (setcdr last nil)
700 ;; Prefer shorter completions. 700 ;; Prefer shorter completions.
701 (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2))))) 701 (setq all (sort all (lambda (c1 c2)
702 (let ((s1 (get-text-property
703 0 :completion-cycle-penalty c1))
704 (s2 (get-text-property
705 0 :completion-cycle-penalty c2)))
706 (if (eq s1 s2)
707 (< (length c1) (length c2))
708 (< (or s1 (length c1))
709 (or s2 (length c2))))))))
702 ;; Prefer recently used completions. 710 ;; Prefer recently used completions.
703 (let ((hist (symbol-value minibuffer-history-variable))) 711 (let ((hist (symbol-value minibuffer-history-variable)))
704 (setq all (sort all (lambda (c1 c2) 712 (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 @@
36(require 'custom) 36(require 'custom)
37(eval-when-compile (require 'cl)) 37(eval-when-compile (require 'cl))
38 38
39(autoload 'auth-source-search "auth-source")
40
39(defgroup ldap nil 41(defgroup ldap nil
40 "Lightweight Directory Access Protocol." 42 "Lightweight Directory Access Protocol."
41 :version "21.1" 43 :version "21.1"
@@ -480,6 +482,22 @@ Additional search parameters can be specified through
480 "Perform a search on a LDAP server. 482 "Perform a search on a LDAP server.
481SEARCH-PLIST is a property list describing the search request. 483SEARCH-PLIST is a property list describing the search request.
482Valid keys in that list are: 484Valid keys in that list are:
485
486 `auth-source', if non-nil, will use `auth-source-search' and
487will grab the :host, :secret, :base, and (:user or :binddn)
488tokens into the `host', `passwd', `base', and `binddn' parameters
489respectively if they are not provided in SEARCH-PLIST. So for
490instance *each* of these netrc lines has the same effect if you
491ask for the host \"ldapserver:2400\":
492
493 machine ldapserver:2400 login myDN secret myPassword base myBase
494 machine ldapserver:2400 binddn myDN secret myPassword port ldap
495 login myDN secret myPassword base myBase
496
497but if you have more than one in your netrc file, only the first
498matching one will be used. Note the \"port ldap\" part is NOT
499required.
500
483 `host' is a string naming one or more (blank-separated) LDAP servers to 501 `host' is a string naming one or more (blank-separated) LDAP servers to
484to try to connect to. Each host name may optionally be of the form HOST:PORT. 502to try to connect to. Each host name may optionally be of the form HOST:PORT.
485 `filter' is a filter string for the search as described in RFC 1558. 503 `filter' is a filter string for the search as described in RFC 1558.
@@ -500,19 +518,34 @@ not their associated values.
500its distinguished name DN. 518its distinguished name DN.
501The function returns a list of matching entries. Each entry is itself 519The function returns a list of matching entries. Each entry is itself
502an alist of attribute/value pairs." 520an alist of attribute/value pairs."
503 (let ((buf (get-buffer-create " *ldap-search*")) 521 (let* ((buf (get-buffer-create " *ldap-search*"))
504 (bufval (get-buffer-create " *ldap-value*")) 522 (bufval (get-buffer-create " *ldap-value*"))
505 (host (or (plist-get search-plist 'host) 523 (host (or (plist-get search-plist 'host)
506 ldap-default-host)) 524 ldap-default-host))
525 ;; find entries with port "ldap" that match the requested host if any
526 (asfound (when (plist-get search-plist 'auth-source)
527 (nth 0 (auth-source-search :host (or host t)
528 :create t))))
529 ;; if no host was requested, get it from the auth-source entry
530 (host (or host (plist-get asfound :host)))
531 ;; get the password from the auth-source
532 (passwd (or (plist-get search-plist 'passwd)
533 (plist-get asfound :secret)))
534 ;; convert the password from a function call if needed
535 (passwd (if (functionp passwd) (funcall passwd) passwd))
536 ;; get the binddn from the search-list or from the
537 ;; auth-source user or binddn tokens
538 (binddn (or (plist-get search-plist 'binddn)
539 (plist-get asfound :user)
540 (plist-get asfound :binddn)))
541 (base (or (plist-get search-plist 'base)
542 (plist-get asfound :base)
543 ldap-default-base))
507 (filter (plist-get search-plist 'filter)) 544 (filter (plist-get search-plist 'filter))
508 (attributes (plist-get search-plist 'attributes)) 545 (attributes (plist-get search-plist 'attributes))
509 (attrsonly (plist-get search-plist 'attrsonly)) 546 (attrsonly (plist-get search-plist 'attrsonly))
510 (base (or (plist-get search-plist 'base)
511 ldap-default-base))
512 (scope (plist-get search-plist 'scope)) 547 (scope (plist-get search-plist 'scope))
513 (binddn (plist-get search-plist 'binddn))
514 (auth (plist-get search-plist 'auth)) 548 (auth (plist-get search-plist 'auth))
515 (passwd (plist-get search-plist 'passwd))
516 (deref (plist-get search-plist 'deref)) 549 (deref (plist-get search-plist 'deref))
517 (timelimit (plist-get search-plist 'timelimit)) 550 (timelimit (plist-get search-plist 'timelimit))
518 (sizelimit (plist-get search-plist 'sizelimit)) 551 (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:
511 (with-current-buffer quickurl-list-last-buffer 511 (with-current-buffer quickurl-list-last-buffer
512 (insert 512 (insert
513 (case type 513 (case type
514 ('url (funcall quickurl-format-function url)) 514 (url (funcall quickurl-format-function url))
515 ('naked-url (quickurl-url-url url)) 515 (naked-url (quickurl-url-url url))
516 ('with-lookup (format "%s <URL:%s>" 516 (with-lookup (format "%s <URL:%s>"
517 (quickurl-url-keyword url) 517 (quickurl-url-keyword url)
518 (quickurl-url-url url))) 518 (quickurl-url-url url)))
519 ('with-desc (format "%S <URL:%s>" 519 (with-desc (format "%S <URL:%s>"
520 (quickurl-url-description url) 520 (quickurl-url-description url)
521 (quickurl-url-url url))) 521 (quickurl-url-url url)))
522 ('lookup (quickurl-url-keyword url))))) 522 (lookup (quickurl-url-keyword url)))))
523 (error "No URL details on that line")) 523 (error "No URL details on that line"))
524 url)) 524 url))
525 525
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."
548 (add-hook 'auto-save-hook 'rcirc-log-write) 548 (add-hook 'auto-save-hook 'rcirc-log-write)
549 549
550 ;; identify 550 ;; identify
551 (when password 551 (unless (zerop (length password))
552 (rcirc-send-string process (concat "PASS " password))) 552 (rcirc-send-string process (concat "PASS " password)))
553 (rcirc-send-string process (concat "NICK " nick)) 553 (rcirc-send-string process (concat "NICK " nick))
554 (rcirc-send-string process (concat "USER " user-name 554 (rcirc-send-string process (concat "USER " user-name
@@ -2449,8 +2449,7 @@ keywords when no KEYWORD is given."
2449 (if rcirc-auto-authenticate-flag 2449 (if rcirc-auto-authenticate-flag
2450 (if rcirc-authenticate-before-join 2450 (if rcirc-authenticate-before-join
2451 (progn 2451 (progn
2452 (with-rcirc-process-buffer process 2452 (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t)
2453 (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t))
2454 (rcirc-authenticate)) 2453 (rcirc-authenticate))
2455 (rcirc-authenticate) 2454 (rcirc-authenticate)
2456 (rcirc-join-channels process rcirc-startup-channels)) 2455 (rcirc-join-channels process rcirc-startup-channels))
@@ -2515,7 +2514,7 @@ the only argument."
2515 (and ;; quakenet 2514 (and ;; quakenet
2516 (string= sender "Q") 2515 (string= sender "Q")
2517 (string= target rcirc-nick) 2516 (string= target rcirc-nick)
2518 (string-match message "\\`You are now logged in as .+\\.\\'"))) 2517 (string-match "\\`You are now logged in as .+\\.\\'" message)))
2519 (setq rcirc-user-authenticated t) 2518 (setq rcirc-user-authenticated t)
2520 (run-hook-with-args 'rcirc-authenticated-hook process) 2519 (run-hook-with-args 'rcirc-authenticated-hook process)
2521 (remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t)))))) 2520 (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.")
90 (tramp-login-args (("%h") ("-l" "%u"))) 90 (tramp-login-args (("%h") ("-l" "%u")))
91 (tramp-remote-sh "/bin/sh") 91 (tramp-remote-sh "/bin/sh")
92 (tramp-copy-program "rcp") 92 (tramp-copy-program "rcp")
93 (tramp-copy-args (("%k" "-p") ("-r"))) 93 (tramp-copy-args (("-p" "%k") ("-r")))
94 (tramp-copy-keep-date t) 94 (tramp-copy-keep-date t)
95 (tramp-copy-recursive t))) 95 (tramp-copy-recursive t)))
96;;;###tramp-autoload 96;;;###tramp-autoload
@@ -100,7 +100,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
100 (tramp-login-args (("%h") ("-l" "%u"))) 100 (tramp-login-args (("%h") ("-l" "%u")))
101 (tramp-remote-sh "/bin/sh") 101 (tramp-remote-sh "/bin/sh")
102 (tramp-copy-program "rcp") 102 (tramp-copy-program "rcp")
103 (tramp-copy-args (("%k" "-p"))) 103 (tramp-copy-args (("-p" "%k")))
104 (tramp-copy-keep-date t))) 104 (tramp-copy-keep-date t)))
105;;;###tramp-autoload 105;;;###tramp-autoload
106(add-to-list 'tramp-methods 106(add-to-list 'tramp-methods
@@ -110,7 +110,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
110 (tramp-async-args (("-q"))) 110 (tramp-async-args (("-q")))
111 (tramp-remote-sh "/bin/sh") 111 (tramp-remote-sh "/bin/sh")
112 (tramp-copy-program "scp") 112 (tramp-copy-program "scp")
113 (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r"))) 113 (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r")))
114 (tramp-copy-keep-date t) 114 (tramp-copy-keep-date t)
115 (tramp-copy-recursive t) 115 (tramp-copy-recursive t)
116 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") 116 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
@@ -126,7 +126,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
126 (tramp-async-args (("-q"))) 126 (tramp-async-args (("-q")))
127 (tramp-remote-sh "/bin/sh") 127 (tramp-remote-sh "/bin/sh")
128 (tramp-copy-program "scp") 128 (tramp-copy-program "scp")
129 (tramp-copy-args (("-1") ("-P" "%p") ("%k" "-p") ("-q") ("-r"))) 129 (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k") ("-q") ("-r")))
130 (tramp-copy-keep-date t) 130 (tramp-copy-keep-date t)
131 (tramp-copy-recursive t) 131 (tramp-copy-recursive t)
132 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") 132 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
@@ -142,7 +142,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
142 (tramp-async-args (("-q"))) 142 (tramp-async-args (("-q")))
143 (tramp-remote-sh "/bin/sh") 143 (tramp-remote-sh "/bin/sh")
144 (tramp-copy-program "scp") 144 (tramp-copy-program "scp")
145 (tramp-copy-args (("-2") ("-P" "%p") ("%k" "-p") ("-q") ("-r"))) 145 (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k") ("-q") ("-r")))
146 (tramp-copy-keep-date t) 146 (tramp-copy-keep-date t)
147 (tramp-copy-recursive t) 147 (tramp-copy-recursive t)
148 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") 148 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
@@ -160,7 +160,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
160 (tramp-async-args (("-q"))) 160 (tramp-async-args (("-q")))
161 (tramp-remote-sh "/bin/sh") 161 (tramp-remote-sh "/bin/sh")
162 (tramp-copy-program "scp") 162 (tramp-copy-program "scp")
163 (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r") 163 (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r")
164 ("-o" "ControlPath=%t.%%r@%%h:%%p") 164 ("-o" "ControlPath=%t.%%r@%%h:%%p")
165 ("-o" "ControlMaster=auto"))) 165 ("-o" "ControlMaster=auto")))
166 (tramp-copy-keep-date t) 166 (tramp-copy-keep-date t)
@@ -179,7 +179,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
179 (tramp-async-args (("-q"))) 179 (tramp-async-args (("-q")))
180 (tramp-remote-sh "/bin/sh") 180 (tramp-remote-sh "/bin/sh")
181 (tramp-copy-program "scp") 181 (tramp-copy-program "scp")
182 (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r"))) 182 (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r")))
183 (tramp-copy-keep-date t) 183 (tramp-copy-keep-date t)
184 (tramp-copy-recursive t) 184 (tramp-copy-recursive t)
185 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") 185 (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
@@ -202,7 +202,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
202 (tramp-async-args (("-q"))) 202 (tramp-async-args (("-q")))
203 (tramp-remote-sh "/bin/sh") 203 (tramp-remote-sh "/bin/sh")
204 (tramp-copy-program "rsync") 204 (tramp-copy-program "rsync")
205 (tramp-copy-args (("-e" "ssh") ("%k" "-t") ("-r"))) 205 (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r")))
206 (tramp-copy-keep-date t) 206 (tramp-copy-keep-date t)
207 (tramp-copy-keep-tmpfile t) 207 (tramp-copy-keep-tmpfile t)
208 (tramp-copy-recursive t))) 208 (tramp-copy-recursive t)))
@@ -217,7 +217,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
217 (tramp-async-args (("-q"))) 217 (tramp-async-args (("-q")))
218 (tramp-remote-sh "/bin/sh") 218 (tramp-remote-sh "/bin/sh")
219 (tramp-copy-program "rsync") 219 (tramp-copy-program "rsync")
220 (tramp-copy-args (("%k" "-t") ("-r"))) 220 (tramp-copy-args (("-t" "%k") ("-r")))
221 (tramp-copy-env (("RSYNC_RSH") 221 (tramp-copy-env (("RSYNC_RSH")
222 (,(concat 222 (,(concat
223 "ssh" 223 "ssh"
@@ -353,7 +353,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
353 (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) 353 (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
354 (tramp-remote-sh "/bin/sh") 354 (tramp-remote-sh "/bin/sh")
355 (tramp-copy-program "pscp") 355 (tramp-copy-program "pscp")
356 (tramp-copy-args (("-P" "%p") ("-scp") ("%k" "-p") 356 (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k")
357 ("-q") ("-r"))) 357 ("-q") ("-r")))
358 (tramp-copy-keep-date t) 358 (tramp-copy-keep-date t)
359 (tramp-copy-recursive t) 359 (tramp-copy-recursive t)
@@ -366,7 +366,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
366 (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) 366 (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
367 (tramp-remote-sh "/bin/sh") 367 (tramp-remote-sh "/bin/sh")
368 (tramp-copy-program "pscp") 368 (tramp-copy-program "pscp")
369 (tramp-copy-args (("-P" "%p") ("-sftp") ("%k" "-p") 369 (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k")
370 ("-q") ("-r"))) 370 ("-q") ("-r")))
371 (tramp-copy-keep-date t) 371 (tramp-copy-keep-date t)
372 (tramp-copy-recursive t) 372 (tramp-copy-recursive t)
@@ -378,7 +378,7 @@ detected as prompt when being sent on echoing hosts, therefore.")
378 (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) 378 (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
379 (tramp-remote-sh "/bin/sh -i") 379 (tramp-remote-sh "/bin/sh -i")
380 (tramp-copy-program "fcp") 380 (tramp-copy-program "fcp")
381 (tramp-copy-args (("%k" "-p"))) 381 (tramp-copy-args (("-p" "%k")))
382 (tramp-copy-keep-date t))) 382 (tramp-copy-keep-date t)))
383 383
384;;;###tramp-autoload 384;;;###tramp-autoload
@@ -2251,11 +2251,15 @@ The method used must be an out-of-band method."
2251 'identity) 2251 'identity)
2252 (if t2 (tramp-make-copy-program-file-name v) newname))) 2252 (if t2 (tramp-make-copy-program-file-name v) newname)))
2253 2253
2254 ;; Check for port number. Until now, there's no need for handling 2254 ;; Check for host and port number. We cannot use
2255 ;; like method, user, host. 2255 ;; `tramp-file-name-port', because this returns also
2256 (setq host (tramp-file-name-real-host v) 2256 ;; `tramp-default-port', which might clash with settings in
2257 port (tramp-file-name-port v) 2257 ;; "~/.ssh/config".
2258 port (or (and port (number-to-string port)) "")) 2258 (setq host (tramp-file-name-host v)
2259 port "")
2260 (when (string-match tramp-host-with-port-regexp host)
2261 (setq host (string-to-number (match-string 1 host))
2262 port (string-to-number (match-string 2 host))))
2259 2263
2260 ;; Compose copy command. 2264 ;; Compose copy command.
2261 (setq spec (format-spec-make 2265 (setq spec (format-spec-make
@@ -2270,7 +2274,7 @@ The method used must be an out-of-band method."
2270 copy-args 2274 copy-args
2271 (delete 2275 (delete
2272 ;; " " has either been a replacement of "%k" (when 2276 ;; " " has either been a replacement of "%k" (when
2273 ;; keep-date argument is non-nil), or a replacemtent 2277 ;; keep-date argument is non-nil), or a replacement
2274 ;; for the whole keep-date sublist. 2278 ;; for the whole keep-date sublist.
2275 " " 2279 " "
2276 (dolist 2280 (dolist
@@ -2281,7 +2285,7 @@ The method used must be an out-of-band method."
2281 (append 2285 (append
2282 copy-args 2286 copy-args
2283 (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) 2287 (let ((y (mapcar (lambda (z) (format-spec z spec)) x)))
2284 (if (zerop (length (car y))) '(" ") y)))))) 2288 (if (member "" y) '(" ") y))))))
2285 copy-env 2289 copy-env
2286 (delq 2290 (delq
2287 nil 2291 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 @@
31;; should be changed only there. 31;; should be changed only there.
32 32
33;;;###tramp-autoload 33;;;###tramp-autoload
34(defconst tramp-version "2.2.1-pre" 34(defconst tramp-version "2.2.1"
35 "This version of Tramp.") 35 "This version of Tramp.")
36 36
37;;;###tramp-autoload 37;;;###tramp-autoload
@@ -44,7 +44,7 @@
44 (= emacs-major-version 21) 44 (= emacs-major-version 21)
45 (>= emacs-minor-version 4))) 45 (>= emacs-minor-version 4)))
46 "ok" 46 "ok"
47 (format "Tramp 2.2.1-pre is not fit for %s" 47 (format "Tramp 2.2.1 is not fit for %s"
48 (when (string-match "^.*$" (emacs-version)) 48 (when (string-match "^.*$" (emacs-version))
49 (match-string 0 (emacs-version))))))) 49 (match-string 0 (emacs-version)))))))
50 (unless (string-match "\\`ok\\'" x) (error "%s" x))) 50 (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'."
414 ;; Hopefully, this will change later. 414 ;; Hopefully, this will change later.
415 (setq hit-fields 415 (setq hit-fields
416 (case (intern vendor-id) 416 (case (intern vendor-id)
417 ('Beagle 417 (Beagle
418 '("xesam:mimeType" "xesam:url")) 418 '("xesam:mimeType" "xesam:url"))
419 ('Strigi 419 (Strigi
420 '("xesam:author" "xesam:cc" "xesam:charset" 420 '("xesam:author" "xesam:cc" "xesam:charset"
421 "xesam:contentType" "xesam:fileExtension" 421 "xesam:contentType" "xesam:fileExtension"
422 "xesam:id" "xesam:lineCount" "xesam:links" 422 "xesam:id" "xesam:lineCount" "xesam:links"
423 "xesam:mimeType" "xesam:name" "xesam:size" 423 "xesam:mimeType" "xesam:name" "xesam:size"
424 "xesam:sourceModified" "xesam:subject" "xesam:to" 424 "xesam:sourceModified" "xesam:subject" "xesam:to"
425 "xesam:url")) 425 "xesam:url"))
426 ('TrackerXesamSession 426 (TrackerXesamSession
427 '("xesam:relevancyRating" "xesam:url")) 427 '("xesam:relevancyRating" "xesam:url"))
428 ('Debbugs 428 (Debbugs
429 '("xesam:keyword" "xesam:owner" "xesam:title" 429 '("xesam:keyword" "xesam:owner" "xesam:title"
430 "xesam:url" "xesam:sourceModified" "xesam:mimeType" 430 "xesam:url" "xesam:sourceModified" "xesam:mimeType"
431 "debbugs:key")) 431 "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
210 (add-to-list 'hints `(:dict-entry 210 (add-to-list 'hints `(:dict-entry
211 "urgency" 211 "urgency"
212 (:variant :byte ,(case urgency 212 (:variant :byte ,(case urgency
213 ('low 0) 213 (low 0)
214 ('critical 2) 214 (critical 2)
215 (t 1)))) t)) 215 (t 1)))) t))
216 (when category 216 (when category
217 (add-to-list 'hints `(:dict-entry 217 (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 @@
12011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * org-src.el (org-src-switch-to-buffer):
4 * org-plot.el (org-plot/gnuplot-script, org-plot/gnuplot):
5 * org-mouse.el (org-mouse-agenda-type):
6 * org-freemind.el (org-freemind-node-to-org):
7 * ob-sql.el (org-babel-execute:sql):
8 * ob-exp.el (org-babel-exp-do-export, org-babel-exp-code):
9 * ob-ref.el (org-babel-ref-resolve): Fix use of case.
10
12011-03-06 Juanma Barranquero <lekktu@gmail.com> 112011-03-06 Juanma Barranquero <lekktu@gmail.com>
2 12
3 * org.el (org-blank-before-new-entry, org-context-in-file-links) 13 * 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."
231 (org-babel-exp-results info type 'silent)))) 231 (org-babel-exp-results info type 'silent))))
232 (clean () (org-babel-remove-result info))) 232 (clean () (org-babel-remove-result info)))
233 (case (intern (or (cdr (assoc :exports (nth 2 info))) "code")) 233 (case (intern (or (cdr (assoc :exports (nth 2 info))) "code"))
234 ('none (silently) (clean) "") 234 (none (silently) (clean) "")
235 ('code (silently) (clean) (org-babel-exp-code info type)) 235 (code (silently) (clean) (org-babel-exp-code info type))
236 ('results (org-babel-exp-results info type)) 236 (results (org-babel-exp-results info type))
237 ('both (concat (org-babel-exp-code info type) 237 (both (concat (org-babel-exp-code info type)
238 "\n\n" 238 "\n\n"
239 (org-babel-exp-results info type)))))) 239 (org-babel-exp-results info type))))))
240 240
@@ -250,8 +250,8 @@ The code block is not evaluated."
250 (name (nth 4 info)) 250 (name (nth 4 info))
251 (args (mapcar #'cdr (org-babel-get-header (nth 2 info) :var)))) 251 (args (mapcar #'cdr (org-babel-get-header (nth 2 info) :var))))
252 (case type 252 (case type
253 ('inline (format "=%s=" body)) 253 (inline (format "=%s=" body))
254 ('block 254 (block
255 (let ((str 255 (let ((str
256 (format "#+BEGIN_SRC %s %s\n%s%s#+END_SRC\n" lang switches body 256 (format "#+BEGIN_SRC %s %s\n%s%s#+END_SRC\n" lang switches body
257 (if (and body (string-match "\n$" body)) 257 (if (and body (string-match "\n$" body))
@@ -265,7 +265,7 @@ The code block is not evaluated."
265 (mapconcat #'identity args ", "))) 265 (mapconcat #'identity args ", ")))
266 str)) 266 str))
267 str)) 267 str))
268 ('lob 268 (lob
269 (let ((call-line (and (string-match "results=" (car args)) 269 (let ((call-line (and (string-match "results=" (car args))
270 (substring (car args) (match-end 0))))) 270 (substring (car args) (match-end 0)))))
271 (cond 271 (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."
147 (let ((params (append args '((:results . "silent"))))) 147 (let ((params (append args '((:results . "silent")))))
148 (setq result 148 (setq result
149 (case type 149 (case type
150 ('results-line (org-babel-read-result)) 150 (results-line (org-babel-read-result))
151 ('table (org-babel-read-table)) 151 (table (org-babel-read-table))
152 ('list (org-babel-read-list)) 152 (list (org-babel-read-list))
153 ('file (org-babel-read-link)) 153 (file (org-babel-read-link))
154 ('source-block (org-babel-execute-src-block nil nil params)) 154 (source-block (org-babel-execute-src-block nil nil params))
155 ('lob (org-babel-execute-src-block nil lob-info params))))) 155 (lob (org-babel-execute-src-block nil lob-info params)))))
156 (if (symbolp result) 156 (if (symbolp result)
157 (format "%S" result) 157 (format "%S" result)
158 (if (and index (listp result)) 158 (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'."
66 (out-file (or (cdr (assoc :out-file params)) 66 (out-file (or (cdr (assoc :out-file params))
67 (org-babel-temp-file "sql-out-"))) 67 (org-babel-temp-file "sql-out-")))
68 (command (case (intern engine) 68 (command (case (intern engine)
69 ('msosql (format "osql %s -s \"\t\" -i %s -o %s" 69 (msosql (format "osql %s -s \"\t\" -i %s -o %s"
70 (or cmdline "")
71 (org-babel-process-file-name in-file)
72 (org-babel-process-file-name out-file)))
73 ('mysql (format "mysql %s -e \"source %s\" > %s"
74 (or cmdline "") 70 (or cmdline "")
75 (org-babel-process-file-name in-file) 71 (org-babel-process-file-name in-file)
76 (org-babel-process-file-name out-file))) 72 (org-babel-process-file-name out-file)))
77 ('postgresql (format "psql -A -P footer=off -F \"\t\" -f %s -o %s %s" 73 (mysql (format "mysql %s -e \"source %s\" > %s"
78 (org-babel-process-file-name in-file) 74 (or cmdline "")
79 (org-babel-process-file-name out-file) 75 (org-babel-process-file-name in-file)
80 (or cmdline ""))) 76 (org-babel-process-file-name out-file)))
77 (postgresql (format "psql -A -P footer=off -F \"\t\" -f %s -o %s %s"
78 (org-babel-process-file-name in-file)
79 (org-babel-process-file-name out-file)
80 (or cmdline "")))
81 (t (error "no support for the %s sql engine" engine))))) 81 (t (error "no support for the %s sql engine" engine)))))
82 (with-temp-file in-file 82 (with-temp-file in-file
83 (insert (org-babel-expand-body:sql body params))) 83 (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
1172 (when (< 0 (- level skip-levels)) 1172 (when (< 0 (- level skip-levels))
1173 (dolist (attrib attributes) 1173 (dolist (attrib attributes)
1174 (case (car attrib) 1174 (case (car attrib)
1175 ('TEXT (setq text (cdr attrib))) 1175 (TEXT (setq text (cdr attrib)))
1176 ('text (setq text (cdr attrib))))) 1176 (text (setq text (cdr attrib)))))
1177 (unless text 1177 (unless text
1178 ;; There should be a richcontent node holding the text: 1178 ;; There should be a richcontent node holding the text:
1179 (setq text (org-freemind-get-richcontent-node-text node))) 1179 (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
1193 (setq text (replace-regexp-in-string "\n $" "" text)) 1193 (setq text (replace-regexp-in-string "\n $" "" text))
1194 (insert text)) 1194 (insert text))
1195 (case qname 1195 (case qname
1196 ('node 1196 (node
1197 (insert (make-string (- level skip-levels) ?*) " " text "\n") 1197 (insert (make-string (- level skip-levels) ?*) " " text "\n")
1198 (when note 1198 (when note
1199 (insert ":COMMENT:\n" note "\n:END:\n")) 1199 (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:"
476 476
477(defun org-mouse-agenda-type (type) 477(defun org-mouse-agenda-type (type)
478 (case type 478 (case type
479 ('tags "Tags: ") 479 (tags "Tags: ")
480 ('todo "TODO: ") 480 (todo "TODO: ")
481 ('tags-tree "Tags tree: ") 481 (tags-tree "Tags tree: ")
482 ('todo-tree "TODO tree: ") 482 (todo-tree "TODO tree: ")
483 ('occur-tree "Occur tree: ") 483 (occur-tree "Occur tree: ")
484 (t "Agenda command ???"))) 484 (t "Agenda command ???")))
485 485
486 486
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."
206 (y-labels (plist-get params :ylabels)) 206 (y-labels (plist-get params :ylabels))
207 (plot-str "'%s' using %s%d%s with %s title '%s'") 207 (plot-str "'%s' using %s%d%s with %s title '%s'")
208 (plot-cmd (case type 208 (plot-cmd (case type
209 ('2d "plot") 209 (2d "plot")
210 ('3d "splot") 210 (3d "splot")
211 ('grid "splot"))) 211 (grid "splot")))
212 (script "reset") plot-lines) 212 (script "reset") plot-lines)
213 (flet ((add-to-script (line) (setf script (format "%s\n%s" script line)))) 213 (flet ((add-to-script (line) (setf script (format "%s\n%s" script line))))
214 (when file ;; output file 214 (when file ;; output file
215 (add-to-script (format "set term %s" (file-name-extension file))) 215 (add-to-script (format "set term %s" (file-name-extension file)))
216 (add-to-script (format "set output '%s'" file))) 216 (add-to-script (format "set output '%s'" file)))
217 (case type ;; type 217 (case type ;; type
218 ('2d ()) 218 (2d ())
219 ('3d (if map (add-to-script "set map"))) 219 (3d (if map (add-to-script "set map")))
220 ('grid (if map 220 (grid (if map
221 (add-to-script "set pm3d map") 221 (add-to-script "set pm3d map")
222 (add-to-script "set pm3d")))) 222 (add-to-script "set pm3d"))))
223 (when title (add-to-script (format "set title '%s'" title))) ;; title 223 (when title (add-to-script (format "set title '%s'" title))) ;; title
@@ -243,7 +243,7 @@ manner suitable for prepending to a user-specified script."
243 "%Y-%m-%d-%H:%M:%S") "\""))) 243 "%Y-%m-%d-%H:%M:%S") "\"")))
244 (unless preface 244 (unless preface
245 (case type ;; plot command 245 (case type ;; plot command
246 ('2d (dotimes (col num-cols) 246 (2d (dotimes (col num-cols)
247 (unless (and (equal type '2d) 247 (unless (and (equal type '2d)
248 (or (and ind (equal (+ 1 col) ind)) 248 (or (and ind (equal (+ 1 col) ind))
249 (and deps (not (member (+ 1 col) deps))))) 249 (and deps (not (member (+ 1 col) deps)))))
@@ -258,10 +258,10 @@ manner suitable for prepending to a user-specified script."
258 with 258 with
259 (or (nth col col-labels) (format "%d" (+ 1 col)))) 259 (or (nth col col-labels) (format "%d" (+ 1 col))))
260 plot-lines))))) 260 plot-lines)))))
261 ('3d 261 (3d
262 (setq plot-lines (list (format "'%s' matrix with %s title ''" 262 (setq plot-lines (list (format "'%s' matrix with %s title ''"
263 data-file with)))) 263 data-file with))))
264 ('grid 264 (grid
265 (setq plot-lines (list (format "'%s' with %s title ''" 265 (setq plot-lines (list (format "'%s' with %s title ''"
266 data-file with))))) 266 data-file with)))))
267 (add-to-script 267 (add-to-script
@@ -305,9 +305,9 @@ line directly before or after the table."
305 (setf params (org-plot/collect-options params)))) 305 (setf params (org-plot/collect-options params))))
306 ;; dump table to datafile (very different for grid) 306 ;; dump table to datafile (very different for grid)
307 (case (plist-get params :plot-type) 307 (case (plist-get params :plot-type)
308 ('2d (org-plot/gnuplot-to-data table data-file params)) 308 (2d (org-plot/gnuplot-to-data table data-file params))
309 ('3d (org-plot/gnuplot-to-data table data-file params)) 309 (3d (org-plot/gnuplot-to-data table data-file params))
310 ('grid (let ((y-labels (org-plot/gnuplot-to-grid-data 310 (grid (let ((y-labels (org-plot/gnuplot-to-grid-data
311 table data-file params))) 311 table data-file params)))
312 (when y-labels (plist-put params :ylabels y-labels))))) 312 (when y-labels (plist-put params :ylabels y-labels)))))
313 ;; check for timestamp ind column 313 ;; 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."
335 335
336(defun org-src-switch-to-buffer (buffer context) 336(defun org-src-switch-to-buffer (buffer context)
337 (case org-src-window-setup 337 (case org-src-window-setup
338 ('current-window 338 (current-window
339 (switch-to-buffer buffer)) 339 (switch-to-buffer buffer))
340 ('other-window 340 (other-window
341 (switch-to-buffer-other-window buffer)) 341 (switch-to-buffer-other-window buffer))
342 ('other-frame 342 (other-frame
343 (case context 343 (case context
344 ('exit 344 (exit
345 (let ((frame (selected-frame))) 345 (let ((frame (selected-frame)))
346 (switch-to-buffer-other-frame buffer) 346 (switch-to-buffer-other-frame buffer)
347 (delete-frame frame))) 347 (delete-frame frame)))
348 ('save 348 (save
349 (kill-buffer (current-buffer)) 349 (kill-buffer (current-buffer))
350 (switch-to-buffer buffer)) 350 (switch-to-buffer buffer))
351 (t 351 (t
352 (switch-to-buffer-other-frame buffer)))) 352 (switch-to-buffer-other-frame buffer))))
353 ('reorganize-frame 353 (reorganize-frame
354 (if (eq context 'edit) (delete-other-windows)) 354 (if (eq context 'edit) (delete-other-windows))
355 (org-switch-to-buffer-other-window buffer) 355 (org-switch-to-buffer-other-window buffer)
356 (if (eq context 'exit) (delete-other-windows))) 356 (if (eq context 'exit) (delete-other-windows)))
357 ('switch-invisibly 357 (switch-invisibly
358 (set-buffer buffer)) 358 (set-buffer buffer))
359 (t 359 (t
360 (message "Invalid value %s for org-src-window-setup" 360 (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[] = {
719(defsubst bubbles--grid-width () 719(defsubst bubbles--grid-width ()
720 "Return the grid width for the current game theme." 720 "Return the grid width for the current game theme."
721 (car (case bubbles-game-theme 721 (car (case bubbles-game-theme
722 ('easy 722 (easy
723 bubbles--grid-small) 723 bubbles--grid-small)
724 ('medium 724 (medium
725 bubbles--grid-medium) 725 bubbles--grid-medium)
726 ('difficult 726 (difficult
727 bubbles--grid-large) 727 bubbles--grid-large)
728 ('hard 728 (hard
729 bubbles--grid-huge) 729 bubbles--grid-huge)
730 ('user-defined 730 (user-defined
731 bubbles-grid-size)))) 731 bubbles-grid-size))))
732 732
733(defsubst bubbles--grid-height () 733(defsubst bubbles--grid-height ()
734 "Return the grid height for the current game theme." 734 "Return the grid height for the current game theme."
735 (cdr (case bubbles-game-theme 735 (cdr (case bubbles-game-theme
736 ('easy 736 (easy
737 bubbles--grid-small) 737 bubbles--grid-small)
738 ('medium 738 (medium
739 bubbles--grid-medium) 739 bubbles--grid-medium)
740 ('difficult 740 (difficult
741 bubbles--grid-large) 741 bubbles--grid-large)
742 ('hard 742 (hard
743 bubbles--grid-huge) 743 bubbles--grid-huge)
744 ('user-defined 744 (user-defined
745 bubbles-grid-size)))) 745 bubbles-grid-size))))
746 746
747(defsubst bubbles--colors () 747(defsubst bubbles--colors ()
748 "Return the color list for the current game theme." 748 "Return the color list for the current game theme."
749 (case bubbles-game-theme 749 (case bubbles-game-theme
750 ('easy 750 (easy
751 bubbles--colors-2) 751 bubbles--colors-2)
752 ('medium 752 (medium
753 bubbles--colors-3) 753 bubbles--colors-3)
754 ('difficult 754 (difficult
755 bubbles--colors-4) 755 bubbles--colors-4)
756 ('hard 756 (hard
757 bubbles--colors-5) 757 bubbles--colors-5)
758 ('user-defined 758 (user-defined
759 bubbles-colors))) 759 bubbles-colors)))
760 760
761(defsubst bubbles--shift-mode () 761(defsubst bubbles--shift-mode ()
762 "Return the shift mode for the current game theme." 762 "Return the shift mode for the current game theme."
763 (case bubbles-game-theme 763 (case bubbles-game-theme
764 ('easy 764 (easy
765 'default) 765 'default)
766 ('medium 766 (medium
767 'default) 767 'default)
768 ('difficult 768 (difficult
769 'always) 769 'always)
770 ('hard 770 (hard
771 'always) 771 'always)
772 ('user-defined 772 (user-defined
773 bubbles-shift-mode))) 773 bubbles-shift-mode)))
774 774
775(defun bubbles-save-settings () 775(defun bubbles-save-settings ()
@@ -1346,11 +1346,11 @@ Return t if new char is non-empty."
1346 (when (and (display-images-p) 1346 (when (and (display-images-p)
1347 (not (eq bubbles-graphics-theme 'ascii))) 1347 (not (eq bubbles-graphics-theme 'ascii)))
1348 (let ((template (case bubbles-graphics-theme 1348 (let ((template (case bubbles-graphics-theme
1349 ('circles bubbles--image-template-circle) 1349 (circles bubbles--image-template-circle)
1350 ('balls bubbles--image-template-ball) 1350 (balls bubbles--image-template-ball)
1351 ('squares bubbles--image-template-square) 1351 (squares bubbles--image-template-square)
1352 ('diamonds bubbles--image-template-diamond) 1352 (diamonds bubbles--image-template-diamond)
1353 ('emacs bubbles--image-template-emacs)))) 1353 (emacs bubbles--image-template-emacs))))
1354 (setq bubbles--empty-image 1354 (setq bubbles--empty-image
1355 (create-image (replace-regexp-in-string 1355 (create-image (replace-regexp-in-string
1356 "^\"\\(.*\\)\t.*c .*\",$" 1356 "^\"\\(.*\\)\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[] = {
213 (let ((data (gamegrid-match-spec-list data-spec-list)) 213 (let ((data (gamegrid-match-spec-list data-spec-list))
214 (color (gamegrid-match-spec-list color-spec-list))) 214 (color (gamegrid-match-spec-list color-spec-list)))
215 (case data 215 (case data
216 ('color-x 216 (color-x
217 (gamegrid-make-color-x-face color)) 217 (gamegrid-make-color-x-face color))
218 ('grid-x 218 (grid-x
219 (unless gamegrid-grid-x-face 219 (unless gamegrid-grid-x-face
220 (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face))) 220 (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face)))
221 gamegrid-grid-x-face) 221 gamegrid-grid-x-face)
222 ('mono-x 222 (mono-x
223 (unless gamegrid-mono-x-face 223 (unless gamegrid-mono-x-face
224 (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face))) 224 (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face)))
225 gamegrid-mono-x-face) 225 gamegrid-mono-x-face)
226 ('color-tty 226 (color-tty
227 (gamegrid-make-color-tty-face color)) 227 (gamegrid-make-color-tty-face color))
228 ('mono-tty 228 (mono-tty
229 (unless gamegrid-mono-tty-face 229 (unless gamegrid-mono-tty-face
230 (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face))) 230 (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face)))
231 gamegrid-mono-tty-face)))) 231 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 @@
25;; Converts text to Morse code and back with M-x morse-region and 25;; Converts text to Morse code and back with M-x morse-region and
26;; M-x unmorse-region (though Morse code is no longer official :-(). 26;; M-x unmorse-region (though Morse code is no longer official :-().
27 27
28;; Converts text to NATO phonetic alphabet and back with M-x
29;; nato-region and M-x denato-region.
30
28;;; Code: 31;;; Code:
29 32
30(defvar morse-code '(("a" . ".-") 33(defvar morse-code '(("a" . ".-")
@@ -91,10 +94,64 @@
91 ("@" . ".--.-.")) 94 ("@" . ".--.-."))
92 "Morse code character set.") 95 "Morse code character set.")
93 96
97(defvar nato-alphabet '(("a" . "Alfa")
98 ("b" . "Bravo")
99 ("c" . "Charlie")
100 ("d" . "Delta")
101 ("e" . "Echo")
102 ("f" . "Foxtrot")
103 ("g" . "Golf")
104 ("h" . "Hotel")
105 ("i" . "India")
106 ("j" . "Juliett")
107 ("k" . "Kilo")
108 ("l" . "Lima")
109 ("m" . "Mike")
110 ("n" . "November")
111 ("o" . "Oscar")
112 ("p" . "Papa")
113 ("q" . "Quebec")
114 ("r" . "Romeo")
115 ("s" . "Sierra")
116 ("t" . "Tango")
117 ("u" . "Uniform")
118 ("v" . "Victor")
119 ("w" . "Whiskey")
120 ("x" . "Xray")
121 ("y" . "Yankee")
122 ("z" . "Zulu")
123 ;; Numbers
124 ("0" . "Zero")
125 ("1" . "One")
126 ("2" . "Two")
127 ("3" . "Three")
128 ("4" . "Four")
129 ("5" . "Five")
130 ("6" . "Six")
131 ("7" . "Seven")
132 ("8" . "Eight")
133 ("9" . "Niner")
134 ;; Punctuation is not part of standard
135 ("=" . "Equals")
136 ("?" . "Query")
137 ("/" . "Slash")
138 ("," . "Comma")
139 ("." . "Stop")
140 (":" . "Colon")
141 ("'" . "Apostrophe")
142 ("-" . "Dash")
143 ("(" . "Open")
144 (")" . "Close")
145 ("@" . "At"))
146 "NATO phonetic alphabet.
147See ''International Code of Signals'' (INTERCO), United States
148Edition, 1969 Edition (Revised 2003) available from National
149Geospatial-Intelligence Agency at http://www.nga.mil/")
150
94;;;###autoload 151;;;###autoload
95(defun morse-region (beg end) 152(defun morse-region (beg end)
96 "Convert all text in a given region to morse code." 153 "Convert all text in a given region to morse code."
97 (interactive "r") 154 (interactive "*r")
98 (if (integerp end) 155 (if (integerp end)
99 (setq end (copy-marker end))) 156 (setq end (copy-marker end)))
100 (save-excursion 157 (save-excursion
@@ -117,7 +174,7 @@
117;;;###autoload 174;;;###autoload
118(defun unmorse-region (beg end) 175(defun unmorse-region (beg end)
119 "Convert morse coded text in region to ordinary ASCII text." 176 "Convert morse coded text in region to ordinary ASCII text."
120 (interactive "r") 177 (interactive "*r")
121 (if (integerp end) 178 (if (integerp end)
122 (setq end (copy-marker end))) 179 (setq end (copy-marker end)))
123 (save-excursion 180 (save-excursion
@@ -136,6 +193,53 @@
136 (if (looking-at "/") 193 (if (looking-at "/")
137 (delete-char 1)))))))) 194 (delete-char 1))))))))
138 195
196;;;###autoload
197(defun nato-region (beg end)
198 "Convert all text in a given region to NATO phonetic alphabet."
199 ;; Copied from morse-region. -- ashawley 2009-02-10
200 (interactive "*r")
201 (if (integerp end)
202 (setq end (copy-marker end)))
203 (save-excursion
204 (let ((sep "")
205 str nato)
206 (goto-char beg)
207 (while (< (point) end)
208 (setq str (downcase (buffer-substring (point) (1+ (point)))))
209 (cond ((looking-at "\\s-+")
210 (goto-char (match-end 0))
211 (setq sep ""))
212 ((setq nato (assoc str nato-alphabet))
213 (delete-char 1)
214 (insert sep (cdr nato))
215 (setq sep "-"))
216 (t
217 (forward-char 1)
218 (setq sep "")))))))
219
220;;;###autoload
221(defun denato-region (beg end)
222 "Convert NATO phonetic alphabet in region to ordinary ASCII text."
223 ;; Copied from unmorse-region. -- ashawley 2009-02-10
224 (interactive "*r")
225 (if (integerp end)
226 (setq end (copy-marker end)))
227 (save-excursion
228 (let (str paren nato)
229 (goto-char beg)
230 (while (< (point) end)
231 (if (null (looking-at "[a-z]+"))
232 (forward-char 1)
233 (setq str (buffer-substring (match-beginning 0) (match-end 0)))
234 (if (null (setq nato (rassoc str nato-alphabet)))
235 (goto-char (match-end 0))
236 (replace-match
237 (if (string-equal "(" (car nato))
238 (if (setq paren (null paren)) "(" ")")
239 (car nato)) t)
240 (if (looking-at "-")
241 (delete-char 1))))))))
242
139(provide 'morse) 243(provide 'morse)
140 244
141;;; morse.el ends here 245;;; 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\"."
2564 ;; Are we about to move backwards into or out of a 2564 ;; Are we about to move backwards into or out of a
2565 ;; preprocessor command? If so, locate its beginning. 2565 ;; preprocessor command? If so, locate its beginning.
2566 (when (eq (cdr res) 'macro-boundary) 2566 (when (eq (cdr res) 'macro-boundary)
2567 (setq macro-fence 2567 (save-excursion
2568 (save-excursion 2568 (beginning-of-line)
2569 (if macro-fence 2569 (setq macro-fence
2570 (progn 2570 (and (not (bobp))
2571 (end-of-line) 2571 (progn (c-skip-ws-backward) (c-beginning-of-macro))
2572 (and (not (eobp)) 2572 (point)))))
2573 (progn (c-skip-ws-forward)
2574 (c-beginning-of-macro))
2575 (progn (c-end-of-macro)
2576 (point))))
2577 (and (not (eobp))
2578 (c-beginning-of-macro)
2579 (progn (c-end-of-macro) (point)))))))
2580 ;; Are we about to move backwards into a literal? 2573 ;; Are we about to move backwards into a literal?
2581 (when (memq (cdr res) '(macro-boundary literal)) 2574 (when (memq (cdr res) '(macro-boundary literal))
2582 (setq range (c-ascertain-preceding-literal))) 2575 (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.")
860 (car compilation--previous-directory-cache))) 860 (car compilation--previous-directory-cache)))
861 (prev 861 (prev
862 (previous-single-property-change 862 (previous-single-property-change
863 pos 'compilation-directory nil cache))) 863 pos 'compilation-directory nil cache))
864 (cond 864 (res
865 ((null cache) 865 (cond
866 (setq compilation--previous-directory-cache 866 ((null cache)
867 (cons (copy-marker pos) (copy-marker prev))) 867 (setq compilation--previous-directory-cache
868 prev) 868 (cons (copy-marker pos) (if prev (copy-marker prev))))
869 ((eq prev cache) 869 prev)
870 (if cache 870 ((and prev (= prev cache))
871 (set-marker (car compilation--previous-directory-cache) pos) 871 (if cache
872 (setq compilation--previous-directory-cache 872 (set-marker (car compilation--previous-directory-cache) pos)
873 (cons (copy-marker pos) nil))) 873 (setq compilation--previous-directory-cache
874 (cdr compilation--previous-directory-cache)) 874 (cons (copy-marker pos) nil)))
875 (t 875 (cdr compilation--previous-directory-cache))
876 (if cache 876 (t
877 (progn 877 (if cache
878 (set-marker (car compilation--previous-directory-cache) pos) 878 (progn
879 (setcdr compilation--previous-directory-cache 879 (set-marker cache pos)
880 (copy-marker prev))) 880 (setcdr compilation--previous-directory-cache
881 (setq compilation--previous-directory-cache 881 (copy-marker prev)))
882 (cons (copy-marker pos) (copy-marker prev)))) 882 (setq compilation--previous-directory-cache
883 prev))))) 883 (cons (copy-marker pos) (if prev (copy-marker prev)))))
884 prev))))
885 (if (markerp res) (marker-position res) res))))
884 886
885;; Internal function for calculating the text properties of a directory 887;; Internal function for calculating the text properties of a directory
886;; change message. The compilation-directory property is important, because it 888;; change message. The compilation-directory property is important, because it
@@ -889,7 +891,7 @@ POS and RES.")
889(defun compilation-directory-properties (idx leave) 891(defun compilation-directory-properties (idx leave)
890 (if leave (setq leave (match-end leave))) 892 (if leave (setq leave (match-end leave)))
891 ;; find previous stack, and push onto it, or if `leave' pop it 893 ;; find previous stack, and push onto it, or if `leave' pop it
892 (let ((dir (compilation--previous-directory (point)))) 894 (let ((dir (compilation--previous-directory (match-beginning 0))))
893 (setq dir (if dir (or (get-text-property (1- dir) 'compilation-directory) 895 (setq dir (if dir (or (get-text-property (1- dir) 'compilation-directory)
894 (get-text-property dir 'compilation-directory)))) 896 (get-text-property dir 'compilation-directory))))
895 `(font-lock-face ,(if leave 897 `(font-lock-face ,(if leave
@@ -948,7 +950,8 @@ POS and RES.")
948 (match-string-no-properties file)))) 950 (match-string-no-properties file))))
949 (let ((dir 951 (let ((dir
950 (unless (file-name-absolute-p file) 952 (unless (file-name-absolute-p file)
951 (let ((pos (compilation--previous-directory (point)))) 953 (let ((pos (compilation--previous-directory
954 (match-beginning 0))))
952 (when pos 955 (when pos
953 (or (get-text-property (1- pos) 'compilation-directory) 956 (or (get-text-property (1- pos) 'compilation-directory)
954 (get-text-property pos 'compilation-directory))))))) 957 (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 @@
26 26
27;; To enter Delphi mode when you find a Delphi source file, one must override 27;; To enter Delphi mode when you find a Delphi source file, one must override
28;; the auto-mode-alist to associate Delphi with .pas (and .dpr and .dpk) 28;; the auto-mode-alist to associate Delphi with .pas (and .dpr and .dpk)
29;; files. Emacs, by default, will otherwise enter Pascal mode. E.g. 29;; files. Emacs, by default, will otherwise enter Pascal mode. E.g.
30;; 30;;
31;; (autoload 'delphi-mode "delphi") 31;; (autoload 'delphi-mode "delphi")
32;; (setq auto-mode-alist 32;; (setq auto-mode-alist
33;; (cons '("\\.\\(pas\\|dpr\\|dpk\\)$" . delphi-mode) auto-mode-alist)) 33;; (cons '("\\.\\(pas\\|dpr\\|dpk\\)$" . delphi-mode) auto-mode-alist))
34 34
35;; To get keyword, comment, and string literal coloring, be sure that font-lock 35;; To get keyword, comment, and string literal coloring, be sure that font-lock
36;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or 36;; is running. One can manually do M-x font-lock-mode in a Delphi buffer, or
37;; one can put in .emacs: 37;; one can put in .emacs:
38;; 38;;
39;; (add-hook 'delphi-mode-hook 'turn-on-font-lock) 39;; (add-hook 'delphi-mode-hook 'turn-on-font-lock)
@@ -56,8 +56,8 @@
56;; When you have entered Delphi mode, you may get more info by pressing 56;; When you have entered Delphi mode, you may get more info by pressing
57;; C-h m. 57;; C-h m.
58 58
59;; This delphi mode implementation is fairly tolerant of syntax errors, relying 59;; This Delphi mode implementation is fairly tolerant of syntax errors, relying
60;; as much as possible on the indentation of the previous statement. This also 60;; as much as possible on the indentation of the previous statement. This also
61;; makes it faster and simpler, since there is less searching for properly 61;; makes it faster and simpler, since there is less searching for properly
62;; constructed beginnings. 62;; constructed beginnings.
63 63
@@ -74,15 +74,16 @@
74 "True if in debug mode.") 74 "True if in debug mode.")
75 75
76(defcustom delphi-search-path "." 76(defcustom delphi-search-path "."
77 "*Directories to search when finding external units. It is a list of 77 "*Directories to search when finding external units.
78directory strings. If only a single directory, it can be a single 78It is a list of directory strings. If only a single directory,
79string instead of a list. If a directory ends in \"...\" then that 79it can be a single string instead of a list. If a directory
80directory is recursively searched." 80ends in \"...\" then that directory is recursively searched."
81 :type 'string 81 :type 'string
82 :group 'delphi) 82 :group 'delphi)
83 83
84(defcustom delphi-indent-level 3 84(defcustom delphi-indent-level 3
85 "*Indentation of Delphi statements with respect to containing block. E.g. 85 "*Indentation of Delphi statements with respect to containing block.
86E.g.
86 87
87begin 88begin
88 // This is an indent of 3. 89 // This is an indent of 3.
@@ -117,7 +118,7 @@ end; end;"
117 :group 'delphi) 118 :group 'delphi)
118 119
119(defcustom delphi-verbose t ; nil 120(defcustom delphi-verbose t ; nil
120 "*If true then delphi token processing progress is reported to the user." 121 "*If true then Delphi token processing progress is reported to the user."
121 :type 'boolean 122 :type 'boolean
122 :group 'delphi) 123 :group 'delphi)
123 124
@@ -137,17 +138,17 @@ differs from the default."
137 :group 'delphi) 138 :group 'delphi)
138 139
139(defcustom delphi-comment-face 'font-lock-comment-face 140(defcustom delphi-comment-face 'font-lock-comment-face
140 "*Face used to color delphi comments." 141 "*Face used to color Delphi comments."
141 :type 'face 142 :type 'face
142 :group 'delphi) 143 :group 'delphi)
143 144
144(defcustom delphi-string-face 'font-lock-string-face 145(defcustom delphi-string-face 'font-lock-string-face
145 "*Face used to color delphi strings." 146 "*Face used to color Delphi strings."
146 :type 'face 147 :type 'face
147 :group 'delphi) 148 :group 'delphi)
148 149
149(defcustom delphi-keyword-face 'font-lock-keyword-face 150(defcustom delphi-keyword-face 'font-lock-keyword-face
150 "*Face used to color delphi keywords." 151 "*Face used to color Delphi keywords."
151 :type 'face 152 :type 'face
152 :group 'delphi) 153 :group 'delphi)
153 154
@@ -720,9 +721,9 @@ routine.")
720 (delphi-progress-done))))) 721 (delphi-progress-done)))))
721 722
722(defvar delphi-ignore-changes t 723(defvar delphi-ignore-changes t
723 "Internal flag to control if the delphi-mode responds to buffer changes. 724 "Internal flag to control if the Delphi mode responds to buffer changes.
724Defaults to t in case the delphi-after-change function is called on a 725Defaults to t in case the `delphi-after-change' function is called on a
725non-delphi buffer. Set to nil in a delphi buffer. To override, just do: 726non-Delphi buffer. Set to nil in a Delphi buffer. To override, just do:
726 (let ((delphi-ignore-changes t)) ...)") 727 (let ((delphi-ignore-changes t)) ...)")
727 728
728(defun delphi-after-change (change-start change-end old-length) 729(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:
1521 indent))) 1522 indent)))
1522 1523
1523(defun delphi-indent-line () 1524(defun delphi-indent-line ()
1524 "Indent the current line according to the current language construct. If 1525 "Indent the current line according to the current language construct.
1525before the indent, the point is moved to the indent." 1526If before the indent, the point is moved to the indent."
1526 (interactive) 1527 (interactive)
1527 (delphi-save-match-data 1528 (delphi-save-match-data
1528 (let ((marked-point (point-marker)) ; Maintain our position reliably. 1529 (let ((marked-point (point-marker)) ; Maintain our position reliably.
@@ -1547,7 +1548,7 @@ before the indent, the point is moved to the indent."
1547 (set-marker marked-point nil)))) 1548 (set-marker marked-point nil))))
1548 1549
1549(defvar delphi-mode-abbrev-table nil 1550(defvar delphi-mode-abbrev-table nil
1550 "Abbrev table in use in delphi-mode buffers.") 1551 "Abbrev table in use in Delphi mode buffers.")
1551(define-abbrev-table 'delphi-mode-abbrev-table ()) 1552(define-abbrev-table 'delphi-mode-abbrev-table ())
1552 1553
1553(defmacro delphi-ensure-buffer (buffer-var buffer-name) 1554(defmacro delphi-ensure-buffer (buffer-var buffer-name)
@@ -1568,7 +1569,7 @@ before the indent, the point is moved to the indent."
1568;; Debugging helpers: 1569;; Debugging helpers:
1569 1570
1570(defvar delphi-debug-buffer nil 1571(defvar delphi-debug-buffer nil
1571 "Buffer to write delphi-mode debug messages to. Created on demand.") 1572 "Buffer to write Delphi mode debug messages to. Created on demand.")
1572 1573
1573(defun delphi-debug-log (format-string &rest args) 1574(defun delphi-debug-log (format-string &rest args)
1574 ;; Writes a message to the log buffer. 1575 ;; Writes a message to the log buffer.
@@ -1679,7 +1680,7 @@ before the indent, the point is moved to the indent."
1679 1680
1680(defun delphi-tab () 1681(defun delphi-tab ()
1681 "Indent the region, when Transient Mark mode is enabled and the region is 1682 "Indent the region, when Transient Mark mode is enabled and the region is
1682active. Otherwise, indent the current line or insert a TAB, depending on the 1683active. Otherwise, indent the current line or insert a TAB, depending on the
1683value of `delphi-tab-always-indents' and the current line position." 1684value of `delphi-tab-always-indents' and the current line position."
1684 (interactive) 1685 (interactive)
1685 (cond ((use-region-p) 1686 (cond ((use-region-p)
@@ -1768,8 +1769,8 @@ value of `delphi-tab-always-indents' and the current line position."
1768 nil)) 1769 nil))
1769 1770
1770(defun delphi-find-unit (unit) 1771(defun delphi-find-unit (unit)
1771 "Finds the specified delphi source file according to `delphi-search-path'. 1772 "Find the specified Delphi source file according to `delphi-search-path'.
1772If no extension is specified, .pas is assumed. Creates a buffer for the unit." 1773If no extension is specified, .pas is assumed. Creates a buffer for the unit."
1773 (interactive "sDelphi unit name: ") 1774 (interactive "sDelphi unit name: ")
1774 (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit) 1775 (let* ((unit-file (if (string-match "^\\(.*\\)\\.[a-z]+$" unit)
1775 unit 1776 unit
@@ -1791,7 +1792,7 @@ If no extension is specified, .pas is assumed. Creates a buffer for the unit."
1791 "Find the definition of the identifier under the current point, searching 1792 "Find the definition of the identifier under the current point, searching
1792in external units if necessary (as listed in the current unit's use clause). 1793in external units if necessary (as listed in the current unit's use clause).
1793The set of directories to search for a unit is specified by the global variable 1794The set of directories to search for a unit is specified by the global variable
1794delphi-search-path." 1795`delphi-search-path'."
1795 (interactive) 1796 (interactive)
1796 (error "delphi-find-current-xdef: not implemented yet")) 1797 (error "delphi-find-current-xdef: not implemented yet"))
1797 1798
@@ -1802,7 +1803,7 @@ it is a routine."
1802 (error "delphi-find-current-body: not implemented yet")) 1803 (error "delphi-find-current-body: not implemented yet"))
1803 1804
1804(defun delphi-fill-comment () 1805(defun delphi-fill-comment ()
1805 "Fills the text of the current comment, according to `fill-column'. 1806 "Fill the text of the current comment, according to `fill-column'.
1806An error is raised if not in a comment." 1807An error is raised if not in a comment."
1807 (interactive) 1808 (interactive)
1808 (save-excursion 1809 (save-excursion
@@ -1888,8 +1889,8 @@ An error is raised if not in a comment."
1888 (delphi-progress-done))))))) 1889 (delphi-progress-done)))))))
1889 1890
1890(defun delphi-new-comment-line () 1891(defun delphi-new-comment-line ()
1891 "If in a // comment, does a newline, indented such that one is still in the 1892 "If in a // comment, do a newline, indented such that one is still in the
1892comment block. If not in a // comment, just does a normal newline." 1893comment block. If not in a // comment, just does a normal newline."
1893 (interactive) 1894 (interactive)
1894 (let ((comment (delphi-current-token))) 1895 (let ((comment (delphi-current-token)))
1895 (if (not (eq 'comment-single-line (delphi-token-kind comment))) 1896 (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."
1923 nil ; Syntax begin movement doesn't apply 1924 nil ; Syntax begin movement doesn't apply
1924 (font-lock-fontify-region-function . delphi-fontify-region) 1925 (font-lock-fontify-region-function . delphi-fontify-region)
1925 (font-lock-verbose . delphi-fontifying-progress-step)) 1926 (font-lock-verbose . delphi-fontifying-progress-step))
1926 "Delphi mode font-lock defaults. Syntactic fontification is ignored.") 1927 "Delphi mode font-lock defaults. Syntactic fontification is ignored.")
1927 1928
1928(defvar delphi-debug-mode-map 1929(defvar delphi-debug-mode-map
1929 (let ((kmap (make-sparse-keymap))) 1930 (let ((kmap (make-sparse-keymap)))
@@ -1944,7 +1945,7 @@ comment block. If not in a // comment, just does a normal newline."
1944 ("x" delphi-debug-show-is-stable) 1945 ("x" delphi-debug-show-is-stable)
1945 )) 1946 ))
1946 kmap) 1947 kmap)
1947 "Keystrokes for delphi-mode debug commands.") 1948 "Keystrokes for Delphi mode debug commands.")
1948 1949
1949(defvar delphi-mode-map 1950(defvar delphi-mode-map
1950 (let ((kmap (make-sparse-keymap))) 1951 (let ((kmap (make-sparse-keymap)))
@@ -1964,7 +1965,7 @@ comment block. If not in a // comment, just does a normal newline."
1964 "Keymap used in Delphi mode.") 1965 "Keymap used in Delphi mode.")
1965 1966
1966(defconst delphi-mode-syntax-table (make-syntax-table) 1967(defconst delphi-mode-syntax-table (make-syntax-table)
1967 "Delphi mode's syntax table. It is just a standard syntax table. 1968 "Delphi mode's syntax table. It is just a standard syntax table.
1968This is ok since we do our own keyword/comment/string face coloring.") 1969This is ok since we do our own keyword/comment/string face coloring.")
1969 1970
1970;;;###autoload 1971;;;###autoload
@@ -1976,7 +1977,7 @@ This is ok since we do our own keyword/comment/string face coloring.")
1976\\[delphi-fill-comment]\t- Fill the current comment. 1977\\[delphi-fill-comment]\t- Fill the current comment.
1977\\[delphi-new-comment-line]\t- If in a // comment, do a new comment line. 1978\\[delphi-new-comment-line]\t- If in a // comment, do a new comment line.
1978 1979
1979M-x indent-region also works for indenting a whole region. 1980\\[indent-region] also works for indenting a whole region.
1980 1981
1981Customization: 1982Customization:
1982 1983
@@ -1996,21 +1997,21 @@ Customization:
1996 `delphi-search-path' (default .) 1997 `delphi-search-path' (default .)
1997 Directories to search when finding external units. 1998 Directories to search when finding external units.
1998 `delphi-verbose' (default nil) 1999 `delphi-verbose' (default nil)
1999 If true then delphi token processing progress is reported to the user. 2000 If true then Delphi token processing progress is reported to the user.
2000 2001
2001Coloring: 2002Coloring:
2002 2003
2003 `delphi-comment-face' (default font-lock-comment-face) 2004 `delphi-comment-face' (default font-lock-comment-face)
2004 Face used to color delphi comments. 2005 Face used to color Delphi comments.
2005 `delphi-string-face' (default font-lock-string-face) 2006 `delphi-string-face' (default font-lock-string-face)
2006 Face used to color delphi strings. 2007 Face used to color Delphi strings.
2007 `delphi-keyword-face' (default font-lock-keyword-face) 2008 `delphi-keyword-face' (default font-lock-keyword-face)
2008 Face used to color delphi keywords. 2009 Face used to color Delphi keywords.
2009 `delphi-other-face' (default nil) 2010 `delphi-other-face' (default nil)
2010 Face used to color everything else. 2011 Face used to color everything else.
2011 2012
2012Turning on Delphi mode calls the value of the variable delphi-mode-hook with 2013Turning on Delphi mode calls the value of the variable `delphi-mode-hook'
2013no args, if that value is non-nil." 2014with no args, if that value is non-nil."
2014 (interactive) 2015 (interactive)
2015 (kill-all-local-variables) 2016 (kill-all-local-variables)
2016 (use-local-map delphi-mode-map) 2017 (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."
3566 (insert kind) 3566 (insert kind)
3567 (indent-to 50) 3567 (indent-to 50)
3568 (insert (case (second info) 3568 (insert (case (second info)
3569 ('ebrowse-ts-member-functions "member function") 3569 (ebrowse-ts-member-functions "member function")
3570 ('ebrowse-ts-member-variables "member variable") 3570 (ebrowse-ts-member-variables "member variable")
3571 ('ebrowse-ts-static-functions "static function") 3571 (ebrowse-ts-static-functions "static function")
3572 ('ebrowse-ts-static-variables "static variable") 3572 (ebrowse-ts-static-variables "static variable")
3573 ('ebrowse-ts-friends (if globals-p "define" "friend")) 3573 (ebrowse-ts-friends (if globals-p "define" "friend"))
3574 ('ebrowse-ts-types "type") 3574 (ebrowse-ts-types "type")
3575 (t "unknown")) 3575 (t "unknown"))
3576 "\n"))) 3576 "\n")))
3577 3577
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.
648 (set (make-local-variable 'gud-minor-mode) 'gdbmi) 648 (set (make-local-variable 'gud-minor-mode) 'gdbmi)
649 (setq comint-input-sender 'gdb-send) 649 (setq comint-input-sender 'gdb-send)
650 (when (ring-empty-p comint-input-ring) ; cf shell-mode 650 (when (ring-empty-p comint-input-ring) ; cf shell-mode
651 (let (hfile) 651 (let ((hfile (expand-file-name (or (getenv "GBDHISTFILE")
652 (when (catch 'done 652 (if (eq system-type 'ms-dos)
653 (dolist (file '(".gdbinit" "~/.gdbinit")) 653 "_gdb_history"
654 (if (file-readable-p (setq file (expand-file-name file))) 654 ".gdb_history"))))
655 (with-temp-buffer 655 ;; gdb defaults to 256, but we'll default to comint-input-ring-size.
656 (insert-file-contents file) 656 (hsize (getenv "HISTSIZE")))
657 (and (re-search-forward 657 (dolist (file (append '("~/.gdbinit")
658 "^ *set history filename *\\(.*\\)" nil t) 658 (unless (string-equal (expand-file-name ".")
659 (file-readable-p 659 (expand-file-name "~"))
660 (setq hfile (expand-file-name 660 '(".gdbinit"))))
661 (match-string 1) 661 (if (file-readable-p (setq file (expand-file-name file)))
662 (file-name-directory file)))) 662 (with-temp-buffer
663 (throw 'done t)))))) 663 (insert-file-contents file)
664 (set (make-local-variable 'comint-input-ring-file-name) hfile) 664 ;; TODO? check for "set history save\\( *on\\)?" and do
665 (comint-read-input-ring t)))) 665 ;; not use history otherwise?
666 (while (re-search-forward
667 "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t)
668 (cond ((string-equal (match-string 1) "filename")
669 (setq hfile (expand-file-name
670 (match-string 2)
671 (file-name-directory file))))
672 ((string-equal (match-string 1) "size")
673 (setq hsize (match-string 2))))))))
674 (and (stringp hsize)
675 (integerp (setq hsize (string-to-number hsize)))
676 (> hsize 0)
677 (set (make-local-variable 'comint-input-ring-size) hsize))
678 (if (stringp hfile)
679 (set (make-local-variable 'comint-input-ring-file-name) hfile))
680 (comint-read-input-ring t)))
666 (gud-def gud-tbreak "tbreak %f:%l" "\C-t" 681 (gud-def gud-tbreak "tbreak %f:%l" "\C-t"
667 "Set temporary breakpoint at current line.") 682 "Set temporary breakpoint at current line.")
668 (gud-def gud-jump 683 (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)."
3127 ("^document\\s-.*\\(\n\\)" (1 "< b")) 3127 ("^document\\s-.*\\(\n\\)" (1 "< b"))
3128 ("^end\\(\\>\\)" 3128 ("^end\\(\\>\\)"
3129 (1 (ignore 3129 (1 (ignore
3130 (unless (eq (match-beginning 0) (point-min)) 3130 (when (and (> (match-beginning 0) (point-min))
3131 (eq 1 (nth 7 (save-excursion
3132 (syntax-ppss (1- (match-beginning 0)))))))
3131 ;; We change the \n in front, which is more difficult, but results 3133 ;; We change the \n in front, which is more difficult, but results
3132 ;; in better highlighting. If the doc is empty, the single \n is 3134 ;; in better highlighting. If the doc is empty, the single \n is
3133 ;; both the beginning and the end of the docstring, which can't be 3135 ;; 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."
974 (goto-char (scan-sexps (1+ (point)) -1)) 974 (goto-char (scan-sexps (1+ (point)) -1))
975 (case (char-before) 975 (case (char-before)
976 (?% (forward-char -1)) 976 (?% (forward-char -1))
977 ('(?q ?Q ?w ?W ?r ?x) 977 ((?q ?Q ?w ?W ?r ?x)
978 (if (eq (char-before (1- (point))) ?%) (forward-char -2)))) 978 (if (eq (char-before (1- (point))) ?%) (forward-char -2))))
979 nil) 979 nil)
980 ((looking-at "\\s\"\\|\\\\\\S_") 980 ((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."
486 (file-name-as-directory dir)) 486 (file-name-as-directory dir))
487 :warning) 487 :warning)
488 (throw :safe t)) 488 (throw :safe t))
489 (unless (eql uid (user-uid)) ; is the dir ours? 489 (unless (or (= uid (user-uid)) ; is the dir ours?
490 (and w32
491 ;; Files created on Windows by
492 ;; Administrator (RID=500) have
493 ;; the Administrators (RID=544)
494 ;; group recorded as the owner.
495 (= uid 544) (= (user-uid) 500)))
490 (throw :safe nil)) 496 (throw :safe nil))
491 (when w32 ; on NTFS? 497 (when w32 ; on NTFS?
492 (throw :safe t)) 498 (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."
459 ;; shell-dependent assignments. 459 ;; shell-dependent assignments.
460 (when (ring-empty-p comint-input-ring) 460 (when (ring-empty-p comint-input-ring)
461 (let ((shell (file-name-nondirectory (car 461 (let ((shell (file-name-nondirectory (car
462 (process-command (get-buffer-process (current-buffer))))))) 462 (process-command (get-buffer-process (current-buffer))))))
463 (hsize (getenv "HISTSIZE")))
464 (and (stringp hsize)
465 (integerp (setq hsize (string-to-number hsize)))
466 (> hsize 0)
467 (set (make-local-variable 'comint-input-ring-size) hsize))
463 (setq comint-input-ring-file-name 468 (setq comint-input-ring-file-name
464 (or (getenv "HISTFILE") 469 (or (getenv "HISTFILE")
465 (cond ((string-equal shell "bash") "~/.bash_history") 470 (cond ((string-equal shell "bash") "~/.bash_history")
@@ -578,6 +583,21 @@ Otherwise, one argument `-i' is passed to the shell.
578 (get-buffer-create (or buffer "*shell*")) 583 (get-buffer-create (or buffer "*shell*"))
579 ;; If the current buffer is a dead shell buffer, use it. 584 ;; If the current buffer is a dead shell buffer, use it.
580 (current-buffer))) 585 (current-buffer)))
586
587 ;; On remote hosts, the local `shell-file-name' might be useless.
588 (if (and (interactive-p)
589 (file-remote-p default-directory)
590 (null explicit-shell-file-name)
591 (null (getenv "ESHELL")))
592 (with-current-buffer buffer
593 (set (make-local-variable 'explicit-shell-file-name)
594 (file-remote-p
595 (expand-file-name
596 (read-file-name
597 "Remote shell path: " default-directory shell-file-name
598 t shell-file-name))
599 'localname))))
600
581 ;; Pop to buffer, so that the buffer's window will be correctly set 601 ;; Pop to buffer, so that the buffer's window will be correctly set
582 ;; when we call comint (so that comint sets the COLUMNS env var properly). 602 ;; when we call comint (so that comint sets the COLUMNS env var properly).
583 (pop-to-buffer buffer) 603 (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."
636 (if (looking-at ".*\f") 636 (if (looking-at ".*\f")
637 (goto-char (match-end 0)))) 637 (goto-char (match-end 0))))
638 (delete-region (point) (match-end 0))) 638 (delete-region (point) (match-end 0)))
639 (set-marker end-marker nil))))) 639 (set-marker end-marker nil))))
640 ;; Return nil for the benefit of `write-file-functions'.
641 nil)
640 642
641(defun newline-and-indent () 643(defun newline-and-indent ()
642 "Insert a newline, then indent according to major mode. 644 "Insert a newline, then indent according to major mode.
@@ -2627,7 +2629,7 @@ specifies the value of ERROR-BUFFER."
2627 (with-output-to-string 2629 (with-output-to-string
2628 (with-current-buffer 2630 (with-current-buffer
2629 standard-output 2631 standard-output
2630 (call-process shell-file-name nil t nil shell-command-switch command)))) 2632 (process-file shell-file-name nil t nil shell-command-switch command))))
2631 2633
2632(defun process-file (program &optional infile buffer display &rest args) 2634(defun process-file (program &optional infile buffer display &rest args)
2633 "Process files synchronously in a separate process. 2635 "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
392 :type 'directory 392 :type 'directory
393 :initialize 'custom-initialize-delay) 393 :initialize 'custom-initialize-delay)
394 394
395(defconst package-subdirectory-regexp
396 "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)"
397 "Regular expression matching the name of a package subdirectory.
398The first subexpression is the package name.
399The second subexpression is the version string.
400
401The regexp should not contain a starting \"\\`\" or a trailing
402 \"\\'\"; those are added automatically by callers.")
403
395(defun normal-top-level-add-subdirs-to-load-path () 404(defun normal-top-level-add-subdirs-to-load-path ()
396 "Add all subdirectories of current directory to `load-path'. 405 "Add all subdirectories of current directory to `load-path'.
397More precisely, this uses only the subdirectories whose names 406More 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).")
1006 (if init-file-user 1015 (if init-file-user
1007 (let ((user-init-file-1 1016 (let ((user-init-file-1
1008 (cond 1017 (cond
1009 ((eq system-type 'ms-dos) 1018 ((eq system-type 'ms-dos)
1010 (concat "~" init-file-user "/_emacs")) 1019 (concat "~" init-file-user "/_emacs"))
1011 ((eq system-type 'windows-nt) 1020 ((not (eq system-type 'windows-nt))
1012 ;; Prefer .emacs on Windows. 1021 (concat "~" init-file-user "/.emacs"))
1013 (if (directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$") 1022 ;; Else deal with the Windows situation
1014 "~/.emacs" 1023 ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$")
1015 ;; Also support _emacs for compatibility. 1024 ;; Prefer .emacs on Windows.
1016 (if (directory-files "~" nil "^_emacs\\(\\.elc?\\)?$") 1025 "~/.emacs")
1017 "~/_emacs" 1026 ((directory-files "~" nil "^_emacs\\(\\.elc?\\)?$")
1018 ;; But default to .emacs if _emacs does not exist. 1027 ;; Also support _emacs for compatibility, but warn about it.
1019 "~/.emacs"))) 1028 (display-warning
1020 (t 1029 'initialization
1021 (concat "~" init-file-user "/.emacs"))))) 1030 "`_emacs' init file is deprecated, please use `.emacs'"
1031 :warning)
1032 "~/_emacs")
1033 (t ;; But default to .emacs if _emacs does not exist.
1034 "~/.emacs"))))
1022 ;; This tells `load' to store the file name found 1035 ;; This tells `load' to store the file name found
1023 ;; into user-init-file. 1036 ;; into user-init-file.
1024 (setq user-init-file t) 1037 (setq user-init-file t)
@@ -1190,9 +1203,9 @@ the `--debug-init' option to view a complete error backtrace."
1190 (when (file-directory-p dir) 1203 (when (file-directory-p dir)
1191 (dolist (subdir (directory-files dir)) 1204 (dolist (subdir (directory-files dir))
1192 (when (and (file-directory-p (expand-file-name subdir dir)) 1205 (when (and (file-directory-p (expand-file-name subdir dir))
1193 ;; package-subdirectory-regexp from package.el 1206 (string-match
1194 (string-match "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$" 1207 (concat "\\`" package-subdirectory-regexp "\\'")
1195 subdir)) 1208 subdir))
1196 (throw 'package-dir-found t))))))) 1209 (throw 'package-dir-found t)))))))
1197 (package-initialize)) 1210 (package-initialize))
1198 1211
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
2066keyboard-quit events while waiting for a valid input." 2066keyboard-quit events while waiting for a valid input."
2067 (unless (consp chars) 2067 (unless (consp chars)
2068 (error "Called `read-char-choice' without valid char choices")) 2068 (error "Called `read-char-choice' without valid char choices"))
2069 (let ((cursor-in-echo-area t) 2069 (let (char done)
2070 (executing-kbd-macro executing-kbd-macro) 2070 (let ((cursor-in-echo-area t)
2071 char done) 2071 (executing-kbd-macro executing-kbd-macro))
2072 (while (not done) 2072 (while (not done)
2073 (unless (get-text-property 0 'face prompt) 2073 (unless (get-text-property 0 'face prompt)
2074 (setq prompt (propertize prompt 'face 'minibuffer-prompt))) 2074 (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
2075 (setq char (let ((inhibit-quit inhibit-keyboard-quit)) 2075 (setq char (let ((inhibit-quit inhibit-keyboard-quit))
2076 (read-key prompt))) 2076 (read-key prompt)))
2077 (cond 2077 (cond
2078 ((not (numberp char))) 2078 ((not (numberp char)))
2079 ((memq char chars) 2079 ((memq char chars)
2080 (setq done t)) 2080 (setq done t))
2081 ((and executing-kbd-macro (= char -1)) 2081 ((and executing-kbd-macro (= char -1))
2082 ;; read-event returns -1 if we are in a kbd macro and 2082 ;; read-event returns -1 if we are in a kbd macro and
2083 ;; there are no more events in the macro. Attempt to 2083 ;; there are no more events in the macro. Attempt to
2084 ;; get an event interactively. 2084 ;; get an event interactively.
2085 (setq executing-kbd-macro nil)))) 2085 (setq executing-kbd-macro nil)))))
2086 ;; Display the question with the answer. 2086 ;; Display the question with the answer. But without cursor-in-echo-area.
2087 (message "%s%s" prompt (char-to-string char)) 2087 (message "%s%s" prompt (char-to-string char))
2088 char)) 2088 char))
2089 2089
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."
318 318
319(defconst texinfo-environments 319(defconst texinfo-environments
320 '("cartouche" "copying" "defcv" "deffn" "defivar" "defmac" 320 '("cartouche" "copying" "defcv" "deffn" "defivar" "defmac"
321 "defmethod" "defop" "defopt" "defspec" "deftp" "deftypefn" 321 "defmethod" "defop" "defopt" "defspec" "deftp" "deftypecv"
322 "deftypefun" "deftypevar" "deftypevr" "defun" "defvar" 322 "deftypefn" "deftypefun" "deftypeivar" "deftypemethod"
323 "deftypeop" "deftypevar" "deftypevr" "defun" "defvar"
323 "defvr" "description" "detailmenu" "direntry" "display" 324 "defvr" "description" "detailmenu" "direntry" "display"
324 "documentdescription" "enumerate" "example" "flushleft" 325 "documentdescription" "enumerate" "example" "flushleft"
325 "flushright" "format" "ftable" "group" "ifclear" "ifset" 326 "flushright" "format" "ftable" "group" "html" "ifclear" "ifset"
326 "ifhtml" "ifinfo" "ifnothtml" "ifnotinfo" "ifnotplaintext" 327 "ifhtml" "ifinfo" "ifnothtml" "ifnotinfo" "ifnotplaintext"
327 "ifnottex" "ifplaintext" "iftex" "ignore" "itemize" "lisp" 328 "ifnottex" "ifplaintext" "iftex" "ignore" "itemize" "lisp"
328 "macro" "menu" "multitable" "quotation" "smalldisplay" 329 "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)."
122 ("\C-m" . diff-goto-source) 122 ("\C-m" . diff-goto-source)
123 ([mouse-2] . diff-goto-source) 123 ([mouse-2] . diff-goto-source)
124 ;; From XEmacs' diff-mode. 124 ;; From XEmacs' diff-mode.
125 ;; Standard M-w is useful, so don't change M-W. 125 ("W" . widen)
126 ;;("W" . widen)
127 ;;("." . diff-goto-source) ;display-buffer 126 ;;("." . diff-goto-source) ;display-buffer
128 ;;("f" . diff-goto-source) ;find-file 127 ;;("f" . diff-goto-source) ;find-file
129 ("o" . diff-goto-source) ;other-window 128 ("o" . diff-goto-source) ;other-window
@@ -135,17 +134,21 @@ when editing big diffs)."
135 ;; Not useful if you have to metafy them. 134 ;; Not useful if you have to metafy them.
136 ;;(" " . scroll-up) 135 ;;(" " . scroll-up)
137 ;;("\177" . scroll-down) 136 ;;("\177" . scroll-down)
138 ;; Standard M-a is useful, so don't change M-A. 137 ("A" . diff-ediff-patch)
139 ;;("A" . diff-ediff-patch) 138 ("r" . diff-restrict-view)
140 ;; Standard M-r is useful, so don't change M-r or M-R. 139 ("R" . diff-reverse-direction))
141 ;;("r" . diff-restrict-view)
142 ;;("R" . diff-reverse-direction)
143 )
144 "Basic keymap for `diff-mode', bound to various prefix keys." 140 "Basic keymap for `diff-mode', bound to various prefix keys."
145 :inherit special-mode-map) 141 :inherit special-mode-map)
146 142
147(easy-mmode-defmap diff-mode-map 143(easy-mmode-defmap diff-mode-map
148 `(("\e" . ,diff-mode-shared-map) 144 `(("\e" . ,(let ((map (make-sparse-keymap)))
145 ;; We want to inherit most bindings from diff-mode-shared-map,
146 ;; but not all since they may hide useful M-<foo> global
147 ;; bindings when editing.
148 (set-keymap-parent map diff-mode-shared-map)
149 (dolist (key '("A" "r" "R" "g" "q" "W"))
150 (define-key map key nil))
151 map))
149 ;; From compilation-minor-mode. 152 ;; From compilation-minor-mode.
150 ("\C-c\C-c" . diff-goto-source) 153 ("\C-c\C-c" . diff-goto-source)
151 ;; By analogy with the global C-x 4 a binding. 154 ;; 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'."
3176 3176
3177;; Metacharacters that have to be protected from the shell when executing 3177;; Metacharacters that have to be protected from the shell when executing
3178;; a diff/diff3 command. 3178;; a diff/diff3 command.
3179(defcustom emerge-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]" 3179(defcustom emerge-metachars
3180 "Characters that must be quoted with \\ when used in a shell command line. 3180 (if (memq system-type '(ms-dos windows-nt))
3181 "[ \t\"<>|?*^&=]"
3182 "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]")
3183 "Characters that must be quoted when used in a shell command line.
3181More precisely, a [...] regexp to match any one such character." 3184More precisely, a [...] regexp to match any one such character."
3182 :type 'regexp 3185 :type 'regexp
3183 :group 'emerge) 3186 :group 'emerge)
3184 3187
3185;; Quote metacharacters (using \) when executing a diff/diff3 command. 3188;; Quote metacharacters (using \) when executing a diff/diff3 command.
3186(defun emerge-protect-metachars (s) 3189(defun emerge-protect-metachars (s)
3187 (let ((limit 0)) 3190 (if (memq system-type '(ms-dos windows-nt))
3188 (while (string-match emerge-metachars s limit) 3191 (shell-quote-argument s)
3189 (setq s (concat (substring s 0 (match-beginning 0)) 3192 (let ((limit 0))
3190 "\\" 3193 (while (string-match emerge-metachars s limit)
3191 (substring s (match-beginning 0)))) 3194 (setq s (concat (substring s 0 (match-beginning 0))
3192 (setq limit (1+ (match-end 0))))) 3195 "\\"
3193 s) 3196 (substring s (match-beginning 0))))
3197 (setq limit (1+ (match-end 0)))))
3198 s))
3194 3199
3195(provide 'emerge) 3200(provide 'emerge)
3196 3201
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."
435(defun vc-bzr-state (file) 435(defun vc-bzr-state (file)
436 (lexical-let ((result (vc-bzr-status file))) 436 (lexical-let ((result (vc-bzr-status file)))
437 (when (consp result) 437 (when (consp result)
438 (when (cdr result) 438 (let ((warnings (cdr result)))
439 (message "Warnings in `bzr' output: %s" (cdr result))) 439 (when warnings
440 ;; bzr 2.3.0 returns info about shelves, which is not really a warning
441 (when (string-match "[1-9]+ shel\\(f\\|ves\\) exists?\\..*?\n" warnings)
442 (setq warnings (replace-match "" nil nil warnings)))
443 (unless (string= warnings "")
444 (message "Warnings in `bzr' output: %s" warnings))))
440 (cdr (assq (car result) 445 (cdr (assq (car result)
441 '((added . added) 446 '((added . added)
442 (kindchanged . edited) 447 (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'."
104 ;; We pass a filename to create-file-buffer because it is what 104 ;; We pass a filename to create-file-buffer because it is what
105 ;; the function expects, and also what uniquify needs (if active) 105 ;; the function expects, and also what uniquify needs (if active)
106 (with-current-buffer (create-file-buffer (expand-file-name bname dir)) 106 (with-current-buffer (create-file-buffer (expand-file-name bname dir))
107 (cd dir) 107 (setq default-directory dir)
108 (vc-setup-buffer (current-buffer)) 108 (vc-setup-buffer (current-buffer))
109 ;; Reset the vc-parent-buffer-name so that it does not appear 109 ;; Reset the vc-parent-buffer-name so that it does not appear
110 ;; in the mode-line. 110 ;; in the mode-line.
@@ -1002,7 +1002,7 @@ specific headers."
1002 (generate-new-buffer (format " *VC-%s* tmp status" backend)))) 1002 (generate-new-buffer (format " *VC-%s* tmp status" backend))))
1003 (lexical-let ((buffer (current-buffer))) 1003 (lexical-let ((buffer (current-buffer)))
1004 (with-current-buffer vc-dir-process-buffer 1004 (with-current-buffer vc-dir-process-buffer
1005 (cd def-dir) 1005 (setq default-directory def-dir)
1006 (erase-buffer) 1006 (erase-buffer)
1007 (vc-call-backend 1007 (vc-call-backend
1008 backend 'dir-status-files def-dir files default-state 1008 backend 'dir-status-files def-dir files default-state
@@ -1067,7 +1067,7 @@ Throw an error if another update process is in progress."
1067 (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) "") 1067 (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) "")
1068 (lexical-let ((buffer (current-buffer))) 1068 (lexical-let ((buffer (current-buffer)))
1069 (with-current-buffer vc-dir-process-buffer 1069 (with-current-buffer vc-dir-process-buffer
1070 (cd def-dir) 1070 (setq default-directory def-dir)
1071 (erase-buffer) 1071 (erase-buffer)
1072 (vc-call-backend 1072 (vc-call-backend
1073 backend 'dir-status def-dir 1073 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."
119 :version "23.1" 119 :version "23.1"
120 :group 'vc) 120 :group 'vc)
121 121
122(defcustom vc-git-program "git"
123 "Name of the Git executable (excluding any arguments)."
124 :version "24.1"
125 :type 'string
126 :group 'vc)
127
122(defcustom vc-git-root-log-format 128(defcustom vc-git-root-log-format
123 '("%d%h..: %an %ad %s" 129 '("%d%h..: %an %ad %s"
124 ;; The first shy group matches the characters drawn by --graph. 130 ;; The first shy group matches the characters drawn by --graph.
@@ -554,7 +560,7 @@ or an empty string if none."
554 "Return the existing branches, as a list of strings. 560 "Return the existing branches, as a list of strings.
555The car of the list is the current branch." 561The car of the list is the current branch."
556 (with-temp-buffer 562 (with-temp-buffer
557 (call-process "git" nil t nil "branch") 563 (call-process vc-git-program nil t nil "branch")
558 (goto-char (point-min)) 564 (goto-char (point-min))
559 (let (current-branch branches) 565 (let (current-branch branches)
560 (while (not (eobp)) 566 (while (not (eobp))
@@ -633,13 +639,13 @@ for the Git command to run."
633 (let* ((root (vc-git-root default-directory)) 639 (let* ((root (vc-git-root default-directory))
634 (buffer (format "*vc-git : %s*" (expand-file-name root))) 640 (buffer (format "*vc-git : %s*" (expand-file-name root)))
635 (command "pull") 641 (command "pull")
636 (git-program "git") 642 (git-program vc-git-program)
637 args) 643 args)
638 ;; If necessary, prompt for the exact command. 644 ;; If necessary, prompt for the exact command.
639 (when prompt 645 (when prompt
640 (setq args (split-string 646 (setq args (split-string
641 (read-shell-command "Git pull command: " 647 (read-shell-command "Git pull command: "
642 "git pull" 648 (format "%s pull" git-program)
643 'vc-git-history) 649 'vc-git-history)
644 " " t)) 650 " " t))
645 (setq git-program (car args) 651 (setq git-program (car args)
@@ -663,7 +669,7 @@ This prompts for a branch to merge from."
663 branches 669 branches
664 (cons "FETCH_HEAD" branches)) 670 (cons "FETCH_HEAD" branches))
665 nil t))) 671 nil t)))
666 (apply 'vc-do-async-command buffer root "git" "merge" 672 (apply 'vc-do-async-command buffer root vc-git-program "merge"
667 (list merge-source)) 673 (list merge-source))
668 (vc-set-async-update buffer))) 674 (vc-set-async-update buffer)))
669 675
@@ -1083,8 +1089,10 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
1083 1089
1084(defun vc-git-command (buffer okstatus file-or-list &rest flags) 1090(defun vc-git-command (buffer okstatus file-or-list &rest flags)
1085 "A wrapper around `vc-do-command' for use in vc-git.el. 1091 "A wrapper around `vc-do-command' for use in vc-git.el.
1086The difference to vc-do-command is that this function always invokes `git'." 1092The difference to vc-do-command is that this function always invokes
1087 (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags)) 1093`vc-git-program'."
1094 (apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program
1095 file-or-list flags))
1088 1096
1089(defun vc-git--empty-db-p () 1097(defun vc-git--empty-db-p ()
1090 "Check if the git db is empty (no commit done yet)." 1098 "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'."
1095 ;; We don't need to care the arguments. If there is a file name, it 1103 ;; We don't need to care the arguments. If there is a file name, it
1096 ;; is always a relative one. This works also for remote 1104 ;; is always a relative one. This works also for remote
1097 ;; directories. 1105 ;; directories.
1098 (apply 'process-file "git" nil buffer nil command args)) 1106 (apply 'process-file vc-git-program nil buffer nil command args))
1099 1107
1100(defun vc-git--out-ok (command &rest args) 1108(defun vc-git--out-ok (command &rest args)
1101 (zerop (apply 'vc-git--call '(t nil) command args))) 1109 (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."
529 (insert (propertize 529 (insert (propertize
530 (format " (%s %s)" 530 (format " (%s %s)"
531 (case (vc-hg-extra-fileinfo->rename-state extra) 531 (case (vc-hg-extra-fileinfo->rename-state extra)
532 ('copied "copied from") 532 (copied "copied from")
533 ('renamed-from "renamed from") 533 (renamed-from "renamed from")
534 ('renamed-to "renamed to")) 534 (renamed-to "renamed to"))
535 (vc-hg-extra-fileinfo->extra-name extra)) 535 (vc-hg-extra-fileinfo->extra-name extra))
536 'face 'font-lock-comment-face))))) 536 'face 'font-lock-comment-face)))))
537 537
@@ -663,14 +663,15 @@ then attempts to update the working directory."
663 (let* ((root (vc-hg-root default-directory)) 663 (let* ((root (vc-hg-root default-directory))
664 (buffer (format "*vc-hg : %s*" (expand-file-name root))) 664 (buffer (format "*vc-hg : %s*" (expand-file-name root)))
665 (command "pull") 665 (command "pull")
666 (hg-program "hg") 666 (hg-program vc-hg-program)
667 ;; Fixme: before updating the working copy to the latest 667 ;; Fixme: before updating the working copy to the latest
668 ;; state, should check if it's visiting an old revision. 668 ;; state, should check if it's visiting an old revision.
669 (args '("-u"))) 669 (args '("-u")))
670 ;; If necessary, prompt for the exact command. 670 ;; If necessary, prompt for the exact command.
671 (when prompt 671 (when prompt
672 (setq args (split-string 672 (setq args (split-string
673 (read-shell-command "Run Hg (like this): " "hg pull -u" 673 (read-shell-command "Run Hg (like this): "
674 (format "%s pull -u" hg-program)
674 'vc-hg-history) 675 'vc-hg-history)
675 " " t)) 676 " " t))
676 (setq hg-program (car args) 677 (setq hg-program (car args)
@@ -685,7 +686,7 @@ then attempts to update the working directory."
685This runs the command \"hg merge\"." 686This runs the command \"hg merge\"."
686 (let* ((root (vc-hg-root default-directory)) 687 (let* ((root (vc-hg-root default-directory))
687 (buffer (format "*vc-hg : %s*" (expand-file-name root)))) 688 (buffer (format "*vc-hg : %s*" (expand-file-name root))))
688 (apply 'vc-do-async-command buffer root "hg" '("merge")) 689 (apply 'vc-do-async-command buffer root vc-hg-program '("merge"))
689 (vc-set-async-update buffer))) 690 (vc-set-async-update buffer)))
690 691
691;;; Internal functions 692;;; 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."
1115 (dolist (file files) 1115 (dolist (file files)
1116 (unless (file-writable-p file) 1116 (unless (file-writable-p file)
1117 ;; Make the file+buffer read-write. 1117 ;; Make the file+buffer read-write.
1118 (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue?" file)) 1118 (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue? " file))
1119 (error "Aborted")) 1119 (error "Aborted"))
1120 (set-file-modes file (logior (file-modes file) 128)) 1120 ;; Maybe we somehow lost permissions on the directory.
1121 (condition-case nil
1122 (set-file-modes file (logior (file-modes file) 128))
1123 (error (error "Unable to make file writable")))
1121 (let ((visited (get-file-buffer file))) 1124 (let ((visited (get-file-buffer file)))
1122 (when visited 1125 (when visited
1123 (with-current-buffer visited 1126 (with-current-buffer visited