aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorMiles Bader2007-07-15 04:47:46 +0000
committerMiles Bader2007-07-15 04:47:46 +0000
commit8c406a9bc42ee77fcbbb4201fe8bda855eafd832 (patch)
tree14c8fa2e72341edd9db40b17079fd5208b1554c8 /lisp
parent9bdeb5e9bedd773cc6845bc29a98e1e2a208f1ff (diff)
parent6f8a87c027ebd6f9cfdac5c0df97d651227bec62 (diff)
downloademacs-8c406a9bc42ee77fcbbb4201fe8bda855eafd832.tar.gz
emacs-8c406a9bc42ee77fcbbb4201fe8bda855eafd832.zip
Merge from emacs--devo--0
Patches applied: * emacs--devo--0 (patch 806-813) - Merge from emacs--rel--22 - Update from CVS * emacs--rel--22 (patch 51-58) - Update from CVS - Merge from gnus--rel--5.10 * gnus--rel--5.10 (patch 233-236) - Merge from emacs--devo--0 - Update from CVS Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-230
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog352
-rw-r--r--lisp/ChangeLog.104
-rw-r--r--lisp/ChangeLog.112
-rw-r--r--lisp/ChangeLog.128
-rw-r--r--lisp/autoinsert.el2
-rw-r--r--lisp/bookmark.el28
-rw-r--r--lisp/calendar/cal-bahai.el1
-rw-r--r--lisp/comint.el42
-rw-r--r--lisp/cus-start.el7
-rw-r--r--lisp/desktop.el6
-rw-r--r--lisp/emacs-lisp/advice.el2
-rw-r--r--lisp/emacs-lisp/autoload.el16
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el7
-rw-r--r--lisp/emacs-lisp/cl.el2
-rw-r--r--lisp/emacs-lisp/copyright.el2
-rw-r--r--lisp/emacs-lisp/easymenu.el40
-rw-r--r--lisp/emacs-lisp/eldoc.el120
-rw-r--r--lisp/emacs-lisp/lisp-mode.el4
-rw-r--r--lisp/files.el14
-rw-r--r--lisp/follow.el168
-rw-r--r--lisp/gnus/ChangeLog39
-rw-r--r--lisp/gnus/gnus-art.el21
-rw-r--r--lisp/gnus/gnus-srvr.el41
-rw-r--r--lisp/gnus/gnus-start.el9
-rw-r--r--lisp/gnus/gnus-sum.el3
-rw-r--r--lisp/gnus/mm-util.el34
-rw-r--r--lisp/gnus/nnrss.el7
-rw-r--r--lisp/gnus/rfc2047.el11
-rw-r--r--lisp/isearch.el1
-rw-r--r--lisp/makefile.w32-in15
-rw-r--r--lisp/menu-bar.el1
-rw-r--r--lisp/mh-e/ChangeLog5
-rw-r--r--lisp/mh-e/mh-compat.el12
-rw-r--r--lisp/net/ange-ftp.el14
-rw-r--r--lisp/net/rcompile.el3
-rw-r--r--lisp/net/tramp-cache.el317
-rw-r--r--lisp/net/tramp-fish.el1178
-rw-r--r--lisp/net/tramp-ftp.el30
-rw-r--r--lisp/net/tramp-gw.el324
-rw-r--r--lisp/net/tramp-smb.el1043
-rw-r--r--lisp/net/tramp-util.el138
-rw-r--r--lisp/net/tramp-uu.el9
-rw-r--r--lisp/net/tramp-vc.el536
-rw-r--r--lisp/net/tramp.el8612
-rw-r--r--lisp/net/trampver.el18
-rw-r--r--lisp/pcomplete.el1
-rw-r--r--lisp/pcvs-info.el4
-rw-r--r--lisp/progmodes/compile.el136
-rw-r--r--lisp/progmodes/gdb-ui.el2
-rw-r--r--lisp/progmodes/gud.el20
-rw-r--r--lisp/progmodes/python.el34
-rw-r--r--lisp/progmodes/which-func.el4
-rw-r--r--lisp/replace.el2
-rw-r--r--lisp/subr.el62
-rw-r--r--lisp/textmodes/org.el1293
-rw-r--r--lisp/textmodes/tex-mode.el24
-rw-r--r--lisp/vc-arch.el14
-rw-r--r--lisp/vc-cvs.el186
-rw-r--r--lisp/vc-hooks.el52
-rw-r--r--lisp/w32-fns.el21
-rw-r--r--lisp/window.el5
61 files changed, 8473 insertions, 6635 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index dfea40b56ba..6a568afe055 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,325 @@
12007-07-15 Karl Fogel <kfogel@red-bean.com>
2
3 * bookmark.el: Revert 2007-07-13T18:16:17Z!kfogel@red-bean.com,
4 thus restoring bookmark bindings to three slots under C-x r. See
5 http://lists.gnu.org/archive/html/emacs-devel/2007-07/msg00705.html.
6
72007-07-15 Jeff Miller <jmiller@cablespeed.com> (tiny change)
8
9 * calendar/cal-bahai.el (calendar-goto-bahai-date): Add autoload
10 cookie.
11
122007-07-15 Jason Rumney <jasonr@gnu.org>
13
14 * w32-fns.el (set-default-process-coding-system): Use dos line ends
15 for input to cmdproxy on all versions of Windows.
16 Use dos line ends for input to plink.
17
18 * comint.el (comint-simple-send): Concat newline before sending.
19 (comint-password-prompt-regexp): Recognize plink's passphrase prompt.
20
212007-07-14 Stefan Monnier <monnier@iro.umontreal.ca>
22
23 * emacs-lisp/autoload.el (generated-autoload-file): Autoload the
24 safe-local-variable setting.
25
262007-07-14 David Kastrup <dak@gnu.org>
27
28 * emacs-lisp/advice.el (defadvice): Doc fix.
29
302007-07-14 Juanma Barranquero <lekktu@gmail.com>
31
32 * subr.el (when, unless): Doc fix.
33
342007-07-13 Dan Nicolaescu <dann@ics.uci.edu>
35
36 * replace.el (match): Use yellow1 instead of yellow.
37
38 * progmodes/gdb-ui.el (breakpoint-enabled): Use red1 instead of
39 red.
40
41 * pcvs-info.el (cvs-unknown): Likewise.
42
432007-07-13 Eli Zaretskii <eliz@gnu.org>
44
45 * makefile.w32-in (install-lisp-SH, install-lisp-CMD): New targets.
46 (install): Use them to copy all *.el files before *.elc.
47
482007-07-13 Drew Adams <drew.adams@oracle.com>
49
50 * bookmark.el (bookmark-jump-other-window): New function.
51 (bookmark-map): Bind it to "o".
52
53 http://lists.gnu.org/archive/html/emacs-devel/2007-07/msg00633.html
54 and its thread contains discussion about this change.
55 The original patch was slightly tweaked by Karl Fogel
56 <kfogel@red-bean.com> before committing.
57
582007-07-13 Karl Fogel <kfogel@red-bean.com>
59
60 * bookmark.el: Shorten some comments to fit within 80 lines.
61
622007-07-13 Karl Fogel <kfogel@red-bean.com>
63
64 * bookmark.el: Don't define bookmark keys under the "C-xr" map;
65 instead, make "C-xp" a prefix for bookmark-map. Patch by Drew
66 Adams <drew.adams@oracle.com>, mildly tweaked by me. See
67 http://lists.gnu.org/archive/html/emacs-devel/2007-07/msg00633.html.
68
692007-07-13 Carsten Dominik <dominik@science.uva.nl>
70
71 * textmodes/org.el: Bug fixes.
72 (org-end-of-line): Move to end of line if in headline without tags.
73
742007-07-13 Stefan Monnier <monnier@iro.umontreal.ca>
75
76 * vc-hooks.el: Remove spurious * in docstrings.
77 (vc-handled-backends): Add BZR.
78
79 * vc-hooks.el (vc-find-file-hook): Use with-demoted-errors.
80
812007-07-12 Davis Herring <herring@lanl.gov>
82
83 * desktop.el (desktop-buffer-info, desktop-save):
84 Use `desktop-dirname' instead of `dirname'.
85
862007-07-12 Paul Pogonyshev <pogonyshev@gmx.net>
87
88 * progmodes/which-func.el (which-func-modes): Add `python-mode'.
89
90 * progmodes/python.el (python-which-func-length-limit): New var.
91 (python-which-func): New function.
92 (python-current-defun): Add optional `length-limit' and try to fit
93 computed function name to that length.
94 (python-mode): Hook `python-which-func' up.
95
962007-07-12 Sean O'Rourke <sorourke@cs.ucsd.edu> (tiny change)
97
98 * pcomplete.el (pcomplete-entries): Obey pcomplete-ignore-case.
99
100 * comint.el (comint-dynamic-complete-as-filename):
101 Use read-file-name-completion-ignore-case.
102
1032007-07-12 Stefan Monnier <monnier@iro.umontreal.ca>
104
105 * comint.el (comint-dynamic-list-filename-completions):
106 Use read-file-name-completion-ignore-case.
107
108 * vc-cvs.el: Require CL.
109 (vc-cvs-revision-table, vc-cvs-revision-completion-table):
110 New functions to provide completion of revision names.
111
112 * vc-cvs.el (vc-functions): Clear up the cache when reloading the file.
113 (vc-cvs-annotate-first-line-re): New const.
114 (vc-cvs-annotate-process-filter): New fun.
115 (vc-cvs-annotate-command): Use them and run the command asynchronously.
116
1172007-07-12 Paul Pogonyshev <pogonyshev@gmx.net>
118
119 * emacs-lisp/eldoc.el (eldoc-last-data): Revise documentation.
120 (eldoc-print-current-symbol-info): Adjust for changed helper
121 function signatures.
122 (eldoc-get-fnsym-args-string): Add `args' argument. Use new
123 `eldoc-highlight-function-argument'.
124 (eldoc-highlight-function-argument): New function.
125 (eldoc-get-var-docstring): Format documentation with
126 `font-lock-variable-name-face'.
127 (eldoc-docstring-format-sym-doc): Add `face' argument and apply it
128 where suited.
129 (eldoc-fnsym-in-current-sexp): Return a list with argument index.
130 (eldoc-beginning-of-sexp): Return number of skipped sexps.
131
1322007-07-11 Michael Albinus <michael.albinus@gmx.de>
133
134 * progmodes/compile.el (compilation-start): `start-process' must
135 still be redefined when calling `start-process-shell-command'.
136
137 * progmodes/gud.el (gud-file-name): When `default-directory' is a
138 remote file name, prepend its remote part to the filename.
139 (gud-common-init): When `default-directory' is a remote file name,
140 make the filename relative to it.
141 Based on a patch by Nick Roberts <nickrob@snap.net.nz>.
142
1432007-07-11 Dan Nicolaescu <dann@ics.uci.edu>
144
145 * vc-hooks.el (vc-default-mode-line-string): Add a mouse face,
146 mouse binding and a tooltip.
147
1482007-07-11 Stefan Monnier <monnier@iro.umontreal.ca>
149
150 * menu-bar.el (vc-menu-map): New defalias.
151
1522007-07-10 Richard Stallman <rms@gnu.org>
153
154 * emacs-lisp/lisp-mode.el (eval-defun):
155 Explain special handling of `defface'.
156
1572007-07-10 Jim Meyering <jim@meyering.net> (tiny change)
158
159 * emacs-lisp/copyright.el (copyright-current-gpl-version): Set to 3.
160
161 * autoinsert.el (auto-insert-alist): s/2/3/ in the generated comment.
162
1632007-07-10 Stefan Monnier <monnier@iro.umontreal.ca>
164
165 * emacs-lisp/cl.el: Load cl-loaddefs.el quietly.
166
167 * vc-arch.el (vc-arch-complete): Remove.
168 (vc-arch-revision-completion-table): Use complete-with-action.
169
170 * subr.el (condition-case-no-debug, with-demoted-errors): New macros.
171 (complete-with-action): New function.
172 (dynamic-completion-table): Use it.
173
1742007-07-10 Michael Albinus <michael.albinus@gmx.de>
175
176 * comint.el (make-comint, make-comint-in-buffer)
177 (comint-exec-1): Replace `start-process' by `start-file-process'.
178
179 * progmodes/compile.el (compilation-start): Revert redefining
180 `start-process'.
181
1822007-07-10 Stefan Monnier <monnier@iro.umontreal.ca>
183
184 * emacs-lisp/autoload.el (autoload-generate-file-autoloads): Be careful
185 with EOLs when generating MD5 checksums.
186
187 * follow.el: Don't change the global map from the follow-mode-map
188 defvar, but from the toplevel. Use easy-menu to unify the Emacs and
189 XEmacs code.
190 (turn-on-follow-mode, turn-off-follow-mode): Remove interactive spec
191 since `follow-mode' should be used instead for that.
192
193 * emacs-lisp/easymenu.el (easy-menu-binding): New function.
194 (easy-menu-do-define): Use it.
195 (easy-menu-do-add-item): Inline into easy-menu-add-item and then remove.
196
197 * progmodes/compile.el (compilation-auto-jump-to-first-error)
198 (compilation-auto-jump-to-next): New vars.
199 (compilation-auto-jump): New function.
200 (compilation-error-properties): Use them to jump to first error.
201 (compilation-start): Set the var if requested.
202
203 * emacs-lisp/autoload.el (update-directory-autoloads): Remove
204 duplicates without also removing entries from other directories.
205
2062007-07-10 Carsten Dominik <dominik@science.uva.nl>
207
208 * textmodes/org.el (org-agenda-day-view, org-agenda-week-view):
209 Remember span as default.
210 (org-columns-edit-value): Rename from `org-column-edit'.
211 (org-columns-display-here-title): Rename from
212 `org-overlay-columns-title'.
213 (org-columns-remove-overlays): Rename from org-remove-column-overlays.
214 (org-columns-get-autowidth-alist): Rename from
215 `org-get-columns-autowidth-alist'.
216 (org-columns-display-here): Rename from `org-overlay-columns'.
217 (org-columns-new-overlay): Rename from `org-new-column-overlay'.
218 (org-columns-quit): Rename from `org-column-quit'.
219 (org-columns-show-value): Rename from `org-column-show-value'.
220 (org-columns-content, org-columns-widen)
221 (org-columns-next-allowed-value)
222 (org-columns-edit-allowed, org-columns-store-format)
223 (org-columns-uncompile-format, org-columns-redo)
224 (org-columns-edit-attributes, org-delete-property)
225 (org-set-property, org-columns-update)
226 (org-columns-compute, org-columns-eval)
227 (org-columns-not-in-agenda, org-columns-compute-all)
228 (org-property-next-allowed-value)
229 (org-columns-compile-format)
230 (org-fill-paragraph-experimental)
231 (org-string-to-number, org-property-action)
232 (org-columns-move-left, org-columns-new )
233 (org-column-number-to-string)
234 (org-property-previous-allowed-value)
235 (org-at-property-p, org-columns-delete)
236 (org-columns-previous-allowed-value)
237 (org-columns-move-right, org-columns-narrow)
238 (org-property-get-allowed-values)
239 (org-verify-version, org-column-string-to-number)
240 (org-delete-property-globally): New functions.
241 (org-columns-current-fmt): Rename from `org-current-columns-fmt'.
242 (org-columns-overlays): Rename from `org-column-overlays'.
243 (org-columns-map): Rename from `org-column-map'.
244 (org-columns-current-maxwidths): Rename from
245 `org-current-columns-maxwidths'.
246 (org-columns-begin-marker, org-columns-current-fmt-compiled)
247 (org-previous-header-line-format)
248 (org-columns-inhibit-recalculation)
249 (org-columns-top-level-marker): New variables.
250 (org-columns-default-format): Rename from `org-default-columns-format'.
251 (org-property-re): New constant.
252
2532007-07-10 Guanpeng Xu <herberteuler@hotmail.com>
254
255 * subr.el (looking-at-p, string-match-p): New functions.
256
2572007-07-09 Reiner Steib <Reiner.Steib@gmx.de>
258
259 * textmodes/tex-mode.el (tex-fontify-script)
260 (tex-font-script-display): New variables to make display of
261 superscripts and subscripts customizable.
262 (tex-font-lock-suscript, tex-font-lock-match-suscript): Use them.
263
2642007-07-09 Richard Stallman <rms@gnu.org>
265
266 * isearch.el (isearch-edit-string): Call to isearch-push-state
267 after the search.
268
2692007-07-09 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
270
271 * window.el (fit-window-to-buffer): Remove setting of window-min-height
272 to 1 as enlarge-window uses the value to resize/shrink windows other
273 than WINDOW if needed.
274
2752007-07-08 Katsumi Yamaoka <yamaoka@jpl.org>
276
277 * cus-start.el (file-coding-system-alist): Fix custom type.
278
2792007-07-08 Chong Yidong <cyd@stupidchicken.com>
280
281 * longlines.el (longlines-wrap-region): Avoid marking buffer as
282 modified.
283 (longlines-auto-wrap, longlines-window-change-function):
284 Remove unnecessary calls to set-buffer-modified-p.
285
2862007-07-08 Katsumi Yamaoka <yamaoka@jpl.org>
287
288 * cus-start.el (file-coding-system-alist): Fix custom type.
289
2902007-07-08 Stefan Monnier <monnier@iro.umontreal.ca>
291
292 * vc-cvs.el (vc-cvs-revert): Use vc-default-revert.
293 (vc-cvs-checkout): Remove last arg now unused; simplify.
294
2952007-07-08 Michael Albinus <michael.albinus@gmx.de>
296
297 * files.el (file-remote-p): Introduce optional parameter CONNECTED.
298
299 * net/tramp.el:
300 * net/tramp-ftp.el:
301 * net/tramp-smb.el:
302 * net/tramp-uu.el:
303 * net/trampver.el: Migrate to Tramp 2.1.
304
305 * net/tramp-cache.el:
306 * net/tramp-fish.el:
307 * net/tramp-gw.el: New Tramp packages.
308
309 * net/tramp-util.el:
310 * net/tramp-vc.el: Removed.
311
312 * net/ange-ftp.el: Add ange-ftp property to 'start-file-process
313 (ange-ftp-file-remote-p): Handle optional parameter CONNECTED.
314
315 * net/rcompile.el (remote-compile): Handle Tramp 2.1 arguments.
316
317 * progmodes/compile.el (compilation-start): Redefine
318 `start-process' temporarily when `default-directory' is remote.
319 Remove case of synchronous compilation, this won't happen ever.
320 (compilation-setup): Make local variable `comint-file-name-prefix'
321 for remote compilation.
322
12007-07-08 Martin Rudalics <rudalics@gmx.at> 3232007-07-08 Martin Rudalics <rudalics@gmx.at>
2 324
3 * novice.el (disabled-command-function): Fit window to buffer to 325 * novice.el (disabled-command-function): Fit window to buffer to
@@ -16,20 +338,21 @@
16 (math-bignum-digit-power-of-two): Evaluate when compiled. 338 (math-bignum-digit-power-of-two): Evaluate when compiled.
17 339
18 * calc/calc-comb.el (math-small-factorial-table) 340 * calc/calc-comb.el (math-small-factorial-table)
19 (math-init-random-base,math-prime-test): Remove unnecessary calls 341 (math-init-random-base, math-prime-test): Remove unnecessary calls
20 to `math-read-number-simple'. 342 to `math-read-number-simple'.
21 343
22 * calc/calc-ext.el (math-approx-pi,math-approx-sqrt-e) 344 * calc/calc-ext.el (math-approx-pi, math-approx-sqrt-e)
23 (math-approx-gamma-const): Add docstrings. 345 (math-approx-gamma-const): Add docstrings.
24 346
25 * calc/calc-forms.el (math-julian-date-beginning) 347 * calc/calc-forms.el (math-julian-date-beginning)
26 (math-julian-date-beginning-int) New constants. 348 (math-julian-date-beginning-int): New constants.
27 (math-format-date-part,math-parse-standard-date,calcFunc-julian): 349 (math-format-date-part, math-parse-standard-date, calcFunc-julian):
28 Use the new constants. 350 Use the new constants.
29 351
30 * calc/calc-funcs.el (math-gammap1-raw): Add docstring. 352 * calc/calc-funcs.el (math-gammap1-raw): Add docstring.
31 353
32 * calc/calc-math.el (math-approx-ln-10,math-approx-ln-2): Add docstrings. 354 * calc/calc-math.el (math-approx-ln-10, math-approx-ln-2):
355 Add docstrings.
33 356
342007-07-07 Tom Tromey <tromey@redhat.com> 3572007-07-07 Tom Tromey <tromey@redhat.com>
35 358
@@ -106,8 +429,8 @@
106 429
107 * calc/calc-bin.el (math-bignum-logb-digit-size) 430 * calc/calc-bin.el (math-bignum-logb-digit-size)
108 (math-bignum-digit-power-of-two): New constants. 431 (math-bignum-digit-power-of-two): New constants.
109 (math-and-bignum,math-or-bignum,math-xor-bignum,math-diff-bignum) 432 (math-and-bignum, math-or-bignum, math-xor-bignum, math-diff-bignum)
110 (math-not-bignum,math-clip-bignum): Use the constants 433 (math-not-bignum, math-clip-bignum): Use the constants
111 `math-bignum-digit-power-of-two' and `math-bignum-logb-digit-size' 434 `math-bignum-digit-power-of-two' and `math-bignum-logb-digit-size'
112 instead of their values. 435 instead of their values.
113 (math-clip): Use math-small-integer-size instead of its value. 436 (math-clip): Use math-small-integer-size instead of its value.
@@ -186,6 +509,11 @@
186 * calculator.el (calculator-expt): Use more cases to determine 509 * calculator.el (calculator-expt): Use more cases to determine
187 the value. 510 the value.
188 511
5122007-07-03 Dan Nicolaescu <dann@ics.uci.edu>
513
514 * progmodes/gud.el (auto-mode-alist): Match more valid gdb init
515 file names.
516
1892007-07-03 Jay Belanger <jay.p.belanger@gmail.com> 5172007-07-03 Jay Belanger <jay.p.belanger@gmail.com>
190 518
191 * calculator.el (calculator-expt, calculator-integer-p): 519 * calculator.el (calculator-expt, calculator-integer-p):
@@ -261,7 +589,7 @@
261 589
2622007-07-02 Martin Rudalics <rudalics@gmx.at> 5902007-07-02 Martin Rudalics <rudalics@gmx.at>
263 591
264 * help-mode.el (help-make-xrefs): Skip spaces too when 592 * help-mode.el (help-make-xrefs): Skip spaces too when
265 skipping tabs. 593 skipping tabs.
266 594
267 * ffap.el (dired-at-point-prompter): Improve prompt in 595 * ffap.el (dired-at-point-prompter): Improve prompt in
@@ -269,6 +597,10 @@
269 597
2702007-07-01 Richard Stallman <rms@gnu.org> 5982007-07-01 Richard Stallman <rms@gnu.org>
271 599
600 * files.el (find-file-visit-truename): Fix safe-local-variable value.
601
6022007-07-01 Richard Stallman <rms@gnu.org>
603
272 * cus-start.el (max-mini-window-height): Added. 604 * cus-start.el (max-mini-window-height): Added.
273 605
2742007-07-01 Sean O'Rourke <sorourke@cs.ucsd.edu> (tiny change) 6062007-07-01 Sean O'Rourke <sorourke@cs.ucsd.edu> (tiny change)
@@ -918,7 +1250,7 @@
918 post-command-hook. 1250 post-command-hook.
919 (rcirc-window-configuration-change-1): Update mode-line and 1251 (rcirc-window-configuration-change-1): Update mode-line and
920 overlay arrows here. 1252 overlay arrows here.
921 (rcirc-authenticate): Fix chanserv identification. 1253 (rcirc-authenticate): Fixc hanserv identification.
922 (rcirc-default-server): Remove variable. 1254 (rcirc-default-server): Remove variable.
923 (rcirc): Connect according to rcirc-connections. 1255 (rcirc): Connect according to rcirc-connections.
924 (rcirc-connections): Add variable. 1256 (rcirc-connections): Add variable.
@@ -1536,7 +1868,7 @@
1536 1868
1537 * files.el (auto-mode-alist): Open `.asd' files in lisp-mode. 1869 * files.el (auto-mode-alist): Open `.asd' files in lisp-mode.
1538 1870
15392007-05-22 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change) 18712007-05-22 Katsumi Yamaoka <yamaoka@jpl.org>
1540 1872
1541 * mail/mail-extr.el (mail-extract-address-components): 1873 * mail/mail-extr.el (mail-extract-address-components):
1542 Recognize non-ASCII characters except for NBSP as words. 1874 Recognize non-ASCII characters except for NBSP as words.
diff --git a/lisp/ChangeLog.10 b/lisp/ChangeLog.10
index d6d69c52924..d63ef8fbbd7 100644
--- a/lisp/ChangeLog.10
+++ b/lisp/ChangeLog.10
@@ -1340,7 +1340,7 @@
1340 (shell-directory-tracker): Make regexp used for skipping to next 1340 (shell-directory-tracker): Make regexp used for skipping to next
1341 command correspond to one used for command itself. 1341 command correspond to one used for command itself.
1342 1342
13432003-06-13 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change) 13432003-06-13 Katsumi Yamaoka <yamaoka@jpl.org>
1344 1344
1345 * textmodes/texinfmt.el (texinfo-format-scan): 1345 * textmodes/texinfmt.el (texinfo-format-scan):
1346 Silence `whitespace-cleanup'. 1346 Silence `whitespace-cleanup'.
@@ -11805,7 +11805,7 @@
11805 11805
11806 * vc-hooks.el (vc-kill-buffer-hook): Add it to kill-buffer-hook again. 11806 * vc-hooks.el (vc-kill-buffer-hook): Add it to kill-buffer-hook again.
11807 11807
118082002-08-22 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change) 118082002-08-22 Katsumi Yamaoka <yamaoka@jpl.org>
11809 11809
11810 * frame.el (select-frame-by-name, select-frame-set-input-focus): 11810 * frame.el (select-frame-by-name, select-frame-set-input-focus):
11811 Always call x-focus-frame, if using x. 11811 Always call x-focus-frame, if using x.
diff --git a/lisp/ChangeLog.11 b/lisp/ChangeLog.11
index ac47f4eaeaa..0ef83a0ed9d 100644
--- a/lisp/ChangeLog.11
+++ b/lisp/ChangeLog.11
@@ -5295,7 +5295,7 @@
5295 (reb-lisp-syntax-p, reb-change-syntax): `rx' is a Lisp syntax. 5295 (reb-lisp-syntax-p, reb-change-syntax): `rx' is a Lisp syntax.
5296 (reb-cook-regexp): Call `rx-to-string' when `re-reb-syntax' is `rx'. 5296 (reb-cook-regexp): Call `rx-to-string' when `re-reb-syntax' is `rx'.
5297 5297
52982004-08-05 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change) 52982004-08-05 Katsumi Yamaoka <yamaoka@jpl.org>
5299 5299
5300 * mail/mail-extr.el (mail-extr-disable-voodoo): New variable. 5300 * mail/mail-extr.el (mail-extr-disable-voodoo): New variable.
5301 (mail-extr-voodoo): Check mail-extr-disable-voodoo. 5301 (mail-extr-voodoo): Check mail-extr-disable-voodoo.
diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12
index 957d9a51bb4..2d4882a8b1e 100644
--- a/lisp/ChangeLog.12
+++ b/lisp/ChangeLog.12
@@ -1092,8 +1092,8 @@
1092 North American rule. Replace "daylight savings" with "daylight 1092 North American rule. Replace "daylight savings" with "daylight
1093 saving" in doc. 1093 saving" in doc.
1094 1094
1095 * calendar/cal-china.el,cal-dst.el,calendar.el,diary-lib.el: 1095 * calendar/cal-china.el, cal-dst.el, calendar.el, diary-lib.el:
1096 * calendar/lunar.el,solar.el: Replace "daylight savings" with 1096 * calendar/lunar.el, solar.el: Replace "daylight savings" with
1097 "daylight saving" in text. 1097 "daylight saving" in text.
1098 1098
1099 * woman.el (woman-change-fonts): Tweak previous change by using 1099 * woman.el (woman-change-fonts): Tweak previous change by using
@@ -8709,7 +8709,7 @@
8709 * term.el (term-handle-scroll, term-delete-lines) 8709 * term.el (term-handle-scroll, term-delete-lines)
8710 (term-insert-lines): Fix off by one errors. 8710 (term-insert-lines): Fix off by one errors.
8711 8711
87122006-06-15 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change) 87122006-06-15 Katsumi Yamaoka <yamaoka@jpl.org>
8713 8713
8714 * net/tramp.el (tramp-touch): Use UTC to express time. 8714 * net/tramp.el (tramp-touch): Use UTC to express time.
8715 8715
@@ -22969,7 +22969,7 @@
22969 22969
22970 * menu-bar.el (menu-bar-showhide-menu): Add `showhide-battery'. 22970 * menu-bar.el (menu-bar-showhide-menu): Add `showhide-battery'.
22971 22971
229722005-08-09 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change) 229722005-08-09 Katsumi Yamaoka <yamaoka@jpl.org>
22973 22973
22974 * net/ange-ftp.el (ange-ftp-send-cmd): Make it work properly with 22974 * net/ange-ftp.el (ange-ftp-send-cmd): Make it work properly with
22975 uploading files. 22975 uploading files.
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 3f615dcfbd3..dcacc6a99ff 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -188,7 +188,7 @@ If this contains a %s, that will be replaced by the matching rule."
188 188
189\;; This file is free software; you can redistribute it and/or modify 189\;; This file is free software; you can redistribute it and/or modify
190\;; it under the terms of the GNU General Public License as published by 190\;; it under the terms of the GNU General Public License as published by
191\;; the Free Software Foundation; either version 2, or (at your option) 191\;; the Free Software Foundation; either version 3, or (at your option)
192\;; any later version. 192\;; any later version.
193 193
194\;; This file is distributed in the hope that it will be useful, 194\;; This file is distributed in the hope that it will be useful,
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 3c1469fef97..75c4826ae0b 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -240,12 +240,13 @@ functions have a binding in this keymap.")
240 240
241;; Read the help on all of these functions for details... 241;; Read the help on all of these functions for details...
242;;;###autoload (define-key bookmark-map "x" 'bookmark-set) 242;;;###autoload (define-key bookmark-map "x" 'bookmark-set)
243;;;###autoload (define-key bookmark-map "m" 'bookmark-set) ; "m" for "mark" 243;;;###autoload (define-key bookmark-map "m" 'bookmark-set) ;"m"ark
244;;;###autoload (define-key bookmark-map "j" 'bookmark-jump) 244;;;###autoload (define-key bookmark-map "j" 'bookmark-jump)
245;;;###autoload (define-key bookmark-map "g" 'bookmark-jump) ; "g" for "go" 245;;;###autoload (define-key bookmark-map "g" 'bookmark-jump) ;"g"o
246;;;###autoload (define-key bookmark-map "o" 'bookmark-jump-other-window)
246;;;###autoload (define-key bookmark-map "i" 'bookmark-insert) 247;;;###autoload (define-key bookmark-map "i" 'bookmark-insert)
247;;;###autoload (define-key bookmark-map "e" 'edit-bookmarks) 248;;;###autoload (define-key bookmark-map "e" 'edit-bookmarks)
248;;;###autoload (define-key bookmark-map "f" 'bookmark-insert-location) ; "f" for "find" 249;;;###autoload (define-key bookmark-map "f" 'bookmark-insert-location) ;"f"ind
249;;;###autoload (define-key bookmark-map "r" 'bookmark-rename) 250;;;###autoload (define-key bookmark-map "r" 'bookmark-rename)
250;;;###autoload (define-key bookmark-map "d" 'bookmark-delete) 251;;;###autoload (define-key bookmark-map "d" 'bookmark-delete)
251;;;###autoload (define-key bookmark-map "l" 'bookmark-load) 252;;;###autoload (define-key bookmark-map "l" 'bookmark-load)
@@ -1083,6 +1084,27 @@ of the old one in the permanent bookmark record."
1083 (bookmark-show-annotation bookmark))))) 1084 (bookmark-show-annotation bookmark)))))
1084 1085
1085 1086
1087;;;###autoload
1088(defun bookmark-jump-other-window (bookmark)
1089 "Jump to BOOKMARK (a point in some file) in another window.
1090See `bookmark-jump'."
1091 (interactive
1092 (let ((bkm (bookmark-completing-read "Jump to bookmark (in another window)"
1093 bookmark-current-bookmark)))
1094 (if (> emacs-major-version 21)
1095 (list bkm) bkm)))
1096 (when bookmark
1097 (bookmark-maybe-historicize-string bookmark)
1098 (let ((cell (bookmark-jump-noselect bookmark)))
1099 (and cell
1100 (switch-to-buffer-other-window (car cell))
1101 (goto-char (cdr cell))
1102 (if bookmark-automatically-show-annotations
1103 ;; if there is an annotation for this bookmark,
1104 ;; show it in a buffer.
1105 (bookmark-show-annotation bookmark))))))
1106
1107
1086(defun bookmark-file-or-variation-thereof (file) 1108(defun bookmark-file-or-variation-thereof (file)
1087 "Return FILE (a string) if it exists, or return a reasonable 1109 "Return FILE (a string) if it exists, or return a reasonable
1088variation of FILE if that exists. Reasonable variations are checked 1110variation of FILE if that exists. Reasonable variations are checked
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
index 06703e3b73b..7bf90ec5d11 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -149,6 +149,7 @@ Defaults to today's date if DATE is not given."
149 (message "Baha'i date: %s" 149 (message "Baha'i date: %s"
150 (calendar-bahai-date-string (calendar-cursor-to-date t)))) 150 (calendar-bahai-date-string (calendar-cursor-to-date t))))
151 151
152;;;###autoload
152(defun calendar-goto-bahai-date (date &optional noecho) 153(defun calendar-goto-bahai-date (date &optional noecho)
153 "Move cursor to Baha'i date DATE. 154 "Move cursor to Baha'i date DATE.
154Echo Baha'i date unless NOECHO is t." 155Echo Baha'i date unless NOECHO is t."
diff --git a/lisp/comint.el b/lisp/comint.el
index 7d81f357e22..17ab13337aa 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -333,12 +333,13 @@ This variable is buffer-local."
333;; kinit prints a prompt like `Password for devnull@GNU.ORG: '. 333;; kinit prints a prompt like `Password for devnull@GNU.ORG: '.
334;; ksu prints a prompt like `Kerberos password for devnull/root@GNU.ORG: '. 334;; ksu prints a prompt like `Kerberos password for devnull/root@GNU.ORG: '.
335;; ssh-add prints a prompt like `Enter passphrase: '. 335;; ssh-add prints a prompt like `Enter passphrase: '.
336;; plink prints a prompt like `Passphrase for key "root@GNU.ORG": '.
336;; Some implementations of passwd use "Password (again)" as the 2nd prompt. 337;; Some implementations of passwd use "Password (again)" as the 2nd prompt.
337(defcustom comint-password-prompt-regexp 338(defcustom comint-password-prompt-regexp
338 "\\(\\([Oo]ld \\|[Nn]ew \\|'s \\|login \\|\ 339 "\\(\\([Oo]ld \\|[Nn]ew \\|'s \\|login \\|\
339Kerberos \\|CVS \\|UNIX \\| SMB \\|^\\)\ 340Kerberos \\|CVS \\|UNIX \\| SMB \\|^\\)\
340\[Pp]assword\\( (again)\\)?\\|\ 341\[Pp]assword\\( (again)\\)?\\|\
341pass phrase\\|\\(Enter\\|Repeat\\|Bad\\) passphrase\\)\ 342pass phrase\\|\\(Enter \\|Repeat \\|Bad \\)?[Pp]assphrase\\)\
342\\(?:, try again\\)?\\(?: for [^:]+\\)?:\\s *\\'" 343\\(?:, try again\\)?\\(?: for [^:]+\\)?:\\s *\\'"
343 "*Regexp matching prompts for passwords in the inferior process. 344 "*Regexp matching prompts for passwords in the inferior process.
344This is used by `comint-watch-for-password-prompt'." 345This is used by `comint-watch-for-password-prompt'."
@@ -670,13 +671,13 @@ BUFFER can be either a buffer or the name of one."
670 "Make a Comint process NAME in BUFFER, running PROGRAM. 671 "Make a Comint process NAME in BUFFER, running PROGRAM.
671If BUFFER is nil, it defaults to NAME surrounded by `*'s. 672If BUFFER is nil, it defaults to NAME surrounded by `*'s.
672PROGRAM should be either a string denoting an executable program to create 673PROGRAM should be either a string denoting an executable program to create
673via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP 674via `start-file-process', or a cons pair of the form (HOST . SERVICE) denoting
674connection to be opened via `open-network-stream'. If there is already a 675a TCP connection to be opened via `open-network-stream'. If there is already
675running process in that buffer, it is not restarted. Optional fourth arg 676a running process in that buffer, it is not restarted. Optional fourth arg
676STARTFILE is the name of a file to send the contents of to the process. 677STARTFILE is the name of a file to send the contents of to the process.
677 678
678If PROGRAM is a string, any more args are arguments to PROGRAM." 679If PROGRAM is a string, any more args are arguments to PROGRAM."
679 (or (fboundp 'start-process) 680 (or (fboundp 'start-file-process)
680 (error "Multi-processing is not supported for this system")) 681 (error "Multi-processing is not supported for this system"))
681 (setq buffer (get-buffer-create (or buffer (concat "*" name "*")))) 682 (setq buffer (get-buffer-create (or buffer (concat "*" name "*"))))
682 ;; If no process, or nuked process, crank up a new one and put buffer in 683 ;; If no process, or nuked process, crank up a new one and put buffer in
@@ -693,9 +694,9 @@ If PROGRAM is a string, any more args are arguments to PROGRAM."
693 "Make a Comint process NAME in a buffer, running PROGRAM. 694 "Make a Comint process NAME in a buffer, running PROGRAM.
694The name of the buffer is made by surrounding NAME with `*'s. 695The name of the buffer is made by surrounding NAME with `*'s.
695PROGRAM should be either a string denoting an executable program to create 696PROGRAM should be either a string denoting an executable program to create
696via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP 697via `start-file-process', or a cons pair of the form (HOST . SERVICE) denoting
697connection to be opened via `open-network-stream'. If there is already a 698a TCP connection to be opened via `open-network-stream'. If there is already
698running process in that buffer, it is not restarted. Optional third arg 699a running process in that buffer, it is not restarted. Optional third arg
699STARTFILE is the name of a file to send the contents of the process to. 700STARTFILE is the name of a file to send the contents of the process to.
700 701
701If PROGRAM is a string, any more args are arguments to PROGRAM." 702If PROGRAM is a string, any more args are arguments to PROGRAM."
@@ -781,17 +782,17 @@ buffer. The hook `comint-exec-hook' is run after each exec."
781 ;; If the command has slashes, make sure we 782 ;; If the command has slashes, make sure we
782 ;; first look relative to the current directory. 783 ;; first look relative to the current directory.
783 (cons default-directory exec-path) exec-path))) 784 (cons default-directory exec-path) exec-path)))
784 (setq proc (apply 'start-process name buffer command switches))) 785 (setq proc (apply 'start-file-process name buffer command switches)))
785 (let ((coding-systems (process-coding-system proc))) 786 (let ((coding-systems (process-coding-system proc)))
786 (setq decoding (car coding-systems) 787 (setq decoding (car coding-systems)
787 encoding (cdr coding-systems))) 788 encoding (cdr coding-systems)))
788 ;; If start-process decided to use some coding system for decoding 789 ;; If start-file-process decided to use some coding system for decoding
789 ;; data sent from the process and the coding system doesn't 790 ;; data sent from the process and the coding system doesn't
790 ;; specify EOL conversion, we had better convert CRLF to LF. 791 ;; specify EOL conversion, we had better convert CRLF to LF.
791 (if (vectorp (coding-system-eol-type decoding)) 792 (if (vectorp (coding-system-eol-type decoding))
792 (setq decoding (coding-system-change-eol-conversion decoding 'dos) 793 (setq decoding (coding-system-change-eol-conversion decoding 'dos)
793 changed t)) 794 changed t))
794 ;; Even if start-process left the coding system for encoding data 795 ;; Even if start-file-process left the coding system for encoding data
795 ;; sent from the process undecided, we had better use the same one 796 ;; sent from the process undecided, we had better use the same one
796 ;; as what we use for decoding. But, we should suppress EOL 797 ;; as what we use for decoding. But, we should suppress EOL
797 ;; conversion. 798 ;; conversion.
@@ -1953,11 +1954,16 @@ If this takes us past the end of the current line, don't skip at all."
1953 "Default function for sending to PROC input STRING. 1954 "Default function for sending to PROC input STRING.
1954This just sends STRING plus a newline. To override this, 1955This just sends STRING plus a newline. To override this,
1955set the hook `comint-input-sender'." 1956set the hook `comint-input-sender'."
1956 (comint-send-string proc string) 1957 (let ((send-string
1957 (if comint-input-sender-no-newline 1958 (if comint-input-sender-no-newline
1958 (if (not (string-equal string "")) 1959 string
1959 (process-send-eof)) 1960 ;; Sending as two separate strings does not work
1960 (comint-send-string proc "\n"))) 1961 ;; on Windows, so concat the \n before sending.
1962 (concat string "\n"))))
1963 (comint-send-string proc send-string))
1964 (if (and comint-input-sender-no-newline
1965 (not (string-equal string "")))
1966 (process-send-eof)))
1961 1967
1962(defun comint-line-beginning-position () 1968(defun comint-line-beginning-position ()
1963 "Return the buffer position of the beginning of the line, after any prompt. 1969 "Return the buffer position of the beginning of the line, after any prompt.
@@ -2805,7 +2811,7 @@ Returns t if successful."
2805(defun comint-dynamic-complete-as-filename () 2811(defun comint-dynamic-complete-as-filename ()
2806 "Dynamically complete at point as a filename. 2812 "Dynamically complete at point as a filename.
2807See `comint-dynamic-complete-filename'. Returns t if successful." 2813See `comint-dynamic-complete-filename'. Returns t if successful."
2808 (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt cygwin))) 2814 (let* ((completion-ignore-case read-file-name-completion-ignore-case)
2809 (completion-ignored-extensions comint-completion-fignore) 2815 (completion-ignored-extensions comint-completion-fignore)
2810 ;; If we bind this, it breaks remote directory tracking in rlogin.el. 2816 ;; If we bind this, it breaks remote directory tracking in rlogin.el.
2811 ;; I think it was originally bound to solve file completion problems, 2817 ;; I think it was originally bound to solve file completion problems,
@@ -2934,7 +2940,7 @@ See also `comint-dynamic-complete-filename'."
2934(defun comint-dynamic-list-filename-completions () 2940(defun comint-dynamic-list-filename-completions ()
2935 "List in help buffer possible completions of the filename at point." 2941 "List in help buffer possible completions of the filename at point."
2936 (interactive) 2942 (interactive)
2937 (let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt cygwin))) 2943 (let* ((completion-ignore-case read-file-name-completion-ignore-case)
2938 ;; If we bind this, it breaks remote directory tracking in rlogin.el. 2944 ;; If we bind this, it breaks remote directory tracking in rlogin.el.
2939 ;; I think it was originally bound to solve file completion problems, 2945 ;; I think it was originally bound to solve file completion problems,
2940 ;; but subsequent changes may have made this unnecessary. sm. 2946 ;; but subsequent changes may have made this unnecessary. sm.
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index e003e4f4622..3f2bd91ca84 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -125,8 +125,11 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
125 :value (undecided . undecided) 125 :value (undecided . undecided)
126 (coding-system :tag "Decoding") 126 (coding-system :tag "Decoding")
127 (coding-system :tag "Encoding")) 127 (coding-system :tag "Encoding"))
128 (coding-system :tag "Single coding system" 128 (coding-system
129 :value undecided) 129 :tag "Single coding system"
130 :value undecided
131 :match (lambda (widget value)
132 (and value (not (functionp value)))))
130 (function :value ignore)))) 133 (function :value ignore))))
131 (selection-coding-system mule coding-system) 134 (selection-coding-system mule coding-system)
132 ;; dired.c 135 ;; dired.c
diff --git a/lisp/desktop.el b/lisp/desktop.el
index ca5ed9290b0..4f6524ec3f6 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -652,7 +652,7 @@ is nil, ask the user where to save the desktop."
652 (set-buffer buffer) 652 (set-buffer buffer)
653 (list 653 (list
654 ;; basic information 654 ;; basic information
655 (desktop-file-name (buffer-file-name) dirname) 655 (desktop-file-name (buffer-file-name) desktop-dirname)
656 (buffer-name) 656 (buffer-name)
657 major-mode 657 major-mode
658 ;; minor modes 658 ;; minor modes
@@ -673,7 +673,7 @@ is nil, ask the user where to save the desktop."
673 buffer-read-only 673 buffer-read-only
674 ;; auxiliary information 674 ;; auxiliary information
675 (when (functionp desktop-save-buffer) 675 (when (functionp desktop-save-buffer)
676 (funcall desktop-save-buffer dirname)) 676 (funcall desktop-save-buffer desktop-dirname))
677 ;; local variables 677 ;; local variables
678 (let ((locals desktop-locals-to-save) 678 (let ((locals desktop-locals-to-save)
679 (loclist (buffer-local-variables)) 679 (loclist (buffer-local-variables))
@@ -897,7 +897,7 @@ See also `desktop-base-file-name'."
897 (insert "\n " (desktop-value-to-string e))) 897 (insert "\n " (desktop-value-to-string e)))
898 (insert ")\n\n"))) 898 (insert ")\n\n")))
899 899
900 (setq default-directory dirname) 900 (setq default-directory desktop-dirname)
901 (let ((coding-system-for-write 'emacs-mule)) 901 (let ((coding-system-for-write 'emacs-mule))
902 (write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage)) 902 (write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage))
903 ;; We remember when it was modified (which is presumably just now). 903 ;; We remember when it was modified (which is presumably just now).
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 8023bc58a53..0123124b26d 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -3759,7 +3759,7 @@ The syntax of `defadvice' is as follows:
3759 3759
3760 \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) 3760 \(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
3761 [DOCSTRING] [INTERACTIVE-FORM] 3761 [DOCSTRING] [INTERACTIVE-FORM]
3762 BODY... ) 3762 BODY...)
3763 3763
3764FUNCTION ::= Name of the function to be advised. 3764FUNCTION ::= Name of the function to be advised.
3765CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'. 3765CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'.
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 93ba83bb729..6495ca2a5e9 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -41,6 +41,7 @@
41A `.el' file can set this in its local variables section to make its 41A `.el' file can set this in its local variables section to make its
42autoloads go somewhere else. The autoload file is assumed to contain a 42autoloads go somewhere else. The autoload file is assumed to contain a
43trailer starting with a FormFeed character.") 43trailer starting with a FormFeed character.")
44;;;###autoload
44(put 'generated-autoload-file 'safe-local-variable 'stringp) 45(put 'generated-autoload-file 'safe-local-variable 'stringp)
45 46
46;; This feels like it should be a defconst, but MH-E sets it to 47;; This feels like it should be a defconst, but MH-E sets it to
@@ -432,7 +433,10 @@ Return non-nil iff FILE adds no autoloads to OUTFILE
432 ;; checksum in secondary autoload files where we do 433 ;; checksum in secondary autoload files where we do
433 ;; not need the time-stamp optimization because it is 434 ;; not need the time-stamp optimization because it is
434 ;; already provided by the primary autoloads file. 435 ;; already provided by the primary autoloads file.
435 (md5 secondary-autoloads-file-buf nil nil 'emacs-mule) 436 (md5 secondary-autoloads-file-buf
437 ;; We'd really want to just use
438 ;; `emacs-internal' instead.
439 nil nil 'emacs-mule-unix)
436 (nth 5 (file-attributes relfile)))) 440 (nth 5 (file-attributes relfile))))
437 (insert ";;; Generated autoloads from " relfile "\n")) 441 (insert ";;; Generated autoloads from " relfile "\n"))
438 (insert generate-autoload-section-trailer)))) 442 (insert generate-autoload-section-trailer))))
@@ -559,6 +563,7 @@ directory or directories specified."
559 (directory-files (expand-file-name dir) 563 (directory-files (expand-file-name dir)
560 t files-re)) 564 t files-re))
561 dirs))) 565 dirs)))
566 (done ())
562 (this-time (current-time)) 567 (this-time (current-time))
563 ;; Files with no autoload cookies or whose autoloads go to other 568 ;; Files with no autoload cookies or whose autoloads go to other
564 ;; files because of file-local autoload-generated-file settings. 569 ;; files because of file-local autoload-generated-file settings.
@@ -592,10 +597,10 @@ directory or directories specified."
592 (push file no-autoloads) 597 (push file no-autoloads)
593 (setq files (delete file files))))))) 598 (setq files (delete file files)))))))
594 ((not (stringp file))) 599 ((not (stringp file)))
595 ((not (and (file-exists-p file) 600 ((or (not (file-exists-p file))
596 ;; Remove duplicates as well, just in case. 601 ;; Remove duplicates as well, just in case.
597 (member file files))) 602 (member file done))
598 ;; Remove the obsolete section. 603 ;; Remove the obsolete section.
599 (autoload-remove-section (match-beginning 0))) 604 (autoload-remove-section (match-beginning 0)))
600 ((not (time-less-p (nth 4 form) 605 ((not (time-less-p (nth 4 form)
601 (nth 5 (file-attributes file)))) 606 (nth 5 (file-attributes file))))
@@ -606,6 +611,7 @@ directory or directories specified."
606 (if (autoload-generate-file-autoloads 611 (if (autoload-generate-file-autoloads
607 file (current-buffer) buffer-file-name) 612 file (current-buffer) buffer-file-name)
608 (push file no-autoloads)))) 613 (push file no-autoloads))))
614 (push file done)
609 (setq files (delete file files))))) 615 (setq files (delete file files)))))
610 ;; Elements remaining in FILES have no existing autoload sections yet. 616 ;; Elements remaining in FILES have no existing autoload sections yet.
611 (dolist (file files) 617 (dolist (file files)
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 65cb0754446..1589e19cbb2 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -10,8 +10,7 @@
10;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p 10;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p
11;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively 11;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively
12;;;;;; notevery notany every some mapcon mapcan mapl maplist map 12;;;;;; notevery notany every some mapcon mapcan mapl maplist map
13;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" (18050 13;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "47c92504dda976a632c2c10bedd4b6a4")
14;;;;;; 46455))
15;;; Generated autoloads from cl-extra.el 14;;; Generated autoloads from cl-extra.el
16 15
17(autoload (quote coerce) "cl-extra" "\ 16(autoload (quote coerce) "cl-extra" "\
@@ -284,7 +283,7 @@ Not documented
284;;;;;; do* do loop return-from return block etypecase typecase ecase 283;;;;;; do* do loop return-from return block etypecase typecase ecase
285;;;;;; case load-time-value eval-when destructuring-bind function* 284;;;;;; case load-time-value eval-when destructuring-bind function*
286;;;;;; defmacro* defun* gentemp gensym cl-compile-time-init) "cl-macs" 285;;;;;; defmacro* defun* gentemp gensym cl-compile-time-init) "cl-macs"
287;;;;;; "cl-macs.el" (18051 52572)) 286;;;;;; "cl-macs.el" "7ccc827d272482ca276937ca18a7895a")
288;;; Generated autoloads from cl-macs.el 287;;; Generated autoloads from cl-macs.el
289 288
290(autoload (quote cl-compile-time-init) "cl-macs" "\ 289(autoload (quote cl-compile-time-init) "cl-macs" "\
@@ -746,7 +745,7 @@ Not documented
746;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not 745;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not
747;;;;;; substitute-if substitute delete-duplicates remove-duplicates 746;;;;;; substitute-if substitute delete-duplicates remove-duplicates
748;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* 747;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove*
749;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" (18050 45841)) 748;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "8805f76626399794931f5db36ddf855f")
750;;; Generated autoloads from cl-seq.el 749;;; Generated autoloads from cl-seq.el
751 750
752(autoload (quote reduce) "cl-seq" "\ 751(autoload (quote reduce) "cl-seq" "\
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index 233df65ac91..f8b178ac07c 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -628,7 +628,7 @@ If ALIST is non-nil, the new pairs are prepended to it."
628(fmakunbound 'dolist) 628(fmakunbound 'dolist)
629(fmakunbound 'dotimes) 629(fmakunbound 'dotimes)
630(fmakunbound 'declare) 630(fmakunbound 'declare)
631(load "cl-loaddefs") 631(load "cl-loaddefs" nil 'quiet)
632 632
633;; This goes here so that cl-macs can find it if it loads right now. 633;; This goes here so that cl-macs can find it if it loads right now.
634(provide 'cl-19) ; usage: (require 'cl-19 "cl") 634(provide 'cl-19) ; usage: (require 'cl-19 "cl")
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index d4501bd57b0..41a3144f91a 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -77,7 +77,7 @@ When this is `function', only ask when called non-interactively."
77 77
78 78
79;; when modifying this, also modify the comment generated by autoinsert.el 79;; when modifying this, also modify the comment generated by autoinsert.el
80(defconst copyright-current-gpl-version "2" 80(defconst copyright-current-gpl-version "3"
81 "String representing the current version of the GPL or nil.") 81 "String representing the current version of the GPL or nil.")
82 82
83(defvar copyright-update t) 83(defvar copyright-update t)
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index d1ec5a1fe39..19df1a16a11 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -152,6 +152,21 @@ A menu item can be a list with the same format as MENU. This is a submenu."
152 ,(if symbol `(defvar ,symbol nil ,doc)) 152 ,(if symbol `(defvar ,symbol nil ,doc))
153 (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) 153 (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
154 154
155(defun easy-menu-binding (menu &optional item-name)
156 "Return a binding suitable to pass to `define-key'.
157This is expected to be bound to a mouse event."
158 ;; Under Emacs this is almost trivial, whereas under XEmacs this may
159 ;; involve defining a function that calls popup-menu.
160 (let ((props (if (symbolp menu)
161 (prog1 (get menu 'menu-prop)
162 (setq menu (symbol-function menu))))))
163 (cons 'menu-item
164 (cons (or item-name
165 (if (keymapp menu)
166 (keymap-prompt menu))
167 "")
168 (cons menu props)))))
169
155;;;###autoload 170;;;###autoload
156(defun easy-menu-do-define (symbol maps doc menu) 171(defun easy-menu-do-define (symbol maps doc menu)
157 ;; We can't do anything that might differ between Emacs dialects in 172 ;; We can't do anything that might differ between Emacs dialects in
@@ -173,15 +188,10 @@ A menu item can be a list with the same format as MENU. This is a submenu."
173 'identity) 188 'identity)
174 (symbol-function ,symbol))) 189 (symbol-function ,symbol)))
175 ,symbol))))) 190 ,symbol)))))
176 (mapcar (lambda (map) 191 (dolist (map (if (keymapp maps) (list maps) maps))
177 (define-key map (vector 'menu-bar (easy-menu-intern (car menu))) 192 (define-key map
178 (cons 'menu-item 193 (vector 'menu-bar (easy-menu-intern (car menu)))
179 (cons (car menu) 194 (easy-menu-binding keymap (car menu))))))
180 (if (not (symbolp keymap))
181 (list keymap)
182 (cons (symbol-function keymap)
183 (get keymap 'menu-prop)))))))
184 (if (keymapp maps) (list maps) maps))))
185 195
186(defun easy-menu-filter-return (menu &optional name) 196(defun easy-menu-filter-return (menu &optional name)
187 "Convert MENU to the right thing to return from a menu filter. 197 "Convert MENU to the right thing to return from a menu filter.
@@ -249,10 +259,6 @@ possibly preceded by keyword pairs as described in `easy-menu-define'."
249(defvar easy-menu-button-prefix 259(defvar easy-menu-button-prefix
250 '((radio . :radio) (toggle . :toggle))) 260 '((radio . :radio) (toggle . :toggle)))
251 261
252(defun easy-menu-do-add-item (menu item &optional before)
253 (setq item (easy-menu-convert-item item))
254 (easy-menu-define-key menu (easy-menu-intern (car item)) (cdr item) before))
255
256(defvar easy-menu-converted-items-table (make-hash-table :test 'equal)) 262(defvar easy-menu-converted-items-table (make-hash-table :test 'equal))
257 263
258(defun easy-menu-convert-item (item) 264(defun easy-menu-convert-item (item)
@@ -269,7 +275,7 @@ would always fail because the key is `equal' but not `eq'."
269(defun easy-menu-convert-item-1 (item) 275(defun easy-menu-convert-item-1 (item)
270 "Parse an item description and convert it to a menu keymap element. 276 "Parse an item description and convert it to a menu keymap element.
271ITEM defines an item as in `easy-menu-define'." 277ITEM defines an item as in `easy-menu-define'."
272 (let (name command label prop remove help) 278 (let (name command label prop remove)
273 (cond 279 (cond
274 ((stringp item) ; An item or separator. 280 ((stringp item) ; An item or separator.
275 (setq label item)) 281 (setq label item))
@@ -536,7 +542,8 @@ earlier by `easy-menu-define' or `easy-menu-create-menu'."
536 (setq item (symbol-value item)))) 542 (setq item (symbol-value item))))
537 ;; Item is a keymap, find the prompt string and use as item name. 543 ;; Item is a keymap, find the prompt string and use as item name.
538 (setq item (cons (keymap-prompt item) item))) 544 (setq item (cons (keymap-prompt item) item)))
539 (easy-menu-do-add-item map item before))) 545 (setq item (easy-menu-convert-item item))
546 (easy-menu-define-key map (easy-menu-intern (car item)) (cdr item) before)))
540 547
541(defun easy-menu-item-present-p (map path name) 548(defun easy-menu-item-present-p (map path name)
542 "In submenu of MAP with path PATH, return non-nil iff item NAME is present. 549 "In submenu of MAP with path PATH, return non-nil iff item NAME is present.
@@ -615,7 +622,8 @@ In some cases we use that to select between the local and global maps."
615 (catch 'found 622 (catch 'found
616 (if (and map (symbolp map) (not (keymapp map))) 623 (if (and map (symbolp map) (not (keymapp map)))
617 (setq map (symbol-value map))) 624 (setq map (symbol-value map)))
618 (let ((maps (if map (list map) (current-active-maps)))) 625 (let ((maps (if map (if (keymapp map) (list map) map)
626 (current-active-maps))))
619 ;; Look for PATH in each map. 627 ;; Look for PATH in each map.
620 (unless map (push 'menu-bar path)) 628 (unless map (push 'menu-bar path))
621 (dolist (name path) 629 (dolist (name path)
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 85b150b6ae5..37e2eb351f2 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -124,8 +124,8 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.")
124(defconst eldoc-last-data (make-vector 3 nil) 124(defconst eldoc-last-data (make-vector 3 nil)
125 "Bookkeeping; elements are as follows: 125 "Bookkeeping; elements are as follows:
126 0 - contains the last symbol read from the buffer. 126 0 - contains the last symbol read from the buffer.
127 1 - contains the string last displayed in the echo area for that 127 1 - contains the string last displayed in the echo area for variables,
128 symbol, so it can be printed again if necessary without reconsing. 128 or argument string for functions.
129 2 - 'function if function args, 'variable if variable documentation.") 129 2 - 'function if function args, 'variable if variable documentation.")
130(defvar eldoc-last-message nil) 130(defvar eldoc-last-message nil)
131 131
@@ -249,12 +249,16 @@ Emacs Lisp mode) that support Eldoc.")
249 (let* ((current-symbol (eldoc-current-symbol)) 249 (let* ((current-symbol (eldoc-current-symbol))
250 (current-fnsym (eldoc-fnsym-in-current-sexp)) 250 (current-fnsym (eldoc-fnsym-in-current-sexp))
251 (doc (cond 251 (doc (cond
252 ((eq current-symbol current-fnsym) 252 ((null current-fnsym)
253 (or (eldoc-get-fnsym-args-string current-fnsym) 253 nil)
254 ((eq current-symbol (car current-fnsym))
255 (or (apply 'eldoc-get-fnsym-args-string
256 current-fnsym)
254 (eldoc-get-var-docstring current-symbol))) 257 (eldoc-get-var-docstring current-symbol)))
255 (t 258 (t
256 (or (eldoc-get-var-docstring current-symbol) 259 (or (eldoc-get-var-docstring current-symbol)
257 (eldoc-get-fnsym-args-string current-fnsym)))))) 260 (apply 'eldoc-get-fnsym-args-string
261 current-fnsym))))))
258 (eldoc-message doc)))) 262 (eldoc-message doc))))
259 ;; This is run from post-command-hook or some idle timer thing, 263 ;; This is run from post-command-hook or some idle timer thing,
260 ;; so we need to be careful that errors aren't ignored. 264 ;; so we need to be careful that errors aren't ignored.
@@ -263,24 +267,62 @@ Emacs Lisp mode) that support Eldoc.")
263;; Return a string containing the function parameter list, or 1-line 267;; Return a string containing the function parameter list, or 1-line
264;; docstring if function is a subr and no arglist is obtainable from the 268;; docstring if function is a subr and no arglist is obtainable from the
265;; docstring or elsewhere. 269;; docstring or elsewhere.
266(defun eldoc-get-fnsym-args-string (sym) 270(defun eldoc-get-fnsym-args-string (sym argument-index)
267 (let ((args nil) 271 (let ((args nil)
268 (doc nil)) 272 (doc nil))
269 (cond ((not (and sym (symbolp sym) (fboundp sym)))) 273 (cond ((not (and sym (symbolp sym) (fboundp sym))))
270 ((and (eq sym (aref eldoc-last-data 0)) 274 ((and (eq sym (aref eldoc-last-data 0))
271 (eq 'function (aref eldoc-last-data 2))) 275 (eq 'function (aref eldoc-last-data 2)))
272 (setq doc (aref eldoc-last-data 1))) 276 (setq args (aref eldoc-last-data 1)))
273 ((setq doc (help-split-fundoc (documentation sym t) sym)) 277 ((setq doc (help-split-fundoc (documentation sym t) sym))
274 (setq args (car doc)) 278 (setq args (car doc))
275 (string-match "\\`[^ )]* ?" args) 279 (string-match "\\`[^ )]* ?" args)
276 (setq args (concat "(" (substring args (match-end 0))))) 280 (setq args (concat "(" (substring args (match-end 0))))
281 (eldoc-last-data-store sym args 'function))
277 (t 282 (t
278 (setq args (eldoc-function-argstring sym)))) 283 (setq args (eldoc-function-argstring sym))))
279 (cond (args 284 (when args
280 (setq doc (eldoc-docstring-format-sym-doc sym args)) 285 (setq doc (eldoc-highlight-function-argument sym args argument-index)))
281 (eldoc-last-data-store sym doc 'function)))
282 doc)) 286 doc))
283 287
288;; Highlight argument INDEX in ARGS list for SYM.
289(defun eldoc-highlight-function-argument (sym args index)
290 (let ((start nil)
291 (end 0)
292 (argument-face 'bold))
293 ;; Find the current argument in the argument string. We need to
294 ;; handle `&rest' and informal `...' properly.
295 ;;
296 ;; FIXME: What to do with optional arguments, like in
297 ;; (defun NAME ARGLIST [DOCSTRING] BODY...) case?
298 ;; The problem is there is no robust way to determine if
299 ;; the current argument is indeed a docstring.
300 (while (>= index 1)
301 (if (string-match "[^ ()]+" args end)
302 (progn
303 (setq start (match-beginning 0)
304 end (match-end 0))
305 (let ((argument (match-string 0 args)))
306 (cond ((string= argument "&rest")
307 ;; All the rest arguments are the same.
308 (setq index 1))
309 ((string= argument "&optional"))
310 ((string-match "\\.\\.\\.$" argument)
311 (setq index 0))
312 (t
313 (setq index (1- index))))))
314 (setq end (length args)
315 start (1- end)
316 argument-face 'font-lock-warning-face
317 index 0)))
318 (let ((doc args))
319 (when start
320 (setq doc (copy-sequence args))
321 (add-text-properties start end (list 'face argument-face) doc))
322 (setq doc (eldoc-docstring-format-sym-doc
323 sym doc 'font-lock-function-name-face))
324 doc)))
325
284;; Return a string containing a brief (one-line) documentation string for 326;; Return a string containing a brief (one-line) documentation string for
285;; the variable. 327;; the variable.
286(defun eldoc-get-var-docstring (sym) 328(defun eldoc-get-var-docstring (sym)
@@ -292,7 +334,8 @@ Emacs Lisp mode) that support Eldoc.")
292 (let ((doc (documentation-property sym 'variable-documentation t))) 334 (let ((doc (documentation-property sym 'variable-documentation t)))
293 (cond (doc 335 (cond (doc
294 (setq doc (eldoc-docstring-format-sym-doc 336 (setq doc (eldoc-docstring-format-sym-doc
295 sym (eldoc-docstring-first-line doc))) 337 sym (eldoc-docstring-first-line doc)
338 'font-lock-variable-name-face))
296 (eldoc-last-data-store sym doc 'variable))) 339 (eldoc-last-data-store sym doc 'variable)))
297 doc))))) 340 doc)))))
298 341
@@ -316,7 +359,7 @@ Emacs Lisp mode) that support Eldoc.")
316;; If the entire line cannot fit in the echo area, the symbol name may be 359;; If the entire line cannot fit in the echo area, the symbol name may be
317;; truncated or eliminated entirely from the output to make room for the 360;; truncated or eliminated entirely from the output to make room for the
318;; description. 361;; description.
319(defun eldoc-docstring-format-sym-doc (sym doc) 362(defun eldoc-docstring-format-sym-doc (sym doc face)
320 (save-match-data 363 (save-match-data
321 (let* ((name (symbol-name sym)) 364 (let* ((name (symbol-name sym))
322 (ea-multi eldoc-echo-area-use-multiline-p) 365 (ea-multi eldoc-echo-area-use-multiline-p)
@@ -328,7 +371,7 @@ Emacs Lisp mode) that support Eldoc.")
328 (cond ((or (<= strip 0) 371 (cond ((or (<= strip 0)
329 (eq ea-multi t) 372 (eq ea-multi t)
330 (and ea-multi (> (length doc) ea-width))) 373 (and ea-multi (> (length doc) ea-width)))
331 (format "%s: %s" sym doc)) 374 (format "%s: %s" (propertize name 'face face) doc))
332 ((> (length doc) ea-width) 375 ((> (length doc) ea-width)
333 (substring (format "%s" doc) 0 ea-width)) 376 (substring (format "%s" doc) 0 ea-width))
334 ((>= strip (length name)) 377 ((>= strip (length name))
@@ -338,27 +381,44 @@ Emacs Lisp mode) that support Eldoc.")
338 ;; than the beginning, since the former is more likely 381 ;; than the beginning, since the former is more likely
339 ;; to be unique given package namespace conventions. 382 ;; to be unique given package namespace conventions.
340 (setq name (substring name strip)) 383 (setq name (substring name strip))
341 (format "%s: %s" name doc)))))) 384 (format "%s: %s" (propertize name 'face face) doc))))))
342 385
343 386
387;; Return a list of current function name and argument index.
344(defun eldoc-fnsym-in-current-sexp () 388(defun eldoc-fnsym-in-current-sexp ()
345 (let ((p (point))) 389 (save-excursion
346 (eldoc-beginning-of-sexp) 390 (let ((argument-index (1- (eldoc-beginning-of-sexp))))
347 (prog1 391 ;; If we are at the beginning of function name, this will be -1.
348 ;; Don't do anything if current word is inside a string. 392 (when (< argument-index 0)
349 (if (= (or (char-after (1- (point))) 0) ?\") 393 (setq argument-index 0))
350 nil 394 ;; Don't do anything if current word is inside a string.
351 (eldoc-current-symbol)) 395 (if (= (or (char-after (1- (point))) 0) ?\")
352 (goto-char p)))) 396 nil
353 397 (list (eldoc-current-symbol) argument-index)))))
398
399;; Move to the beginnig of current sexp. Return the number of nested
400;; sexp the point was over or after.
354(defun eldoc-beginning-of-sexp () 401(defun eldoc-beginning-of-sexp ()
355 (let ((parse-sexp-ignore-comments t)) 402 (let ((parse-sexp-ignore-comments t)
403 (num-skipped-sexps 0))
356 (condition-case err 404 (condition-case err
357 (while (progn 405 (progn
358 (forward-sexp -1) 406 ;; First account for the case the point is directly over a
359 (or (= (char-before) ?\") 407 ;; beginning of a nested sexp.
360 (> (point) (point-min))))) 408 (condition-case err
361 (error nil)))) 409 (let ((p (point)))
410 (forward-sexp -1)
411 (forward-sexp 1)
412 (when (< (point) p)
413 (setq num-skipped-sexps 1)))
414 (error))
415 (while
416 (let ((p (point)))
417 (forward-sexp -1)
418 (when (< (point) p)
419 (setq num-skipped-sexps (1+ num-skipped-sexps))))))
420 (error))
421 num-skipped-sexps))
362 422
363;; returns nil unless current word is an interned symbol. 423;; returns nil unless current word is an interned symbol.
364(defun eldoc-current-symbol () 424(defun eldoc-current-symbol ()
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 73379a816d7..374d3ae2327 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -730,7 +730,9 @@ If the current defun is actually a call to `defvar' or `defcustom',
730evaluating it this way resets the variable using its initial value 730evaluating it this way resets the variable using its initial value
731expression even if the variable already has some other value. 731expression even if the variable already has some other value.
732\(Normally `defvar' and `defcustom' do not alter the value if there 732\(Normally `defvar' and `defcustom' do not alter the value if there
733already is one.) 733already is one.) In an analogous way, evaluating a `defface'
734overrides any customizations of the face, so that it becomes
735defined exactly as the `defface' expression says.
734 736
735If `eval-expression-debug-on-error' is non-nil, which is the default, 737If `eval-expression-debug-on-error' is non-nil, which is the default,
736this command arranges for all errors to enter the debugger. 738this command arranges for all errors to enter the debugger.
diff --git a/lisp/files.el b/lisp/files.el
index 69ed54c5633..849d09b4215 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -162,7 +162,7 @@ The truename of a file is found by chasing all links
162both at the file level and at the levels of the containing directories." 162both at the file level and at the levels of the containing directories."
163 :type 'boolean 163 :type 'boolean
164 :group 'find-file) 164 :group 'find-file)
165(put 'find-file-visit-truename 'safe-local-variable 'boolean) 165(put 'find-file-visit-truename 'safe-local-variable 'booleanp)
166 166
167(defcustom revert-without-query nil 167(defcustom revert-without-query nil
168 "Specify which files should be reverted without query. 168 "Specify which files should be reverted without query.
@@ -727,17 +727,23 @@ This is an interface to the function `load'."
727 (cons load-path (get-load-suffixes))))) 727 (cons load-path (get-load-suffixes)))))
728 (load library)) 728 (load library))
729 729
730(defun file-remote-p (file) 730(defun file-remote-p (file &optional connected)
731 "Test whether FILE specifies a location on a remote system. 731 "Test whether FILE specifies a location on a remote system.
732Return an identification of the system if the location is indeed 732Return an identification of the system if the location is indeed
733remote. The identification of the system may comprise a method 733remote. The identification of the system may comprise a method
734to access the system and its hostname, amongst other things. 734to access the system and its hostname, amongst other things.
735 735
736For example, the filename \"/user@host:/foo\" specifies a location 736For example, the filename \"/user@host:/foo\" specifies a location
737on the system \"/user@host:\"." 737on the system \"/user@host:\".
738
739If CONNECTED is non-nil, the function returns an identification only
740if FILE is located on a remote system, and a connection is established
741to that remote system.
742
743`file-remote-p' will never open a connection on its own."
738 (let ((handler (find-file-name-handler file 'file-remote-p))) 744 (let ((handler (find-file-name-handler file 'file-remote-p)))
739 (if handler 745 (if handler
740 (funcall handler 'file-remote-p file) 746 (funcall handler 'file-remote-p file connected)
741 nil))) 747 nil)))
742 748
743(defun file-local-copy (file) 749(defun file-local-copy (file)
diff --git a/lisp/follow.el b/lisp/follow.el
index 048db9bf11a..15d263d300d 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -336,123 +336,45 @@ After that, changing the prefix key requires manipulating keymaps."
336 ;; the look and feel of Follow mode.) 336 ;; the look and feel of Follow mode.)
337 (define-key mainmap [remap end-of-buffer] 'follow-end-of-buffer) 337 (define-key mainmap [remap end-of-buffer] 'follow-end-of-buffer)
338 338
339 ;;
340 ;; The menu.
341 ;;
342
343 (if (not (featurep 'xemacs))
344
345 ;;
346 ;; Emacs
347 ;;
348 (let ((menumap (funcall (symbol-function 'make-sparse-keymap)
349 "Follow"))
350 (count 0)
351 id)
352 (mapcar
353 (function
354 (lambda (item)
355 (setq id
356 (or (cdr item)
357 (progn
358 (setq count (+ count 1))
359 (intern (format "separator-%d" count)))))
360 (define-key menumap (vector id) item)
361 (or (eq id 'follow-mode)
362 (put id 'menu-enable 'follow-mode))))
363 ;; In reverse order:
364 '(("Toggle Follow mode" . follow-mode)
365 ("--")
366 ("Recenter" . follow-recenter)
367 ("--")
368 ("Previous Window" . follow-previous-window)
369 ("Next Windows" . follow-next-window)
370 ("Last Window" . follow-last-window)
371 ("First Window" . follow-first-window)
372 ("--")
373 ("Switch To Buffer (all windows)"
374 . follow-switch-to-buffer-all)
375 ("Switch To Buffer" . follow-switch-to-buffer)
376 ("--")
377 ("Delete Other Windows and Split"
378 . follow-delete-other-windows-and-split)
379 ("--")
380 ("Scroll Down" . follow-scroll-down)
381 ("Scroll Up" . follow-scroll-up)))
382
383 ;; If there is a `tools' menu, we use it. However, we can't add a
384 ;; minor-mode specific item to it (it's broken), so we make the
385 ;; contents ghosted when not in use, and add ourselves to the
386 ;; global map. If no `tools' menu is present, just make a
387 ;; top-level menu visible when the mode is activated.
388
389 (let ((tools-map (lookup-key (current-global-map) [menu-bar tools]))
390 (last nil))
391 (if (sequencep tools-map)
392 (progn
393 ;; Find the last entry in the menu and store it in `last'.
394 (mapcar (function
395 (lambda (x)
396 (setq last (or (cdr-safe
397 (cdr-safe
398 (cdr-safe x)))
399 last))))
400 tools-map)
401 (if last
402 (progn
403 (funcall (symbol-function 'define-key-after)
404 tools-map [separator-follow] '("--") last)
405 (funcall (symbol-function 'define-key-after)
406 tools-map [follow] (cons "Follow" menumap)
407 'separator-follow))
408 ;; Didn't find the last item, Adding to the top of
409 ;; tools. (This will probably never happend...)
410 (define-key (current-global-map) [menu-bar tools follow]
411 (cons "Follow" menumap))))
412 ;; No tools menu, add "Follow" to the menubar.
413 (define-key mainmap [menu-bar follow]
414 (cons "Follow" menumap)))))
415
416 ;;
417 ;; XEmacs.
418 ;;
419
420 ;; place the menu in the `Tools' menu.
421 (let ((menu '("Follow"
422 :filter follow-menu-filter
423 ["Scroll Up" follow-scroll-up t]
424 ["Scroll Down" follow-scroll-down t]
425 ["Delete Other Windows and Split"
426 follow-delete-other-windows-and-split t]
427 ["Switch To Buffer" follow-switch-to-buffer t]
428 ["Switch To Buffer (all windows)"
429 follow-switch-to-buffer-all t]
430 ["First Window" follow-first-window t]
431 ["Last Window" follow-last-window t]
432 ["Next Windows" follow-next-window t]
433 ["Previous Window" follow-previous-window t]
434 ["Recenter" follow-recenter t]
435 ["Deactivate" follow-mode t])))
436
437 ;; Why not just `(set-buffer-menubar current-menubar)'? The
438 ;; question is a very good question. The reason is that under
439 ;; Emacs, neither `set-buffer-menubar' nor
440 ;; `current-menubar' is defined, hence the byte-compiler will
441 ;; warn.
442 (funcall (symbol-function 'set-buffer-menubar)
443 (symbol-value 'current-menubar))
444 (funcall (symbol-function 'add-submenu) '("Tools") menu))
445
446 ;; When the mode is not activated, only one item is visible:
447 ;; "Activate".
448 (defun follow-menu-filter (menu)
449 (if follow-mode
450 menu
451 '(["Activate " follow-mode t]))))
452
453 mainmap) 339 mainmap)
454 "Minor mode keymap for Follow mode.") 340 "Minor mode keymap for Follow mode.")
455 341
342;; When the mode is not activated, only one item is visible to activate
343;; the mode.
344(defun follow-menu-filter (menu)
345 (if (bound-and-true-p 'follow-mode)
346 menu
347 '(["Follow mode " follow-mode
348 :style toggle :selected follow-mode])))
349
350;; If there is a `tools' menu, we use it. However, we can't add a
351;; minor-mode specific item to it (it's broken), so we make the
352;; contents ghosted when not in use, and add ourselves to the
353;; global map.
354(easy-menu-add-item nil '("Tools")
355 '("Follow"
356 ;; The Emacs code used to just grey out operations when follow-mode was
357 ;; not enabled, whereas the XEmacs code used to remove it altogether.
358 ;; Not sure which is preferable, but clearly the preference should not
359 ;; depend on the flavor.
360 :filter follow-menu-filter
361 ["Scroll Up" follow-scroll-up follow-mode]
362 ["Scroll Down" follow-scroll-down follow-mode]
363 "--"
364 ["Delete Other Windows and Split" follow-delete-other-windows-and-split follow-mode]
365 "--"
366 ["Switch To Buffer" follow-switch-to-buffer follow-mode]
367 ["Switch To Buffer (all windows)" follow-switch-to-buffer-all follow-mode]
368 "--"
369 ["First Window" follow-first-window follow-mode]
370 ["Last Window" follow-last-window follow-mode]
371 ["Next Window" follow-next-window follow-mode]
372 ["Previous Window" follow-previous-window follow-mode]
373 "--"
374 ["Recenter" follow-recenter follow-mode]
375 "--"
376 ["Follow mode" follow-mode :style toggle :selected follow-mode]))
377
456;;}}} 378;;}}}
457 379
458(defcustom follow-mode-line-text " Follow" 380(defcustom follow-mode-line-text " Follow"
@@ -553,14 +475,12 @@ Used by `follow-window-size-change'.")
553;;;###autoload 475;;;###autoload
554(defun turn-on-follow-mode () 476(defun turn-on-follow-mode ()
555 "Turn on Follow mode. Please see the function `follow-mode'." 477 "Turn on Follow mode. Please see the function `follow-mode'."
556 (interactive)
557 (follow-mode 1)) 478 (follow-mode 1))
558 479
559 480
560;;;###autoload 481;;;###autoload
561(defun turn-off-follow-mode () 482(defun turn-off-follow-mode ()
562 "Turn off Follow mode. Please see the function `follow-mode'." 483 "Turn off Follow mode. Please see the function `follow-mode'."
563 (interactive)
564 (follow-mode -1)) 484 (follow-mode -1))
565 485
566(put 'follow-mode 'permanent-local t) 486(put 'follow-mode 'permanent-local t)
@@ -2084,8 +2004,8 @@ report this using the `report-emacs-bug' function."
2084 2004
2085(defun follow-window-size-change (frame) 2005(defun follow-window-size-change (frame)
2086 "Redraw all windows in FRAME, when in Follow mode." 2006 "Redraw all windows in FRAME, when in Follow mode."
2087 ;; Below, we call `post-command-hook'. This makes sure that we 2007 ;; Below, we call `post-command-hook'. This makes sure that we
2088 ;; doesn't start a mutally recursive endless loop. 2008 ;; don't start a mutually recursive endless loop.
2089 (if follow-inside-post-command-hook 2009 (if follow-inside-post-command-hook
2090 nil 2010 nil
2091 (let ((buffers '()) 2011 (let ((buffers '())
@@ -2109,12 +2029,12 @@ report this using the `report-emacs-bug' function."
2109 (setq windows (follow-all-followers win)) 2029 (setq windows (follow-all-followers win))
2110 (if (memq orig-window windows) 2030 (if (memq orig-window windows)
2111 (progn 2031 (progn
2112 ;; Make sure we're redrawing around the 2032 ;; Make sure we're redrawing around the
2113 ;; selected window. 2033 ;; selected window.
2114 ;; 2034 ;;
2115 ;; We must be really careful not to do this 2035 ;; We must be really careful not to do this
2116 ;; when we are (indirectly) called by 2036 ;; when we are (indirectly) called by
2117 ;; `post-command-hook'. 2037 ;; `post-command-hook'.
2118 (select-window orig-window) 2038 (select-window orig-window)
2119 (follow-post-command-hook) 2039 (follow-post-command-hook)
2120 (setq orig-window (selected-window))) 2040 (setq orig-window (selected-window)))
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 0e9da63da1a..6a66ebbf756 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,42 @@
12007-07-14 David Kastrup <dak@gnu.org>
2
3 * gnus-art.el (gnus-mime-delete-part): Don't go through article-edit
4 finishing actions if we did not edit the article.
5
62007-07-13 Katsumi Yamaoka <yamaoka@jpl.org>
7
8 * gnus-srvr.el (gnus-server-agent-face, gnus-server-opened-face)
9 (gnus-server-closed-face, gnus-server-denied-face)
10 (gnus-server-offline-face): Remove variable.
11 (gnus-server-font-lock-keywords): Use faces that are not aliases.
12
13 * mm-util.el (mm-decode-coding-string, mm-encode-coding-string)
14 (mm-decode-coding-region, mm-encode-coding-region): Don't modify string
15 if the coding-system argument is nil for XEmacs.
16
17 * nnrss.el (nnrss-compatible-encoding-alist): Inherit the value of
18 mm-charset-override-alist.
19
20 * rfc2047.el: Don't require base64; require rfc2045 for the function
21 rfc2045-encode-string.
22 (rfc2047-encode-parameter): Use rfc2045-encode-string to quote or not
23 to quote the parameter value.
24
252007-07-04 Katsumi Yamaoka <yamaoka@jpl.org>
26
27 * gnus-sum.el (gnus-summary-catchup): Don't recognize cached articles
28 as unfetched articles.
29
302007-07-02 Reiner Steib <Reiner.Steib@gmx.de>
31
32 * gnus-start.el (gnus-level-unsubscribed): Improve doc string.
33
342007-06-26 Katsumi Yamaoka <yamaoka@jpl.org>
35
36 * gnus-art.el (gnus-article-summary-command-nosave)
37 (gnus-article-read-summary-keys): Don't set the 3rd arg of
38 pop-to-buffer for XEmacs.
39
12007-06-14 Katsumi Yamaoka <yamaoka@jpl.org> 402007-06-14 Katsumi Yamaoka <yamaoka@jpl.org>
2 41
3 * gnus-agent.el (gnus-agent-fetch-headers) 42 * gnus-agent.el (gnus-agent-fetch-headers)
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 90af0740318..020bd283189 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -4408,11 +4408,11 @@ Deleting parts may malfunction or destroy the article; continue? ")
4408 (gnus-summary-edit-article-done 4408 (gnus-summary-edit-article-done
4409 ,(or (mail-header-references gnus-current-headers) "") 4409 ,(or (mail-header-references gnus-current-headers) "")
4410 ,(gnus-group-read-only-p) 4410 ,(gnus-group-read-only-p)
4411 ,gnus-summary-buffer no-highlight))))) 4411 ,gnus-summary-buffer no-highlight))))
4412 ;; Not in `gnus-mime-save-part-and-strip': 4412 ;; Not in `gnus-mime-save-part-and-strip':
4413 (gnus-article-edit-done) 4413 (gnus-article-edit-done)
4414 (gnus-summary-expand-window) 4414 (gnus-summary-expand-window)
4415 (gnus-summary-show-article)) 4415 (gnus-summary-show-article)))
4416 4416
4417(defun gnus-mime-save-part () 4417(defun gnus-mime-save-part ()
4418 "Save the MIME part under point." 4418 "Save the MIME part under point."
@@ -5607,7 +5607,7 @@ not have a face in `gnus-article-boring-faces'."
5607 "Execute the last keystroke in the summary buffer." 5607 "Execute the last keystroke in the summary buffer."
5608 (interactive) 5608 (interactive)
5609 (let (func) 5609 (let (func)
5610 (pop-to-buffer gnus-article-current-summary nil 'norecord) 5610 (pop-to-buffer gnus-article-current-summary nil (not (featurep 'xemacs)))
5611 (setq func (lookup-key (current-local-map) (this-command-keys))) 5611 (setq func (lookup-key (current-local-map) (this-command-keys)))
5612 (call-interactively func))) 5612 (call-interactively func)))
5613 5613
@@ -5646,7 +5646,8 @@ not have a face in `gnus-article-boring-faces'."
5646 (member keys nosave-in-article)) 5646 (member keys nosave-in-article))
5647 (let (func) 5647 (let (func)
5648 (save-window-excursion 5648 (save-window-excursion
5649 (pop-to-buffer gnus-article-current-summary nil 'norecord) 5649 (pop-to-buffer gnus-article-current-summary
5650 nil (not (featurep 'xemacs)))
5650 ;; We disable the pick minor mode commands. 5651 ;; We disable the pick minor mode commands.
5651 (let (gnus-pick-mode) 5652 (let (gnus-pick-mode)
5652 (setq func (lookup-key (current-local-map) keys)))) 5653 (setq func (lookup-key (current-local-map) keys))))
@@ -5658,14 +5659,16 @@ not have a face in `gnus-article-boring-faces'."
5658 (call-interactively func) 5659 (call-interactively func)
5659 (setq new-sum-point (point))) 5660 (setq new-sum-point (point)))
5660 (when (member keys nosave-but-article) 5661 (when (member keys nosave-but-article)
5661 (pop-to-buffer gnus-article-buffer nil 'norecord))) 5662 (pop-to-buffer gnus-article-buffer
5663 nil (not (featurep 'xemacs)))))
5662 ;; These commands should restore window configuration. 5664 ;; These commands should restore window configuration.
5663 (let ((obuf (current-buffer)) 5665 (let ((obuf (current-buffer))
5664 (owin (current-window-configuration)) 5666 (owin (current-window-configuration))
5665 (opoint (point)) 5667 (opoint (point))
5666 win func in-buffer selected new-sum-start new-sum-hscroll) 5668 win func in-buffer selected new-sum-start new-sum-hscroll)
5667 (cond (not-restore-window 5669 (cond (not-restore-window
5668 (pop-to-buffer gnus-article-current-summary nil 'norecord)) 5670 (pop-to-buffer gnus-article-current-summary
5671 nil (not (featurep 'xemacs))))
5669 ((setq win (get-buffer-window gnus-article-current-summary)) 5672 ((setq win (get-buffer-window gnus-article-current-summary))
5670 (select-window win)) 5673 (select-window win))
5671 (t 5674 (t
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index f6804f3b114..0d5443f576c 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -214,43 +214,12 @@ If nil, a faster, but more primitive, buffer is used instead."
214;; backward-compatibility alias 214;; backward-compatibility alias
215(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline) 215(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
216 216
217(defcustom gnus-server-agent-face 'gnus-server-agent
218 "Face name to use on AGENTIZED servers."
219 :version "22.1"
220 :group 'gnus-server-visual
221 :type 'face)
222
223(defcustom gnus-server-opened-face 'gnus-server-opened
224 "Face name to use on OPENED servers."
225 :version "22.1"
226 :group 'gnus-server-visual
227 :type 'face)
228
229(defcustom gnus-server-closed-face 'gnus-server-closed
230 "Face name to use on CLOSED servers."
231 :version "22.1"
232 :group 'gnus-server-visual
233 :type 'face)
234
235(defcustom gnus-server-denied-face 'gnus-server-denied
236 "Face name to use on DENIED servers."
237 :version "22.1"
238 :group 'gnus-server-visual
239 :type 'face)
240
241(defcustom gnus-server-offline-face 'gnus-server-offline
242 "Face name to use on OFFLINE servers."
243 :version "22.1"
244 :group 'gnus-server-visual
245 :type 'face)
246
247(defvar gnus-server-font-lock-keywords 217(defvar gnus-server-font-lock-keywords
248 (list 218 '(("(\\(agent\\))" 1 gnus-server-agent)
249 '("(\\(agent\\))" 1 gnus-server-agent-face) 219 ("(\\(opened\\))" 1 gnus-server-opened)
250 '("(\\(opened\\))" 1 gnus-server-opened-face) 220 ("(\\(closed\\))" 1 gnus-server-closed)
251 '("(\\(closed\\))" 1 gnus-server-closed-face) 221 ("(\\(offline\\))" 1 gnus-server-offline)
252 '("(\\(offline\\))" 1 gnus-server-offline-face) 222 ("(\\(denied\\))" 1 gnus-server-denied)))
253 '("(\\(denied\\))" 1 gnus-server-denied-face)))
254 223
255(defun gnus-server-mode () 224(defun gnus-server-mode ()
256 "Major mode for listing and editing servers. 225 "Major mode for listing and editing servers.
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 276b028843a..17876302cfb 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -178,8 +178,13 @@ properly with all servers."
178 178
179(defconst gnus-level-unsubscribed 7 179(defconst gnus-level-unsubscribed 7
180 "Groups with levels less than or equal to this variable are unsubscribed. 180 "Groups with levels less than or equal to this variable are unsubscribed.
181Groups with levels less than `gnus-level-subscribed', which should be 181
182less than this variable, are subscribed.") 182Groups with levels less than `gnus-level-subscribed', which
183should be less than this variable, are subscribed. Groups with
184levels from `gnus-level-subscribed' (exclusive) upto this
185variable (inclusive) are unsubscribed. See also
186`gnus-level-zombie', `gnus-level-killed' and the Info node `Group
187Levels' for details.")
183 188
184(defconst gnus-level-zombie 8 189(defconst gnus-level-zombie 8
185 "Groups with this level are zombie groups.") 190 "Groups with this level are zombie groups.")
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index b1b6c8b760b..56c5fffb7e5 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -10514,7 +10514,8 @@ The number of articles marked as read is returned."
10514 (gnus-sorted-nunion 10514 (gnus-sorted-nunion
10515 (gnus-sorted-intersection gnus-newsgroup-unreads 10515 (gnus-sorted-intersection gnus-newsgroup-unreads
10516 gnus-newsgroup-downloadable) 10516 gnus-newsgroup-downloadable)
10517 gnus-newsgroup-unfetched))) 10517 (gnus-sorted-difference gnus-newsgroup-unfetched
10518 gnus-newsgroup-cached))))
10518 ;; We actually mark all articles as canceled, which we 10519 ;; We actually mark all articles as canceled, which we
10519 ;; have to do when using auto-expiry or adaptive scoring. 10520 ;; have to do when using auto-expiry or adaptive scoring.
10520 (gnus-summary-show-all-threads) 10521 (gnus-summary-show-all-threads)
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el
index 3508c1ac406..b08517170d4 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -36,11 +36,7 @@
36 (if (fboundp (car elem)) 36 (if (fboundp (car elem))
37 (defalias nfunc (car elem)) 37 (defalias nfunc (car elem))
38 (defalias nfunc (cdr elem))))) 38 (defalias nfunc (cdr elem)))))
39 '((decode-coding-string . (lambda (s a) s)) 39 '((coding-system-list . ignore)
40 (encode-coding-string . (lambda (s a) s))
41 (encode-coding-region . ignore)
42 (coding-system-list . ignore)
43 (decode-coding-region . ignore)
44 (char-int . identity) 40 (char-int . identity)
45 (coding-system-equal . equal) 41 (coding-system-equal . equal)
46 (annotationp . ignore) 42 (annotationp . ignore)
@@ -97,6 +93,34 @@
97 (multibyte-char-to-unibyte . identity)))) 93 (multibyte-char-to-unibyte . identity))))
98 94
99(eval-and-compile 95(eval-and-compile
96 (if (featurep 'xemacs)
97 (if (featurep 'file-coding)
98 ;; Don't modify string if CODING-SYSTEM is nil.
99 (progn
100 (defun mm-decode-coding-string (str coding-system)
101 (if coding-system
102 (decode-coding-string str coding-system)
103 str))
104 (defun mm-encode-coding-string (str coding-system)
105 (if coding-system
106 (encode-coding-string str coding-system)
107 str))
108 (defun mm-decode-coding-region (start end coding-system)
109 (if coding-system
110 (decode-coding-region start end coding-system)))
111 (defun mm-encode-coding-region (start end coding-system)
112 (if coding-system
113 (encode-coding-region start end coding-system))))
114 (defun mm-decode-coding-string (str coding-system) str)
115 (defun mm-encode-coding-string (str coding-system) str)
116 (defalias 'mm-decode-coding-region 'ignore)
117 (defalias 'mm-encode-coding-region 'ignore))
118 (defalias 'mm-decode-coding-string 'decode-coding-string)
119 (defalias 'mm-encode-coding-string 'encode-coding-string)
120 (defalias 'mm-decode-coding-region 'decode-coding-region)
121 (defalias 'mm-encode-coding-region 'encode-coding-region)))
122
123(eval-and-compile
100 (cond 124 (cond
101 ((fboundp 'replace-in-string) 125 ((fboundp 'replace-in-string)
102 (defalias 'mm-replace-in-string 'replace-in-string)) 126 (defalias 'mm-replace-in-string 'replace-in-string))
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index 996783e69b6..1f7e5ba1de9 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -85,7 +85,12 @@ ARTICLE is the article number of the current headline.")
85(defvar nnrss-file-coding-system mm-universal-coding-system 85(defvar nnrss-file-coding-system mm-universal-coding-system
86 "Coding system used when reading and writing files.") 86 "Coding system used when reading and writing files.")
87 87
88(defvar nnrss-compatible-encoding-alist '((iso-8859-1 . windows-1252)) 88(defvar nnrss-compatible-encoding-alist
89 (delq nil (mapcar (lambda (elem)
90 (if (and (mm-coding-system-p (car elem))
91 (mm-coding-system-p (cdr elem)))
92 elem))
93 mm-charset-override-alist))
89 "Alist of encodings and those supersets. 94 "Alist of encodings and those supersets.
90The cdr of each element is used to decode data if it is available when 95The cdr of each element is used to decode data if it is available when
91the car is what the data specify as the encoding. Or, the car is used 96the car is what the data specify as the encoding. Or, the car is used
diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el
index b7d25d87c68..1d489d80e60 100644
--- a/lisp/gnus/rfc2047.el
+++ b/lisp/gnus/rfc2047.el
@@ -55,7 +55,7 @@ Value is what BODY returns."
55(require 'ietf-drums) 55(require 'ietf-drums)
56;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus. 56;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
57(require 'mail-prsvr) 57(require 'mail-prsvr)
58(require 'base64) 58(require 'rfc2045) ;; rfc2045-encode-string
59(autoload 'mm-body-7-or-8 "mm-bodies") 59(autoload 'mm-body-7-or-8 "mm-bodies")
60 60
61(eval-and-compile 61(eval-and-compile
@@ -834,12 +834,9 @@ it, put the following line in your ~/.gnus.el file:
834 834
835\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) 835\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
836" 836"
837 (let* ((rfc2047-encoding-type 'mime) 837 (let ((rfc2047-encoding-type 'mime)
838 (rfc2047-encode-max-chars nil) 838 (rfc2047-encode-max-chars nil))
839 (string (rfc2047-encode-string value))) 839 (rfc2045-encode-string param (rfc2047-encode-string value))))
840 (if (string-match (concat "[" ietf-drums-tspecials "]") string)
841 (format "%s=%S" param string)
842 (concat param "=" string))))
843 840
844;;; 841;;;
845;;; Functions for decoding RFC2047 messages 842;;; Functions for decoding RFC2047 messages
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 4258c33f3d0..57e995a8811 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -1065,6 +1065,7 @@ If first char entered is \\[isearch-yank-word-or-char], then do word search inst
1065 1065
1066 ;; Reinvoke the pending search. 1066 ;; Reinvoke the pending search.
1067 (isearch-search) 1067 (isearch-search)
1068 (isearch-push-state)
1068 (isearch-update) 1069 (isearch-update)
1069 (if isearch-nonincremental 1070 (if isearch-nonincremental
1070 (progn 1071 (progn
diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in
index 4aa1ad1b3f8..c12b7e52cf7 100644
--- a/lisp/makefile.w32-in
+++ b/lisp/makefile.w32-in
@@ -411,7 +411,7 @@ install:
411 - $(DEL) "$(INSTALL_DIR)/same-dir.tst" 411 - $(DEL) "$(INSTALL_DIR)/same-dir.tst"
412 echo SameDirTest > "$(INSTALL_DIR)/same-dir.tst" 412 echo SameDirTest > "$(INSTALL_DIR)/same-dir.tst"
413#ifdef COPY_LISP_SOURCE 413#ifdef COPY_LISP_SOURCE
414 $(IFNOTSAMEDIR) $(CP_DIR) . "$(INSTALL_DIR)/lisp" $(ENDIF) 414 $(IFNOTSAMEDIR) $(MAKE) $(MFLAGS) install-lisp-$(SHELLTYPE) $(ENDIF)
415#else 415#else
416# $(IFNOTSAMEDIR) $(CP_DIR) *.elc "$(INSTALL_DIR)/lisp" $(ENDIF) 416# $(IFNOTSAMEDIR) $(CP_DIR) *.elc "$(INSTALL_DIR)/lisp" $(ENDIF)
417# $(IFNOTSAMEDIR) $(CP) cus-load.el "$(INSTALL_DIR)/lisp" $(ENDIF) 417# $(IFNOTSAMEDIR) $(CP) cus-load.el "$(INSTALL_DIR)/lisp" $(ENDIF)
@@ -428,6 +428,19 @@ install:
428 - $(DEL) ../same-dir.tst 428 - $(DEL) ../same-dir.tst
429 - $(DEL) "$(INSTALL_DIR)/same-dir.tst" 429 - $(DEL) "$(INSTALL_DIR)/same-dir.tst"
430 430
431# Need to copy *.el files first, to avoid "source file is newer" annoyance
432# since cp does not preserve time stamps
433install-lisp-SH:
434 cp -f *.el "$(INSTALL_DIR)/lisp"
435 for dir in $(WINS); do mkdir "$(INSTALL_DIR)/lisp/$$dir" && cp -f $$dir/*.el "$(INSTALL_DIR)/lisp/$$dir"; done
436 for dir in . $(WINS); do cp $$dir/*.elc "$(INSTALL_DIR)/lisp/$$dir"; done
437
438install-lisp-CMD:
439 cp -f *.el "$(INSTALL_DIR)/lisp"
440 for %%f in ($(WINS)) do mkdir "$(INSTALL_DIR)/lisp/%%f"
441 for %%f in ($(WINS)) do cp -f %%f/*.el "$(INSTALL_DIR)/lisp/%%f"
442 for %%f in (. $(WINS)) do cp -f %%f/*.elc "$(INSTALL_DIR)/lisp/%%f"
443
431# 444#
432# Maintenance 445# Maintenance
433# 446#
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 7ad91dffa9f..5fae6382e28 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -1161,6 +1161,7 @@ mail status in mode line"))
1161 '("--")) 1161 '("--"))
1162 1162
1163(defvar vc-menu-map (make-sparse-keymap "Version Control")) 1163(defvar vc-menu-map (make-sparse-keymap "Version Control"))
1164(defalias 'vc-menu-map vc-menu-map)
1164(define-key menu-bar-tools-menu [pcl-cvs] 1165(define-key menu-bar-tools-menu [pcl-cvs]
1165 '(menu-item "PCL-CVS" cvs-global-menu)) 1166 '(menu-item "PCL-CVS" cvs-global-menu))
1166(define-key menu-bar-tools-menu [vc] 1167(define-key menu-bar-tools-menu [vc]
diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog
index 3d3a08e0528..97ccda6e048 100644
--- a/lisp/mh-e/ChangeLog
+++ b/lisp/mh-e/ChangeLog
@@ -1,3 +1,8 @@
12007-07-11 Bill Wohler <wohler@newt.com>
2
3 * mh-compat.el (mh-display-color-cells): Fix on XEmacs 21.5b28.
4 Thanks to Henrique Martins for the help (closes SF #1749774).
5
12007-06-06 Juanma Barranquero <lekktu@gmail.com> 62007-06-06 Juanma Barranquero <lekktu@gmail.com>
2 7
3 * mh-mime.el (mh-mh-directive-present-p): 8 * mh-mime.el (mh-mh-directive-present-p):
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index 2f57e1763ab..a1382a8298e 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -77,13 +77,17 @@ introduced in Emacs 22."
77 'cancel-timer 77 'cancel-timer
78 'delete-itimer)) 78 'delete-itimer))
79 79
80(defun-mh mh-display-color-cells display-color-cells (&optional display) 80(defun mh-display-color-cells (&optional display)
81 "Return the number of color cells supported by DISPLAY. 81 "Return the number of color cells supported by DISPLAY.
82This function is used by XEmacs to return 2 when 82This function is used by XEmacs to return 2 when `device-color-cells'
83`device-color-cells' returns nil. This happens when compiling or 83or `display-color-cells' returns nil. This happens when compiling or
84running on a tty and causes errors since `display-color-cells' is 84running on a tty and causes errors since `display-color-cells' is
85expected to return an integer." 85expected to return an integer."
86 (or (device-color-cells display) 2)) 86 (cond ((fboundp 'display-color-cells) ; GNU Emacs, XEmacs 21.5b28
87 (or (display-color-cells display) 2))
88 ((fboundp 'device-color-cells) ; XEmacs 21.4
89 (or (device-color-cells display) 2))
90 (t 2)))
87 91
88(defmacro mh-display-completion-list (completions &optional common-substring) 92(defmacro mh-display-completion-list (completions &optional common-substring)
89 "Display the list of COMPLETIONS. 93 "Display the list of COMPLETIONS.
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 898f9a23515..3fa75102b32 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -4132,8 +4132,15 @@ directory, so that Emacs will know its current contents."
4132 (format "Getting %s" fn1)) 4132 (format "Getting %s" fn1))
4133 tmp1)))) 4133 tmp1))))
4134 4134
4135(defun ange-ftp-file-remote-p (file) 4135(defun ange-ftp-file-remote-p (file &optional connected)
4136 (ange-ftp-replace-name-component file "")) 4136 (and (or (not connected)
4137 (let* ((parsed (ange-ftp-ftp-name file))
4138 (host (nth 0 parsed))
4139 (user (nth 1 parsed))
4140 (proc (get-process (ange-ftp-ftp-process-buffer host user))))
4141 (and proc (processp proc)
4142 (memq (process-status proc) '(run open)))))
4143 (ange-ftp-replace-name-component file "")))
4137 4144
4138(defun ange-ftp-load (file &optional noerror nomessage nosuffix) 4145(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
4139 (if (ange-ftp-ftp-name file) 4146 (if (ange-ftp-ftp-name file)
@@ -4360,7 +4367,10 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
4360;; This returns nil for any file name as argument. 4367;; This returns nil for any file name as argument.
4361(put 'vc-registered 'ange-ftp 'null) 4368(put 'vc-registered 'ange-ftp 'null)
4362 4369
4370;; We can handle process-file in a restricted way (just for chown).
4371;; Nothing possible for start-file-process.
4363(put 'process-file 'ange-ftp 'ange-ftp-process-file) 4372(put 'process-file 'ange-ftp 'ange-ftp-process-file)
4373(put 'start-file-process 'ange-ftp 'ignore)
4364(put 'shell-command 'ange-ftp 'ange-ftp-shell-command) 4374(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
4365 4375
4366;;; Define ways of getting at unmodified Emacs primitives, 4376;;; Define ways of getting at unmodified Emacs primitives,
diff --git a/lisp/net/rcompile.el b/lisp/net/rcompile.el
index c262a129adc..9eecb8e4481 100644
--- a/lisp/net/rcompile.el
+++ b/lisp/net/rcompile.el
@@ -188,8 +188,7 @@ See \\[compile]."
188 (when (featurep 'tramp) 188 (when (featurep 'tramp)
189 (set (make-local-variable 'comint-file-name-prefix) 189 (set (make-local-variable 'comint-file-name-prefix)
190 (funcall (symbol-function 'tramp-make-tramp-file-name) 190 (funcall (symbol-function 'tramp-make-tramp-file-name)
191 nil ;; multi-method. To be removed with Tramp 2.1. 191 nil ;; method.
192 nil
193 remote-compile-user 192 remote-compile-user
194 remote-compile-host 193 remote-compile-host
195 "")))))) 194 ""))))))
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
new file mode 100644
index 00000000000..96c4b3ecb9b
--- /dev/null
+++ b/lisp/net/tramp-cache.el
@@ -0,0 +1,317 @@
1;;; -*- mode: Emacs-Lisp; coding: iso-2022-7bit; -*-
2;;; tramp-cache.el --- file information caching for Tramp
3
4;; Copyright (C) 2000, 2005, 2006, 2007 by Free Software Foundation, Inc.
5
6;; Author: Daniel Pittman <daniel@inanna.danann.net>
7;; Michael Albinus <michael.albinus@gmx.de>
8;; Keywords: comm, processes
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 3 of the License, or
15;; (at your option) any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, see
24;; <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27
28;; An implementation of information caching for remote files.
29
30;; Each connection, identified by a vector [method user host
31;; localname] or by a process, has a unique cache. We distinguish 3
32;; kind of caches, depending on the key:
33;;
34;; - localname is NIL. This are reusable properties. Examples:
35;; "remote-shell" identifies the POSIX shell to be called on the
36;; remote host, or "perl" is the command to be called on the remote
37;; host, when starting a Perl script. These properties are saved in
38;; the file `tramp-persistency-file-name'.
39;;
40;; - localname is a string. This are temporary properties, which are
41;; related to the file localname is referring to. Examples:
42;; "file-exists-p" is t or nile, depending on the file existence, or
43;; "file-attributes" caches the result of the function
44;; `file-attributes'.
45;;
46;; - The key is a process. This are temporary properties related to
47;; an open connection. Examples: "scripts" keeps shell script
48;; definitions already sent to the remote shell, "last-cmd-time" is
49;; the time stamp a command has been sent to the remote process.
50
51;;; Code:
52
53;; Pacify byte-compiler.
54(eval-when-compile
55 (require 'cl)
56 (autoload 'tramp-message "tramp")
57 (autoload 'tramp-tramp-file-p "tramp")
58 ;; We cannot autoload macro `with-parsed-tramp-file-name', it
59 ;; results in problems of byte-compiled code.
60 (autoload 'tramp-dissect-file-name "tramp")
61 (autoload 'tramp-file-name-method "tramp")
62 (autoload 'tramp-file-name-user "tramp")
63 (autoload 'tramp-file-name-host "tramp")
64 (autoload 'tramp-file-name-localname "tramp")
65 (autoload 'time-stamp-string "time-stamp"))
66
67;;; -- Cache --
68
69(defvar tramp-cache-data (make-hash-table :test 'equal)
70 "Hash table for remote files properties.")
71
72(defcustom tramp-persistency-file-name
73 (cond
74 ;; GNU Emacs.
75 ((and (boundp 'user-emacs-directory)
76 (stringp (symbol-value 'user-emacs-directory))
77 (file-directory-p (symbol-value 'user-emacs-directory)))
78 (expand-file-name "tramp" (symbol-value 'user-emacs-directory)))
79 ((and (not (featurep 'xemacs)) (file-directory-p "~/.emacs.d/"))
80 "~/.emacs.d/tramp")
81 ;; XEmacs.
82 ((and (boundp 'user-init-directory)
83 (stringp (symbol-value 'user-init-directory))
84 (file-directory-p (symbol-value 'user-init-directory)))
85 (expand-file-name "tramp" (symbol-value 'user-init-directory)))
86 ((and (featurep 'xemacs) (file-directory-p "~/.xemacs/"))
87 "~/.xemacs/tramp")
88 ;; For users without `~/.emacs.d/' or `~/.xemacs/'.
89 (t "~/.tramp"))
90 "File which keeps connection history for Tramp connections."
91 :group 'tramp
92 :type 'file)
93
94(defun tramp-get-file-property (vec file property default)
95 "Get the PROPERTY of FILE from the cache context of VEC.
96Returns DEFAULT if not set."
97 ;; Unify localname.
98 (setq vec (copy-sequence vec))
99 (aset vec 3 (directory-file-name file))
100 (let* ((hash (or (gethash vec tramp-cache-data)
101 (puthash vec (make-hash-table :test 'equal)
102 tramp-cache-data)))
103 (value (if (hash-table-p hash)
104 (gethash property hash default)
105 default)))
106 (tramp-message vec 8 "%s %s %s" file property value)
107 value))
108
109(defun tramp-set-file-property (vec file property value)
110 "Set the PROPERTY of FILE to VALUE, in the cache context of VEC.
111Returns VALUE."
112 ;; Unify localname.
113 (setq vec (copy-sequence vec))
114 (aset vec 3 (directory-file-name file))
115 (let ((hash (or (gethash vec tramp-cache-data)
116 (puthash vec (make-hash-table :test 'equal)
117 tramp-cache-data))))
118 (puthash property value hash)
119 (tramp-message vec 8 "%s %s %s" file property value)
120 value))
121
122(defun tramp-flush-file-property (vec file)
123 "Remove all properties of FILE in the cache context of VEC."
124 ;; Unify localname.
125 (setq vec (copy-sequence vec))
126 (aset vec 3 (directory-file-name file))
127 (tramp-message vec 8 "%s" file)
128 (remhash vec tramp-cache-data))
129
130(defun tramp-flush-directory-property (vec directory)
131 "Remove all properties of DIRECTORY in the cache context of VEC.
132Remove also properties of all files in subdirectories."
133 (let ((directory (directory-file-name directory)))
134 (tramp-message vec 8 "%s" directory)
135 (maphash
136 '(lambda (key value)
137 (when (and (stringp key)
138 (string-match directory (tramp-file-name-localname key)))
139 (remhash key tramp-cache-data)))
140 tramp-cache-data)))
141
142(defun tramp-cache-print (table)
143 "Prints hash table TABLE."
144 (when (hash-table-p table)
145 (let (result tmp)
146 (maphash
147 '(lambda (key value)
148 (setq tmp (format
149 "(%s %s)"
150 (if (processp key)
151 (prin1-to-string (prin1-to-string key))
152 (prin1-to-string key))
153 (if (hash-table-p value)
154 (tramp-cache-print value)
155 (if (bufferp value)
156 (prin1-to-string (prin1-to-string value))
157 (prin1-to-string value))))
158 result (if result (concat result " " tmp) tmp)))
159 table)
160 result)))
161
162;; Reverting or killing a buffer should also flush file properties.
163;; They could have been changed outside Tramp.
164(defun tramp-flush-file-function ()
165 "Flush all Tramp cache properties from buffer-file-name."
166 (let ((bfn (buffer-file-name)))
167 (when (and (stringp bfn) (tramp-tramp-file-p bfn))
168 (let* ((v (tramp-dissect-file-name bfn))
169 (localname (tramp-file-name-localname v)))
170 (tramp-flush-file-property v localname)))))
171
172(add-hook 'before-revert-hook 'tramp-flush-file-function)
173(add-hook 'kill-buffer-hook 'tramp-flush-file-function)
174(add-hook 'tramp-cache-unload-hook
175 '(lambda ()
176 (remove-hook 'before-revert-hook
177 'tramp-flush-file-function)
178 (remove-hook 'kill-buffer-hook
179 'tramp-flush-file-function)))
180
181;;; -- Properties --
182
183(defun tramp-get-connection-property (key property default)
184 "Get the named PROPERTY for the connection.
185KEY identifies the connection, it is either a process or a vector.
186If the value is not set for the connection, returns DEFAULT."
187 ;; Unify key by removing localname from vector. Work with a copy in
188 ;; order to avoid side effects.
189 (when (vectorp key)
190 (setq key (copy-sequence key))
191 (aset key 3 nil))
192 (let* ((hash (gethash key tramp-cache-data))
193 (value (if (hash-table-p hash)
194 (gethash property hash default)
195 default)))
196 (tramp-message key 7 "%s %s" property value)
197 value))
198
199(defun tramp-set-connection-property (key property value)
200 "Set the named PROPERTY of a connection to VALUE.
201KEY identifies the connection, it is either a process or a vector.
202PROPERTY is set persistent when KEY is a vector."
203 ;; Unify key by removing localname from vector. Work with a copy in
204 ;; order to avoid side effects.
205 (when (vectorp key)
206 (setq key (copy-sequence key))
207 (aset key 3 nil))
208 (let ((hash (or (gethash key tramp-cache-data)
209 (puthash key (make-hash-table :test 'equal)
210 tramp-cache-data))))
211 (puthash property value hash)
212 ;; This function is called also during initialization of
213 ;; tramp-cache.el. `tramp-message´ is not defined yet at this
214 ;; time, so we ignore the corresponding error.
215 (condition-case nil
216 (tramp-message key 7 "%s %s" property value)
217 (error nil))
218 value))
219
220(defun tramp-flush-connection-property (key event)
221 "Remove all properties identified by KEY.
222KEY identifies the connection, it is either a process or a
223vector. EVENT is not used, it is just applied because this
224function is intended to run also as process sentinel."
225 ;; Unify key by removing localname from vector. Work with a copy in
226 ;; order to avoid side effects.
227 (when (vectorp key)
228 (setq key (copy-sequence key))
229 (aset key 3 nil))
230; (tramp-message key 7 "%s" event)
231 (remhash key tramp-cache-data))
232
233(defun tramp-dump-connection-properties ()
234"Writes persistent connection properties into file
235`tramp-persistency-file-name'."
236 ;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed.
237 (condition-case nil
238 (when (and (hash-table-p tramp-cache-data)
239 (not (zerop (hash-table-count tramp-cache-data)))
240 (stringp tramp-persistency-file-name))
241 (let ((cache (copy-hash-table tramp-cache-data)))
242 ;; Remove temporary data.
243 (maphash
244 '(lambda (key value)
245 (if (and (vectorp key) (not (tramp-file-name-localname key)))
246 (progn
247 (remhash "process-name" value)
248 (remhash "process-buffer" value))
249 (remhash key cache)))
250 cache)
251 ;; Dump it.
252 (with-temp-buffer
253 (insert
254 ";; -*- emacs-lisp -*-"
255 ;; `time-stamp-string' might not exist in all (X)Emacs flavors.
256 (condition-case nil
257 (progn
258 (format
259 " <%s %s>\n"
260 (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S")
261 tramp-persistency-file-name))
262 (error "\n"))
263 ";; Tramp connection history. Don't change this file.\n"
264 ";; You can delete it, forcing Tramp to reapply the checks.\n\n"
265 (with-output-to-string
266 (pp (read (format "(%s)" (tramp-cache-print cache))))))
267 (write-region
268 (point-min) (point-max) tramp-persistency-file-name))))
269 (error nil)))
270
271(add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)
272(add-hook 'tramp-cache-unload-hook
273 '(lambda ()
274 (remove-hook 'kill-emacs-hook
275 'tramp-dump-connection-properties)))
276
277(defun tramp-parse-connection-properties (method)
278 "Return a list of (user host) tuples allowed to access for METHOD.
279This function is added always in `tramp-get-completion-function'
280for all methods. Resulting data are derived from connection
281history."
282 (let (res)
283 (maphash
284 '(lambda (key value)
285 (if (and (vectorp key)
286 (string-equal method (tramp-file-name-method key))
287 (not (tramp-file-name-localname key)))
288 (push (list (tramp-file-name-user key)
289 (tramp-file-name-host key))
290 res)))
291 tramp-cache-data)
292 res))
293
294;; Read persistent connection history. Applied with
295;; `load-in-progress', because it shall be evaluated only once.
296(when load-in-progress
297 (condition-case err
298 (with-temp-buffer
299 (insert-file-contents tramp-persistency-file-name)
300 (let ((list (read (current-buffer)))
301 element key item)
302 (while (setq element (pop list))
303 (setq key (pop element))
304 (while (setq item (pop element))
305 (tramp-set-connection-property key (pop item) (car item))))))
306 (file-error
307 ;; Most likely because the file doesn't exist yet. No message.
308 (clrhash tramp-cache-data))
309 (error
310 ;; File is corrupted.
311 (message "%s" (error-message-string err))
312 (clrhash tramp-cache-data))))
313
314(provide 'tramp-cache)
315
316;; arch-tag: ee1739b7-7628-408c-9b96-d11a74b05d26
317;;; tramp-cache.el ends here
diff --git a/lisp/net/tramp-fish.el b/lisp/net/tramp-fish.el
new file mode 100644
index 00000000000..e370c54f902
--- /dev/null
+++ b/lisp/net/tramp-fish.el
@@ -0,0 +1,1178 @@
1;;; -*- coding: iso-8859-1; -*-
2;;; tramp-fish.el --- Tramp access functions for FISH protocol
3
4;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Michael Albinus <michael.albinus@gmx.de>
7;; Keywords: comm, processes
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; see the file COPYING. If not, see
23;; <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26
27;; Access functions for FIles transferred over SHell protocol from Tramp.
28
29;; FISH is a protocol developped for the GNU Midnight Commander
30;; <https://savannah.gnu.org/projects/mc>. A client connects to a
31;; remote host via ssh (or rsh, shall be configurable), and starts
32;; there a fish server via the command "start_fish_server". All
33;; commands from the client have the form "#FISH_COMMAND\n" (always
34;; one line), followed by equivalent shell commands in case there is
35;; no fish server running.
36
37;; The fish server (or the equivalent shell commands) must return the
38;; response, which is finished by a line "### xxx <optional text>\n".
39;; "xxx" stands for 3 digits, representing a return code. Return
40;; codes "# 000" and "# 001" are reserved for fallback implementation
41;; with native shell commands; they are not used inside the server. See
42;; <http://cvs.savannah.gnu.org/viewcvs/mc/vfs/README.fish?root=mc&view=markup>
43;; for details of original specification.
44
45;; The GNU Midnight Commander implements the original fish protocol
46;; version 0.0.2. The KDE Konqueror has its own implementation, which
47;; can be found at
48;; <http://websvn.kde.org/branches/KDE/3.5/kdebase/kioslave/fish>. It
49;; implements an extended protocol version 0.0.3. Additionally, it
50;; provides a fish server implementation in Perl (which is the only
51;; implementation I've heard of). The following command reference is
52;; based on that implementation.
53
54;; All commands return either "### 2xx\n" (OK) or "### 5xx <optional text>\n"
55;; (NOK). Return codes are mentioned only if they are different from this.
56;; Spaces in any parameter must be escaped by "\ ".
57
58;; Command/Return Code Comment
59;;
60;; #FISH initial connection, not used
61;; in .fishsrv.pl
62;; ### 100 transfer fish server missing server, or wrong checksum
63;; version 0.0.3 only
64
65;; #VER a.b.c <commands requested>
66;; VER x.y.z <commands offered> .fishsrv.pl response is not uptodate
67
68;; #PWD
69;; /path/to/file
70
71;; #CWD /some/path
72
73;; #COPY /path/a /path/b version 0.0.3 only
74
75;; #RENAME /path/a /path/b
76
77;; #SYMLINK /path/a /path/b
78
79;; #LINK /path/a /path/b
80
81;; #DELE /some/path
82
83;; #MKD /some/path
84
85;; #RMD /some/path
86
87;; #CHOWN user /file/name
88
89;; #CHGRP group /file/name
90
91;; #CHMOD 1234 file
92
93;; #READ <offset> <size> /path/and/filename
94;; ### 291 successful exit when reading
95;; ended at eof
96;; ### 292 successful exit when reading
97;; did not end at eof
98
99;; #WRITE <offset> <size> /path/and/filename
100
101;; #APPEND <size> /path/and/filename version 0.0.3 only
102
103;; #LIST /directory
104;; <number of entries> version 0.0.3 only
105;; ### 100 version 0.0.3 only
106;; P<unix permissions> <owner>.<group>
107;; S<size>
108;; d<3-letters month name> <day> <year or HH:MM>
109;; D<year> <month> <day> <hour> <minute> <second>[.1234]
110;; E<major-of-device>,<minor>
111;; :<filename>
112;; L<filename symlink points to>
113;; M<mimetype> version 0.0.3 only
114;; <blank line to separate items>
115
116;; #STAT /file version 0.0.3 only
117;; like #LIST except for directories
118;; <number of entries>
119;; ### 100
120;; P<unix permissions> <owner>.<group>
121;; S<size>
122;; d<3-letters month name> <day> <year or HH:MM>
123;; D<year> <month> <day> <hour> <minute> <second>[.1234]
124;; E<major-of-device>,<minor>
125;; :<filename>
126;; L<filename symlink points to>
127;; <blank line to separate items>
128
129;; #RETR /some/name
130;; <filesize>
131;; ### 100
132;; <binary data> exactly filesize bytes
133;; ### 200 with no preceding newline
134
135;; #STOR <size> /file/name
136;; ### 100
137;; <data> exactly size bytes
138;; ### 001 partial success
139
140;; #EXEC <command> <tmpfile> version 0.0.3 only
141;; <tmpfile> must not exists. It contains the output of <command>.
142;; It can be retrieved afterwards. Last line is
143;; ###RESULT: <returncode>
144
145;; This implementation is meant as proof of the concept, whether there
146;; is a better performance compared with the native ssh method. It
147;; looks like the file information retrieval is slower, especially the
148;; #LIST command. On the other hand, the file contents transmission
149;; seems to perform better than other inline methods, because there is
150;; no need for data encoding/decoding, and it supports the APPEND
151;; parameter of `write-region'. Transfer of binary data fails due to
152;; Emacs' process input/output handling.
153
154
155;;; Code:
156
157(require 'tramp)
158(require 'tramp-cache)
159
160;; Pacify byte-compiler
161(eval-when-compile
162 (require 'cl)
163 (require 'custom))
164
165;; Avoid byte-compiler warnings if the byte-compiler supports this.
166;; Currently, XEmacs supports this.
167(eval-when-compile
168 (when (featurep 'xemacs)
169 (byte-compiler-options (warnings (- unused-vars)))))
170
171;; `directory-sep-char' is an obsolete variable in Emacs. But it is
172;; used in XEmacs, so we set it here and there. The following is needed
173;; to pacify Emacs byte-compiler.
174(eval-when-compile
175 (unless (boundp 'byte-compile-not-obsolete-var)
176 (defvar byte-compile-not-obsolete-var nil))
177 (setq byte-compile-not-obsolete-var 'directory-sep-char))
178
179;; Define FISH method ...
180(defcustom tramp-fish-method "fish"
181 "*Method to connect via FISH protocol."
182 :group 'tramp
183 :type 'string)
184
185;; ... and add it to the method list.
186(add-to-list 'tramp-methods (cons tramp-fish-method nil))
187
188;; Add a default for `tramp-default-user-alist'. Default is the local user.
189(add-to-list 'tramp-default-user-alist
190 `(,tramp-fish-method nil ,(user-login-name)))
191
192;; Add completion function for FISH method.
193(tramp-set-completion-function
194 tramp-fish-method tramp-completion-function-alist-ssh)
195
196(defconst tramp-fish-continue-prompt-regexp "^### 100.*\n"
197 "FISH return code OK.")
198
199;; It cannot be a defconst, occasionally we bind it locally.
200(defvar tramp-fish-ok-prompt-regexp "^### 200\n"
201 "FISH return code OK.")
202
203(defconst tramp-fish-error-prompt-regexp "^### \\(4\\|5\\)[0-9]+.*\n"
204 "Regexp for possible error strings of FISH servers.
205Used instead of analyzing error codes of commands.")
206
207(defcustom tramp-fish-start-fish-server-command
208 (concat "stty intr \"\" quit \"\" erase \"\" kill \"\" eof \"\" eol \"\" eol2 \"\" swtch \"\" start \"\" stop \"\" susp \"\" rprnt \"\" werase \"\" lnext \"\" flush \"\"; "
209 "perl .fishsrv.pl "
210 "`grep 'ARGV\\[0\\]' .fishsrv.pl | "
211 "sed -e 's/^[^\"]*\"//' -e 's/\"[^\"]*$//'`; "
212 "exit")
213 "*Command to connect via FISH protocol."
214 :group 'tramp
215 :type 'string)
216
217;; New handlers should be added here.
218(defconst tramp-fish-file-name-handler-alist
219 '(
220 ;; `access-file' performed by default handler
221 (add-name-to-file . tramp-fish-handle-add-name-to-file)
222 ;; `byte-compiler-base-file-name' performed by default handler
223 (copy-file . tramp-fish-handle-copy-file)
224 (delete-directory . tramp-fish-handle-delete-directory)
225 (delete-file . tramp-fish-handle-delete-file)
226 ;; `diff-latest-backup-file' performed by default handler
227 (directory-file-name . tramp-handle-directory-file-name)
228 (directory-files . tramp-handle-directory-files)
229 (directory-files-and-attributes . tramp-fish-handle-directory-files-and-attributes)
230 ;; `dired-call-process' performed by default handler
231 ;; `dired-compress-file' performed by default handler
232 ;; `dired-uncache' performed by default handler
233 (expand-file-name . tramp-fish-handle-expand-file-name)
234 ;; `file-accessible-directory-p' performed by default handler
235 (file-attributes . tramp-fish-handle-file-attributes)
236 (file-directory-p . tramp-fish-handle-file-directory-p)
237 (file-executable-p . tramp-fish-handle-file-executable-p)
238 (file-exists-p . tramp-fish-handle-file-exists-p)
239 (file-local-copy . tramp-fish-handle-file-local-copy)
240 (file-remote-p . tramp-handle-file-remote-p)
241 (file-modes . tramp-handle-file-modes)
242 (file-name-all-completions . tramp-fish-handle-file-name-all-completions)
243 ;; `file-name-as-directory' performed by default handler
244 (file-name-completion . tramp-handle-file-name-completion)
245 (file-name-directory . tramp-handle-file-name-directory)
246 (file-name-nondirectory . tramp-handle-file-name-nondirectory)
247 ;; `file-name-sans-versions' performed by default handler
248 (file-newer-than-file-p . tramp-fish-handle-file-newer-than-file-p)
249 (file-ownership-preserved-p . ignore)
250 (file-readable-p . tramp-fish-handle-file-readable-p)
251 (file-regular-p . tramp-handle-file-regular-p)
252 (file-symlink-p . tramp-handle-file-symlink-p)
253 ;; `file-truename' performed by default handler
254 (file-writable-p . tramp-fish-handle-file-writable-p)
255 (find-backup-file-name . tramp-handle-find-backup-file-name)
256 ;; `find-file-noselect' performed by default handler
257 ;; `get-file-buffer' performed by default handler
258 (insert-directory . tramp-fish-handle-insert-directory)
259 (insert-file-contents . tramp-fish-handle-insert-file-contents)
260 (load . tramp-handle-load)
261 (make-directory . tramp-fish-handle-make-directory)
262 (make-directory-internal . tramp-fish-handle-make-directory-internal)
263 (make-symbolic-link . tramp-fish-handle-make-symbolic-link)
264 (rename-file . tramp-fish-handle-rename-file)
265 (set-file-modes . tramp-fish-handle-set-file-modes)
266 (set-visited-file-modtime . ignore)
267 (shell-command . tramp-handle-shell-command)
268 (substitute-in-file-name . tramp-handle-substitute-in-file-name)
269 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
270 (vc-registered . ignore)
271 (verify-visited-file-modtime . ignore)
272 (write-region . tramp-fish-handle-write-region)
273 (executable-find . tramp-fish-handle-executable-find)
274 (start-process . ignore)
275 (call-process . tramp-fish-handle-call-process)
276 (process-file . tramp-handle-process-file)
277)
278 "Alist of handler functions for Tramp FISH method.
279Operations not mentioned here will be handled by the default Emacs primitives.")
280
281(defun tramp-fish-file-name-p (filename)
282 "Check if it's a filename for FISH protocol."
283 (let ((v (tramp-dissect-file-name filename)))
284 (string= (tramp-file-name-method v) tramp-fish-method)))
285
286(defun tramp-fish-file-name-handler (operation &rest args)
287 "Invoke the FISH related OPERATION.
288First arg specifies the OPERATION, second arg is a list of arguments to
289pass to the OPERATION."
290 (let ((fn (assoc operation tramp-fish-file-name-handler-alist)))
291 (if fn
292 (save-match-data (apply (cdr fn) args))
293 (tramp-run-real-handler operation args))))
294
295(add-to-list 'tramp-foreign-file-name-handler-alist
296 (cons 'tramp-fish-file-name-p 'tramp-fish-file-name-handler))
297
298
299;; File name primitives
300
301(defun tramp-fish-handle-add-name-to-file
302 (filename newname &optional ok-if-already-exists)
303 "Like `add-name-to-file' for Tramp files."
304 (unless (tramp-equal-remote filename newname)
305 (with-parsed-tramp-file-name
306 (if (tramp-tramp-file-p filename) filename newname) nil
307 (tramp-error
308 v 'file-error
309 "add-name-to-file: %s"
310 "only implemented for same method, same user, same host")))
311 (with-parsed-tramp-file-name filename v1
312 (with-parsed-tramp-file-name newname v2
313 (when (and (not ok-if-already-exists)
314 (file-exists-p newname)
315 (not (numberp ok-if-already-exists))
316 (y-or-n-p
317 (format
318 "File %s already exists; make it a new name anyway? "
319 newname)))
320 (tramp-error
321 v2 'file-error
322 "add-name-to-file: file %s already exists" newname))
323 (tramp-flush-file-property v2 v2-localname)
324 (unless (tramp-fish-send-command-and-check
325 v1 (format "#LINK %s %s" v1-localname v2-localname))
326 (tramp-error
327 v1 'file-error "Error with add-name-to-file %s" newname)))))
328
329(defun tramp-fish-handle-copy-file
330 (filename newname &optional ok-if-already-exists keep-date)
331 "Like `copy-file' for Tramp files."
332 (tramp-fish-do-copy-or-rename-file
333 'copy filename newname ok-if-already-exists keep-date))
334
335(defun tramp-fish-handle-delete-directory (directory)
336 "Like `delete-directory' for Tramp files."
337 (when (file-exists-p directory)
338 (with-parsed-tramp-file-name
339 (directory-file-name (expand-file-name directory)) nil
340 (tramp-flush-directory-property v localname)
341 (tramp-fish-send-command-and-check v (format "#RMD %s" localname)))))
342
343(defun tramp-fish-handle-delete-file (filename)
344 "Like `delete-file' for Tramp files."
345 (when (file-exists-p filename)
346 (with-parsed-tramp-file-name (expand-file-name filename) nil
347 (tramp-flush-file-property v localname)
348 (tramp-fish-send-command-and-check v (format "#DELE %s" localname)))))
349
350(defun tramp-fish-handle-directory-files-and-attributes
351 (directory &optional full match nosort id-format)
352 "Like `directory-files-and-attributes' for Tramp files."
353 (mapcar
354 (lambda (x)
355 ;; We cannot call `file-attributes' for backward compatibility reasons.
356 ;; Its optional parameter ID-FORMAT is introduced with Emacs 22.
357 (cons x (tramp-fish-handle-file-attributes
358 (if full x (expand-file-name x directory)) id-format)))
359 (directory-files directory full match nosort)))
360
361(defun tramp-fish-handle-expand-file-name (name &optional dir)
362 "Like `expand-file-name' for Tramp files."
363 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
364 (setq dir (or dir default-directory "/"))
365 ;; Unless NAME is absolute, concat DIR and NAME.
366 (unless (file-name-absolute-p name)
367 (setq name (concat (file-name-as-directory dir) name)))
368 ;; If NAME is not a tramp file, run the real handler
369 (if (or (tramp-completion-mode) (not (tramp-tramp-file-p name)))
370 (tramp-drop-volume-letter
371 (tramp-run-real-handler 'expand-file-name (list name nil)))
372 ;; Dissect NAME.
373 (with-parsed-tramp-file-name name nil
374 (unless (file-name-absolute-p localname)
375 (setq localname (concat "~/" localname)))
376 ;; Tilde expansion if necessary.
377 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
378 (let ((uname (match-string 1 localname))
379 (fname (match-string 2 localname)))
380 ;; We cannot apply "~user/", because this is not supported
381 ;; by the FISH protocol.
382 (unless (string-equal uname "~")
383 (tramp-error
384 v 'file-error "Tilde expansion not supported for %s" name))
385 (setq uname
386 (with-connection-property v uname
387 (tramp-fish-send-command-and-check v "#PWD")
388 (with-current-buffer (tramp-get-buffer v)
389 (goto-char (point-min))
390 (buffer-substring (point) (tramp-line-end-position)))))
391 (setq localname (concat uname fname))))
392 ;; There might be a double slash, for example when "~/"
393 ;; expands to "/". Remove this.
394 (while (string-match "//" localname)
395 (setq localname (replace-match "/" t t localname)))
396 ;; No tilde characters in file name, do normal
397 ;; expand-file-name (this does "/./" and "/../"). We bind
398 ;; `directory-sep-char' here for XEmacs on Windows, which
399 ;; would otherwise use backslash. `default-directory' is
400 ;; bound, because on Windows there would be problems with UNC
401 ;; shares or Cygwin mounts.
402 (tramp-let-maybe directory-sep-char ?/
403 (let ((default-directory (tramp-temporary-file-directory)))
404 (tramp-make-tramp-file-name
405 method user host
406 (tramp-drop-volume-letter
407 (tramp-run-real-handler 'expand-file-name
408 (list localname)))))))))
409
410(defun tramp-fish-handle-file-attributes (filename &optional id-format)
411 "Like `file-attributes' for Tramp files."
412 (with-parsed-tramp-file-name (expand-file-name filename) nil
413 (with-file-property v localname (format "file-attributes-%s" id-format)
414 (cdr (car (tramp-fish-get-file-entries v localname nil))))))
415
416(defun tramp-fish-handle-file-directory-p (filename)
417 "Like `file-directory-p' for Tramp files."
418 (let ((attributes (file-attributes filename)))
419 (and attributes
420 (or (string-match "d" (nth 8 attributes))
421 (and (file-symlink-p filename)
422 (with-parsed-tramp-file-name filename nil
423 (file-directory-p
424 (tramp-make-tramp-file-name
425 method user host (nth 0 attributes))))))
426 t)))
427
428(defun tramp-fish-handle-file-exists-p (filename)
429 "Like `file-exists-p' for Tramp files."
430 (and (file-attributes filename) t))
431
432(defun tramp-fish-handle-file-executable-p (filename)
433 "Like `file-executable-p' for Tramp files."
434 (with-parsed-tramp-file-name (expand-file-name filename) nil
435 (with-file-property v localname "file-executable-p"
436 (when (file-exists-p filename)
437 (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename))))
438 (home-directory
439 (tramp-make-tramp-file-name
440 method user host
441 (tramp-get-connection-property v "home-directory" nil))))
442 (or (and (char-equal (aref mode-chars 3) ?x)
443 (equal (nth 2 (file-attributes filename))
444 (nth 2 (file-attributes home-directory))))
445 (and (char-equal (aref mode-chars 6) ?x)
446 (equal (nth 3 (file-attributes filename))
447 (nth 3 (file-attributes home-directory))))
448 (char-equal (aref mode-chars 9) ?x)))))))
449
450(defun tramp-fish-handle-file-readable-p (filename)
451 "Like `file-readable-p' for Tramp files."
452 (with-parsed-tramp-file-name (expand-file-name filename) nil
453 (with-file-property v localname "file-readable-p"
454 (when (file-exists-p filename)
455 (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename))))
456 (home-directory
457 (tramp-make-tramp-file-name
458 method user host
459 (tramp-get-connection-property v "home-directory" nil))))
460 (or (and (char-equal (aref mode-chars 1) ?r)
461 (equal (nth 2 (file-attributes filename))
462 (nth 2 (file-attributes home-directory))))
463 (and (char-equal (aref mode-chars 4) ?r)
464 (equal (nth 3 (file-attributes filename))
465 (nth 3 (file-attributes home-directory))))
466 (char-equal (aref mode-chars 7) ?r)))))))
467
468(defun tramp-fish-handle-file-writable-p (filename)
469 "Like `file-writable-p' for Tramp files."
470 (with-parsed-tramp-file-name (expand-file-name filename) nil
471 (with-file-property v localname "file-writable-p"
472 (if (not (file-exists-p filename))
473 ;; If file doesn't exist, check if directory is writable.
474 (and (file-directory-p (file-name-directory filename))
475 (file-writable-p (file-name-directory filename)))
476 ;; Existing files must be writable.
477 (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename))))
478 (home-directory
479 (tramp-make-tramp-file-name
480 method user host
481 (tramp-get-connection-property v "home-directory" nil))))
482 (or (and (char-equal (aref mode-chars 2) ?w)
483 (equal (nth 2 (file-attributes filename))
484 (nth 2 (file-attributes home-directory))))
485 (and (char-equal (aref mode-chars 5) ?w)
486 (equal (nth 3 (file-attributes filename))
487 (nth 3 (file-attributes home-directory))))
488 (char-equal (aref mode-chars 8) ?w)))))))
489
490(defun tramp-fish-handle-file-local-copy (filename)
491 "Like `file-local-copy' for Tramp files."
492 (with-parsed-tramp-file-name (expand-file-name filename) nil
493 (unless (file-exists-p filename)
494 (tramp-error
495 v 'file-error
496 "Cannot make local copy of non-existing file `%s'" filename))
497 (let ((tmpfil (tramp-make-temp-file filename)))
498 (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfil)
499 (when (tramp-fish-retrieve-data v)
500 ;; Save file
501 (with-current-buffer (tramp-get-buffer v)
502 (write-region (point-min) (point-max) tmpfil))
503 (tramp-message v 4 "Fetching %s to tmp file %s...done" filename tmpfil)
504 tmpfil))))
505
506;; This function should return "foo/" for directories and "bar" for
507;; files.
508(defun tramp-fish-handle-file-name-all-completions (filename directory)
509 "Like `file-name-all-completions' for Tramp files."
510 (all-completions
511 filename
512 (with-parsed-tramp-file-name (expand-file-name directory) nil
513 (with-file-property v localname "file-name-all-completions"
514 (save-match-data
515 (let ((entries
516 (with-file-property v localname "file-entries"
517 (tramp-fish-get-file-entries v localname t))))
518 (mapcar
519 (lambda (x)
520 (list
521 (if (string-match "d" (nth 9 x))
522 (file-name-as-directory (nth 0 x))
523 (nth 0 x))))
524 entries)))))))
525
526(defun tramp-fish-handle-file-newer-than-file-p (file1 file2)
527 "Like `file-newer-than-file-p' for Tramp files."
528 (cond
529 ((not (file-exists-p file1)) nil)
530 ((not (file-exists-p file2)) t)
531 (t (tramp-time-less-p (nth 5 (file-attributes file2))
532 (nth 5 (file-attributes file1))))))
533
534(defun tramp-fish-handle-insert-directory
535 (filename switches &optional wildcard full-directory-p)
536 "Like `insert-directory' for Tramp files.
537WILDCARD and FULL-DIRECTORY-P are not handled."
538 (setq filename (expand-file-name filename))
539 (when (file-directory-p filename)
540 ;; This check is a little bit strange, but in `dired-add-entry'
541 ;; this function is called with a non-directory ...
542 (setq filename (file-name-as-directory filename)))
543
544 (with-parsed-tramp-file-name filename nil
545 (tramp-flush-file-property v localname)
546 (save-match-data
547 (let ((entries
548 (with-file-property v localname "file-entries"
549 (tramp-fish-get-file-entries v localname t))))
550
551 ;; Sort entries
552 (setq entries
553 (sort
554 entries
555 (lambda (x y)
556 (if (string-match "t" switches)
557 ;; Sort by date.
558 (tramp-time-less-p (nth 6 y) (nth 6 x))
559 ;; Sort by name.
560 (string-lessp (nth 0 x) (nth 0 y))))))
561
562 ;; Print entries.
563 (mapcar
564 (lambda (x)
565 (insert
566 (format
567 "%10s %3d %-8s %-8s %8s %s %s%s\n"
568 (nth 9 x) ; mode
569 1 ; hardlinks
570 (nth 3 x) ; uid
571 (nth 4 x) ; gid
572 (nth 8 x) ; size
573 (format-time-string
574 (if (tramp-time-less-p
575 (tramp-time-subtract (current-time) (nth 6 x))
576 tramp-half-a-year)
577 "%b %e %R"
578 "%b %e %Y")
579 (nth 6 x)) ; date
580 (nth 0 x) ; file name
581 (if (stringp (nth 1 x)) (format " -> %s" (nth 1 x)) "")))
582 (forward-line)
583 (beginning-of-line))
584 entries)))))
585
586(defun tramp-fish-handle-insert-file-contents
587 (filename &optional visit beg end replace)
588 "Like `insert-file-contents' for Tramp files."
589 (barf-if-buffer-read-only)
590 (when visit
591 (setq buffer-file-name (expand-file-name filename))
592 (set-visited-file-modtime)
593 (set-buffer-modified-p nil))
594
595 (with-parsed-tramp-file-name filename nil
596 (if (not (file-exists-p filename))
597 (tramp-error
598 v 'file-error "File %s not found on remote host" filename)
599
600 (let ((point (point))
601 size)
602 (tramp-message v 4 "Fetching file %s..." filename)
603 (when (tramp-fish-retrieve-data v)
604 ;; Insert file
605 (insert
606 (with-current-buffer (tramp-get-buffer v)
607 (let ((beg (or beg (point-min)))
608 (end (min (or end (point-max)) (point-max))))
609 (setq size (- end beg))
610 (buffer-substring beg end))))
611 (goto-char point))
612 (tramp-message v 4 "Fetching file %s...done" filename)
613
614 (list (expand-file-name filename) size)))))
615
616(defun tramp-fish-handle-make-directory (dir &optional parents)
617 "Like `make-directory' for Tramp files."
618 (setq dir (directory-file-name (expand-file-name dir)))
619 (unless (file-name-absolute-p dir)
620 (setq dir (expand-file-name dir default-directory)))
621 (with-parsed-tramp-file-name dir nil
622 (save-match-data
623 (let ((ldir (file-name-directory dir)))
624 ;; Make missing directory parts
625 (when (and parents (not (file-directory-p ldir)))
626 (make-directory ldir parents))
627 ;; Just do it
628 (when (file-directory-p ldir)
629 (make-directory-internal dir))
630 (unless (file-directory-p dir)
631 (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
632
633(defun tramp-fish-handle-make-directory-internal (directory)
634 "Like `make-directory-internal' for Tramp files."
635 (setq directory (directory-file-name (expand-file-name directory)))
636 (unless (file-name-absolute-p directory)
637 (setq directory (expand-file-name directory default-directory)))
638 (when (file-directory-p (file-name-directory directory))
639 (with-parsed-tramp-file-name directory nil
640 (save-match-data
641 (unless
642 (tramp-fish-send-command-and-check v (format "#MKD %s" localname))
643 (tramp-error
644 v 'file-error "Couldn't make directory %s" directory))))))
645
646(defun tramp-fish-handle-make-symbolic-link
647 (filename linkname &optional ok-if-already-exists)
648 "Like `make-symbolic-link' for Tramp files.
649If LINKNAME is a non-Tramp file, it is used verbatim as the target of
650the symlink. If LINKNAME is a Tramp file, only the localname component is
651used as the target of the symlink.
652
653If LINKNAME is a Tramp file and the localname component is relative, then
654it is expanded first, before the localname component is taken. Note that
655this can give surprising results if the user/host for the source and
656target of the symlink differ."
657 (with-parsed-tramp-file-name linkname nil
658 ;; Do the 'confirm if exists' thing.
659 (when (file-exists-p linkname)
660 ;; What to do?
661 (if (or (null ok-if-already-exists) ; not allowed to exist
662 (and (numberp ok-if-already-exists)
663 (not (yes-or-no-p
664 (format
665 "File %s already exists; make it a link anyway? "
666 localname)))))
667 (tramp-error
668 v 'file-already-exists "File %s already exists" localname)
669 (delete-file linkname)))
670
671 ;; If FILENAME is a Tramp name, use just the localname component.
672 (when (tramp-tramp-file-p filename)
673 (setq filename (tramp-file-name-localname
674 (tramp-dissect-file-name (expand-file-name filename)))))
675
676 ;; Right, they are on the same host, regardless of user, method, etc.
677 ;; We now make the link on the remote machine. This will occur as the user
678 ;; that FILENAME belongs to.
679 (unless
680 (tramp-fish-send-command-and-check
681 v (format "#SYMLINK %s %s" filename localname))
682 (tramp-error v 'file-error "Error creating symbolic link %s" linkname))))
683
684(defun tramp-fish-handle-rename-file
685 (filename newname &optional ok-if-already-exists)
686 "Like `rename-file' for Tramp files."
687 (tramp-fish-do-copy-or-rename-file
688 'rename filename newname ok-if-already-exists t))
689
690(defun tramp-fish-handle-set-file-modes (filename mode)
691 "Like `set-file-modes' for Tramp files."
692 (with-parsed-tramp-file-name filename nil
693 (tramp-flush-file-property v localname)
694 (unless (tramp-fish-send-command-and-check
695 v (format "#CHMOD %s %s"
696 (tramp-decimal-to-octal mode)
697 (tramp-shell-quote-argument localname)))
698 (tramp-error
699 v 'file-error "Error while changing file's mode %s" filename))))
700
701(defun tramp-fish-handle-write-region
702 (start end filename &optional append visit lockname confirm)
703 "Like `write-region' for Tramp files."
704 (setq filename (expand-file-name filename))
705 (with-parsed-tramp-file-name filename nil
706 ;; XEmacs takes a coding system as the seventh argument, not `confirm'
707 (when (and (not (featurep 'xemacs))
708 confirm (file-exists-p filename))
709 (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
710 filename))
711 (tramp-error v 'file-error "File not overwritten")))
712
713 (tramp-flush-file-property v localname)
714
715 ;; Send command
716 (let ((tramp-fish-ok-prompt-regexp
717 (concat
718 tramp-fish-ok-prompt-regexp "\\|"
719 tramp-fish-continue-prompt-regexp)))
720 (tramp-fish-send-command
721 v (format "%s %d %s\n### 100"
722 (if append "#APPEND" "#STOR") (- end start) localname)))
723
724 ;; Send data, if there are any.
725 (when (> end start)
726 (tramp-fish-send-command v (buffer-substring-no-properties start end)))
727
728 (when (eq visit t)
729 (set-visited-file-modtime))))
730
731(defun tramp-fish-handle-executable-find (command)
732 "Like `executable-find' for Tramp files."
733 (with-temp-buffer
734 (if (zerop (call-process "which" nil t nil command))
735 (progn
736 (goto-char (point-min))
737 (buffer-substring (point-min) (tramp-line-end-position))))))
738
739(defun tramp-fish-handle-call-process
740 (program &optional infile destination display &rest args)
741 "Like `call-process' for Tramp files."
742 ;; The implementation is not complete yet.
743 (when (and (numberp destination) (zerop destination))
744 (error "Implementation does not handle immediate return"))
745
746 (with-parsed-tramp-file-name default-directory nil
747 (let ((temp-name-prefix (tramp-make-tramp-temp-file v))
748 command input output stderr outbuf tmpfil ret)
749 ;; Compute command.
750 (setq command (mapconcat 'tramp-shell-quote-argument
751 (cons program args) " "))
752 ;; Determine input.
753 (if (null infile)
754 (setq input "/dev/null")
755 (setq infile (expand-file-name infile))
756 (if (tramp-equal-remote default-directory infile)
757 ;; INFILE is on the same remote host.
758 (setq input (with-parsed-tramp-file-name infile nil localname))
759 ;; INFILE must be copied to remote host.
760 (setq input (concat temp-name-prefix ".in"))
761 (copy-file
762 infile
763 (tramp-make-tramp-file-name method user host input)
764 t)))
765 (when input (setq command (format "%s <%s" command input)))
766
767 ;; Determine output.
768 (setq output (concat temp-name-prefix ".out"))
769 (cond
770 ;; Just a buffer
771 ((bufferp destination)
772 (setq outbuf destination))
773 ;; A buffer name
774 ((stringp destination)
775 (setq outbuf (get-buffer-create destination)))
776 ;; (REAL-DESTINATION ERROR-DESTINATION)
777 ((consp destination)
778 ;; output
779 (cond
780 ((bufferp (car destination))
781 (setq outbuf (car destination)))
782 ((stringp (car destination))
783 (setq outbuf (get-buffer-create (car destination)))))
784 ;; stderr
785 (cond
786 ((stringp (cadr destination))
787 (setcar (cdr destination) (expand-file-name (cadr destination)))
788 (if (tramp-equal-remote default-directory (cadr destination))
789 ;; stderr is on the same remote host.
790 (setq stderr (with-parsed-tramp-file-name
791 (cadr destination) nil localname))
792 ;; stderr must be copied to remote host. The temporary
793 ;; file must be deleted after execution.
794 (setq stderr (concat temp-name-prefix ".err"))))
795 ;; stderr to be discarded
796 ((null (cadr destination))
797 (setq stderr "/dev/null"))))
798 ;; 't
799 (destination
800 (setq outbuf (current-buffer))))
801 (when stderr (setq command (format "%s 2>%s" command stderr)))
802
803 ;; If we have a temporary file, it must be removed after operation.
804 (when (and input (string-match temp-name-prefix input))
805 (setq command (format "%s; rm %s" command input)))
806 ;; Goto working directory.
807 (unless
808 (tramp-fish-send-command-and-check
809 v (format "#CWD %s" (tramp-shell-quote-argument localname)))
810 (tramp-error v 'file-error "No such directory: %s" default-directory))
811 ;; Send the command. It might not return in time, so we protect it.
812 (condition-case nil
813 (unwind-protect
814 (unless (tramp-fish-send-command-and-check
815 v (format
816 "#EXEC %s %s"
817 (tramp-shell-quote-argument command) output))
818 (error))
819 ;; Check return code.
820 (setq tmpfil (file-local-copy
821 (tramp-make-tramp-file-name method user host output)))
822 (with-temp-buffer
823 (insert-file-contents tmpfil)
824 (goto-char (point-max))
825 (forward-line -1)
826 (looking-at "^###RESULT: \\([0-9]+\\)")
827 (setq ret (string-to-number (match-string 1)))
828 (delete-region (point) (point-max))
829 (write-region (point-min) (point-max) tmpfil))
830 ;; We should show the output anyway.
831 (when outbuf
832 (with-current-buffer outbuf (insert-file-contents tmpfil))
833 (when display (display-buffer outbuf)))
834 ;; Remove output file.
835 (delete-file (tramp-make-tramp-file-name method user host output)))
836 ;; When the user did interrupt, we should do it also.
837 (error (setq ret 1)))
838 (unless ret
839 ;; Provide error file.
840 (when (and stderr (string-match temp-name-prefix stderr))
841 (rename-file (tramp-make-tramp-file-name method user host stderr)
842 (cadr destination) t)))
843 ;; Return exit status.
844 ret)))
845
846
847;; Internal file name functions
848
849(defun tramp-fish-do-copy-or-rename-file
850 (op filename newname &optional ok-if-already-exists keep-date)
851 "Copy or rename a remote file.
852OP must be `copy' or `rename' and indicates the operation to
853perform. FILENAME specifies the file to copy or rename, NEWNAME
854is the name of the new file (for copy) or the new name of the
855file (for rename). OK-IF-ALREADY-EXISTS means don't barf if
856NEWNAME exists already. KEEP-DATE means to make sure that
857NEWNAME has the same timestamp as FILENAME.
858
859This function is invoked by `tramp-fish-handle-copy-file' and
860`tramp-fish-handle-rename-file'. It is an error if OP is neither
861of `copy' and `rename'. FILENAME and NEWNAME must be absolute
862file names."
863 (unless (memq op '(copy rename))
864 (error "Unknown operation `%s', must be `copy' or `rename'" op))
865 (let ((t1 (tramp-tramp-file-p filename))
866 (t2 (tramp-tramp-file-p newname)))
867
868 (unless ok-if-already-exists
869 (when (and t2 (file-exists-p newname))
870 (with-parsed-tramp-file-name newname nil
871 (tramp-error
872 v 'file-already-exists "File %s already exists" newname))))
873
874 (prog1
875 (cond
876 ;; Both are Tramp files.
877 ((and t1 t2)
878 (cond
879 ;; Shortcut: if method, host, user are the same for both
880 ;; files, we invoke `cp' or `mv' on the remote host
881 ;; directly.
882 ((tramp-equal-remote filename newname)
883 (tramp-fish-do-copy-or-rename-file-directly
884 op filename newname keep-date))
885 ;; No shortcut was possible. So we copy the
886 ;; file first. If the operation was `rename', we go
887 ;; back and delete the original file (if the copy was
888 ;; successful). The approach is simple-minded: we
889 ;; create a new buffer, insert the contents of the
890 ;; source file into it, then write out the buffer to
891 ;; the target file. The advantage is that it doesn't
892 ;; matter which filename handlers are used for the
893 ;; source and target file.
894 (t
895 (tramp-do-copy-or-rename-file-via-buffer
896 op filename newname keep-date))))
897
898 ;; One file is a Tramp file, the other one is local.
899 ((or t1 t2)
900 ;; Use the generic method via a Tramp buffer.
901 (tramp-do-copy-or-rename-file-via-buffer
902 op filename newname keep-date))
903
904 (t
905 ;; One of them must be a Tramp file.
906 (error "Tramp implementation says this cannot happen")))
907 ;; When newname did exist, we have wrong cached values.
908 (when t2
909 (with-parsed-tramp-file-name newname nil
910 (tramp-flush-file-property v localname)
911 (tramp-flush-file-property v (file-name-directory localname)))))))
912
913(defun tramp-fish-do-copy-or-rename-file-directly
914 (op filename newname keep-date)
915 "Invokes `COPY' or `RENAME' on the remote system.
916OP must be one of `copy' or `rename', indicating `cp' or `mv',
917respectively. VEC specifies the connection. LOCALNAME1 and
918LOCALNAME2 specify the two arguments of `cp' or `mv'. If
919KEEP-DATE is non-nil, preserve the time stamp when copying."
920 (with-parsed-tramp-file-name filename v1
921 (with-parsed-tramp-file-name newname v2
922 (tramp-fish-send-command
923 v1
924 (format "%s %s %s"
925 (if (eq op 'copy) "#COPY" "#RENAME")
926 (tramp-shell-quote-argument v1-localname)
927 (tramp-shell-quote-argument v2-localname)))))
928 ;; KEEP-DATE handling.
929 (when keep-date
930 (let ((modtime (nth 5 (file-attributes filename))))
931 (when (and (not (null modtime))
932 (not (equal modtime '(0 0))))
933 (tramp-touch newname modtime))))
934 ;; Set the mode.
935 (set-file-modes newname (file-modes filename)))
936
937(defun tramp-fish-get-file-entries (vec localname list)
938 "Read entries returned by FISH server.
939When LIST is true, a #LIST command will be sent, including all entries
940of a directory. Otherwise, #STAT is sent for just one entry.
941Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
942SIZE MODE WEIRD INODE DEVICE)."
943 (block nil
944 (with-current-buffer (tramp-get-buffer vec)
945 ;; #LIST does not work properly with trailing "/", at least in .fishsrv.pl
946 (when (string-match "/$" localname)
947 (setq localname (concat localname ".")))
948
949 (let ((command (format "%s %s" (if list "#LIST" "#STAT") localname))
950 buffer-read-only num res)
951
952 ;; Send command
953 (tramp-fish-send-command vec command)
954
955 ;; Read number of entries
956 (goto-char (point-min))
957 (condition-case nil
958 (unless (integerp (setq num (read (current-buffer)))) (error))
959 (error (return nil)))
960 (forward-line)
961 (delete-region (point-min) (point))
962
963 ;; Read return code
964 (goto-char (point-min))
965 (condition-case nil
966 (unless (looking-at tramp-fish-continue-prompt-regexp) (error))
967 (error (return nil)))
968 (forward-line)
969 (delete-region (point-min) (point))
970
971 ;; Loop the listing
972 (dotimes (i num)
973 (let ((item (tramp-fish-read-file-entry)))
974 ;; Add inode and device.
975 (add-to-list
976 'res (append item
977 (list (tramp-get-inode (car item))
978 (tramp-get-device vec))))))
979
980 ;; Read return code
981 (goto-char (point-min))
982 (condition-case nil
983 (unless (looking-at tramp-fish-ok-prompt-regexp) (error))
984 (error (tramp-error
985 vec 'file-error
986 "`%s' does not return a valid Lisp expression: `%s'"
987 command (buffer-string))))
988 (forward-line)
989 (delete-region (point-min) (point))
990
991 res))))
992
993(defun tramp-fish-read-file-entry ()
994 "Parse entry in output buffer.
995Result is the list (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
996SIZE MODE WEIRD)."
997 ;; We are called from `tramp-fish-get-file-entries', which sets the
998 ;; current buffer.
999 (let (buffer-read-only localname link uid gid mtime size mode)
1000 (block nil
1001 (while t
1002 (cond
1003 ;; P<unix permissions> <owner>.<group>
1004 ((looking-at "^P\\(.+\\)\\s-\\(.+\\)\\.\\(.+\\)$")
1005 (setq mode (match-string 1))
1006 (setq uid (match-string 2))
1007 (setq gid (match-string 3))
1008 (when (string-match "^d" mode) (setq link t)))
1009 ;; S<size>
1010 ((looking-at "^S\\([0-9]+\\)$")
1011 (setq size (string-to-number (match-string 1))))
1012 ;; D<year> <month> <day> <hour> <minute> <second>[.1234]
1013 ((looking-at
1014 "^D\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\(\\S-+\\)$")
1015 (setq mtime
1016 (encode-time
1017 (string-to-number (match-string 6))
1018 (string-to-number (match-string 5))
1019 (string-to-number (match-string 4))
1020 (string-to-number (match-string 3))
1021 (string-to-number (match-string 2))
1022 (string-to-number (match-string 1)))))
1023 ;; d<3-letters month name> <day> <year or HH:MM>
1024 ((looking-at "^d") nil)
1025 ;; E<major-of-device>,<minor>
1026 ((looking-at "^E") nil)
1027 ;; :<filename>
1028 ((looking-at "^:\\(.+\\)$")
1029 (setq localname (match-string 1)))
1030 ;; L<filename symlink points to>
1031 ((looking-at "^L\\(.+\\)$")
1032 (setq link (match-string 1)))
1033 ;; M<mimetype>
1034 ((looking-at "^M\\(.+\\)$") nil)
1035 ;; last line
1036 ((looking-at "^$")
1037 (return)))
1038 ;; delete line
1039 (forward-line)
1040 (delete-region (point-min) (point))))
1041
1042 ;; delete trailing empty line
1043 (forward-line)
1044 (delete-region (point-min) (point))
1045
1046 ;; Return entry in file-attributes format
1047 (list localname link -1 uid gid '(0 0) mtime '(0 0) size mode nil)))
1048
1049(defun tramp-fish-retrieve-data (vec)
1050 "Reads remote data for FISH protocol.
1051The data are left in the connection buffer of VEC for further processing.
1052Returns the size of the data."
1053 (block nil
1054 (with-current-buffer (tramp-get-buffer vec)
1055 ;; The retrieved data might be in binary format, without
1056 ;; trailing newline. Therefore, the OK prompt might not start
1057 ;; at the beginning of a line.
1058 (let ((tramp-fish-ok-prompt-regexp "### 200\n")
1059 size)
1060
1061 ;; Send command
1062 (tramp-fish-send-command
1063 vec (format "#RETR %s" (tramp-file-name-localname vec)))
1064
1065 ;; Read filesize
1066 (goto-char (point-min))
1067 (condition-case nil
1068 (unless (integerp (setq size (read (current-buffer)))) (error))
1069 (error (return nil)))
1070 (forward-line)
1071 (delete-region (point-min) (point))
1072
1073 ;; Read return code
1074 (goto-char (point-min))
1075 (condition-case nil
1076 (unless (looking-at tramp-fish-continue-prompt-regexp) (error))
1077 (error (return nil)))
1078 (forward-line)
1079 (delete-region (point-min) (point))
1080
1081 ;; The received data might contain the OK prompt already, so
1082 ;; there might be outstanding data.
1083 (while (/= (+ size (length tramp-fish-ok-prompt-regexp))
1084 (- (point-max) (point-min)))
1085 (tramp-wait-for-regexp
1086 (tramp-get-connection-process vec) nil
1087 (concat tramp-fish-ok-prompt-regexp "$")))
1088
1089 ;; Read return code
1090 (goto-char (+ (point-min) size))
1091 (condition-case nil
1092 (unless (looking-at tramp-fish-ok-prompt-regexp) (error))
1093 (error (return nil)))
1094 (delete-region (+ (point-min) size) (point-max))
1095 size))))
1096
1097
1098;; Connection functions
1099
1100(defun tramp-fish-maybe-open-connection (vec)
1101 "Maybe open a connection VEC.
1102Does not do anything if a connection is already open, but re-opens the
1103connection if a previous connection has died for some reason."
1104 (let ((process-connection-type tramp-process-connection-type)
1105 (p (get-buffer-process (tramp-get-buffer vec))))
1106
1107 ;; New connection must be opened.
1108 (unless (and p (processp p) (memq (process-status p) '(run open)))
1109
1110 ;; Set variables for computing the prompt for reading password.
1111 (setq tramp-current-method (tramp-file-name-method vec)
1112 tramp-current-user (tramp-file-name-user vec)
1113 tramp-current-host (tramp-file-name-host vec))
1114
1115 ;; Start new process.
1116 (when (and p (processp p))
1117 (delete-process p))
1118 (setenv "TERM" tramp-terminal-type)
1119 (setenv "PS1" "$ ")
1120 (tramp-message
1121 vec 3 "Opening connection for %s@%s using %s..."
1122 tramp-current-user tramp-current-host tramp-current-method)
1123
1124 (let* ((process-connection-type tramp-process-connection-type)
1125 (inhibit-eol-conversion nil)
1126 (coding-system-for-read 'binary)
1127 (coding-system-for-write 'binary)
1128 ;; This must be done in order to avoid our file name handler.
1129 (p (let ((default-directory (tramp-temporary-file-directory)))
1130 (start-process
1131 (or (tramp-get-connection-property vec "process-name" nil)
1132 (tramp-buffer-name vec))
1133 (tramp-get-connection-buffer vec)
1134 "ssh" "-l"
1135 (tramp-file-name-user vec)
1136 (tramp-file-name-host vec)))))
1137 (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " "))
1138
1139 ;; Check whether process is alive.
1140 (set-process-sentinel p 'tramp-flush-connection-property)
1141 (tramp-set-process-query-on-exit-flag p nil)
1142
1143 (tramp-process-actions p vec tramp-actions-before-shell 60)
1144 (tramp-fish-send-command vec tramp-fish-start-fish-server-command)
1145 (tramp-message
1146 vec 3
1147 "Found remote shell prompt on `%s'" (tramp-file-name-host vec))))))
1148
1149(defun tramp-fish-send-command (vec command)
1150 "Send the COMMAND to connection VEC."
1151 (tramp-fish-maybe-open-connection vec)
1152 (tramp-message vec 6 "%s" command)
1153 (tramp-send-string vec command)
1154 (tramp-wait-for-regexp
1155 (tramp-get-connection-process vec) nil
1156 (concat tramp-fish-ok-prompt-regexp "\\|" tramp-fish-error-prompt-regexp)))
1157
1158(defun tramp-fish-send-command-and-check (vec command)
1159 "Send the COMMAND to connection VEC.
1160Returns nil if there has been an error message."
1161
1162 ;; Send command.
1163 (tramp-fish-send-command vec command)
1164
1165 ;; Read return code.
1166 (with-current-buffer (tramp-get-buffer vec)
1167 (goto-char (point-min))
1168 (looking-at tramp-fish-ok-prompt-regexp)))
1169
1170(provide 'tramp-fish)
1171;
1172;;;; TODO:
1173;
1174;; * Evaluate the MIME information with #LIST or #STAT.
1175;
1176
1177;; arch-tag: a66df7df-5f29-42a7-a921-643ceb29db49
1178;;;; tramp-fish.el ends here
diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el
index d33873d1689..fcdab250ac8 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -10,8 +10,8 @@
10 10
11;; GNU Emacs is free software; you can redistribute it and/or modify 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 12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option) 13;; the Free Software Foundation; either version 3 of the License, or
14;; any later version. 14;; (at your option) any later version.
15 15
16;; GNU Emacs is distributed in the hope that it will be useful, 16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -19,9 +19,8 @@
19;; GNU General Public License for more details. 19;; GNU General Public License for more details.
20 20
21;; You should have received a copy of the GNU General Public License 21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; along with GNU Emacs; see the file COPYING. If not, see
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; <http://www.gnu.org/licenses/>.
24;; Boston, MA 02110-1301, USA.
25 24
26;;; Commentary: 25;;; Commentary:
27 26
@@ -110,10 +109,13 @@ present for backward compatibility."
110 (list "" "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) 109 (list "" "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))
111 110
112;; Add completion function for FTP method. 111;; Add completion function for FTP method.
113(unless (memq system-type '(windows-nt)) 112(tramp-set-completion-function
114 (tramp-set-completion-function 113 tramp-ftp-method
115 tramp-ftp-method 114 '((tramp-parse-netrc "~/.netrc")))
116 '((tramp-parse-netrc "~/.netrc")))) 115
116;; If there is URL syntax, `substitute-in-file-name' needs special
117;; handling.
118(put 'substitute-in-file-name 'ange-ftp 'tramp-handle-substitute-in-file-name)
117 119
118(defun tramp-ftp-file-name-handler (operation &rest args) 120(defun tramp-ftp-file-name-handler (operation &rest args)
119 "Invoke the Ange-FTP handler for OPERATION. 121 "Invoke the Ange-FTP handler for OPERATION.
@@ -152,13 +154,7 @@ pass to the OPERATION."
152(defun tramp-ftp-file-name-p (filename) 154(defun tramp-ftp-file-name-p (filename)
153 "Check if it's a filename that should be forwarded to Ange-FTP." 155 "Check if it's a filename that should be forwarded to Ange-FTP."
154 (let ((v (tramp-dissect-file-name filename))) 156 (let ((v (tramp-dissect-file-name filename)))
155 (string= 157 (string= (tramp-file-name-method v) tramp-ftp-method)))
156 (tramp-find-method
157 (tramp-file-name-multi-method v)
158 (tramp-file-name-method v)
159 (tramp-file-name-user v)
160 (tramp-file-name-host v))
161 tramp-ftp-method)))
162 158
163(add-to-list 'tramp-foreign-file-name-handler-alist 159(add-to-list 'tramp-foreign-file-name-handler-alist
164 (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler)) 160 (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))
@@ -172,8 +168,6 @@ pass to the OPERATION."
172;; pretended in `tramp-file-name-handler' otherwise. 168;; pretended in `tramp-file-name-handler' otherwise.
173;; Furthermore, there are no backup files on FTP hosts. 169;; Furthermore, there are no backup files on FTP hosts.
174;; Worth further investigations. 170;; Worth further investigations.
175;; * Map /multi:ssh:out@gate:ftp:kai@real.host:/path/to.file
176;; on Ange-FTP gateways.
177 171
178;;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff 172;;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff
179;;; tramp-ftp.el ends here 173;;; tramp-ftp.el ends here
diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el
new file mode 100644
index 00000000000..78f8040a909
--- /dev/null
+++ b/lisp/net/tramp-gw.el
@@ -0,0 +1,324 @@
1;;; -*- coding: iso-8859-1; -*-
2;;; tramp-gw.el --- Tramp utility functions for HTTP tunnels and SOCKS gateways
3
4;; Copyright (C) 2007 Free Software Foundation, Inc.
5
6;; Author: Michael Albinus <michael.albinus@gmx.de>
7;; Keywords: comm, processes
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; see the file COPYING. If not, see
23;; <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26
27;; Access functions for HTTP tunnels and SOCKS gateways from Tramp.
28;; SOCKS functionality is implemented by socks.el from the w3 package.
29;; HTTP tunnels are partly implemented in socks.el and url-http.el;
30;; both implementations are not complete. Therefore, it is
31;; implemented in this package.
32
33;;; Code:
34
35(require 'tramp)
36
37;; Pacify byte-compiler
38(eval-when-compile
39 (require 'cl)
40 (require 'custom))
41
42;; Autoload the socks library. It is used only when we access a SOCKS server.
43(autoload 'socks-open-network-stream "socks")
44(defvar socks-username (user-login-name))
45(defvar socks-server (list "Default server" "socks" 1080 5))
46
47;; Avoid byte-compiler warnings if the byte-compiler supports this.
48;; Currently, XEmacs supports this.
49(eval-when-compile
50 (when (featurep 'xemacs)
51 (byte-compiler-options (warnings (- unused-vars)))))
52
53;; Define HTTP tunnel method ...
54(defvar tramp-gw-tunnel-method "tunnel"
55 "*Method to connect HTTP gateways.")
56
57;; ... and port.
58(defvar tramp-gw-default-tunnel-port 8080
59 "*Default port for HTTP gateways.")
60
61;; Define SOCKS method ...
62(defvar tramp-gw-socks-method "socks"
63 "*Method to connect SOCKS servers.")
64
65;; ... and port.
66(defvar tramp-gw-default-socks-port 1080
67 "*Default port for SOCKS servers.")
68
69;; Add a default for `tramp-default-user-alist'. Default is the local user.
70(add-to-list 'tramp-default-user-alist
71 `(,tramp-gw-tunnel-method nil ,(user-login-name)))
72(add-to-list 'tramp-default-user-alist
73 `(,tramp-gw-socks-method nil ,(user-login-name)))
74
75;; Internal file name functions and variables.
76
77(defvar tramp-gw-vector nil
78 "Keeps the remote host identification. Needed for Tramp messages.")
79
80(defvar tramp-gw-gw-vector nil
81 "Current gateway identification vector.")
82
83(defvar tramp-gw-gw-proc nil
84 "Current gateway process.")
85
86;; This variable keeps the listening process, in order to reuse it for
87;; new processes.
88(defvar tramp-gw-aux-proc nil
89 "Process listening on local port, as mediation between SSH and the gateway.")
90
91(defun tramp-gw-gw-proc-sentinel (proc event)
92 "Delete auxiliary process when we are deleted."
93 (unless (memq (process-status proc) '(run open))
94 (tramp-message
95 tramp-gw-vector 4 "Deleting auxiliary process `%s'" tramp-gw-gw-proc)
96 (let* (tramp-verbose
97 (p (tramp-get-connection-property proc "process" nil)))
98 (when (processp p) (delete-process p)))))
99
100(defun tramp-gw-aux-proc-sentinel (proc event)
101 "Activate the different filters for involved gateway and auxiliary processes."
102 (when (memq (process-status proc) '(run open))
103 ;; A new process has been spawned from `tramp-gw-aux-proc'.
104 (tramp-message
105 tramp-gw-vector 4
106 "Opening auxiliary process `%s', speaking with process `%s'"
107 proc tramp-gw-gw-proc)
108 (tramp-set-process-query-on-exit-flag proc nil)
109 ;; We don't want debug messages, because the corresponding debug
110 ;; buffer might be undecided.
111 (let (tramp-verbose)
112 (tramp-set-connection-property tramp-gw-gw-proc "process" proc)
113 (tramp-set-connection-property proc "process" tramp-gw-gw-proc))
114 ;; Set the process-filter functions for both processes.
115 (set-process-filter proc 'tramp-gw-process-filter)
116 (set-process-filter tramp-gw-gw-proc 'tramp-gw-process-filter)
117 ;; There might be already some output from the gateway process.
118 (with-current-buffer (process-buffer tramp-gw-gw-proc)
119 (unless (= (point-min) (point-max))
120 (let ((s (buffer-string)))
121 (delete-region (point) (point-max))
122 (tramp-gw-process-filter tramp-gw-gw-proc s))))))
123
124(defun tramp-gw-process-filter (proc string)
125 (let (tramp-verbose)
126 (process-send-string
127 (tramp-get-connection-property proc "process" nil) string)))
128
129(defun tramp-gw-open-connection (vec gw-vec target-vec)
130 "Open a remote connection to VEC (see `tramp-file-name' structure).
131Take GW-VEC as SOCKS or HTTP gateway, i.e. its method must be a
132gateway method. TARGET-VEC identifies where to connect to via
133the gateway, it can be different from VEC when there are more
134hops to be applied.
135
136It returns a string like \"localhost#port\", which must be used
137instead of the host name declared in TARGET-VEC."
138
139 ;; Remember vectors for property retrieval.
140 (setq tramp-gw-vector vec
141 tramp-gw-gw-vector gw-vec)
142
143 ;; Start listening auxiliary process.
144 (unless (and (processp tramp-gw-aux-proc)
145 (memq (process-status tramp-gw-aux-proc) '(listen)))
146 (let ((aux-vec
147 (vector "aux" (tramp-file-name-user gw-vec)
148 (tramp-file-name-host gw-vec) nil)))
149 (setq tramp-gw-aux-proc
150 (make-network-process
151 :name (tramp-buffer-name aux-vec) :buffer nil :host 'local
152 :server t :noquery t :service t :coding 'binary))
153 (set-process-sentinel tramp-gw-aux-proc 'tramp-gw-aux-proc-sentinel)
154 (tramp-set-process-query-on-exit-flag tramp-gw-aux-proc nil)
155 (tramp-message
156 vec 4 "Opening auxiliary process `%s', listening on port %d"
157 tramp-gw-aux-proc (process-contact tramp-gw-aux-proc :service))))
158
159 (let* ((gw-method
160 (intern
161 (tramp-find-method
162 (tramp-file-name-method gw-vec)
163 (tramp-file-name-user gw-vec)
164 (tramp-file-name-host gw-vec))))
165 (socks-username
166 (tramp-find-user
167 (tramp-file-name-method gw-vec)
168 (tramp-file-name-user gw-vec)
169 (tramp-file-name-host gw-vec)))
170 ;; Declare the SOCKS server to be used.
171 (socks-server
172 (list "Tramp tempory socks server list"
173 ;; Host name.
174 (tramp-file-name-real-host gw-vec)
175 ;; Port number.
176 (or (tramp-file-name-port gw-vec)
177 (case gw-method
178 (tunnel tramp-gw-default-tunnel-port)
179 (socks tramp-gw-default-socks-port)))
180 ;; Type. We support only http and socks5, NO socks4.
181 ;; 'http could be used when HTTP tunnel works in socks.el.
182 5))
183 ;; The function to be called.
184 (socks-function
185 (case gw-method
186 (tunnel 'tramp-gw-open-network-stream)
187 (socks 'socks-open-network-stream)))
188 socks-noproxy)
189
190 ;; Open SOCKS process.
191 (setq tramp-gw-gw-proc
192 (funcall
193 socks-function
194 (tramp-buffer-name gw-vec)
195 (tramp-get-buffer gw-vec)
196 (tramp-file-name-real-host target-vec)
197 (tramp-file-name-port target-vec)))
198 (set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel)
199 (tramp-set-process-query-on-exit-flag tramp-gw-gw-proc nil)
200 (tramp-message
201 vec 4 "Opened %s process `%s'"
202 (case gw-method ('tunnel "HTTP tunnel") ('socks "SOCKS"))
203 tramp-gw-gw-proc)
204
205 ;; Return the new host for gateway access.
206 (format "localhost#%d" (process-contact tramp-gw-aux-proc :service))))
207
208(defun tramp-gw-open-network-stream (name buffer host service)
209 "Open stream to proxy server HOST:SERVICE.
210Resulting process has name NAME and buffer BUFFER. If
211authentication is requested from proxy server, provide it."
212 (let ((command (format (concat
213 "CONNECT %s:%d HTTP/1.1\r\n"
214 "Host: %s:%d\r\n"
215 "Connection: keep-alive\r\n"
216 "User-Agent: Tramp/%s\r\n")
217 host service host service tramp-version))
218 (authentication "")
219 (first t)
220 found proc)
221
222 (while (not found)
223 ;; Clean up.
224 (when (processp proc) (delete-process proc))
225 (with-current-buffer buffer (erase-buffer))
226 ;; Open network stream.
227 (setq proc (open-network-stream
228 name buffer (nth 1 socks-server) (nth 2 socks-server)))
229 (set-process-coding-system proc 'binary 'binary)
230 (tramp-set-process-query-on-exit-flag proc nil)
231 ;; Send CONNECT command.
232 (process-send-string proc (format "%s%s\r\n" command authentication))
233 (tramp-message
234 tramp-gw-vector 6 "\n%s"
235 (format
236 "%s%s\r\n" command
237 (replace-regexp-in-string ;; no password in trace!
238 "Basic [^\r\n]+" "Basic xxxxx" authentication t)))
239 (with-current-buffer buffer
240 ;; Trap errors to be traced in the right trace buffer. Often,
241 ;; proxies have a timeout of 60". We wait 65" in order to
242 ;; receive an answer this case.
243 (condition-case nil
244 (let (tramp-verbose)
245 (tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))
246 (error nil))
247 ;; Check return code.
248 (goto-char (point-min))
249 (narrow-to-region
250 (point-min)
251 (or (search-forward-regexp "\r?\n\r?\n" nil t) (point-max)))
252 (tramp-message tramp-gw-vector 6 "\n%s" (buffer-string))
253 (goto-char (point-min))
254 (search-forward-regexp "^HTTP/[1-9]\\.[0-9]" nil t)
255 (case (condition-case nil (read (current-buffer)) (error))
256 ;; Connected.
257 (200 (setq found t))
258 ;; We need basic authentication.
259 (401 (setq authentication (tramp-gw-basic-authentication nil first)))
260 ;; Target host not found.
261 (404 (tramp-error-with-buffer
262 (current-buffer) tramp-gw-vector 'file-error
263 "Host %s not found." host))
264 ;; We need basic proxy authentication.
265 (407 (setq authentication (tramp-gw-basic-authentication t first)))
266 ;; Connection failed.
267 (503 (tramp-error-with-buffer
268 (current-buffer) tramp-gw-vector 'file-error
269 "Connection to %s:%d failed." host service))
270 ;; That doesn't work at all.
271 (t (tramp-error-with-buffer
272 (current-buffer) tramp-gw-vector 'file-error
273 "Access to HTTP server %s:%d failed."
274 (nth 1 socks-server) (nth 2 socks-server))))
275 ;; Remove HTTP headers.
276 (delete-region (point-min) (point-max))
277 (widen)
278 (setq first nil)))
279 ;; Return the process.
280 proc))
281
282(defun tramp-gw-basic-authentication (proxy pw-cache)
283 "Return authentication header for CONNECT, based on server request.
284PROXY is an indication whether we need a Proxy-Authorization header
285or an Authorization header. If PW-CACHE is non-nil, check for
286password in password cache. This is done for the first try only."
287
288 ;; `tramp-current-*' must be set for `tramp-read-passwd' and
289 ;; `tramp-clear-passwd'.
290 (let ((tramp-current-method (tramp-file-name-method tramp-gw-gw-vector))
291 (tramp-current-user (tramp-file-name-user tramp-gw-gw-vector))
292 (tramp-current-host (tramp-file-name-host tramp-gw-gw-vector)))
293 (unless pw-cache (tramp-clear-passwd))
294 ;; We are already in the right buffer.
295 (tramp-message
296 tramp-gw-vector 5 "%s required"
297 (if proxy "Proxy authentication" "Authentication"))
298 ;; Search for request header. We accept only basic authentication.
299 (goto-char (point-min))
300 (search-forward-regexp
301 "^\\(Proxy\\|WWW\\)-Authenticate:\\s-*Basic\\s-+realm=")
302 ;; Return authentication string.
303 (format
304 "%s: Basic %s\r\n"
305 (if proxy "Proxy-Authorization" "Authorization")
306 (base64-encode-string
307 (format
308 "%s:%s"
309 socks-username
310 (tramp-read-passwd
311 proc
312 (format
313 "Password for %s@[%s]: " socks-username (read (current-buffer)))))))))
314
315
316(provide 'tramp-gw)
317
318;;; TODO:
319
320;; * Provide descriptive Commentary.
321;; * Enable it for several gateway processes in parallel.
322
323;; arch-tag: 277e3a81-fdee-40cf-9e6b-59626292a5e0
324;;; tramp-gw.el ends here
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 7382bdef63b..981073f7126 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1,6 +1,7 @@
1;;; tramp-smb.el --- Tramp access functions for SMB servers -*- coding: iso-8859-1; -*- 1;;; tramp-smb.el --- Tramp access functions for SMB servers -*- coding: iso-8859-1; -*-
2 2
3;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 3;; Copyright (C) 2002, 2003, 2004, 2005, 2006,
4;; 2007 Free Software Foundation, Inc.
4 5
5;; Author: Michael Albinus <michael.albinus@gmx.de> 6;; Author: Michael Albinus <michael.albinus@gmx.de>
6;; Keywords: comm, processes 7;; Keywords: comm, processes
@@ -9,8 +10,8 @@
9 10
10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by 12;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option) 13;; the Free Software Foundation; either version 3 of the License, or
13;; any later version. 14;; (at your option) any later version.
14 15
15;; GNU Emacs is distributed in the hope that it will be useful, 16;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,9 +19,8 @@
18;; GNU General Public License for more details. 19;; GNU General Public License for more details.
19 20
20;; You should have received a copy of the GNU General Public License 21;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; along with GNU Emacs; see the file COPYING. If not, see
22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; <http://www.gnu.org/licenses/>.
23;; Boston, MA 02110-1301, USA.
24 24
25;;; Commentary: 25;;; Commentary:
26 26
@@ -29,6 +29,7 @@
29;;; Code: 29;;; Code:
30 30
31(require 'tramp) 31(require 'tramp)
32(require 'tramp-cache)
32 33
33;; Pacify byte-compiler 34;; Pacify byte-compiler
34(eval-when-compile (require 'custom)) 35(eval-when-compile (require 'custom))
@@ -36,10 +37,8 @@
36;; Avoid byte-compiler warnings if the byte-compiler supports this. 37;; Avoid byte-compiler warnings if the byte-compiler supports this.
37;; Currently, XEmacs supports this. 38;; Currently, XEmacs supports this.
38(eval-when-compile 39(eval-when-compile
39 (when (fboundp 'byte-compiler-options) 40 (when (featurep 'xemacs)
40 (let (unused-vars) ; Pacify Emacs byte-compiler 41 (byte-compiler-options (warnings (- unused-vars)))))
41 (defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
42 (byte-compiler-options (warnings (- unused-vars))))))
43 42
44;; Define SMB method ... 43;; Define SMB method ...
45(defcustom tramp-smb-method "smb" 44(defcustom tramp-smb-method "smb"
@@ -53,7 +52,12 @@
53;; Add a default for `tramp-default-method-alist'. Rule: If there is 52;; Add a default for `tramp-default-method-alist'. Rule: If there is
54;; a domain in USER, it must be the SMB method. 53;; a domain in USER, it must be the SMB method.
55(add-to-list 'tramp-default-method-alist 54(add-to-list 'tramp-default-method-alist
56 (list "" "%" tramp-smb-method)) 55 `(nil "%" ,tramp-smb-method))
56
57;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method,
58;; the anonymous user is chosen.
59(add-to-list 'tramp-default-user-alist
60 `(,tramp-smb-method nil ""))
57 61
58;; Add completion function for SMB method. 62;; Add completion function for SMB method.
59(tramp-set-completion-function 63(tramp-set-completion-function
@@ -69,11 +73,13 @@
69 "Regexp used as prompt in smbclient.") 73 "Regexp used as prompt in smbclient.")
70 74
71(defconst tramp-smb-errors 75(defconst tramp-smb-errors
76 ;; `regexp-opt' not possible because of first string.
72 (mapconcat 77 (mapconcat
73 'identity 78 'identity
74 '(; Connection error 79 '(;; Connection error / timeout
75 "Connection to \\S-+ failed" 80 "Connection to \\S-+ failed"
76 ; Samba 81 "Read from server failed, maybe it closed the connection"
82 ;; Samba
77 "ERRDOS" 83 "ERRDOS"
78 "ERRSRV" 84 "ERRSRV"
79 "ERRbadfile" 85 "ERRbadfile"
@@ -82,34 +88,48 @@
82 "ERRnoaccess" 88 "ERRnoaccess"
83 "ERRnomem" 89 "ERRnomem"
84 "ERRnosuchshare" 90 "ERRnosuchshare"
85 ; Windows NT 4.0, Windows 5.0 (Windows 2000), Windows 5.1 (Windows XP) 91 ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
92 ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003)
86 "NT_STATUS_ACCESS_DENIED" 93 "NT_STATUS_ACCESS_DENIED"
87 "NT_STATUS_ACCOUNT_LOCKED_OUT" 94 "NT_STATUS_ACCOUNT_LOCKED_OUT"
88 "NT_STATUS_BAD_NETWORK_NAME" 95 "NT_STATUS_BAD_NETWORK_NAME"
89 "NT_STATUS_CANNOT_DELETE" 96 "NT_STATUS_CANNOT_DELETE"
97 "NT_STATUS_DIRECTORY_NOT_EMPTY"
98 "NT_STATUS_DUPLICATE_NAME"
99 "NT_STATUS_FILE_IS_A_DIRECTORY"
90 "NT_STATUS_LOGON_FAILURE" 100 "NT_STATUS_LOGON_FAILURE"
91 "NT_STATUS_NETWORK_ACCESS_DENIED" 101 "NT_STATUS_NETWORK_ACCESS_DENIED"
92 "NT_STATUS_NO_SUCH_FILE" 102 "NT_STATUS_NO_SUCH_FILE"
103 "NT_STATUS_OBJECT_NAME_COLLISION"
93 "NT_STATUS_OBJECT_NAME_INVALID" 104 "NT_STATUS_OBJECT_NAME_INVALID"
94 "NT_STATUS_OBJECT_NAME_NOT_FOUND" 105 "NT_STATUS_OBJECT_NAME_NOT_FOUND"
95 "NT_STATUS_SHARING_VIOLATION" 106 "NT_STATUS_SHARING_VIOLATION"
107 "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
96 "NT_STATUS_WRONG_PASSWORD") 108 "NT_STATUS_WRONG_PASSWORD")
97 "\\|") 109 "\\|")
98 "Regexp for possible error strings of SMB servers. 110 "Regexp for possible error strings of SMB servers.
99Used instead of analyzing error codes of commands.") 111Used instead of analyzing error codes of commands.")
100 112
101(defvar tramp-smb-share nil 113(defconst tramp-smb-actions-with-share
102 "Holds the share name for the current buffer. 114 '((tramp-smb-prompt tramp-action-succeed)
103This variable is local to each buffer.") 115 (tramp-password-prompt-regexp tramp-action-password)
104(make-variable-buffer-local 'tramp-smb-share) 116 (tramp-wrong-passwd-regexp tramp-action-permission-denied)
117 (tramp-smb-errors tramp-action-permission-denied)
118 (tramp-process-alive-regexp tramp-action-process-alive))
119 "List of pattern/action pairs.
120This list is used for login to SMB servers.
121
122See `tramp-actions-before-shell' for more info.")
105 123
106(defvar tramp-smb-share-cache nil 124(defconst tramp-smb-actions-without-share
107 "Caches the share names accessible to host related to the current buffer. 125 '((tramp-password-prompt-regexp tramp-action-password)
108This variable is local to each buffer.") 126 (tramp-wrong-passwd-regexp tramp-action-permission-denied)
109(make-variable-buffer-local 'tramp-smb-share-cache) 127 (tramp-smb-errors tramp-action-permission-denied)
128 (tramp-process-alive-regexp tramp-action-out-of-band))
129 "List of pattern/action pairs.
130This list is used for login to SMB servers.
110 131
111(defvar tramp-smb-inodes nil 132See `tramp-actions-before-shell' for more info.")
112 "Keeps virtual inodes numbers for SMB files.")
113 133
114;; New handlers should be added here. 134;; New handlers should be added here.
115(defconst tramp-smb-file-name-handler-alist 135(defconst tramp-smb-file-name-handler-alist
@@ -124,8 +144,8 @@ This variable is local to each buffer.")
124 (directory-file-name . tramp-handle-directory-file-name) 144 (directory-file-name . tramp-handle-directory-file-name)
125 (directory-files . tramp-smb-handle-directory-files) 145 (directory-files . tramp-smb-handle-directory-files)
126 (directory-files-and-attributes . tramp-smb-handle-directory-files-and-attributes) 146 (directory-files-and-attributes . tramp-smb-handle-directory-files-and-attributes)
127 (dired-call-process . tramp-smb-not-handled) 147 (dired-call-process . ignore)
128 (dired-compress-file . tramp-smb-not-handled) 148 (dired-compress-file . ignore)
129 ;; `dired-uncache' performed by default handler 149 ;; `dired-uncache' performed by default handler
130 ;; `expand-file-name' not necessary because we cannot expand "~/" 150 ;; `expand-file-name' not necessary because we cannot expand "~/"
131 (file-accessible-directory-p . tramp-smb-handle-file-directory-p) 151 (file-accessible-directory-p . tramp-smb-handle-file-directory-p)
@@ -143,10 +163,10 @@ This variable is local to each buffer.")
143 (file-name-nondirectory . tramp-handle-file-name-nondirectory) 163 (file-name-nondirectory . tramp-handle-file-name-nondirectory)
144 ;; `file-name-sans-versions' performed by default handler 164 ;; `file-name-sans-versions' performed by default handler
145 (file-newer-than-file-p . tramp-smb-handle-file-newer-than-file-p) 165 (file-newer-than-file-p . tramp-smb-handle-file-newer-than-file-p)
146 (file-ownership-preserved-p . tramp-smb-not-handled) 166 (file-ownership-preserved-p . ignore)
147 (file-readable-p . tramp-smb-handle-file-exists-p) 167 (file-readable-p . tramp-smb-handle-file-exists-p)
148 (file-regular-p . tramp-handle-file-regular-p) 168 (file-regular-p . tramp-handle-file-regular-p)
149 (file-symlink-p . tramp-smb-not-handled) 169 (file-symlink-p . tramp-handle-file-symlink-p)
150 ;; `file-truename' performed by default handler 170 ;; `file-truename' performed by default handler
151 (file-writable-p . tramp-smb-handle-file-writable-p) 171 (file-writable-p . tramp-smb-handle-file-writable-p)
152 (find-backup-file-name . tramp-handle-find-backup-file-name) 172 (find-backup-file-name . tramp-handle-find-backup-file-name)
@@ -157,15 +177,15 @@ This variable is local to each buffer.")
157 (load . tramp-handle-load) 177 (load . tramp-handle-load)
158 (make-directory . tramp-smb-handle-make-directory) 178 (make-directory . tramp-smb-handle-make-directory)
159 (make-directory-internal . tramp-smb-handle-make-directory-internal) 179 (make-directory-internal . tramp-smb-handle-make-directory-internal)
160 (make-symbolic-link . tramp-smb-not-handled) 180 (make-symbolic-link . ignore)
161 (rename-file . tramp-smb-handle-rename-file) 181 (rename-file . tramp-smb-handle-rename-file)
162 (set-file-modes . tramp-smb-not-handled) 182 (set-file-modes . ignore)
163 (set-visited-file-modtime . tramp-smb-not-handled) 183 (set-visited-file-modtime . ignore)
164 (shell-command . tramp-smb-not-handled) 184 (shell-command . ignore)
165 (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) 185 (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name)
166 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) 186 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
167 (vc-registered . tramp-smb-not-handled) 187 (vc-registered . ignore)
168 (verify-visited-file-modtime . tramp-smb-not-handled) 188 (verify-visited-file-modtime . ignore)
169 (write-region . tramp-smb-handle-write-region) 189 (write-region . tramp-smb-handle-write-region)
170) 190)
171 "Alist of handler functions for Tramp SMB method. 191 "Alist of handler functions for Tramp SMB method.
@@ -174,13 +194,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
174(defun tramp-smb-file-name-p (filename) 194(defun tramp-smb-file-name-p (filename)
175 "Check if it's a filename for SMB servers." 195 "Check if it's a filename for SMB servers."
176 (let ((v (tramp-dissect-file-name filename))) 196 (let ((v (tramp-dissect-file-name filename)))
177 (string= 197 (string= (tramp-file-name-method v) tramp-smb-method)))
178 (tramp-find-method
179 (tramp-file-name-multi-method v)
180 (tramp-file-name-method v)
181 (tramp-file-name-user v)
182 (tramp-file-name-host v))
183 tramp-smb-method)))
184 198
185(defun tramp-smb-file-name-handler (operation &rest args) 199(defun tramp-smb-file-name-handler (operation &rest args)
186 "Invoke the SMB related OPERATION. 200 "Invoke the SMB related OPERATION.
@@ -188,9 +202,7 @@ First arg specifies the OPERATION, second arg is a list of arguments to
188pass to the OPERATION." 202pass to the OPERATION."
189 (let ((fn (assoc operation tramp-smb-file-name-handler-alist))) 203 (let ((fn (assoc operation tramp-smb-file-name-handler-alist)))
190 (if fn 204 (if fn
191 (if (eq (cdr fn) 'tramp-smb-not-handled) 205 (save-match-data (apply (cdr fn) args))
192 (apply (cdr fn) operation args)
193 (save-match-data (apply (cdr fn) args)))
194 (tramp-run-real-handler operation args)))) 206 (tramp-run-real-handler operation args))))
195 207
196(add-to-list 'tramp-foreign-file-name-handler-alist 208(add-to-list 'tramp-foreign-file-name-handler-alist
@@ -199,14 +211,9 @@ pass to the OPERATION."
199 211
200;; File name primitives 212;; File name primitives
201 213
202(defun tramp-smb-not-handled (operation &rest args)
203 "Default handler for all functions which are disrecarded."
204 (tramp-message 10 "Won't be handled: %s %s" operation args)
205 nil)
206
207(defun tramp-smb-handle-copy-file 214(defun tramp-smb-handle-copy-file
208 (filename newname &optional ok-if-already-exists keep-date) 215 (filename newname &optional ok-if-already-exists keep-date)
209 "Like `copy-file' for tramp files. 216 "Like `copy-file' for Tramp files.
210KEEP-DATE is not handled in case NEWNAME resides on an SMB server." 217KEEP-DATE is not handled in case NEWNAME resides on an SMB server."
211 (setq filename (expand-file-name filename) 218 (setq filename (expand-file-name filename)
212 newname (expand-file-name newname)) 219 newname (expand-file-name newname))
@@ -214,199 +221,187 @@ KEEP-DATE is not handled in case NEWNAME resides on an SMB server."
214 (let ((tmpfile (file-local-copy filename))) 221 (let ((tmpfile (file-local-copy filename)))
215 222
216 (if tmpfile 223 (if tmpfile
217 ;; remote filename 224 ;; Remote filename.
218 (rename-file tmpfile newname ok-if-already-exists) 225 (rename-file tmpfile newname ok-if-already-exists)
219 226
220 ;; remote newname 227 ;; Remote newname.
221 (when (file-directory-p newname) 228 (when (file-directory-p newname)
222 (setq newname (expand-file-name 229 (setq newname (expand-file-name
223 (file-name-nondirectory filename) newname))) 230 (file-name-nondirectory filename) newname)))
224 (when (and (not ok-if-already-exists)
225 (file-exists-p newname))
226 (error "copy-file: file %s already exists" newname))
227 231
228 (with-parsed-tramp-file-name newname nil 232 (with-parsed-tramp-file-name newname nil
229 (save-excursion 233 (when (and (not ok-if-already-exists)
230 (let ((share (tramp-smb-get-share localname)) 234 (file-exists-p newname))
231 (file (tramp-smb-get-localname localname t))) 235 (tramp-error v 'file-already-exists newname))
232 (unless share 236
233 (error "Target `%s' must contain a share name" filename)) 237 ;; We must also flush the cache of the directory, because
234 (tramp-smb-maybe-open-connection user host share) 238 ;; file-attributes reads the values from there.
235 (tramp-message-for-buffer 239 (tramp-flush-file-property v (file-name-directory localname))
236 nil tramp-smb-method user host 240 (tramp-flush-file-property v localname)
237 5 "Copying file %s to file %s..." filename newname) 241 (let ((share (tramp-smb-get-share localname))
238 (if (tramp-smb-send-command 242 (file (tramp-smb-get-localname localname t)))
239 user host (format "put %s \"%s\"" filename file)) 243 (unless share
240 (tramp-message-for-buffer 244 (tramp-error
241 nil tramp-smb-method user host 245 v 'file-error "Target `%s' must contain a share name" newname))
242 5 "Copying file %s to file %s...done" filename newname) 246 (tramp-message v 0 "Copying file %s to file %s..." filename newname)
243 (error "Cannot copy `%s'" filename)))))))) 247 (if (tramp-smb-send-command
248 v (format "put %s \"%s\"" filename file))
249 (tramp-message
250 v 0 "Copying file %s to file %s...done" filename newname)
251 (tramp-error v 'file-error "Cannot copy `%s'" filename)))))))
244 252
245(defun tramp-smb-handle-delete-directory (directory) 253(defun tramp-smb-handle-delete-directory (directory)
246 "Like `delete-directory' for tramp files." 254 "Like `delete-directory' for Tramp files."
247 (setq directory (directory-file-name (expand-file-name directory))) 255 (setq directory (directory-file-name (expand-file-name directory)))
248 (when (file-exists-p directory) 256 (when (file-exists-p directory)
249 (with-parsed-tramp-file-name directory nil 257 (with-parsed-tramp-file-name directory nil
250 (save-excursion 258 ;; We must also flush the cache of the directory, because
251 (let ((share (tramp-smb-get-share localname)) 259 ;; file-attributes reads the values from there.
252 (dir (tramp-smb-get-localname (file-name-directory localname) t)) 260 (tramp-flush-file-property v (file-name-directory localname))
253 (file (file-name-nondirectory localname))) 261 (tramp-flush-directory-property v localname)
254 (tramp-smb-maybe-open-connection user host share) 262 (let ((dir (tramp-smb-get-localname (file-name-directory localname) t))
255 (if (and 263 (file (file-name-nondirectory localname)))
256 (tramp-smb-send-command user host (format "cd \"%s\"" dir)) 264 (unwind-protect
257 (tramp-smb-send-command user host (format "rmdir \"%s\"" file))) 265 (unless (and
258 ;; Go Home 266 (tramp-smb-send-command v (format "cd \"%s\"" dir))
259 (tramp-smb-send-command user host (format "cd \\")) 267 (tramp-smb-send-command v (format "rmdir \"%s\"" file)))
260 ;; Error 268 ;; Error
261 (tramp-smb-send-command user host (format "cd \\")) 269 (with-current-buffer (tramp-get-connection-buffer v)
262 (error "Cannot delete directory `%s'" directory))))))) 270 (goto-char (point-min))
271 (search-forward-regexp tramp-smb-errors nil t)
272 (tramp-error
273 v 'file-error "%s `%s'" (match-string 0) directory)))
274 ;; Always go home
275 (tramp-smb-send-command v (format "cd \\")))))))
263 276
264(defun tramp-smb-handle-delete-file (filename) 277(defun tramp-smb-handle-delete-file (filename)
265 "Like `delete-file' for tramp files." 278 "Like `delete-file' for Tramp files."
266 (setq filename (expand-file-name filename)) 279 (setq filename (expand-file-name filename))
267 (when (file-exists-p filename) 280 (when (file-exists-p filename)
268 (with-parsed-tramp-file-name filename nil 281 (with-parsed-tramp-file-name filename nil
269 (save-excursion 282 ;; We must also flush the cache of the directory, because
270 (let ((share (tramp-smb-get-share localname)) 283 ;; file-attributes reads the values from there.
271 (dir (tramp-smb-get-localname (file-name-directory localname) t)) 284 (tramp-flush-file-property v (file-name-directory localname))
272 (file (file-name-nondirectory localname))) 285 (tramp-flush-file-property v localname)
273 (tramp-smb-maybe-open-connection user host share) 286 (let ((dir (tramp-smb-get-localname (file-name-directory localname) t))
274 (if (and 287 (file (file-name-nondirectory localname)))
275 (tramp-smb-send-command user host (format "cd \"%s\"" dir)) 288 (unwind-protect
276 (tramp-smb-send-command user host (format "rm \"%s\"" file))) 289 (unless (and
277 ;; Go Home 290 (tramp-smb-send-command v (format "cd \"%s\"" dir))
278 (tramp-smb-send-command user host (format "cd \\")) 291 (tramp-smb-send-command v (format "rm \"%s\"" file)))
279 ;; Error 292 ;; Error
280 (tramp-smb-send-command user host (format "cd \\")) 293 (with-current-buffer (tramp-get-connection-buffer v)
281 (error "Cannot delete file `%s'" filename))))))) 294 (goto-char (point-min))
295 (search-forward-regexp tramp-smb-errors nil t)
296 (tramp-error
297 v 'file-error "%s `%s'" (match-string 0) filename)))
298 ;; Always go home
299 (tramp-smb-send-command v (format "cd \\")))))))
282 300
283(defun tramp-smb-handle-directory-files 301(defun tramp-smb-handle-directory-files
284 (directory &optional full match nosort) 302 (directory &optional full match nosort)
285 "Like `directory-files' for tramp files." 303 "Like `directory-files' for Tramp files."
286 (setq directory (directory-file-name (expand-file-name directory))) 304 (let ((result (mapcar 'directory-file-name
287 (with-parsed-tramp-file-name directory nil 305 (file-name-all-completions "" directory))))
288 (save-excursion 306 ;; Discriminate with regexp
289 (let* ((share (tramp-smb-get-share localname)) 307 (when match
290 (file (tramp-smb-get-localname localname nil)) 308 (setq result
291 (entries (tramp-smb-get-file-entries user host share file))) 309 (delete nil
292 ;; Just the file names are needed 310 (mapcar (lambda (x) (when (string-match match x) x))
293 (setq entries (mapcar 'car entries)) 311 result))))
294 ;; Discriminate with regexp 312 ;; Append directory
295 (when match 313 (when full
296 (setq entries 314 (setq result
297 (delete nil 315 (mapcar
298 (mapcar (lambda (x) (when (string-match match x) x)) 316 (lambda (x) (expand-file-name x directory))
299 entries)))) 317 result)))
300 ;; Make absolute localnames if necessary 318 ;; Sort them if necessary
301 (when full 319 (unless nosort (setq result (sort result 'string-lessp)))
302 (setq entries 320 ;; That's it
303 (mapcar (lambda (x) 321 result))
304 (concat (file-name-as-directory directory) x))
305 entries)))
306 ;; Sort them if necessary
307 (unless nosort (setq entries (sort entries 'string-lessp)))
308 ;; That's it
309 entries))))
310 322
311(defun tramp-smb-handle-directory-files-and-attributes 323(defun tramp-smb-handle-directory-files-and-attributes
312 (directory &optional full match nosort id-format) 324 (directory &optional full match nosort id-format)
313 "Like `directory-files-and-attributes' for tramp files." 325 "Like `directory-files-and-attributes' for Tramp files."
314 (mapcar 326 (mapcar
315 (lambda (x) 327 (lambda (x)
316 ;; We cannot call `file-attributes' for backward compatibility reasons. 328 ;; We cannot call `file-attributes' for backward compatibility reasons.
317 ;; Its optional parameter ID-FORMAT is introduced with Emacs 22. 329 ;; Its optional parameter ID-FORMAT is introduced with Emacs 22.
318 (cons x (tramp-smb-handle-file-attributes 330 (cons x (tramp-smb-handle-file-attributes
319 (if full x (concat (file-name-as-directory directory) x)) id-format))) 331 (if full x (expand-file-name x directory)) id-format)))
320 (directory-files directory full match nosort))) 332 (directory-files directory full match nosort)))
321 333
322(defun tramp-smb-handle-file-attributes (filename &optional id-format) 334(defun tramp-smb-handle-file-attributes (filename &optional id-format)
323 "Like `file-attributes' for tramp files." 335 "Like `file-attributes' for Tramp files."
336 ;; Reading just the filename entry via "dir localname" is not
337 ;; possible, because when filename is a directory, some smbclient
338 ;; versions return the content of the directory, and other versions
339 ;; don't. Therefore, the whole content of the upper directory is
340 ;; retrieved, and the entry of the filename is extracted from.
324 (with-parsed-tramp-file-name filename nil 341 (with-parsed-tramp-file-name filename nil
325 (save-excursion 342 (with-file-property v localname (format "file-attributes-%s" id-format)
326 (let* ((share (tramp-smb-get-share localname)) 343 (let* ((entries (tramp-smb-get-file-entries
327 (file (tramp-smb-get-localname localname nil)) 344 (file-name-directory filename)))
328 (entries (tramp-smb-get-file-entries user host share file))
329 (entry (and entries 345 (entry (and entries
330 (assoc (file-name-nondirectory file) entries))) 346 (assoc (file-name-nondirectory filename) entries)))
331 (uid (if (and id-format (equal id-format 'string)) "nobody" -1)) 347 (uid (if (and id-format (equal id-format 'string)) "nobody" -1))
332 (gid (if (and id-format (equal id-format 'string)) "nogroup" -1)) 348 (gid (if (and id-format (equal id-format 'string)) "nogroup" -1))
333 (inode (tramp-smb-get-inode share file)) 349 (inode (tramp-get-inode filename))
334 (device (tramp-get-device nil tramp-smb-method user host))) 350 (device (tramp-get-device v)))
335 351
336 ; check result 352 ;; Check result.
337 (when entry 353 (when entry
338 (list (and (string-match "d" (nth 1 entry)) 354 (list (and (string-match "d" (nth 1 entry))
339 t) ;0 file type 355 t) ;0 file type
340 -1 ;1 link count 356 -1 ;1 link count
341 uid ;2 uid 357 uid ;2 uid
342 gid ;3 gid 358 gid ;3 gid
343 '(0 0) ;4 atime 359 '(0 0) ;4 atime
344 (nth 3 entry) ;5 mtime 360 (nth 3 entry) ;5 mtime
345 '(0 0) ;6 ctime 361 '(0 0) ;6 ctime
346 (nth 2 entry) ;7 size 362 (nth 2 entry) ;7 size
347 (nth 1 entry) ;8 mode 363 (nth 1 entry) ;8 mode
348 nil ;9 gid weird 364 nil ;9 gid weird
349 inode ;10 inode number 365 inode ;10 inode number
350 device)))))) ;11 file system number 366 device)))))) ;11 file system number
351 367
352(defun tramp-smb-handle-file-directory-p (filename) 368(defun tramp-smb-handle-file-directory-p (filename)
353 "Like `file-directory-p' for tramp files." 369 "Like `file-directory-p' for Tramp files."
354 (with-parsed-tramp-file-name filename nil 370 (and (file-exists-p filename)
355 (save-excursion 371 (eq ?d (aref (nth 8 (file-attributes filename)) 0))))
356 (let* ((share (tramp-smb-get-share localname))
357 (file (tramp-smb-get-localname localname nil))
358 (entries (tramp-smb-get-file-entries user host share file))
359 (entry (and entries
360 (assoc (file-name-nondirectory file) entries))))
361 (and entry
362 (string-match "d" (nth 1 entry))
363 t)))))
364 372
365(defun tramp-smb-handle-file-exists-p (filename) 373(defun tramp-smb-handle-file-exists-p (filename)
366 "Like `file-exists-p' for tramp files." 374 "Like `file-exists-p' for Tramp files."
367 (with-parsed-tramp-file-name filename nil 375 (not (null (file-attributes filename))))
368 (save-excursion
369 (let* ((share (tramp-smb-get-share localname))
370 (file (tramp-smb-get-localname localname nil))
371 (entries (tramp-smb-get-file-entries user host share file)))
372 (and entries
373 (member (file-name-nondirectory file) (mapcar 'car entries))
374 t)))))
375 376
376(defun tramp-smb-handle-file-local-copy (filename) 377(defun tramp-smb-handle-file-local-copy (filename)
377 "Like `file-local-copy' for tramp files." 378 "Like `file-local-copy' for Tramp files."
378 (with-parsed-tramp-file-name filename nil 379 (with-parsed-tramp-file-name filename nil
379 (save-excursion 380 (let ((file (tramp-smb-get-localname localname t))
380 (let ((share (tramp-smb-get-share localname)) 381 (tmpfil (tramp-make-temp-file filename)))
381 (file (tramp-smb-get-localname localname t)) 382 (unless (file-exists-p filename)
382 (tmpfil (tramp-make-temp-file filename))) 383 (tramp-error
383 (unless (file-exists-p filename) 384 v 'file-error
384 (error "Cannot make local copy of non-existing file `%s'" filename)) 385 "Cannot make local copy of non-existing file `%s'" filename))
385 (tramp-message-for-buffer 386 (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfil)
386 nil tramp-smb-method user host 387 (if (tramp-smb-send-command v (format "get \"%s\" %s" file tmpfil))
387 5 "Fetching %s to tmp file %s..." filename tmpfil) 388 (tramp-message
388 (tramp-smb-maybe-open-connection user host share) 389 v 4 "Fetching %s to tmp file %s...done" filename tmpfil)
389 (if (tramp-smb-send-command 390 (tramp-error
390 user host (format "get \"%s\" %s" file tmpfil)) 391 v 'file-error
391 (tramp-message-for-buffer 392 "Cannot make local copy of file `%s'" filename))
392 nil tramp-smb-method user host 393 tmpfil)))
393 5 "Fetching %s to tmp file %s...done" filename tmpfil)
394 (error "Cannot make local copy of file `%s'" filename))
395 tmpfil))))
396 394
397;; This function should return "foo/" for directories and "bar" for 395;; This function should return "foo/" for directories and "bar" for
398;; files. 396;; files.
399(defun tramp-smb-handle-file-name-all-completions (filename directory) 397(defun tramp-smb-handle-file-name-all-completions (filename directory)
400 "Like `file-name-all-completions' for tramp files." 398 "Like `file-name-all-completions' for Tramp files."
401 (with-parsed-tramp-file-name directory nil 399 (all-completions
402 (save-match-data 400 filename
403 (save-excursion 401 (with-parsed-tramp-file-name directory nil
404 (let* ((share (tramp-smb-get-share localname)) 402 (with-file-property v localname "file-name-all-completions"
405 (file (tramp-smb-get-localname localname nil)) 403 (save-match-data
406 (entries (tramp-smb-get-file-entries user host share file))) 404 (let ((entries (tramp-smb-get-file-entries directory)))
407
408 (all-completions
409 filename
410 (mapcar 405 (mapcar
411 (lambda (x) 406 (lambda (x)
412 (list 407 (list
@@ -416,51 +411,59 @@ KEEP-DATE is not handled in case NEWNAME resides on an SMB server."
416 entries))))))) 411 entries)))))))
417 412
418(defun tramp-smb-handle-file-newer-than-file-p (file1 file2) 413(defun tramp-smb-handle-file-newer-than-file-p (file1 file2)
419 "Like `file-newer-than-file-p' for tramp files." 414 "Like `file-newer-than-file-p' for Tramp files."
420 (cond 415 (cond
421 ((not (file-exists-p file1)) nil) 416 ((not (file-exists-p file1)) nil)
422 ((not (file-exists-p file2)) t) 417 ((not (file-exists-p file2)) t)
423 (t (tramp-smb-time-less-p (file-attributes file2) 418 (t (tramp-time-less-p (nth 5 (file-attributes file2))
424 (file-attributes file1))))) 419 (nth 5 (file-attributes file1))))))
425 420
426(defun tramp-smb-handle-file-writable-p (filename) 421(defun tramp-smb-handle-file-writable-p (filename)
427 "Like `file-writable-p' for tramp files." 422 "Like `file-writable-p' for Tramp files."
428 (if (not (file-exists-p filename)) 423 (if (file-exists-p filename)
429 (let ((dir (file-name-directory filename))) 424 (string-match "w" (or (nth 8 (file-attributes filename)) ""))
430 (and (file-exists-p dir) 425 (let ((dir (file-name-directory filename)))
431 (file-writable-p dir))) 426 (and (file-exists-p dir)
432 (with-parsed-tramp-file-name filename nil 427 (file-writable-p dir)))))
433 (save-excursion
434 (let* ((share (tramp-smb-get-share localname))
435 (file (tramp-smb-get-localname localname nil))
436 (entries (tramp-smb-get-file-entries user host share file))
437 (entry (and entries
438 (assoc (file-name-nondirectory file) entries))))
439 (and share entry
440 (string-match "w" (nth 1 entry))
441 t))))))
442 428
443(defun tramp-smb-handle-insert-directory 429(defun tramp-smb-handle-insert-directory
444 (filename switches &optional wildcard full-directory-p) 430 (filename switches &optional wildcard full-directory-p)
445 "Like `insert-directory' for tramp files. 431 "Like `insert-directory' for Tramp files."
446WILDCARD and FULL-DIRECTORY-P are not handled."
447 (setq filename (expand-file-name filename)) 432 (setq filename (expand-file-name filename))
448 (when (file-directory-p filename) 433 (when full-directory-p
449 ;; This check is a little bit strange, but in `dired-add-entry' 434 ;; Called from `dired-add-entry'.
450 ;; this function is called with a non-directory ...
451 (setq filename (file-name-as-directory filename))) 435 (setq filename (file-name-as-directory filename)))
452 (with-parsed-tramp-file-name filename nil 436 (with-parsed-tramp-file-name filename nil
437 (tramp-flush-file-property v (file-name-directory localname))
453 (save-match-data 438 (save-match-data
454 (let* ((share (tramp-smb-get-share localname)) 439 (let ((base (file-name-nondirectory filename))
455 (file (tramp-smb-get-localname localname nil)) 440 ;; We should not destroy the cache entry.
456 (entries (tramp-smb-get-file-entries user host share file))) 441 (entries (copy-sequence
457 442 (tramp-smb-get-file-entries
458 ;; Delete dummy "" entry, useless entries 443 (file-name-directory filename)))))
444
445 (when wildcard
446 (string-match "\\." base)
447 (setq base (replace-match "\\\\." nil nil base))
448 (string-match "\\*" base)
449 (setq base (replace-match ".*" nil nil base))
450 (string-match "\\?" base)
451 (setq base (replace-match ".?" nil nil base)))
452
453 ;; Filter entries.
459 (setq entries 454 (setq entries
460 (if (file-directory-p filename) 455 (delq
461 (delq (assoc "" entries) entries) 456 nil
462 ;; We just need the only and only entry FILENAME. 457 (if (or wildcard (zerop (length base)))
463 (list (assoc (file-name-nondirectory filename) entries)))) 458 ;; Check for matching entries.
459 (mapcar
460 (lambda (x)
461 (when (string-match
462 (format "^%s" base) (nth 0 x))
463 x))
464 entries)
465 ;; We just need the only and only entry FILENAME.
466 (list (assoc base entries)))))
464 467
465 ;; Sort entries 468 ;; Sort entries
466 (setq entries 469 (setq entries
@@ -468,37 +471,38 @@ WILDCARD and FULL-DIRECTORY-P are not handled."
468 entries 471 entries
469 (lambda (x y) 472 (lambda (x y)
470 (if (string-match "t" switches) 473 (if (string-match "t" switches)
471 ; sort by date 474 ;; Sort by date.
472 (tramp-smb-time-less-p (nth 3 y) (nth 3 x)) 475 (tramp-time-less-p (nth 3 y) (nth 3 x))
473 ; sort by name 476 ;; Sort by name.
474 (string-lessp (nth 0 x) (nth 0 y)))))) 477 (string-lessp (nth 0 x) (nth 0 y))))))
475 478
476 ;; Print entries 479 ;; Print entries.
477 (mapcar 480 (mapcar
478 (lambda (x) 481 (lambda (x)
479 (insert 482 (when (not (zerop (length (nth 0 x))))
480 (format 483 (insert
481 "%10s %3d %-8s %-8s %8s %s %s\n" 484 (format
482 (nth 1 x) ; mode 485 "%10s %3d %-8s %-8s %8s %s %s\n"
483 1 "nobody" "nogroup" 486 (nth 1 x) ; mode
484 (nth 2 x) ; size 487 1 "nobody" "nogroup"
485 (format-time-string 488 (nth 2 x) ; size
486 (if (tramp-smb-time-less-p 489 (format-time-string
487 (tramp-smb-time-subtract (current-time) (nth 3 x)) 490 (if (tramp-time-less-p
488 tramp-smb-half-a-year) 491 (tramp-time-subtract (current-time) (nth 3 x))
489 "%b %e %R" 492 tramp-half-a-year)
490 "%b %e %Y") 493 "%b %e %R"
491 (nth 3 x)) ; date 494 "%b %e %Y")
492 (nth 0 x))) ; file name 495 (nth 3 x)) ; date
493 (forward-line) 496 (nth 0 x))) ; file name
494 (beginning-of-line)) 497 (forward-line)
495 entries))))) 498 (beginning-of-line)))
499 entries)))))
496 500
497(defun tramp-smb-handle-make-directory (dir &optional parents) 501(defun tramp-smb-handle-make-directory (dir &optional parents)
498 "Like `make-directory' for tramp files." 502 "Like `make-directory' for Tramp files."
499 (setq dir (directory-file-name (expand-file-name dir))) 503 (setq dir (directory-file-name (expand-file-name dir)))
500 (unless (file-name-absolute-p dir) 504 (unless (file-name-absolute-p dir)
501 (setq dir (concat default-directory dir))) 505 (setq dir (expand-file-name dir default-directory)))
502 (with-parsed-tramp-file-name dir nil 506 (with-parsed-tramp-file-name dir nil
503 (save-match-data 507 (save-match-data
504 (let* ((share (tramp-smb-get-share localname)) 508 (let* ((share (tramp-smb-get-share localname))
@@ -510,26 +514,28 @@ WILDCARD and FULL-DIRECTORY-P are not handled."
510 (when (file-directory-p ldir) 514 (when (file-directory-p ldir)
511 (make-directory-internal dir)) 515 (make-directory-internal dir))
512 (unless (file-directory-p dir) 516 (unless (file-directory-p dir)
513 (error "Couldn't make directory %s" dir)))))) 517 (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
514 518
515(defun tramp-smb-handle-make-directory-internal (directory) 519(defun tramp-smb-handle-make-directory-internal (directory)
516 "Like `make-directory-internal' for tramp files." 520 "Like `make-directory-internal' for Tramp files."
517 (setq directory (directory-file-name (expand-file-name directory))) 521 (setq directory (directory-file-name (expand-file-name directory)))
518 (unless (file-name-absolute-p directory) 522 (unless (file-name-absolute-p directory)
519 (setq directory (concat default-directory directory))) 523 (setq directory (expand-file-name directory default-directory)))
520 (with-parsed-tramp-file-name directory nil 524 (with-parsed-tramp-file-name directory nil
521 (save-match-data 525 (save-match-data
522 (let* ((share (tramp-smb-get-share localname)) 526 (let* ((file (tramp-smb-get-localname localname t)))
523 (file (tramp-smb-get-localname localname nil)))
524 (when (file-directory-p (file-name-directory directory)) 527 (when (file-directory-p (file-name-directory directory))
525 (tramp-smb-maybe-open-connection user host share) 528 (tramp-smb-send-command v (format "mkdir \"%s\"" file))
526 (tramp-smb-send-command user host (format "mkdir \"%s\"" file))) 529 ;; We must also flush the cache of the directory, because
530 ;; file-attributes reads the values from there.
531 (tramp-flush-file-property v (file-name-directory localname)))
527 (unless (file-directory-p directory) 532 (unless (file-directory-p directory)
528 (error "Couldn't make directory %s" directory)))))) 533 (tramp-error
534 v 'file-error "Couldn't make directory %s" directory))))))
529 535
530(defun tramp-smb-handle-rename-file 536(defun tramp-smb-handle-rename-file
531 (filename newname &optional ok-if-already-exists) 537 (filename newname &optional ok-if-already-exists)
532 "Like `rename-file' for tramp files." 538 "Like `rename-file' for Tramp files."
533 (setq filename (expand-file-name filename) 539 (setq filename (expand-file-name filename)
534 newname (expand-file-name newname)) 540 newname (expand-file-name newname))
535 541
@@ -543,29 +549,26 @@ WILDCARD and FULL-DIRECTORY-P are not handled."
543 (when (file-directory-p newname) 549 (when (file-directory-p newname)
544 (setq newname (expand-file-name 550 (setq newname (expand-file-name
545 (file-name-nondirectory filename) newname))) 551 (file-name-nondirectory filename) newname)))
546 (when (and (not ok-if-already-exists)
547 (file-exists-p newname))
548 (error "rename-file: file %s already exists" newname))
549 552
550 (with-parsed-tramp-file-name newname nil 553 (with-parsed-tramp-file-name newname nil
551 (save-excursion 554 (when (and (not ok-if-already-exists)
552 (let ((share (tramp-smb-get-share localname)) 555 (file-exists-p newname))
553 (file (tramp-smb-get-localname localname t))) 556 (tramp-error v 'file-already-exists newname))
554 (tramp-smb-maybe-open-connection user host share) 557 ;; We must also flush the cache of the directory, because
555 (tramp-message-for-buffer 558 ;; file-attributes reads the values from there.
556 nil tramp-smb-method user host 559 (tramp-flush-file-property v (file-name-directory localname))
557 5 "Copying file %s to file %s..." filename newname) 560 (tramp-flush-file-property v localname)
558 (if (tramp-smb-send-command 561 (let ((file (tramp-smb-get-localname localname t)))
559 user host (format "put %s \"%s\"" filename file)) 562 (tramp-message v 0 "Copying file %s to file %s..." filename newname)
560 (tramp-message-for-buffer 563 (if (tramp-smb-send-command v (format "put %s \"%s\"" filename file))
561 nil tramp-smb-method user host 564 (tramp-message
562 5 "Copying file %s to file %s...done" filename newname) 565 v 0 "Copying file %s to file %s...done" filename newname)
563 (error "Cannot rename `%s'" filename))))))) 566 (tramp-error v 'file-error "Cannot rename `%s'" filename))))))
564 567
565 (delete-file filename)) 568 (delete-file filename))
566 569
567(defun tramp-smb-handle-substitute-in-file-name (filename) 570(defun tramp-smb-handle-substitute-in-file-name (filename)
568 "Like `handle-substitute-in-file-name' for tramp files. 571 "Like `handle-substitute-in-file-name' for Tramp files.
569Catches errors for shares like \"C$/\", which are common in Microsoft Windows." 572Catches errors for shares like \"C$/\", which are common in Microsoft Windows."
570 (condition-case nil 573 (condition-case nil
571 (tramp-run-real-handler 'substitute-in-file-name (list filename)) 574 (tramp-run-real-handler 'substitute-in-file-name (list filename))
@@ -573,50 +576,49 @@ Catches errors for shares like \"C$/\", which are common in Microsoft Windows."
573 576
574(defun tramp-smb-handle-write-region 577(defun tramp-smb-handle-write-region
575 (start end filename &optional append visit lockname confirm) 578 (start end filename &optional append visit lockname confirm)
576 "Like `write-region' for tramp files." 579 "Like `write-region' for Tramp files."
577 (unless (eq append nil)
578 (error "Cannot append to file using tramp (`%s')" filename))
579 (setq filename (expand-file-name filename)) 580 (setq filename (expand-file-name filename))
580 ;; XEmacs takes a coding system as the seventh argument, not `confirm'
581 (when (and (not (featurep 'xemacs))
582 confirm (file-exists-p filename))
583 (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
584 filename))
585 (error "File not overwritten")))
586 (with-parsed-tramp-file-name filename nil 581 (with-parsed-tramp-file-name filename nil
587 (save-excursion 582 (unless (eq append nil)
588 (let ((share (tramp-smb-get-share localname)) 583 (tramp-error
589 (file (tramp-smb-get-localname localname t)) 584 v 'file-error "Cannot append to file using tramp (`%s')" filename))
590 (curbuf (current-buffer)) 585 ;; XEmacs takes a coding system as the seventh argument, not `confirm'
591 tmpfil) 586 (when (and (not (featurep 'xemacs))
592 ;; Write region into a tmp file. 587 confirm (file-exists-p filename))
593 (setq tmpfil (tramp-make-temp-file filename)) 588 (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
594 ;; We say `no-message' here because we don't want the visited file 589 filename))
595 ;; modtime data to be clobbered from the temp file. We call 590 (tramp-error v 'file-error "File not overwritten")))
596 ;; `set-visited-file-modtime' ourselves later on. 591 ;; We must also flush the cache of the directory, because
597 (tramp-run-real-handler 592 ;; file-attributes reads the values from there.
598 'write-region 593 (tramp-flush-file-property v (file-name-directory localname))
599 (if confirm ; don't pass this arg unless defined for backward compat. 594 (tramp-flush-file-property v localname)
600 (list start end tmpfil append 'no-message lockname confirm) 595 (let ((file (tramp-smb-get-localname localname t))
601 (list start end tmpfil append 'no-message lockname))) 596 (curbuf (current-buffer))
602 597 tmpfil)
603 (tramp-smb-maybe-open-connection user host share) 598 ;; Write region into a tmp file.
604 (tramp-message-for-buffer 599 (setq tmpfil (tramp-make-temp-file filename))
605 nil tramp-smb-method user host 600 ;; We say `no-message' here because we don't want the visited file
606 5 "Writing tmp file %s to file %s..." tmpfil filename) 601 ;; modtime data to be clobbered from the temp file. We call
607 (if (tramp-smb-send-command 602 ;; `set-visited-file-modtime' ourselves later on.
608 user host (format "put %s \"%s\"" tmpfil file)) 603 (tramp-run-real-handler
609 (tramp-message-for-buffer 604 'write-region
610 nil tramp-smb-method user host 605 (if confirm ; don't pass this arg unless defined for backward compat.
611 5 "Writing tmp file %s to file %s...done" tmpfil filename) 606 (list start end tmpfil append 'no-message lockname confirm)
612 (error "Cannot write `%s'" filename)) 607 (list start end tmpfil append 'no-message lockname)))
613 608
614 (delete-file tmpfil) 609 (tramp-message v 5 "Writing tmp file %s to file %s..." tmpfil filename)
615 (unless (equal curbuf (current-buffer)) 610 (if (tramp-smb-send-command v (format "put %s \"%s\"" tmpfil file))
616 (error "Buffer has changed from `%s' to `%s'" 611 (tramp-message
617 curbuf (current-buffer))) 612 v 5 "Writing tmp file %s to file %s...done" tmpfil filename)
618 (when (eq visit t) 613 (tramp-error v 'file-error "Cannot write `%s'" filename))
619 (set-visited-file-modtime)))))) 614
615 (delete-file tmpfil)
616 (unless (equal curbuf (current-buffer))
617 (tramp-error
618 v 'file-error
619 "Buffer has changed from `%s' to `%s'" curbuf (current-buffer)))
620 (when (eq visit t)
621 (set-visited-file-modtime)))))
620 622
621 623
622;; Internal file name functions 624;; Internal file name functions
@@ -652,51 +654,53 @@ If CONVERT is non-nil exchange \"/\" by \"\\\\\"."
652 654
653;; Share names of a host are cached. It is very unlikely that the 655;; Share names of a host are cached. It is very unlikely that the
654;; shares do change during connection. 656;; shares do change during connection.
655(defun tramp-smb-get-file-entries (user host share localname) 657(defun tramp-smb-get-file-entries (directory)
656 "Read entries which match LOCALNAME. 658 "Read entries which match DIRECTORY.
657Either the shares are listed, or the `dir' command is executed. 659Either the shares are listed, or the `dir' command is executed.
658Only entries matching the localname are returned.
659Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." 660Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
660 (save-excursion 661 (with-parsed-tramp-file-name directory nil
661 (save-match-data 662 (setq localname (or localname "/"))
662 (let ((base (or (and (> (length localname) 0) 663 (with-file-property v localname "file-entries"
663 (string-match "\\([^/]+\\)$" localname) 664 (with-current-buffer (tramp-get-buffer v)
664 (regexp-quote (match-string 1 localname))) 665 (let* ((share (tramp-smb-get-share localname))
665 "")) 666 (file (tramp-smb-get-localname localname nil))
666 res entry) 667 (cache (tramp-get-connection-property v "share-cache" nil))
667 (set-buffer (tramp-get-buffer nil tramp-smb-method user host)) 668 res entry)
668 (if (and (not share) tramp-smb-share-cache) 669
669 ;; Return cached shares 670 (if (and (not share) cache)
670 (setq res tramp-smb-share-cache) 671 ;; Return cached shares
671 ;; Read entries 672 (setq res cache)
672 (tramp-smb-maybe-open-connection user host share) 673
673 (when share 674 ;; Read entries
674 (tramp-smb-send-command 675 (setq file (file-name-as-directory file))
675 user host 676 (when (string-match "^\\./" file)
676 (format "dir %s" 677 (setq file (substring file 1)))
677 (if (zerop (length localname)) "" (concat "\"" localname "*\""))))) 678 (if share
678 (goto-char (point-min)) 679 (tramp-smb-send-command v (format "dir \"%s*\"" file))
679 ;; Loop the listing 680 ;; `tramp-smb-maybe-open-connection' lists also the share names
680 (unless (re-search-forward tramp-smb-errors nil t) 681 (tramp-smb-maybe-open-connection v))
681 (while (not (eobp)) 682
682 (setq entry (tramp-smb-read-file-entry share)) 683 ;; Loop the listing
683 (forward-line) 684 (goto-char (point-min))
684 (when entry (add-to-list 'res entry)))) 685 (unless (re-search-forward tramp-smb-errors nil t)
685 (unless share 686 (while (not (eobp))
687 (setq entry (tramp-smb-read-file-entry share))
688 (forward-line)
689 (when entry (add-to-list 'res entry))))
690
686 ;; Cache share entries 691 ;; Cache share entries
687 (setq tramp-smb-share-cache res))) 692 (unless share
693 (tramp-set-connection-property v "share-cache" res)))
688 694
689 ;; Add directory itself 695 ;; Add directory itself
690 (add-to-list 'res '("" "drwxrwxrwx" 0 (0 0))) 696 (add-to-list 'res '("" "drwxrwxrwx" 0 (0 0)))
691 697
692 ;; There's a very strange error (debugged with XEmacs 21.4.14) 698 ;; There's a very strange error (debugged with XEmacs 21.4.14)
693 ;; If there's no short delay, it returns nil. No idea about 699 ;; If there's no short delay, it returns nil. No idea about.
694 (when (featurep 'xemacs) (sleep-for 0.01)) 700 (when (featurep 'xemacs) (sleep-for 0.01))
695 701
696 ;; Check for matching entries 702 ;; Return entries
697 (delq nil (mapcar 703 (delq nil res))))))
698 (lambda (x) (and (string-match base (nth 0 x)) x))
699 res))))))
700 704
701;; Return either a share name (if SHARE is nil), or a file name 705;; Return either a share name (if SHARE is nil), or a file name
702;; 706;;
@@ -721,7 +725,7 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
721;; \s- - space delimeter 725;; \s- - space delimeter
722;; \w\{3,3\} - month 726;; \w\{3,3\} - month
723;; \s- - space delimeter 727;; \s- - space delimeter
724;; [ 19][0-9] - day 728;; [ 12][0-9] - day
725;; \s- - space delimeter 729;; \s- - space delimeter
726;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time 730;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time
727;; \s- - space delimeter 731;; \s- - space delimeter
@@ -756,18 +760,20 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
756 "Parse entry in SMB output buffer. 760 "Parse entry in SMB output buffer.
757If SHARE is result, entries are of type dir. Otherwise, shares are listed. 761If SHARE is result, entries are of type dir. Otherwise, shares are listed.
758Result is the list (LOCALNAME MODE SIZE MTIME)." 762Result is the list (LOCALNAME MODE SIZE MTIME)."
759 (let ((line (buffer-substring (point) (tramp-point-at-eol))) 763;; We are called from `tramp-smb-get-file-entries', which sets the
764;; current buffer.
765 (let ((line (buffer-substring (point) (tramp-line-end-position)))
760 localname mode size month day hour min sec year mtime) 766 localname mode size month day hour min sec year mtime)
761 767
762 (if (not share) 768 (if (not share)
763 769
764 ; Read share entries 770 ;; Read share entries.
765 (when (string-match "^\\s-+\\(\\S-+\\)\\s-+Disk" line) 771 (when (string-match "^\\s-+\\(\\S-\\(.*\\S-\\)?\\)\\s-+Disk" line)
766 (setq localname (match-string 1 line) 772 (setq localname (match-string 1 line)
767 mode "dr-xr-xr-x" 773 mode "dr-xr-xr-x"
768 size 0)) 774 size 0))
769 775
770 ; Real listing 776 ;; Real listing.
771 (block nil 777 (block nil
772 778
773 ;; year 779 ;; year
@@ -833,219 +839,186 @@ Result is the list (LOCALNAME MODE SIZE MTIME)."
833 (if (and sec min hour day month year) 839 (if (and sec min hour day month year)
834 (encode-time 840 (encode-time
835 sec min hour day 841 sec min hour day
836 (cdr (assoc (downcase month) tramp-smb-parse-time-months)) 842 (cdr (assoc (downcase month) tramp-parse-time-months))
837 year) 843 year)
838 '(0 0))) 844 '(0 0)))
839 (list localname mode size mtime)))) 845 (list localname mode size mtime))))
840 846
841;; Inodes don't exist for SMB files. Therefore we must generate virtual ones.
842;; Used in `find-buffer-visiting'.
843;; The method applied might be not so efficient (Ange-FTP uses hashes). But
844;; performance isn't the major issue given that file transfer will take time.
845
846(defun tramp-smb-get-inode (share file)
847 "Returns the virtual inode number.
848If it doesn't exist, generate a new one."
849 (let ((string (concat share "/" (directory-file-name file))))
850 (unless (assoc string tramp-smb-inodes)
851 (add-to-list 'tramp-smb-inodes
852 (list string (length tramp-smb-inodes))))
853 (nth 1 (assoc string tramp-smb-inodes))))
854
855 847
856;; Connection functions 848;; Connection functions
857 849
858(defun tramp-smb-send-command (user host command) 850(defun tramp-smb-send-command (vec command)
859 "Send the COMMAND to USER at HOST (logged into an SMB session). 851 "Send the COMMAND to connection VEC.
860Erases temporary buffer before sending the command. Returns nil if 852Returns nil if there has been an error message from smbclient."
861there has been an error message from smbclient." 853 (tramp-smb-maybe-open-connection vec)
862 (save-excursion 854 (tramp-message vec 6 "%s" command)
863 (set-buffer (tramp-get-buffer nil tramp-smb-method user host)) 855 (tramp-send-string vec command)
864 (erase-buffer) 856 (tramp-smb-wait-for-output vec))
865 (tramp-send-command nil tramp-smb-method user host command nil t) 857
866 (tramp-smb-wait-for-output user host))) 858(defun tramp-smb-maybe-open-connection (vec)
867 859 "Maybe open a connection to HOST, log in as USER, using `tramp-smb-program'.
868(defun tramp-smb-maybe-open-connection (user host share)
869 "Maybe open a connection to HOST, logging in as USER, using `tramp-smb-program'.
870Does not do anything if a connection is already open, but re-opens the 860Does not do anything if a connection is already open, but re-opens the
871connection if a previous connection has died for some reason." 861connection if a previous connection has died for some reason."
872 (let ((process-connection-type tramp-process-connection-type) 862 (let* ((share (tramp-smb-get-share (tramp-file-name-localname vec)))
873 (p (get-buffer-process 863 (buf (tramp-get-buffer vec))
874 (tramp-get-buffer nil tramp-smb-method user host)))) 864 (p (get-buffer-process buf)))
875 (save-excursion
876 (set-buffer (tramp-get-buffer nil tramp-smb-method user host))
877 ;; Check whether it is still the same share
878 (unless (and p (processp p) (string-equal tramp-smb-share share))
879 (when (and p (processp p))
880 (delete-process p)
881 (setq p nil)))
882 ;; If too much time has passed since last command was sent, look
883 ;; whether process is still alive. If it isn't, kill it.
884 (when (and tramp-last-cmd-time
885 (> (tramp-time-diff (current-time) tramp-last-cmd-time) 60)
886 p (processp p) (memq (process-status p) '(run open)))
887 (unless (and p (processp p) (memq (process-status p) '(run open)))
888 (delete-process p)
889 (setq p nil))))
890 (unless (and p (processp p) (memq (process-status p) '(run open)))
891 (when (and p (processp p))
892 (delete-process p))
893 (tramp-smb-open-connection user host share))))
894
895(defun tramp-smb-open-connection (user host share)
896 "Open a connection using `tramp-smb-program'.
897This starts the command `smbclient //HOST/SHARE -U USER', then waits
898for a remote password prompt. It queries the user for the password,
899then sends the password to the remote host.
900
901Domain names in USER and port numbers in HOST are acknowledged."
902
903 (when (and (fboundp 'executable-find)
904 (not (funcall 'executable-find tramp-smb-program)))
905 (error "Cannot find command %s in %s" tramp-smb-program exec-path))
906 865
907 (save-match-data 866 ;; If too much time has passed since last command was sent, look
908 (let* ((buffer (tramp-get-buffer nil tramp-smb-method user host)) 867 ;; whether has been an error message; maybe due to connection timeout.
909 (real-user user) 868 (with-current-buffer buf
910 (real-host host) 869 (goto-char (point-min))
911 domain port args) 870 (when (and (> (tramp-time-diff
912 871 (current-time)
913 ; Check for domain ("user%domain") and port ("host#port") 872 (tramp-get-connection-property
914 (when (and user (string-match "\\(.+\\)%\\(.+\\)" user)) 873 p "last-cmd-time" '(0 0 0)))
915 (setq real-user (or (match-string 1 user) user) 874 60)
916 domain (match-string 2 user))) 875 p (processp p) (memq (process-status p) '(run open))
917 876 (re-search-forward tramp-smb-errors nil t))
918 (when (and host (string-match "\\(.+\\)#\\(.+\\)" host)) 877 (delete-process p)
919 (setq real-host (or (match-string 1 host) host) 878 (setq p nil)))
920 port (match-string 2 host))) 879
921 880 ;; Check whether it is still the same share.
922 (if share 881 (unless
923 (setq args (list (concat "//" real-host "/" share))) 882 (and p (processp p) (memq (process-status p) '(run open))
924 (setq args (list "-L" real-host ))) 883 (string-equal
925 884 share
926 (if real-user 885 (tramp-get-connection-property p "smb-share" "")))
927 (setq args (append args (list "-U" real-user))) 886
928 (setq args (append args (list "-N")))) 887 (save-match-data
929 888 ;; There might be unread output from checking for share names.
930 (when domain (setq args (append args (list "-W" domain)))) 889 (when buf (with-current-buffer buf (erase-buffer)))
931 (when port (setq args (append args (list "-p" port)))) 890 (when (and p (processp p)) (delete-process p))
932 891
933 ; OK, let's go 892 (unless (let ((default-directory
934 (tramp-pre-connection nil tramp-smb-method user host tramp-chunksize) 893 (tramp-temporary-file-directory)))
935 (tramp-message 7 "Opening connection for //%s@%s/%s..." 894 (executable-find tramp-smb-program))
936 user host (or share "")) 895 (error "Cannot find command %s in %s" tramp-smb-program exec-path))
937 896
938 (let* ((default-directory (tramp-temporary-file-directory)) 897 (let* ((user (tramp-file-name-user vec))
939 ;; If we omit the conditional here, then we would use 898 (host (tramp-file-name-host vec))
940 ;; `undecided-dos' in some cases. With the conditional, 899 (real-user user)
941 ;; we use nil in these cases. Which one is right? 900 (real-host host)
942 (coding-system-for-read (unless (and (not (featurep 'xemacs)) 901 domain port args)
943 (> emacs-major-version 20)) 902
944 tramp-dos-coding-system)) 903 ;; Check for domain ("user%domain") and port ("host#port").
945 (p (apply #'start-process (buffer-name buffer) buffer 904 (when (and user (string-match "\\(.+\\)%\\(.+\\)" user))
946 tramp-smb-program args))) 905 (setq real-user (or (match-string 1 user) user)
947 906 domain (match-string 2 user)))
948 (tramp-message 9 "Started process %s" (process-command p)) 907
949 (tramp-set-process-query-on-exit-flag p nil) 908 (when (and host (string-match "\\(.+\\)#\\(.+\\)" host))
950 (set-buffer buffer) 909 (setq real-host (or (match-string 1 host) host)
951 (setq tramp-smb-share share) 910 port (match-string 2 host)))
952 911
953 ; send password 912 (if share
954 (when real-user 913 (setq args (list (concat "//" real-host "/" share)))
955 (let ((pw-prompt "Password:")) 914 (setq args (list "-L" real-host )))
956 (tramp-message 9 "Sending password") 915
957 (tramp-enter-password p pw-prompt user host))) 916 (if (not (zerop (length real-user)))
958 917 (setq args (append args (list "-U" real-user)))
959 (unless (tramp-smb-wait-for-output user host) 918 (setq args (append args (list "-N"))))
960 (tramp-clear-passwd user host) 919
961 (error "Cannot open connection //%s@%s/%s" 920 (when domain (setq args (append args (list "-W" domain))))
962 user host (or share ""))))))) 921 (when port (setq args (append args (list "-p" port))))
922 (setq args (append args (list "-s" "/dev/null")))
923
924 ;; OK, let's go.
925 (tramp-message
926 vec 3 "Opening connection for //%s%s/%s..."
927 (if (not (zerop (length user))) (concat user "@") "")
928 host (or share ""))
929
930 (let* ((coding-system-for-read nil)
931 (process-connection-type tramp-process-connection-type)
932 (p (let ((default-directory (tramp-temporary-file-directory)))
933 (apply #'start-process
934 (tramp-buffer-name vec) (tramp-get-buffer vec)
935 tramp-smb-program args))))
936
937 (tramp-message
938 vec 6 "%s" (mapconcat 'identity (process-command p) " "))
939 (set-process-sentinel p 'tramp-flush-connection-property)
940 (tramp-set-process-query-on-exit-flag p nil)
941 (tramp-set-connection-property p "smb-share" share)
942
943 ;; Set variables for computing the prompt for reading password.
944 (setq tramp-current-method tramp-smb-method
945 tramp-current-user user
946 tramp-current-host host)
947
948 ;; Set chunksize. Otherwise, `tramp-send-string' might
949 ;; try it itself.
950 (tramp-set-connection-property p "chunksize" tramp-chunksize)
951
952 ;; Play login scenario.
953 (tramp-process-actions
954 p vec
955 (if share
956 tramp-smb-actions-with-share
957 tramp-smb-actions-without-share))
958
959 (tramp-message
960 vec 3 "Opening connection for //%s%s/%s...done"
961 (if (not (zerop (length user))) (concat user "@") "")
962 host (or share ""))))))))
963 963
964;; We don't use timeouts. If needed, the caller shall wrap around. 964;; We don't use timeouts. If needed, the caller shall wrap around.
965(defun tramp-smb-wait-for-output (user host) 965(defun tramp-smb-wait-for-output (vec)
966 "Wait for output from smbclient command. 966 "Wait for output from smbclient command.
967Returns nil if an error message has appeared." 967Returns nil if an error message has appeared."
968 (let ((proc (get-buffer-process (current-buffer))) 968 (with-current-buffer (tramp-get-buffer vec)
969 (found (progn (goto-char (point-min)) 969 (let ((p (get-buffer-process (current-buffer)))
970 (re-search-forward tramp-smb-prompt nil t))) 970 (found (progn (goto-char (point-min))
971 (err (progn (goto-char (point-min)) 971 (re-search-forward tramp-smb-prompt nil t)))
972 (re-search-forward tramp-smb-errors nil t)))) 972 (err (progn (goto-char (point-min))
973 973 (re-search-forward tramp-smb-errors nil t))))
974 ;; Algorithm: get waiting output. See if last line contains
975 ;; tramp-smb-prompt sentinel or tramp-smb-errors strings.
976 ;; If not, wait a bit and again get waiting output.
977 (while (not found)
978
979 ;; Accept pending output.
980 (tramp-accept-process-output proc)
981
982 ;; Search for prompt.
983 (goto-char (point-min))
984 (setq found (re-search-forward tramp-smb-prompt nil t))
985
986 ;; Search for errors.
987 (goto-char (point-min))
988 (setq err (re-search-forward tramp-smb-errors nil t)))
989 974
990 ;; Add output to debug buffer if appropriate. 975 ;; Algorithm: get waiting output. See if last line contains
991 (when tramp-debug-buffer 976 ;; tramp-smb-prompt sentinel or tramp-smb-errors strings.
992 (append-to-buffer 977 ;; If not, wait a bit and again get waiting output.
993 (tramp-get-debug-buffer nil tramp-smb-method user host) 978 (while (and (not found) (not err))
994 (point-min) (point-max)))
995 979
996 ;; Return value is whether no error message has appeared. 980 ;; Accept pending output.
997 (not err))) 981 (tramp-accept-process-output p)
998 982
983 ;; Search for prompt.
984 (goto-char (point-min))
985 (setq found (re-search-forward tramp-smb-prompt nil t))
999 986
1000;; Snarfed code from time-date.el and parse-time.el 987 ;; Search for errors.
988 (goto-char (point-min))
989 (setq err (re-search-forward tramp-smb-errors nil t)))
1001 990
1002(defconst tramp-smb-half-a-year '(241 17024) 991 ;; When the process is still alive, read pending output.
1003"Evaluated by \"(days-to-time 183)\".") 992 (while (and (not found) (memq (process-status p) '(run open)))
1004 993
1005(defconst tramp-smb-parse-time-months '(("jan" . 1) ("feb" . 2) ("mar" . 3) 994 ;; Accept pending output.
1006 ("apr" . 4) ("may" . 5) ("jun" . 6) 995 (tramp-accept-process-output p)
1007 ("jul" . 7) ("aug" . 8) ("sep" . 9)
1008 ("oct" . 10) ("nov" . 11) ("dec" . 12))
1009"Alist mapping month names to integers.")
1010 996
1011(defun tramp-smb-time-less-p (t1 t2) 997 ;; Search for prompt.
1012 "Say whether time value T1 is less than time value T2." 998 (goto-char (point-min))
1013 (unless t1 (setq t1 '(0 0))) 999 (setq found (re-search-forward tramp-smb-prompt nil t)))
1014 (unless t2 (setq t2 '(0 0)))
1015 (or (< (car t1) (car t2))
1016 (and (= (car t1) (car t2))
1017 (< (nth 1 t1) (nth 1 t2)))))
1018 1000
1019(defun tramp-smb-time-subtract (t1 t2) 1001 ;; Return value is whether no error message has appeared.
1020 "Subtract two time values. 1002 (tramp-message vec 6 "\n%s" (buffer-string))
1021Return the difference in the format of a time value." 1003 (not err))))
1022 (unless t1 (setq t1 '(0 0)))
1023 (unless t2 (setq t2 '(0 0)))
1024 (let ((borrow (< (cadr t1) (cadr t2))))
1025 (list (- (car t1) (car t2) (if borrow 1 0))
1026 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
1027 1004
1028 1005
1029(provide 'tramp-smb) 1006(provide 'tramp-smb)
1030 1007
1031;;; TODO: 1008;;; TODO:
1032 1009
1033;; * Provide a local smb.conf. The default one might not be readable.
1034;; * Error handling in case password is wrong. 1010;; * Error handling in case password is wrong.
1035;; * Read password from "~/.netrc". 1011;; * Read password from "~/.netrc".
1036;; * Return more comprehensive file permission string. Think whether it is 1012;; * Return more comprehensive file permission string. Think whether it is
1037;; possible to implement `set-file-modes'. 1013;; possible to implement `set-file-modes'.
1038;; * Handle WILDCARD and FULL-DIRECTORY-P in
1039;; `tramp-smb-handle-insert-directory'.
1040;; * Handle links (FILENAME.LNK). 1014;; * Handle links (FILENAME.LNK).
1041;; * Maybe local tmp files should have the same extension like the original 1015;; * Maybe local tmp files should have the same extension like the original
1042;; files. Strange behaviour with jka-compr otherwise? 1016;; files. Strange behaviour with jka-compr otherwise?
1043;; * Copy files in dired from SMB to another method doesn't work.
1044;; * Try to remove the inclusion of dummy "" directory. Seems to be at 1017;; * Try to remove the inclusion of dummy "" directory. Seems to be at
1045;; several places, especially in `tramp-smb-handle-insert-directory'. 1018;; several places, especially in `tramp-smb-handle-insert-directory'.
1046;; * Provide variables for debug.
1047;; * (RMS) Use unwind-protect to clean up the state so as to make the state 1019;; * (RMS) Use unwind-protect to clean up the state so as to make the state
1048;; regular again. 1020;; regular again.
1021;; * Make it multi-hop capable.
1049 1022
1050;;; arch-tag: fcc9dbec-7503-4d73-b638-3c8aa59575f5 1023;;; arch-tag: fcc9dbec-7503-4d73-b638-3c8aa59575f5
1051;;; tramp-smb.el ends here 1024;;; tramp-smb.el ends here
diff --git a/lisp/net/tramp-util.el b/lisp/net/tramp-util.el
deleted file mode 100644
index 4895edf019b..00000000000
--- a/lisp/net/tramp-util.el
+++ /dev/null
@@ -1,138 +0,0 @@
1;;; -*- coding: iso-2022-7bit; -*-
2;;; tramp-util.el --- Misc utility functions to use with Tramp
3
4;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
5;; 2006, 2007 Free Software Foundation, Inc.
6
7;; Author: kai.grossjohann@gmx.net
8;; Keywords: comm, extensions, processes
9
10;; This file is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; This file is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to
22;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23;; Boston, MA 02110-1301, USA.
24
25;;; Commentary:
26
27;; Some misc. utility functions that might go nicely with Tramp.
28;; Mostly, these are kluges awaiting real solutions later on.
29
30;;; Code:
31
32(require 'compile)
33(require 'tramp)
34(add-hook 'tramp-util-unload-hook
35 '(lambda ()
36 (when (featurep 'tramp)
37 (unload-feature 'tramp 'force))))
38
39;; Define a Tramp minor mode. It's intention is to redefine some keys for Tramp
40;; specific functions, like compilation.
41;; The key remapping works since Emacs 22 only. Unknown for XEmacs.
42
43;; Pacify byte-compiler
44(eval-when-compile
45 (unless (fboundp 'define-minor-mode)
46 (defalias 'define-minor-mode 'identity)
47 (defvar tramp-minor-mode))
48 (unless (featurep 'xemacs)
49 (defalias 'add-menu-button 'ignore)))
50
51(defvar tramp-minor-mode-map (make-sparse-keymap)
52 "Keymap for Tramp minor mode.")
53
54(define-minor-mode tramp-minor-mode "Tramp minor mode for utility functions."
55 :group 'tramp
56 :global nil
57 :init-value nil
58 :lighter " Tramp"
59 :keymap tramp-minor-mode-map
60 (setq tramp-minor-mode
61 (and tramp-minor-mode (tramp-tramp-file-p default-directory))))
62
63(add-hook 'find-file-hooks 'tramp-minor-mode t)
64(add-hook 'tramp-util-unload-hook
65 '(lambda ()
66 (remove-hook 'find-file-hooks 'tramp-minor-mode)))
67
68(add-hook 'dired-mode-hook 'tramp-minor-mode t)
69(add-hook 'tramp-util-unload-hook
70 '(lambda ()
71 (remove-hook 'dired-mode-hook 'tramp-minor-mode)))
72
73(defun tramp-remap-command (old-command new-command)
74 "Replaces bindings of OLD-COMMAND by NEW-COMMAND.
75If remapping functionality for keymaps is defined, this happens for all
76bindings. Otherwise, only bindings active during invocation are taken
77into account. XEmacs menubar bindings are not changed by this."
78 (if (functionp 'command-remapping)
79 ;; Emacs 22
80 (eval
81 `(define-key tramp-minor-mode-map [remap ,old-command] new-command))
82 ;; previous Emacs versions.
83 (mapcar
84 '(lambda (x)
85 (define-key tramp-minor-mode-map x new-command))
86 (where-is-internal old-command))))
87
88(tramp-remap-command 'compile 'tramp-compile)
89(tramp-remap-command 'recompile 'tramp-recompile)
90
91;; XEmacs has an own mimic for menu entries
92(when (fboundp 'add-menu-button)
93 (funcall 'add-menu-button
94 '("Tools" "Compile")
95 ["Compile..."
96 (command-execute (if tramp-minor-mode 'tramp-compile 'compile))
97 :active (fboundp 'compile)])
98 (funcall 'add-menu-button
99 '("Tools" "Compile")
100 ["Repeat Compilation"
101 (command-execute (if tramp-minor-mode 'tramp-recompile 'recompile))
102 :active (fboundp 'compile)]))
103
104;; Utility functions.
105
106(defun tramp-compile (command)
107 "Compile on remote host."
108 (interactive
109 (if (or compilation-read-command current-prefix-arg)
110 (list (read-from-minibuffer "Compile command: "
111 compile-command nil nil
112 '(compile-history . 1)))
113 (list compile-command)))
114 (setq compile-command command)
115 (save-some-buffers (not compilation-ask-about-save) nil)
116 (let ((d default-directory))
117 (save-excursion
118 (pop-to-buffer (get-buffer-create "*Compilation*") t)
119 (erase-buffer)
120 (setq default-directory d)))
121 (tramp-handle-shell-command command (get-buffer "*Compilation*"))
122 (pop-to-buffer (get-buffer "*Compilation*"))
123 (tramp-minor-mode 1)
124 (compilation-minor-mode 1))
125
126(defun tramp-recompile ()
127 "Re-compile on remote host."
128 (interactive)
129 (save-some-buffers (not compilation-ask-about-save) nil)
130 (tramp-handle-shell-command compile-command (get-buffer "*Compilation*"))
131 (pop-to-buffer (get-buffer "*Compilation*"))
132 (tramp-minor-mode 1)
133 (compilation-minor-mode 1))
134
135(provide 'tramp-util)
136
137;;; arch-tag: 500f9992-a44e-46d0-83a7-980799251808
138;;; tramp-util.el ends here
diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el
index 32bb9857f7f..9973860efa0 100644
--- a/lisp/net/tramp-uu.el
+++ b/lisp/net/tramp-uu.el
@@ -9,8 +9,8 @@
9 9
10;; This file is free software; you can redistribute it and/or modify 10;; This file is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by 11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option) 12;; the Free Software Foundation; either version 3 of the License, or
13;; any later version. 13;; (at your option) any later version.
14 14
15;; This file is distributed in the hope that it will be useful, 15;; This file is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,9 +18,8 @@
18;; GNU General Public License for more details. 18;; GNU General Public License for more details.
19 19
20;; You should have received a copy of the GNU General Public License 20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to 21;; along with GNU Emacs; see the file COPYING. If not, see
22;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 22;; <http://www.gnu.org/licenses/>.
23;; Boston, MA 02110-1301, USA.
24 23
25;;; Commentary: 24;;; Commentary:
26 25
diff --git a/lisp/net/tramp-vc.el b/lisp/net/tramp-vc.el
deleted file mode 100644
index cc5566d6354..00000000000
--- a/lisp/net/tramp-vc.el
+++ /dev/null
@@ -1,536 +0,0 @@
1;;; tramp-vc.el --- Version control integration for TRAMP.el
2
3;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Daniel Pittman <daniel@danann.net>
7;; Keywords: comm, processes
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 2, or (at your option)
14;; 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; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;; See the main module, 'tramp.el' for discussion of the purpose of TRAMP.
29;; This module provides integration between remote files accessed by TRAMP and
30;; the Emacs version control system.
31
32;;; Code:
33
34(require 'vc)
35;; Old VC defines vc-rcs-release in vc.el, new VC requires extra module.
36(unless (boundp 'vc-rcs-release)
37 (require 'vc-rcs))
38(require 'tramp)
39
40;; Avoid byte-compiler warnings if the byte-compiler supports this.
41;; Currently, XEmacs supports this.
42(eval-when-compile
43 (when (fboundp 'byte-compiler-options)
44 (let (unused-vars) ; Pacify Emacs byte-compiler
45 (defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
46 (byte-compiler-options (warnings (- unused-vars))))))
47
48;; -- vc --
49
50;; This used to blow away the file-name-handler-alist and reinstall
51;; TRAMP into it. This was intended to let VC work remotely. It didn't,
52;; at least not in my XEmacs 21.2 install.
53;;
54;; In any case, tramp-run-real-handler now deals correctly with disabling
55;; the things that should be, making this a no-op.
56;;
57;; I have removed it from the tramp-file-name-handler-alist because the
58;; shortened version does nothing. This is for reference only now.
59;;
60;; Daniel Pittman <daniel@danann.net>
61;;
62;; (defun tramp-handle-vc-registered (file)
63;; "Like `vc-registered' for tramp files."
64;; (tramp-run-real-handler 'vc-registered (list file)))
65
66;; `vc-do-command'
67;; This function does not deal well with remote files, so we define
68;; our own version and make a backup of the original function and
69;; call our version for tramp files and the original version for
70;; normal files.
71
72;; The following function is pretty much copied from vc.el, but
73;; the part that actually executes a command is changed.
74;; CCC: this probably works for Emacs 21, too.
75(defun tramp-vc-do-command (buffer okstatus command file last &rest flags)
76 "Like `vc-do-command' but invoked for tramp files.
77See `vc-do-command' for more information."
78 (save-match-data
79 (and file (setq file (expand-file-name file)))
80 (if (not buffer) (setq buffer "*vc*"))
81 (if vc-command-messages
82 (message "Running `%s' on `%s'..." command file))
83 (let ((obuf (current-buffer)) (camefrom (current-buffer))
84 (squeezed nil)
85 (olddir default-directory)
86 vc-file status)
87 (let* ((v (tramp-dissect-file-name (expand-file-name file)))
88 (multi-method (tramp-file-name-multi-method v))
89 (method (tramp-file-name-method v))
90 (user (tramp-file-name-user v))
91 (host (tramp-file-name-host v))
92 (localname (tramp-file-name-localname v)))
93 (set-buffer (get-buffer-create buffer))
94 (set (make-local-variable 'vc-parent-buffer) camefrom)
95 (set (make-local-variable 'vc-parent-buffer-name)
96 (concat " from " (buffer-name camefrom)))
97 (setq default-directory olddir)
98
99 (erase-buffer)
100
101 (mapcar
102 (function
103 (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
104 flags)
105 (if (and (eq last 'MASTER) file
106 (setq vc-file (vc-name file)))
107 (setq squeezed
108 (append squeezed
109 (list (tramp-file-name-localname
110 (tramp-dissect-file-name vc-file))))))
111 (if (and file (eq last 'WORKFILE))
112 (progn
113 (let* ((pwd (expand-file-name default-directory))
114 (preflen (length pwd)))
115 (if (string= (substring file 0 preflen) pwd)
116 (setq file (substring file preflen))))
117 (setq squeezed (append squeezed (list file)))))
118 ;; Unless we (save-window-excursion) the layout of windows in
119 ;; the current frame changes. This is painful, at best.
120 ;;
121 ;; As a point of note, (save-excursion) is still here only because
122 ;; it preserves (point) in the current buffer. (save-window-excursion)
123 ;; does not, at least under XEmacs 21.2.
124 ;;
125 ;; I trust that the FSF support this as well. I can't find useful
126 ;; documentation to check :(
127 ;;
128 ;; Daniel Pittman <daniel@danann.net>
129 (save-excursion
130 (save-window-excursion
131 ;; Actually execute remote command
132 ;; `shell-command' cannot be used; it isn't magic in XEmacs.
133 (tramp-handle-shell-command
134 (mapconcat 'tramp-shell-quote-argument
135 (cons command squeezed) " ") t)
136 ;;(tramp-wait-for-output)
137 ;; Get status from command
138 (tramp-send-command multi-method method user host "echo $?")
139 (tramp-wait-for-output)
140 ;; Make sure to get status from last line of output.
141 (goto-char (point-max)) (forward-line -1)
142 (setq status (read (current-buffer)))
143 (message "Command %s returned status %d." command status)))
144 (goto-char (point-max))
145 (set-buffer-modified-p nil)
146 (forward-line -1)
147 (if (or (not (integerp status))
148 (and (integerp okstatus) (< okstatus status)))
149 (progn
150 (pop-to-buffer buffer)
151 (goto-char (point-min))
152 (shrink-window-if-larger-than-buffer)
153 (error "Running `%s'...FAILED (%s)" command
154 (if (integerp status)
155 (format "status %d" status)
156 status))
157 )
158 (if vc-command-messages
159 (message "Running %s...OK" command))
160 )
161 (set-buffer obuf)
162 status))
163 ))
164
165;; Following code snarfed from Emacs 21 vc.el and slightly tweaked.
166(defun tramp-vc-do-command-new (buffer okstatus command file &rest flags)
167 "Like `vc-do-command' but for TRAMP files.
168This function is for the new VC which comes with Emacs 21.
169Since TRAMP doesn't do async commands yet, this function doesn't, either."
170 (and file (setq file (expand-file-name file)))
171 (if vc-command-messages
172 (message "Running %s on %s..." command file))
173 (save-current-buffer
174 (unless (eq buffer t)
175 ; Pacify byte-compiler
176 (funcall (symbol-function 'vc-setup-buffer) buffer))
177 (let ((squeezed nil)
178 (inhibit-read-only t)
179 (status 0))
180 (let* ((v (when file (tramp-dissect-file-name file)))
181 (multi-method (when file (tramp-file-name-multi-method v)))
182 (method (when file (tramp-file-name-method v)))
183 (user (when file (tramp-file-name-user v)))
184 (host (when file (tramp-file-name-host v)))
185 (localname (when file (tramp-file-name-localname v))))
186 (setq squeezed (delq nil (copy-sequence flags)))
187 (when file
188 (setq squeezed (append squeezed (list (file-relative-name
189 file default-directory)))))
190 (let ((w32-quote-process-args t))
191 (when (eq okstatus 'async)
192 (message "Tramp doesn't do async commands, running synchronously."))
193 ;; `shell-command' cannot be used; it isn't magic in XEmacs.
194 (setq status (tramp-handle-shell-command
195 (mapconcat 'tramp-shell-quote-argument
196 (cons command squeezed) " ") t))
197 (when (or (not (integerp status))
198 (and (integerp okstatus) (< okstatus status)))
199 (pop-to-buffer (current-buffer))
200 (goto-char (point-min))
201 (shrink-window-if-larger-than-buffer)
202 (error "Running %s...FAILED (%s)" command
203 (if (integerp status) (format "status %d" status) status))))
204 (if vc-command-messages
205 (message "Running %s...OK" command))
206 ; Pacify byte-compiler
207 (funcall (symbol-function 'vc-exec-after)
208 `(run-hook-with-args
209 'vc-post-command-functions ',command ',localname ',flags))
210 status))))
211
212
213;; The context for a VC command is the current buffer.
214;; That makes a test on the buffers file more reliable than a test on the
215;; arguments.
216;; This is needed to handle remote VC correctly - else we test against the
217;; local VC system and get things wrong...
218;; Daniel Pittman <daniel@danann.net>
219;;-(if (fboundp 'vc-call-backend)
220;;- () ;; This is the new VC for which we don't have an appropriate advice yet
221;;-)
222(unless (fboundp 'process-file)
223 (if (fboundp 'vc-call-backend)
224 (defadvice vc-do-command
225 (around tramp-advice-vc-do-command
226 (buffer okstatus command file &rest flags)
227 activate)
228 "Invoke tramp-vc-do-command for tramp files."
229 (let ((file (symbol-value 'file))) ;pacify byte-compiler
230 (if (or (and (stringp file) (tramp-tramp-file-p file))
231 (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))))
232 (setq ad-return-value
233 (apply 'tramp-vc-do-command-new buffer okstatus command
234 file ;(or file (buffer-file-name))
235 flags))
236 ad-do-it)))
237 (defadvice vc-do-command
238 (around tramp-advice-vc-do-command
239 (buffer okstatus command file last &rest flags)
240 activate)
241 "Invoke tramp-vc-do-command for tramp files."
242 (let ((file (symbol-value 'file))) ;pacify byte-compiler
243 (if (or (and (stringp file) (tramp-tramp-file-p file))
244 (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))))
245 (setq ad-return-value
246 (apply 'tramp-vc-do-command buffer okstatus command
247 (or file (buffer-file-name)) last flags))
248 ad-do-it))))
249
250 (add-hook 'tramp-unload-hook
251 '(lambda () (ad-unadvise 'vc-do-command))))
252
253
254;; XEmacs uses this to do some of its work. Like vc-do-command, we
255;; need to enhance it to make VC work via TRAMP-mode.
256;;
257;; Like the previous function, this is a cut-and-paste job from the VC
258;; file. It's based on the vc-do-command code.
259;; CCC: this isn't used in Emacs 21, so do as before.
260(defun tramp-vc-simple-command (okstatus command file &rest args)
261 ;; Simple version of vc-do-command, for use in vc-hooks only.
262 ;; Don't switch to the *vc-info* buffer before running the
263 ;; command, because that would change its default directory
264 (save-match-data
265 (let* ((v (tramp-dissect-file-name (expand-file-name file)))
266 (multi-method (tramp-file-name-multi-method v))
267 (method (tramp-file-name-method v))
268 (user (tramp-file-name-user v))
269 (host (tramp-file-name-host v))
270 (localname (tramp-file-name-localname v)))
271 (save-excursion (set-buffer (get-buffer-create "*vc-info*"))
272 (erase-buffer))
273 (let ((exec-path (append vc-path exec-path)) exec-status
274 ;; Add vc-path to PATH for the execution of this command.
275 (process-environment
276 (cons (concat "PATH=" (getenv "PATH")
277 path-separator
278 (mapconcat 'identity vc-path path-separator))
279 process-environment)))
280 ;; Call the actual process. See tramp-vc-do-command for discussion of
281 ;; why this does both (save-window-excursion) and (save-excursion).
282 ;;
283 ;; As a note, I don't think that the process-environment stuff above
284 ;; has any effect on the remote system. This is a hard one though as
285 ;; there is no real reason to expect local and remote paths to be
286 ;; identical...
287 ;;
288 ;; Daniel Pittman <daniel@danann.net>
289 (save-excursion
290 (save-window-excursion
291 ;; Actually execute remote command
292 ;; `shell-command' cannot be used; it isn't magic in XEmacs.
293 (tramp-handle-shell-command
294 (mapconcat 'tramp-shell-quote-argument
295 (append (list command) args (list localname)) " ")
296 (get-buffer-create"*vc-info*"))
297 ;(tramp-wait-for-output)
298 ;; Get status from command
299 (tramp-send-command multi-method method user host "echo $?")
300 (tramp-wait-for-output)
301 (setq exec-status (read (current-buffer)))
302 (message "Command %s returned status %d." command exec-status)))
303
304 ;; Maybe okstatus can be `async' here. But then, maybe the
305 ;; async thing is new in Emacs 21, but this function is only
306 ;; used in Emacs 20.
307 (cond ((> exec-status okstatus)
308 (switch-to-buffer (get-file-buffer file))
309 (shrink-window-if-larger-than-buffer
310 (display-buffer "*vc-info*"))
311 (error "Couldn't find version control information")))
312 exec-status))))
313
314;; This function does not exist any more in Emacs-21's VC
315(defadvice vc-simple-command
316 (around tramp-advice-vc-simple-command
317 (okstatus command file &rest args)
318 activate)
319 "Invoke tramp-vc-simple-command for tramp files."
320 (let ((file (symbol-value 'file))) ;pacify byte-compiler
321 (if (or (and (stringp file) (tramp-tramp-file-p file))
322 (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))))
323 (setq ad-return-value
324 (apply 'tramp-vc-simple-command okstatus command
325 (or file (buffer-file-name)) args))
326 ad-do-it)))
327
328(add-hook 'tramp-unload-hook
329 '(lambda () (ad-unadvise 'vc-simple-command)))
330
331
332;; `vc-workfile-unchanged-p'
333;; This function does not deal well with remote files, so we do the
334;; same as for `vc-do-command'.
335
336;; `vc-workfile-unchanged-p' checks the modification time, we cannot
337;; do that for remote files, so here's a version which relies on diff.
338;; CCC: this one probably works for Emacs 21, too.
339(defun tramp-vc-workfile-unchanged-p
340 (filename &optional want-differences-if-changed)
341 (if (fboundp 'vc-backend-diff)
342 ;; Old VC. Call `vc-backend-diff'.
343 (let ((status (funcall (symbol-function 'vc-backend-diff)
344 filename nil nil
345 (not want-differences-if-changed))))
346 (zerop status))
347 ;; New VC. Call `vc-default-workfile-unchanged-p'.
348 (funcall (symbol-function 'vc-default-workfile-unchanged-p)
349 (vc-backend filename) filename)))
350
351(defadvice vc-workfile-unchanged-p
352 (around tramp-advice-vc-workfile-unchanged-p
353 (filename &optional want-differences-if-changed)
354 activate)
355 "Invoke tramp-vc-workfile-unchanged-p for tramp files."
356 (if (and (stringp filename)
357 (tramp-tramp-file-p filename)
358 (not
359 (let ((v (tramp-dissect-file-name filename)))
360 ;; The following check is probably to test whether
361 ;; file-attributes returns correct last modification
362 ;; times. This check needs to be changed.
363 (tramp-get-remote-perl (tramp-file-name-multi-method v)
364 (tramp-file-name-method v)
365 (tramp-file-name-user v)
366 (tramp-file-name-host v)))))
367 (setq ad-return-value
368 (tramp-vc-workfile-unchanged-p filename want-differences-if-changed))
369 ad-do-it))
370
371(add-hook 'tramp-unload-hook
372 '(lambda () (ad-unadvise 'vc-workfile-unchanged-p)))
373
374
375;; Redefine a function from vc.el -- allow tramp files.
376;; `save-match-data' seems not to be required -- it isn't in
377;; the original version, either.
378;; CCC: this might need some work -- how does the Emacs 21 version
379;; work, anyway? Does it work over ange-ftp? Hm.
380(if (not (fboundp 'vc-backend-checkout))
381 () ;; our replacement won't work and is unnecessary anyway
382(defun vc-checkout (filename &optional writable rev)
383 "Retrieve a copy of the latest version of the given file."
384 ;; If ftp is on this system and the name matches the ange-ftp format
385 ;; for a remote file, the user is trying something that won't work.
386 (funcall (symbol-function 'vc-backend-checkout) filename writable rev)
387 (vc-resynch-buffer filename t t))
388)
389
390
391;; Do we need to advise the vc-user-login-name function anyway?
392;; This will return the correct login name for the owner of a
393;; file. It does not deal with the default remote user name...
394;;
395;; That is, when vc calls (vc-user-login-name), we return the
396;; local login name, something that may be different to the remote
397;; default.
398;;
399;; The remote VC operations will occur as the user that we logged
400;; in with however - not always the same as the local user.
401;;
402;; In the end, I did advise the function. This is because, well,
403;; the thing didn't work right otherwise ;)
404;;
405;; Daniel Pittman <daniel@danann.net>
406
407(defun tramp-handle-vc-user-login-name (&optional uid)
408 "Return the default user name on the remote machine.
409Whenever VC calls this function, `file' is bound to the file name
410in question. If no uid is provided or the uid is equal to the uid
411owning the file, then we return the user name given in the file name.
412
413This should only be called when `file' is bound to the
414filename we are thinking about..."
415 ;; Pacify byte-compiler; this symbol is bound in the calling
416 ;; function. CCC: Maybe it would be better to move the
417 ;; boundness-checking into this function?
418 (let* ((file (symbol-value 'file))
419 (remote-uid
420 ;; With Emacs 22, `file-attributes' has got an optional parameter
421 ;; ID-FORMAT. Handle this case backwards compatible.
422 (if (and (functionp 'subr-arity)
423 (= 2 (cdr (funcall (symbol-function 'subr-arity)
424 (symbol-function 'file-attributes)))))
425 (nth 2 (file-attributes file 'integer))
426 (nth 2 (file-attributes file)))))
427 (if (and uid (/= uid remote-uid))
428 (error "tramp-handle-vc-user-login-name cannot map a uid to a name")
429 (let* ((v (tramp-dissect-file-name (expand-file-name file)))
430 (u (tramp-file-name-user v)))
431 (cond ((stringp u) u)
432 ((vectorp u) (elt u (1- (length u))))
433 ((null u) (user-login-name))
434 (t (error "tramp-handle-vc-user-login-name cannot cope!")))))))
435
436
437;; The following defadvice is no longer necessary after changes in VC
438;; on 2006-01-25, Andre.
439
440(unless (fboundp 'process-file)
441 (defadvice vc-user-login-name
442 (around tramp-vc-user-login-name activate)
443 "Support for files on remote machines accessed by TRAMP."
444 ;; We rely on the fact that `file' is bound when this is called.
445 ;; This appears to be the case everywhere in vc.el and vc-hooks.el
446 ;; as of Emacs 20.5.
447 ;;
448 ;; With Emacs 22, the definition of `vc-user-login-name' has been
449 ;; changed. It doesn't need to be adviced any longer.
450 (let ((file (when (boundp 'file)
451 (symbol-value 'file)))) ;pacify byte-compiler
452 (or (and (stringp file)
453 (tramp-tramp-file-p file) ; tramp file
454 (setq ad-return-value
455 (save-match-data
456 (tramp-handle-vc-user-login-name uid)))) ; get the owner name
457 ad-do-it))) ; else call the original
458
459 (add-hook 'tramp-unload-hook
460 '(lambda () (ad-unadvise 'vc-user-login-name))))
461
462
463;; Determine the name of the user owning a file.
464(defun tramp-file-owner (filename)
465 "Return who owns FILE (user name, as a string)."
466 (let ((v (tramp-dissect-file-name
467 (expand-file-name filename))))
468 (if (not (file-exists-p filename))
469 nil ; file cannot be opened
470 ;; file exists, find out stuff
471 (save-excursion
472 (tramp-send-command
473 (tramp-file-name-multi-method v) (tramp-file-name-method v)
474 (tramp-file-name-user v) (tramp-file-name-host v)
475 (format "%s -Lld %s"
476 (tramp-get-ls-command (tramp-file-name-multi-method v)
477 (tramp-file-name-method v)
478 (tramp-file-name-user v)
479 (tramp-file-name-host v))
480 (tramp-shell-quote-argument (tramp-file-name-localname v))))
481 (tramp-wait-for-output)
482 ;; parse `ls -l' output ...
483 ;; ... file mode flags
484 (read (current-buffer))
485 ;; ... number links
486 (read (current-buffer))
487 ;; ... uid (as a string)
488 (symbol-name (read (current-buffer)))))))
489
490;; Wire ourselves into the VC infrastructure...
491;; This function does not exist any more in Emacs-21's VC
492;; CCC: it appears that no substitute is needed for Emacs 21.
493(defadvice vc-file-owner
494 (around tramp-vc-file-owner activate)
495 "Support for files on remote machines accessed by TRAMP."
496 (let ((filename (ad-get-arg 0)))
497 (or (and (tramp-file-name-p filename) ; tramp file
498 (setq ad-return-value
499 (save-match-data
500 (tramp-file-owner filename)))) ; get the owner name
501 ad-do-it))) ; else call the original
502
503(add-hook 'tramp-unload-hook
504 '(lambda () (ad-unadvise 'vc-file-owner)))
505
506
507;; We need to make the version control software backend version
508;; information local to the current buffer. This is because each TRAMP
509;; buffer can (theoretically) have a different VC version and I am
510;; *way* too lazy to try and push the correct value into each new
511;; buffer.
512;;
513;; Remote VC costs will just have to be paid, at least for the moment.
514;; Well, at least, they will right until I feel guilty about doing a
515;; botch job here and fix it. :/
516;;
517;; Daniel Pittman <daniel@danann.net>
518;; CCC: this is probably still needed for Emacs 21.
519(defun tramp-vc-setup-for-remote ()
520 "Make the backend release variables buffer local.
521This makes remote VC work correctly at the cost of some processing time."
522 (when (and (buffer-file-name)
523 (tramp-tramp-file-p (buffer-file-name)))
524 (make-local-variable 'vc-rcs-release)
525 (setq vc-rcs-release nil)))
526
527(add-hook 'find-file-hooks 'tramp-vc-setup-for-remote t)
528(add-hook 'tramp-unload-hook
529 '(lambda ()
530 (remove-hook 'find-file-hooks 'tramp-vc-setup-for-remote)))
531
532;; No need to load this again if anyone asks.
533(provide 'tramp-vc)
534
535;;; arch-tag: 27cc42ce-da19-468d-ad5c-a2690558db60
536;;; tramp-vc.el ends here
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index f85620ee323..021d3db6fac 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -14,8 +14,8 @@
14 14
15;; GNU Emacs is free software; you can redistribute it and/or modify 15;; GNU Emacs is free software; you can redistribute it and/or modify
16;; it under the terms of the GNU General Public License as published by 16;; it under the terms of the GNU General Public License as published by
17;; the Free Software Foundation; either version 2, or (at your option) 17;; the Free Software Foundation; either version 3 of the License, or
18;; any later version. 18;; (at your option) any later version.
19 19
20;; GNU Emacs is distributed in the hope that it will be useful, 20;; GNU Emacs is distributed in the hope that it will be useful,
21;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -23,9 +23,8 @@
23;; GNU General Public License for more details. 23;; GNU General Public License for more details.
24 24
25;; You should have received a copy of the GNU General Public License 25;; You should have received a copy of the GNU General Public License
26;; along with GNU Emacs; see the file COPYING. If not, write to the 26;; along with GNU Emacs; see the file COPYING. If not, see
27;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 27;; <http://www.gnu.org/licenses/>.
28;; Boston, MA 02110-1301, USA.
29 28
30;;; Commentary: 29;;; Commentary:
31 30
@@ -39,10 +38,9 @@
39;; Notes: 38;; Notes:
40;; ----- 39;; -----
41;; 40;;
42;; This package only works for Emacs 20 and higher, and for XEmacs 21 41;; This package only works for Emacs 21.1 and higher, and for XEmacs 21.4
43;; and higher. (XEmacs 20 is missing the `with-timeout' macro. Emacs 42;; and higher. For XEmacs 21, you need the package `fsf-compat' for
44;; 19 is reported to have other problems. For XEmacs 21, you need the 43;; the `with-timeout' macro.)
45;; package `fsf-compat' for the `with-timeout' macro.)
46;; 44;;
47;; This version might not work with pre-Emacs 21 VC unless VC is 45;; This version might not work with pre-Emacs 21 VC unless VC is
48;; loaded before tramp.el. Could you please test this and tell me about 46;; loaded before tramp.el. Could you please test this and tell me about
@@ -74,6 +72,8 @@
74 (when (featurep 'trampver) 72 (when (featurep 'trampver)
75 (unload-feature 'trampver 'force)))) 73 (unload-feature 'trampver 'force))))
76 74
75(require 'custom)
76
77(if (featurep 'xemacs) 77(if (featurep 'xemacs)
78 (require 'timer-funcs) 78 (require 'timer-funcs)
79 (require 'timer)) 79 (require 'timer))
@@ -85,15 +85,24 @@
85 (load "password" 'noerror) 85 (load "password" 'noerror)
86 (require 'password nil 'noerror)) ;from No Gnus, also in tar ball 86 (require 'password nil 'noerror)) ;from No Gnus, also in tar ball
87 87
88;; The explicit check is not necessary in Emacs, which provides the
89;; feature even if implemented in C, but it appears to be necessary
90;; in XEmacs.
91(unless (and (fboundp 'base64-encode-region)
92 (fboundp 'base64-decode-region))
93 (require 'base64)) ;for the mimencode methods
94(require 'shell) 88(require 'shell)
95(require 'advice) 89(require 'advice)
96 90
91;; Requiring 'tramp-cache results in an endless loop.
92(autoload 'tramp-get-file-property "tramp-cache")
93(autoload 'tramp-set-file-property "tramp-cache")
94(autoload 'tramp-flush-file-property "tramp-cache")
95(autoload 'tramp-flush-directory-property "tramp-cache")
96(autoload 'tramp-cache-print "tramp-cache")
97(autoload 'tramp-get-connection-property "tramp-cache")
98(autoload 'tramp-set-connection-property "tramp-cache")
99(autoload 'tramp-flush-connection-property "tramp-cache")
100(autoload 'tramp-parse-connection-properties "tramp-cache")
101(add-hook 'tramp-unload-hook
102 '(lambda ()
103 (when (featurep 'tramp-cache)
104 (unload-feature 'tramp-cache 'force))))
105
97(autoload 'tramp-uuencode-region "tramp-uu" 106(autoload 'tramp-uuencode-region "tramp-uu"
98 "Implementation of `uuencode' in Lisp.") 107 "Implementation of `uuencode' in Lisp.")
99(add-hook 'tramp-unload-hook 108(add-hook 'tramp-unload-hook
@@ -101,75 +110,85 @@
101 (when (featurep 'tramp-uu) 110 (when (featurep 'tramp-uu)
102 (unload-feature 'tramp-uu 'force)))) 111 (unload-feature 'tramp-uu 'force))))
103 112
104(unless (fboundp 'uudecode-decode-region) 113(autoload 'uudecode-decode-region "uudecode")
105 (autoload 'uudecode-decode-region "uudecode"))
106 114
107;; XEmacs is distributed with few Lisp packages. Further packages are 115;; The following Tramp packages must be loaded after Tramp, because
108;; installed using EFS. If we use a unified filename format, then 116;; they require Tramp as well.
109;; Tramp is required in addition to EFS. (But why can't Tramp just 117(eval-after-load "tramp"
110;; disable EFS when Tramp is loaded? Then XEmacs can ship with EFS 118 '(progn
111;; just like before.) Another reason for using a separate filename 119
112;; syntax on XEmacs is that EFS hooks into XEmacs in many places, but 120 ;; Load foreign FTP method.
113;; Tramp only knows how to deal with `file-name-handler-alist', not 121 (let ((feature (if (featurep 'xemacs) 'tramp-efs 'tramp-ftp)))
114;; the other places. 122 (require feature)
115;;;###autoload
116(defvar tramp-unified-filenames (not (featurep 'xemacs))
117 "Non-nil means to use unified Ange-FTP/Tramp filename syntax.
118Otherwise, use a separate filename syntax for Tramp.")
119
120;; Load foreign methods. Because they do require Tramp internally, this
121;; must be done with the `eval-after-load' trick.
122
123;; tramp-ftp supports Ange-FTP only. Not suited for XEmacs therefore.
124(unless (featurep 'xemacs)
125 (eval-after-load "tramp"
126 '(progn
127 (require 'tramp-ftp)
128 (add-hook 'tramp-unload-hook
129 '(lambda ()
130 (when (featurep 'tramp-ftp)
131 (unload-feature 'tramp-ftp 'force)))))))
132(when (and tramp-unified-filenames (featurep 'xemacs))
133 (eval-after-load "tramp"
134 '(progn
135 (require 'tramp-efs)
136 (add-hook 'tramp-unload-hook 123 (add-hook 'tramp-unload-hook
137 '(lambda () 124 `(lambda ()
138 (when (featurep 'tramp-efs) 125 (when (featurep ,feature)
139 (unload-feature 'tramp-efs 'force))))))) 126 (unload-feature ,feature 'force)))))
140 127
141;; tramp-smb uses "smbclient" from Samba. 128 ;; tramp-smb uses "smbclient" from Samba. Not available under
142;; Not available under Cygwin and Windows, because they don't offer 129 ;; Cygwin and Windows, because they don't offer "smbclient". And
143;; "smbclient". And even not necessary there, because Emacs supports 130 ;; even not necessary there, because Emacs supports UNC file names
144;; UNC file names like "//host/share/localname". 131 ;; like "//host/share/localname".
145(unless (memq system-type '(cygwin windows-nt)) 132 (unless (memq system-type '(cygwin windows-nt))
146 (eval-after-load "tramp"
147 '(progn
148 (require 'tramp-smb) 133 (require 'tramp-smb)
149 (add-hook 'tramp-unload-hook 134 (add-hook 'tramp-unload-hook
150 '(lambda () 135 '(lambda ()
151 (when (featurep 'tramp-smb) 136 (when (featurep 'tramp-smb)
152 (unload-feature 'tramp-smb 'force))))))) 137 (unload-feature 'tramp-smb 'force)))))
153 138
154(require 'custom) 139 ;; Load foreign FISH method.
155 140 (require 'tramp-fish)
156(unless (boundp 'custom-print-functions) 141 (add-hook 'tramp-unload-hook
157 (defvar custom-print-functions nil)) ; not autoloaded before Emacs 20.4 142 '(lambda ()
143 (when (featurep 'tramp-fish)
144 (unload-feature 'tramp-fish 'force))))
145
146 ;; Load gateways. It needs `make-network-process' from Emacs 22.
147 (if (functionp 'make-network-process)
148 (progn
149 (require 'tramp-gw)
150 (add-hook 'tramp-unload-hook
151 '(lambda ()
152 (when (featurep 'tramp-gw)
153 (unload-feature 'tramp-gw 'force)))))
154 ;; We need to declare used tramp-gw-* symbols at least.
155 (setq tramp-gw-tunnel-method ""
156 tramp-gw-socks-method "")
157 (defalias 'tramp-gw-open-connection 'ignore))
158
159 ;; tramp-util offers integration into other (X)Emacs packages like
160 ;; compile.el, gud.el etc. Not necessary in Emacs 23.
161 (unless (functionp 'start-file-process)
162 (require 'tramp-util)
163 (add-hook 'tramp-unload-hook
164 '(lambda ()
165 (when (featurep 'tramp-util)
166 (unload-feature 'tramp-util 'force)))))))
158 167
159;; Avoid byte-compiler warnings if the byte-compiler supports this. 168;; Avoid byte-compiler warnings if the byte-compiler supports this.
160;; Currently, XEmacs supports this. 169;; Currently, XEmacs supports this.
161(eval-when-compile 170(eval-when-compile
162 (when (featurep 'xemacs) 171 (when (featurep 'xemacs)
163 (let (unused-vars) ; Pacify Emacs byte-compiler 172 (byte-compiler-options (warnings (- unused-vars)))))
164 (defalias 'warnings 'identity) ; Pacify Emacs byte-compiler 173
165 (byte-compiler-options (warnings (- unused-vars)))))) 174;; `last-coding-system-used' is unknown in XEmacs.
175(eval-when-compile
176 (unless (boundp 'last-coding-system-used)
177 (defvar last-coding-system-used nil)))
166 178
167;; `directory-sep-char' is an obsolete variable in Emacs. But it is 179;; `directory-sep-char' is an obsolete variable in Emacs. But it is
168;; used in XEmacs, so we set it here and there. The following is needed 180;; used in XEmacs, so we set it here and there. The following is needed
169;; to pacify Emacs byte-compiler. 181;; to pacify Emacs byte-compiler.
170(eval-when-compile 182(eval-when-compile
171 (when (boundp 'byte-compile-not-obsolete-var) 183 (unless (boundp 'byte-compile-not-obsolete-var)
172 (setq byte-compile-not-obsolete-var 'directory-sep-char))) 184 (defvar byte-compile-not-obsolete-var nil))
185 (setq byte-compile-not-obsolete-var 'directory-sep-char))
186
187;; `with-temp-message' does not exists in XEmacs.
188(eval-and-compile
189 (condition-case nil
190 (with-temp-message (current-message) nil)
191 (error (defmacro with-temp-message (message &rest body) `(progn ,@body)))))
173 192
174;; `set-buffer-multibyte' comes from Emacs Leim. 193;; `set-buffer-multibyte' comes from Emacs Leim.
175(eval-and-compile 194(eval-and-compile
@@ -183,16 +202,23 @@ Otherwise, use a separate filename syntax for Tramp.")
183 :group 'files 202 :group 'files
184 :version "22.1") 203 :version "22.1")
185 204
186(defcustom tramp-verbose 9 205(defcustom tramp-verbose 3
187 "*Verbosity level for tramp.el. 0 means be silent, 10 is most verbose." 206 "*Verbosity level for tramp.
207Any level x includes messages for all levels 1 .. x-1. The levels are
208
209 0 silent (no tramp messages at all)
210 1 errors
211 2 warnings
212 3 connection to remote hosts (default level)
213 4 activities
214 5 internal
215 6 sent and received strings
216 7 file caching
217 8 connection properties
21810 traces (huge)."
188 :group 'tramp 219 :group 'tramp
189 :type 'integer) 220 :type 'integer)
190 221
191(defcustom tramp-debug-buffer nil
192 "*Whether to send all commands and responses to a debug buffer."
193 :group 'tramp
194 :type 'boolean)
195
196;; Emacs case 222;; Emacs case
197(eval-and-compile 223(eval-and-compile
198 (when (boundp 'backup-directory-alist) 224 (when (boundp 'backup-directory-alist)
@@ -201,7 +227,7 @@ Otherwise, use a separate filename syntax for Tramp.")
201Each element looks like (REGEXP . DIRECTORY), with the same meaning like 227Each element looks like (REGEXP . DIRECTORY), with the same meaning like
202in `backup-directory-alist'. If a Tramp file is backed up, and DIRECTORY 228in `backup-directory-alist'. If a Tramp file is backed up, and DIRECTORY
203is a local file name, the backup directory is prepended with Tramp file 229is a local file name, the backup directory is prepended with Tramp file
204name prefix \(multi-method, method, user, host\) of file. 230name prefix \(method, user, host\) of file.
205 231
206\(setq tramp-backup-directory-alist backup-directory-alist\) 232\(setq tramp-backup-directory-alist backup-directory-alist\)
207 233
@@ -220,7 +246,7 @@ policy for local files."
220It has the same meaning like `bkup-backup-directory-info' from package 246It has the same meaning like `bkup-backup-directory-info' from package
221`backup-dir'. If a Tramp file is backed up, and BACKUP-DIR is a local 247`backup-dir'. If a Tramp file is backed up, and BACKUP-DIR is a local
222file name, the backup directory is prepended with Tramp file name prefix 248file name, the backup directory is prepended with Tramp file name prefix
223\(multi-method, method, user, host\) of file. 249\(method, user, host\) of file.
224 250
225\(setq tramp-bkup-backup-directory-info bkup-backup-directory-info\) 251\(setq tramp-bkup-backup-directory-info bkup-backup-directory-info\)
226 252
@@ -240,8 +266,7 @@ policy for local files."
240 "*Put auto-save files in this directory, if set. 266 "*Put auto-save files in this directory, if set.
241The idea is to use a local directory so that auto-saving is faster." 267The idea is to use a local directory so that auto-saving is faster."
242 :group 'tramp 268 :group 'tramp
243 :type '(choice (const nil) 269 :type '(choice (const nil) string))
244 string))
245 270
246(defcustom tramp-encoding-shell 271(defcustom tramp-encoding-shell
247 (if (memq system-type '(windows-nt)) 272 (if (memq system-type '(windows-nt))
@@ -258,9 +283,7 @@ For encoding and deocding, commands like the following are executed:
258 /bin/sh -c COMMAND < INPUT > OUTPUT 283 /bin/sh -c COMMAND < INPUT > OUTPUT
259 284
260This variable can be used to change the \"/bin/sh\" part. See the 285This variable can be used to change the \"/bin/sh\" part. See the
261variable `tramp-encoding-command-switch' for the \"-c\" part. Also, see the 286variable `tramp-encoding-command-switch' for the \"-c\" part.
262variable `tramp-encoding-reads-stdin' to specify whether the commands read
263standard input or a file.
264 287
265Note that this variable is not used for remote commands. There are 288Note that this variable is not used for remote commands. There are
266mechanisms in tramp.el which automatically determine the right shell to 289mechanisms in tramp.el which automatically determine the right shell to
@@ -277,286 +300,313 @@ See the variable `tramp-encoding-shell' for more information."
277 :group 'tramp 300 :group 'tramp
278 :type 'string) 301 :type 'string)
279 302
280(defcustom tramp-encoding-reads-stdin t 303(defcustom tramp-copy-size-limit 10240
281 "*If non-nil, encoding commands read from standard input. 304 "*The maximum file size where inline copying is preferred over an out-of-the-band copy."
282If nil, the filename is the last argument.
283
284Note that the commands always must write to standard output."
285 :group 'tramp 305 :group 'tramp
286 :type 'boolean) 306 :type 'integer)
287
288(defcustom tramp-multi-sh-program
289 tramp-encoding-shell
290 "*Use this program for bootstrapping multi-hop connections.
291This variable is similar to `tramp-encoding-shell', but it is only used
292when initializing a multi-hop connection. Therefore, the set of
293commands sent to this shell is quite restricted, and if you are
294careful it works to use CMD.EXE under Windows (instead of a Bourne-ish
295shell which does not normally exist on Windows anyway).
296
297To use multi-hop methods from Windows, you also need suitable entries
298in `tramp-multi-connection-function-alist' for the first hop.
299 307
300This variable defaults to the value of `tramp-encoding-shell'." 308(defcustom tramp-terminal-type "dumb"
309 "*Value of TERM environment variable for logging in to remote host.
310Because Tramp wants to parse the output of the remote shell, it is easily
311confused by ANSI color escape sequences and suchlike. Often, shell init
312files conditionalize this setup based on the TERM environment variable."
301 :group 'tramp 313 :group 'tramp
302 :type '(file :must-match t)) 314 :type 'string)
303 315
304;; CCC I have changed all occurrences of comint-quote-filename with 316(defvar tramp-methods
305;; tramp-shell-quote-argument, except in tramp-handle-expand-many-files. 317 `(("rcp" (tramp-login-program "rsh")
306;; There, comint-quote-filename was removed altogether. If it turns 318 (tramp-login-args (("%h") ("-l" "%u")))
307;; out to be necessary there, something will need to be done. 319 (tramp-remote-sh "/bin/sh")
308;;-(defcustom tramp-file-name-quote-list 320 (tramp-copy-program "rcp")
309;;- '(?] ?[ ?\| ?& ?< ?> ?\( ?\) ?\; ?\ ?\* ?\? ?\! ?\" ?\' ?\` ?# ?\@ ?\+ ) 321 (tramp-copy-args (("-p" "%k")))
310;;- "*Protect these characters from the remote shell. 322 (tramp-copy-keep-date t)
311;;-Any character in this list is quoted (preceded with a backslash) 323 (tramp-password-end-of-line nil))
312;;-because it means something special to the shell. This takes effect 324 ("scp" (tramp-login-program "ssh")
313;;-when sending file and directory names to the remote shell. 325 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
314;;- 326 ("-e" "none")))
315;;-See `comint-file-name-quote-list' for details." 327 (tramp-remote-sh "/bin/sh")
316;;- :group 'tramp 328 (tramp-copy-program "scp")
317;;- :type '(repeat character)) 329 (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q")))
318 330 (tramp-copy-keep-date t)
319(defcustom tramp-methods 331 (tramp-password-end-of-line nil)
320 '( ("rcp" (tramp-connection-function tramp-open-connection-rsh) 332 (tramp-gw-args (("-o"
321 (tramp-login-program "rsh") 333 "GlobalKnownHostsFile=/dev/null")
322 (tramp-copy-program "rcp") 334 ("-o" "UserKnownHostsFile=/dev/null")
323 (tramp-remote-sh "/bin/sh") 335 ("-o" "StrictHostKeyChecking=no")))
324 (tramp-login-args nil) 336 (tramp-default-port 22))
325 (tramp-copy-args nil) 337 ("scp1" (tramp-login-program "ssh")
326 (tramp-copy-keep-date-arg "-p") 338 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
327 (tramp-password-end-of-line nil)) 339 ("-1" "-e" "none")))
328 ("scp" (tramp-connection-function tramp-open-connection-rsh) 340 (tramp-remote-sh "/bin/sh")
329 (tramp-login-program "ssh") 341 (tramp-copy-program "scp")
330 (tramp-copy-program "scp") 342 (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k")
331 (tramp-remote-sh "/bin/sh") 343 ("-q")))
332 (tramp-login-args ("-e" "none")) 344 (tramp-copy-keep-date t)
333 (tramp-copy-args nil) 345 (tramp-password-end-of-line nil)
334 (tramp-copy-keep-date-arg "-p") 346 (tramp-gw-args (("-o"
335 (tramp-password-end-of-line nil)) 347 "GlobalKnownHostsFile=/dev/null")
336 ("scp1" (tramp-connection-function tramp-open-connection-rsh) 348 ("-o" "UserKnownHostsFile=/dev/null")
337 (tramp-login-program "ssh") 349 ("-o" "StrictHostKeyChecking=no")))
338 (tramp-copy-program "scp") 350 (tramp-default-port 22))
339 (tramp-remote-sh "/bin/sh") 351 ("scp2" (tramp-login-program "ssh")
340 (tramp-login-args ("-1" "-e" "none")) 352 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
341 (tramp-copy-args ("-1")) 353 ("-2" "-e" "none")))
342 (tramp-copy-keep-date-arg "-p") 354 (tramp-remote-sh "/bin/sh")
343 (tramp-password-end-of-line nil)) 355 (tramp-copy-program "scp")
344 ("scp2" (tramp-connection-function tramp-open-connection-rsh) 356 (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k")
345 (tramp-login-program "ssh") 357 ("-q")))
346 (tramp-copy-program "scp") 358 (tramp-copy-keep-date t)
347 (tramp-remote-sh "/bin/sh") 359 (tramp-password-end-of-line nil)
348 (tramp-login-args ("-2" "-e" "none")) 360 (tramp-gw-args (("-o"
349 (tramp-copy-args ("-2")) 361 "GlobalKnownHostsFile=/dev/null")
350 (tramp-copy-keep-date-arg "-p") 362 ("-o" "UserKnownHostsFile=/dev/null")
351 (tramp-password-end-of-line nil)) 363 ("-o" "StrictHostKeyChecking=no")))
352 ("scp1_old" 364 (tramp-default-port 22))
353 (tramp-connection-function tramp-open-connection-rsh) 365 ("scp1_old"
354 (tramp-login-program "ssh1") 366 (tramp-login-program "ssh1")
355 (tramp-copy-program "scp1") 367 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
356 (tramp-remote-sh "/bin/sh") 368 ("-e" "none")))
357 (tramp-login-args ("-e" "none")) 369 (tramp-remote-sh "/bin/sh")
358 (tramp-copy-args nil) 370 (tramp-copy-program "scp1")
359 (tramp-copy-keep-date-arg "-p") 371 (tramp-copy-args (("-p" "%k")))
360 (tramp-password-end-of-line nil)) 372 (tramp-copy-keep-date t)
361 ("scp2_old" 373 (tramp-password-end-of-line nil))
362 (tramp-connection-function tramp-open-connection-rsh) 374 ("scp2_old"
363 (tramp-login-program "ssh2") 375 (tramp-login-program "ssh2")
364 (tramp-copy-program "scp2") 376 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
365 (tramp-remote-sh "/bin/sh") 377 ("-e" "none")))
366 (tramp-login-args ("-e" "none")) 378 (tramp-remote-sh "/bin/sh")
367 (tramp-copy-args nil) 379 (tramp-copy-program "scp2")
368 (tramp-copy-keep-date-arg "-p") 380 (tramp-copy-args (("-p" "%k")))
369 (tramp-password-end-of-line nil)) 381 (tramp-copy-keep-date t)
370 ("rsync" (tramp-connection-function tramp-open-connection-rsh) 382 (tramp-password-end-of-line nil))
371 (tramp-login-program "ssh") 383 ("sftp" (tramp-login-program "ssh")
372 (tramp-copy-program "rsync") 384 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
373 (tramp-remote-sh "/bin/sh") 385 ("-e" "none")))
374 (tramp-login-args ("-e" "none")) 386 (tramp-remote-sh "/bin/sh")
375 (tramp-copy-args ("-e" "ssh")) 387 (tramp-copy-program "sftp")
376 (tramp-copy-keep-date-arg "-t") 388 (tramp-copy-args nil)
377 (tramp-password-end-of-line nil)) 389 (tramp-copy-keep-date nil)
378 ("remcp" (tramp-connection-function tramp-open-connection-rsh) 390 (tramp-password-end-of-line nil))
379 (tramp-login-program "remsh") 391 ("rsync" (tramp-login-program "ssh")
380 (tramp-copy-program "rcp") 392 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
381 (tramp-remote-sh "/bin/sh") 393 ("-e" "none")))
382 (tramp-login-args nil) 394 (tramp-remote-sh "/bin/sh")
383 (tramp-copy-args nil) 395 (tramp-copy-program "rsync")
384 (tramp-copy-keep-date-arg "-p") 396 (tramp-copy-args (("-e" "ssh") ("-t" "%k")))
385 (tramp-password-end-of-line nil)) 397 (tramp-copy-keep-date t)
386 ("rsh" (tramp-connection-function tramp-open-connection-rsh) 398 (tramp-password-end-of-line nil))
387 (tramp-login-program "rsh") 399 ("remcp" (tramp-login-program "remsh")
388 (tramp-copy-program nil) 400 (tramp-login-args (("%h") ("-l" "%u")))
389 (tramp-remote-sh "/bin/sh") 401 (tramp-remote-sh "/bin/sh")
390 (tramp-login-args nil) 402 (tramp-copy-program "rcp")
391 (tramp-copy-args nil) 403 (tramp-copy-args (("-p" "%k")))
392 (tramp-copy-keep-date-arg nil) 404 (tramp-copy-keep-date t)
393 (tramp-password-end-of-line nil)) 405 (tramp-password-end-of-line nil))
394 ("ssh" (tramp-connection-function tramp-open-connection-rsh) 406 ("rsh" (tramp-login-program "rsh")
395 (tramp-login-program "ssh") 407 (tramp-login-args (("%h") ("-l" "%u")))
396 (tramp-copy-program nil) 408 (tramp-remote-sh "/bin/sh")
397 (tramp-remote-sh "/bin/sh") 409 (tramp-copy-program nil)
398 (tramp-login-args ("-e" "none")) 410 (tramp-copy-args nil)
399 (tramp-copy-args nil) 411 (tramp-copy-keep-date nil)
400 (tramp-copy-keep-date-arg nil) 412 (tramp-password-end-of-line nil))
401 (tramp-password-end-of-line nil)) 413 ("ssh" (tramp-login-program "ssh")
402 ("ssh1" (tramp-connection-function tramp-open-connection-rsh) 414 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
403 (tramp-login-program "ssh") 415 ("-e" "none")))
404 (tramp-copy-program nil) 416 (tramp-remote-sh "/bin/sh")
405 (tramp-remote-sh "/bin/sh") 417 (tramp-copy-program nil)
406 (tramp-login-args ("-1" "-e" "none")) 418 (tramp-copy-args nil)
407 (tramp-copy-args ("-1")) 419 (tramp-copy-keep-date nil)
408 (tramp-copy-keep-date-arg nil) 420 (tramp-password-end-of-line nil)
409 (tramp-password-end-of-line nil)) 421 (tramp-gw-args (("-o"
410 ("ssh2" (tramp-connection-function tramp-open-connection-rsh) 422 "GlobalKnownHostsFile=/dev/null")
411 (tramp-login-program "ssh") 423 ("-o" "UserKnownHostsFile=/dev/null")
412 (tramp-copy-program nil) 424 ("-o" "StrictHostKeyChecking=no")))
413 (tramp-remote-sh "/bin/sh") 425 (tramp-default-port 22))
414 (tramp-login-args ("-2" "-e" "none")) 426 ("ssh1" (tramp-login-program "ssh")
415 (tramp-copy-args ("-2")) 427 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
416 (tramp-copy-keep-date-arg nil) 428 ("-1" "-e" "none")))
417 (tramp-password-end-of-line nil)) 429 (tramp-remote-sh "/bin/sh")
418 ("ssh1_old" 430 (tramp-copy-program nil)
419 (tramp-connection-function tramp-open-connection-rsh) 431 (tramp-copy-args nil)
420 (tramp-login-program "ssh1") 432 (tramp-copy-keep-date nil)
421 (tramp-copy-program nil) 433 (tramp-password-end-of-line nil)
422 (tramp-remote-sh "/bin/sh") 434 (tramp-gw-args (("-o"
423 (tramp-login-args ("-e" "none")) 435 "GlobalKnownHostsFile=/dev/null")
424 (tramp-copy-args nil) 436 ("-o" "UserKnownHostsFile=/dev/null")
425 (tramp-copy-keep-date-arg nil) 437 ("-o" "StrictHostKeyChecking=no")))
426 (tramp-password-end-of-line nil)) 438 (tramp-default-port 22))
427 ("ssh2_old" 439 ("ssh2" (tramp-login-program "ssh")
428 (tramp-connection-function tramp-open-connection-rsh) 440 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
429 (tramp-login-program "ssh2") 441 ("-2" "-e" "none")))
430 (tramp-copy-program nil) 442 (tramp-remote-sh "/bin/sh")
431 (tramp-remote-sh "/bin/sh") 443 (tramp-copy-program nil)
432 (tramp-login-args ("-e" "none")) 444 (tramp-copy-args nil)
433 (tramp-copy-args nil) 445 (tramp-copy-keep-date nil)
434 (tramp-copy-keep-date-arg nil) 446 (tramp-password-end-of-line nil)
435 (tramp-password-end-of-line nil)) 447 (tramp-gw-args (("-o"
436 ("remsh" (tramp-connection-function tramp-open-connection-rsh) 448 "GlobalKnownHostsFile=/dev/null")
437 (tramp-login-program "remsh") 449 ("-o" "UserKnownHostsFile=/dev/null")
438 (tramp-copy-program nil) 450 ("-o" "StrictHostKeyChecking=no")))
439 (tramp-remote-sh "/bin/sh") 451 (tramp-default-port 22))
440 (tramp-login-args nil) 452 ("ssh1_old"
441 (tramp-copy-args nil) 453 (tramp-login-program "ssh1")
442 (tramp-copy-keep-date-arg nil) 454 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
443 (tramp-password-end-of-line nil)) 455 ("-e" "none")))
444 ("telnet" 456 (tramp-remote-sh "/bin/sh")
445 (tramp-connection-function tramp-open-connection-telnet) 457 (tramp-copy-program nil)
446 (tramp-login-program "telnet") 458 (tramp-copy-args nil)
447 (tramp-copy-program nil) 459 (tramp-copy-keep-date nil)
448 (tramp-remote-sh "/bin/sh") 460 (tramp-password-end-of-line nil))
449 (tramp-login-args nil) 461 ("ssh2_old"
450 (tramp-copy-args nil) 462 (tramp-login-program "ssh2")
451 (tramp-copy-keep-date-arg nil) 463 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
452 (tramp-password-end-of-line nil)) 464 ("-e" "none")))
453 ("su" (tramp-connection-function tramp-open-connection-su) 465 (tramp-remote-sh "/bin/sh")
454 (tramp-login-program "su") 466 (tramp-copy-program nil)
455 (tramp-copy-program nil) 467 (tramp-copy-args nil)
456 (tramp-remote-sh "/bin/sh") 468 (tramp-copy-keep-date nil)
457 (tramp-login-args ("-" "%u")) 469 (tramp-password-end-of-line nil))
458 (tramp-copy-args nil) 470 ("remsh" (tramp-login-program "remsh")
459 (tramp-copy-keep-date-arg nil) 471 (tramp-login-args (("%h") ("-l" "%u")))
460 (tramp-password-end-of-line nil)) 472 (tramp-remote-sh "/bin/sh")
461 ("sudo" (tramp-connection-function tramp-open-connection-su) 473 (tramp-copy-program nil)
462 (tramp-login-program "sudo") 474 (tramp-copy-args nil)
463 (tramp-copy-program nil) 475 (tramp-copy-keep-date nil)
464 (tramp-remote-sh "/bin/sh") 476 (tramp-password-end-of-line nil))
465 (tramp-login-args ("-u" "%u" "-s" 477 ("telnet"
466 "-p" "Password:")) 478 (tramp-login-program "telnet")
467 (tramp-copy-args nil) 479 (tramp-login-args (("%h") ("%p")))
468 (tramp-copy-keep-date-arg nil) 480 (tramp-remote-sh "/bin/sh")
469 (tramp-password-end-of-line nil)) 481 (tramp-copy-program nil)
470 ("multi" (tramp-connection-function tramp-open-connection-multi) 482 (tramp-copy-args nil)
471 (tramp-login-program nil) 483 (tramp-copy-keep-date nil)
472 (tramp-copy-program nil) 484 (tramp-password-end-of-line nil)
473 (tramp-remote-sh "/bin/sh") 485 (tramp-default-port 23))
474 (tramp-login-args nil) 486 ("su" (tramp-login-program "su")
475 (tramp-copy-args nil) 487 (tramp-login-args (("-") ("%u")))
476 (tramp-copy-keep-date-arg nil) 488 (tramp-remote-sh "/bin/sh")
477 (tramp-password-end-of-line nil)) 489 (tramp-copy-program nil)
478 ("scpc" (tramp-connection-function tramp-open-connection-rsh) 490 (tramp-copy-args nil)
479 (tramp-login-program "ssh") 491 (tramp-copy-keep-date nil)
480 (tramp-copy-program "scp") 492 (tramp-password-end-of-line nil))
481 (tramp-remote-sh "/bin/sh") 493 ("sudo" (tramp-login-program "sudo")
482 (tramp-login-args ("-o" "ControlPath=%t.%%r@%%h:%%p" 494 (tramp-login-args (("-u" "%u")
483 "-o" "ControlMaster=yes" 495 ("-s" "-p" "Password:")))
484 "-e" "none")) 496 (tramp-remote-sh "/bin/sh")
485 (tramp-copy-args ("-o" "ControlPath=%t.%%r@%%h:%%p" 497 (tramp-copy-program nil)
486 "-o" "ControlMaster=auto")) 498 (tramp-copy-args nil)
487 (tramp-copy-keep-date-arg "-p") 499 (tramp-copy-keep-date nil)
488 (tramp-password-end-of-line nil)) 500 (tramp-password-end-of-line nil))
489 ("scpx" (tramp-connection-function tramp-open-connection-rsh) 501 ("scpc" (tramp-login-program "ssh")
490 (tramp-login-program "ssh") 502 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
491 (tramp-copy-program "scp") 503 ("-o" "ControlPath=%t.%%r@%%h:%%p")
492 (tramp-remote-sh "/bin/sh") 504 ("-o" "ControlMaster=yes")
493 (tramp-login-args ("-e" "none" "-t" "-t" "/bin/sh")) 505 ("-e" "none")))
494 (tramp-copy-args nil) 506 (tramp-remote-sh "/bin/sh")
495 (tramp-copy-keep-date-arg "-p") 507 (tramp-copy-program "scp")
496 (tramp-password-end-of-line nil)) 508 (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q")
497 ("sshx" (tramp-connection-function tramp-open-connection-rsh) 509 ("-o" "ControlPath=%t.%%r@%%h:%%p")
498 (tramp-login-program "ssh") 510 ("-o" "ControlMaster=auto")))
499 (tramp-copy-program nil) 511 (tramp-copy-keep-date t)
500 (tramp-remote-sh "/bin/sh") 512 (tramp-password-end-of-line nil)
501 (tramp-login-args ("-e" "none" "-t" "-t" "/bin/sh")) 513 (tramp-gw-args (("-o"
502 (tramp-copy-args nil) 514 "GlobalKnownHostsFile=/dev/null")
503 (tramp-copy-keep-date-arg nil) 515 ("-o" "UserKnownHostsFile=/dev/null")
504 (tramp-password-end-of-line nil)) 516 ("-o" "StrictHostKeyChecking=no")))
505 ("krlogin" 517 (tramp-default-port 22))
506 (tramp-connection-function tramp-open-connection-rsh) 518 ("scpx" (tramp-login-program "ssh")
507 (tramp-login-program "krlogin") 519 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
508 (tramp-copy-program nil) 520 ("-e" "none" "-t" "-t" "/bin/sh")))
509 (tramp-remote-sh "/bin/sh") 521 (tramp-remote-sh "/bin/sh")
510 (tramp-login-args ("-x")) 522 (tramp-copy-program "scp")
511 (tramp-copy-args nil) 523 (tramp-copy-args (("-p" "%k")))
512 (tramp-copy-keep-date-arg nil) 524 (tramp-copy-keep-date t)
513 (tramp-password-end-of-line nil)) 525 (tramp-password-end-of-line nil)
514 ("plink" 526 (tramp-gw-args (("-o"
515 (tramp-connection-function tramp-open-connection-rsh) 527 "GlobalKnownHostsFile=/dev/null")
516 (tramp-login-program "plink") 528 ("-o" "UserKnownHostsFile=/dev/null")
517 (tramp-copy-program nil) 529 ("-o" "StrictHostKeyChecking=no")))
518 (tramp-remote-sh "/bin/sh") 530 (tramp-default-port 22))
519 (tramp-login-args ("-ssh")) ;optionally add "-v" 531 ("sshx" (tramp-login-program "ssh")
520 (tramp-copy-args nil) 532 (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
521 (tramp-copy-keep-date-arg nil) 533 ("-e" "none" "-t" "-t" "/bin/sh")))
522 (tramp-password-end-of-line "xy")) ;see docstring for "xy" 534 (tramp-remote-sh "/bin/sh")
523 ("plink1" 535 (tramp-copy-program nil)
524 (tramp-connection-function tramp-open-connection-rsh) 536 (tramp-copy-args nil)
525 (tramp-login-program "plink") 537 (tramp-copy-keep-date nil)
526 (tramp-copy-program nil) 538 (tramp-password-end-of-line nil)
527 (tramp-remote-sh "/bin/sh") 539 (tramp-gw-args (("-o"
528 (tramp-login-args ("-1" "-ssh")) ;optionally add "-v" 540 "GlobalKnownHostsFile=/dev/null")
529 (tramp-copy-args nil) 541 ("-o" "UserKnownHostsFile=/dev/null")
530 (tramp-copy-keep-date-arg nil) 542 ("-o" "StrictHostKeyChecking=no")))
531 (tramp-password-end-of-line "xy")) ;see docstring for "xy" 543 (tramp-default-port 22))
532 ("pscp" 544 ("krlogin"
533 (tramp-connection-function tramp-open-connection-rsh) 545 (tramp-login-program "krlogin")
534 (tramp-login-program "plink") 546 (tramp-login-args (("%h") ("-l" "%u") ("-x")))
535 (tramp-copy-program "pscp") 547 (tramp-remote-sh "/bin/sh")
536 (tramp-remote-sh "/bin/sh") 548 (tramp-copy-program nil)
537 (tramp-login-args ("-ssh")) 549 (tramp-copy-args nil)
538 (tramp-copy-args nil) 550 (tramp-copy-keep-date nil)
539 (tramp-copy-keep-date-arg "-p") 551 (tramp-password-end-of-line nil))
540 (tramp-password-end-of-line "xy")) ;see docstring for "xy" 552 ("plink" (tramp-login-program "plink")
541 ("fcp" 553 (tramp-login-args (("%h") ("-l" "%u") ("-P" "%p")
542 (tramp-connection-function tramp-open-connection-rsh) 554 ("-ssh")))
543 (tramp-login-program "fsh") 555 (tramp-remote-sh "/bin/sh")
544 (tramp-copy-program "fcp") 556 (tramp-copy-program nil)
545 (tramp-remote-sh "/bin/sh -i") 557 (tramp-copy-args nil)
546 (tramp-login-args ("sh" "-i")) 558 (tramp-copy-keep-date nil)
547 (tramp-copy-args nil) 559 (tramp-password-end-of-line "xy") ;see docstring for "xy"
548 (tramp-copy-keep-date-arg "-p") 560 (tramp-default-port 22))
549 (tramp-password-end-of-line nil)) 561 ("plink1"
550 ) 562 (tramp-login-program "plink")
563 (tramp-login-args (("%h") ("-l" "%u") ("-P" "%p")
564 ("-1" "-ssh")))
565 (tramp-remote-sh "/bin/sh")
566 (tramp-copy-program nil)
567 (tramp-copy-args nil)
568 (tramp-copy-keep-date nil)
569 (tramp-password-end-of-line "xy") ;see docstring for "xy"
570 (tramp-default-port 22))
571 ("plinkx"
572 (tramp-login-program "plink")
573 (tramp-login-args (("-load" "%h") ("-t")
574 (,(format "env 'TERM=%s' 'PS1=$ '"
575 tramp-terminal-type))
576 ("/bin/sh")))
577 (tramp-remote-sh "/bin/sh")
578 (tramp-copy-program nil)
579 (tramp-copy-args nil)
580 (tramp-copy-keep-date nil)
581 (tramp-password-end-of-line nil))
582 ("pscp" (tramp-login-program "plink")
583 (tramp-login-args (("%h") ("-l" "%u") ("-P" "%p")
584 ("-ssh")))
585 (tramp-remote-sh "/bin/sh")
586 (tramp-copy-program "pscp")
587 (tramp-copy-args (("-scp") ("-p" "%k")))
588 (tramp-copy-keep-date t)
589 (tramp-password-end-of-line "xy") ;see docstring for "xy"
590 (tramp-default-port 22))
591 ("psftp" (tramp-login-program "plink")
592 (tramp-login-args (("%h") ("-l" "%u") ("-P" "%p")
593 ("-ssh")))
594 (tramp-remote-sh "/bin/sh")
595 (tramp-copy-program "pscp")
596 (tramp-copy-args (("-psftp") ("-p" "%k")))
597 (tramp-copy-keep-date t)
598 (tramp-password-end-of-line "xy")) ;see docstring for "xy"
599 ("fcp" (tramp-login-program "fsh")
600 (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
601 (tramp-remote-sh "/bin/sh -i")
602 (tramp-copy-program "fcp")
603 (tramp-copy-args (("-p" "%k")))
604 (tramp-copy-keep-date t)
605 (tramp-password-end-of-line nil)))
551 "*Alist of methods for remote files. 606 "*Alist of methods for remote files.
552This is a list of entries of the form (NAME PARAM1 PARAM2 ...). 607This is a list of entries of the form (NAME PARAM1 PARAM2 ...).
553Each NAME stands for a remote access method. Each PARAM is a 608Each NAME stands for a remote access method. Each PARAM is a
554pair of the form (KEY VALUE). The following KEYs are defined: 609pair of the form (KEY VALUE). The following KEYs are defined:
555 * `tramp-connection-function'
556 This specifies the function to use to connect to the remote host.
557 Currently, `tramp-open-connection-rsh', `tramp-open-connection-telnet'
558 and `tramp-open-connection-su' are defined. See the documentation
559 of these functions for more details.
560 * `tramp-remote-sh' 610 * `tramp-remote-sh'
561 This specifies the Bourne shell to use on the remote host. This 611 This specifies the Bourne shell to use on the remote host. This
562 MUST be a Bourne-like shell. It is normally not necessary to set 612 MUST be a Bourne-like shell. It is normally not necessary to set
@@ -566,21 +616,22 @@ pair of the form (KEY VALUE). The following KEYs are defined:
566 the value that you decide to use. You Have Been Warned. 616 the value that you decide to use. You Have Been Warned.
567 * `tramp-login-program' 617 * `tramp-login-program'
568 This specifies the name of the program to use for logging in to the 618 This specifies the name of the program to use for logging in to the
569 remote host. Depending on `tramp-connection-function', this may be 619 remote host. This may be the name of rsh or a workalike program,
570 the name of rsh or a workalike program (when 620 or the name of telnet or a workalike, or the name of su or a workalike.
571 `tramp-connection-function' is `tramp-open-connection-rsh'), or the
572 name of telnet or a workalike (for `tramp-open-connection-telnet'),
573 or the name of su or a workalike (for `tramp-open-connection-su').
574 * `tramp-login-args' 621 * `tramp-login-args'
575 This specifies the list of arguments to pass to the above 622 This specifies the list of arguments to pass to the above
576 mentioned program. Please note that this is a list of arguments, 623 mentioned program. Please note that this is a list of list of arguments,
577 that is, normally you don't want to put \"-a -b\" or \"-f foo\" 624 that is, normally you don't want to put \"-a -b\" or \"-f foo\"
578 here. Instead, you want two list elements, one for \"-a\" and one 625 here. Instead, you want a list (\"-a\" \"-b\"), or (\"-f\" \"foo\").
579 for \"-b\", or one for \"-f\" and one for \"foo\". 626 There are some patterns: \"%h\" in this list is replaced by the host
580 If `tramp-connection-function' is `tramp-open-connection-su', then 627 name, \"%u\" is replaced by the user name, \"%p\" is replaced by the
581 \"%u\" in this list is replaced by the user name, and \"%%\" can 628 port number, and \"%%\" can be used to obtain a literal percent character.
582 be used to obtain a literal percent character. 629 If a list containing \"%h\", \"%u\" or \"%p\" is unchanged during
583 \"%t\" is replaced by the temporary file name for `scp'-like methods. 630 expansion (i.e. no host or no user specified), this list is not used as
631 argument. By this, arguments like (\"-l\" \"%u\") are optional.
632 \"%t\" is replaced by the temporary file name produced with
633 `tramp-make-tramp-temp-file'. \"%k\" indicates the keep-date
634 parameter of a program, if exists.
584 * `tramp-copy-program' 635 * `tramp-copy-program'
585 This specifies the name of the program to use for remotely copying 636 This specifies the name of the program to use for remotely copying
586 the file; this might be the absolute filename of rcp or the name of 637 the file; this might be the absolute filename of rcp or the name of
@@ -588,10 +639,16 @@ pair of the form (KEY VALUE). The following KEYs are defined:
588 * `tramp-copy-args' 639 * `tramp-copy-args'
589 This specifies the list of parameters to pass to the above mentioned 640 This specifies the list of parameters to pass to the above mentioned
590 program, the hints for `tramp-login-args' also apply here. 641 program, the hints for `tramp-login-args' also apply here.
591 * `tramp-copy-keep-date-arg' 642 * `tramp-copy-keep-date'
592 This specifies the parameter to use for the copying program when the 643 This specifies whether the copying program when the preserves the
593 timestamp of the original file should be kept. For `rcp', use `-p', for 644 timestamp of the original file.
594 `rsync', use `-t'. 645 * `tramp-default-port'
646 The default port of a method is needed in case of gateway connections.
647 Additionally, it is used as indication which method is prepared for
648 passing gateways.
649 * `tramp-gw-args'
650 As the attribute name says, additional arguments are specified here
651 when a method is applied via a gateway.
595 * `tramp-password-end-of-line' 652 * `tramp-password-end-of-line'
596 This specifies the string to use for terminating the line after 653 This specifies the string to use for terminating the line after
597 submitting the password. If this method parameter is nil, then the 654 submitting the password. If this method parameter is nil, then the
@@ -613,78 +670,22 @@ file is passed through the same buffer used by `tramp-login-program'. In
613this case, the file contents need to be protected since the 670this case, the file contents need to be protected since the
614`tramp-login-program' might use escape codes or the connection might not 671`tramp-login-program' might use escape codes or the connection might not
615be eight-bit clean. Therefore, file contents are encoded for transit. 672be eight-bit clean. Therefore, file contents are encoded for transit.
616See the variable `tramp-coding-commands' for details. 673See the variables `tramp-local-coding-commands' and
674`tramp-remote-coding-commands' for details.
617 675
618So, to summarize: if the method is an out-of-band method, then you 676So, to summarize: if the method is an out-of-band method, then you
619must specify `tramp-copy-program' and `tramp-copy-args'. If it is an 677must specify `tramp-copy-program' and `tramp-copy-args'. If it is an
620inline method, then these two parameters should be nil. Every method, 678inline method, then these two parameters should be nil. Methods which
621inline or out of band, must specify `tramp-connection-function' plus 679are fit for gateways must have `tramp-default-port' at least.
622the associated arguments (for example, the login program if you chose
623`tramp-open-connection-telnet').
624 680
625Notes: 681Notes:
626 682
627When using `tramp-open-connection-su' the phrase `open connection to a 683When using `su' or `sudo' the phrase `open connection to a remote
628remote host' sounds strange, but it is used nevertheless, for 684host' sounds strange, but it is used nevertheless, for consistency.
629consistency. No connection is opened to a remote host, but `su' is 685No connection is opened to a remote host, but `su' or `sudo' is
630started on the local host. You are not allowed to specify a remote 686started on the local host. You should specify a remote host
631host other than `localhost' or the name of the local host." 687`localhost' or the name of the local host. Another host name is
632 :group 'tramp 688useful only in combination with `tramp-default-proxies-alist'.")
633 :type '(repeat
634 (cons string
635 (set (list (const tramp-connection-function) function)
636 (list (const tramp-login-program)
637 (choice (const nil) string))
638 (list (const tramp-copy-program)
639 (choice (const nil) string))
640 (list (const tramp-remote-sh)
641 (choice (const nil) string))
642 (list (const tramp-login-args) (repeat string))
643 (list (const tramp-copy-args) (repeat string))
644 (list (const tramp-copy-keep-date-arg)
645 (choice (const nil) string))
646 (list (const tramp-encoding-command)
647 (choice (const nil) string))
648 (list (const tramp-decoding-command)
649 (choice (const nil) string))
650 (list (const tramp-encoding-function)
651 (choice (const nil) function))
652 (list (const tramp-decoding-function)
653 (choice (const nil) function))
654 (list (const tramp-password-end-of-line)
655 (choice (const nil) string))))))
656
657(defcustom tramp-multi-methods '("multi" "multiu")
658 "*List of multi-hop methods.
659Each entry in this list should be a method name as mentioned in the
660variable `tramp-methods'."
661 :group 'tramp
662 :type '(repeat string))
663
664(defcustom tramp-multi-connection-function-alist
665 '(("telnet" tramp-multi-connect-telnet "telnet %h%n")
666 ("rsh" tramp-multi-connect-rlogin "rsh %h -l %u%n")
667 ("remsh" tramp-multi-connect-rlogin "remsh %h -l %u%n")
668 ("ssh" tramp-multi-connect-rlogin "ssh %h -l %u%n")
669 ("ssht" tramp-multi-connect-rlogin "ssh %h -e none -t -t -l %u%n")
670 ("su" tramp-multi-connect-su "su - %u%n")
671 ("sudo" tramp-multi-connect-su "sudo -u %u -s -p Password:%n"))
672 "*List of connection functions for multi-hop methods.
673Each list item is a list of three items (METHOD FUNCTION COMMAND),
674where METHOD is the name as used in the file name, FUNCTION is the
675function to be executed, and COMMAND is the shell command used for
676connecting.
677
678COMMAND may contain percent escapes. `%u' will be replaced with the
679user name, `%h' will be replaced with the host name, and `%n' will be
680replaced with an end-of-line character, as specified in the variable
681`tramp-rsh-end-of-line'. Use `%%' for a literal percent character.
682Note that the interpretation of the percent escapes also depends on
683the FUNCTION. For example, the `%u' escape is forbidden with the
684function `tramp-multi-connect-telnet'. See the documentation of the
685various functions for details."
686 :group 'tramp
687 :type '(repeat (list string function string)))
688 689
689(defcustom tramp-default-method 690(defcustom tramp-default-method
690 ;; An external copy method seems to be preferred, because it is much 691 ;; An external copy method seems to be preferred, because it is much
@@ -696,30 +697,26 @@ various functions for details."
696 ;; another good choice because of the "ControlMaster" option, but 697 ;; another good choice because of the "ControlMaster" option, but
697 ;; this is a more modern alternative in OpenSSH 4, which cannot be 698 ;; this is a more modern alternative in OpenSSH 4, which cannot be
698 ;; taken as default. 699 ;; taken as default.
699 (let ((e-f (fboundp 'executable-find))) 700 (cond
700 (cond 701 ;; PuTTY is installed.
701 ;; PuTTY is installed. 702 ((executable-find "pscp")
702 ((and e-f (funcall 'executable-find "pscp")) 703 (if (or (fboundp 'password-read)
703 (if (or (fboundp 'password-read) 704 ;; Pageant is running.
704 ;; Pageant is running. 705 (and (fboundp 'w32-window-exists-p)
705 (and (fboundp 'w32-window-exists-p) 706 (funcall (symbol-function 'w32-window-exists-p)
706 (funcall 'w32-window-exists-p "Pageant" "Pageant"))) 707 "Pageant" "Pageant")))
707 "pscp" 708 "pscp"
708 "plink")) 709 "plink"))
709 ;; There is an ssh installation. 710 ;; There is an ssh installation.
710 ((and e-f (funcall 'executable-find "scp")) 711 ((executable-find "scp")
711 (if (or (fboundp 'password-read) 712 (if (or (fboundp 'password-read)
712 ;; ssh-agent is running. 713 ;; ssh-agent is running.
713 (getenv "SSH_AUTH_SOCK") 714 (getenv "SSH_AUTH_SOCK")
714 (getenv "SSH_AGENT_PID")) 715 (getenv "SSH_AGENT_PID"))
715 "scp" 716 "scp"
716 "ssh")) 717 "ssh"))
717 ;; Under Emacs 20, `executable-find' does not exists. So we 718 ;; Fallback.
718 ;; couldn't check whether there is an ssh implementation. Let's 719 (t "ftp"))
719 ;; hope the best.
720 ((not e-f) "ssh")
721 ;; Fallback.
722 (t "ftp")))
723 "*Default method to use for transferring files. 720 "*Default method to use for transferring files.
724See `tramp-methods' for possibilities. 721See `tramp-methods' for possibilities.
725Also see `tramp-default-method-alist'." 722Also see `tramp-default-method-alist'."
@@ -728,7 +725,7 @@ Also see `tramp-default-method-alist'."
728 725
729(defcustom tramp-default-method-alist 726(defcustom tramp-default-method-alist
730 '(("\\`localhost\\'" "\\`root\\'" "su")) 727 '(("\\`localhost\\'" "\\`root\\'" "su"))
731 "*Default method to use for specific user/host pairs. 728 "*Default method to use for specific host/user pairs.
732This is an alist of items (HOST USER METHOD). The first matching item 729This is an alist of items (HOST USER METHOD). The first matching item
733specifies the method to use for a file name which does not specify a 730specifies the method to use for a file name which does not specify a
734method. HOST and USER are regular expressions or nil, which is 731method. HOST and USER are regular expressions or nil, which is
@@ -744,42 +741,90 @@ See `tramp-methods' for a list of possibilities for METHOD."
744 (regexp :tag "User regexp") 741 (regexp :tag "User regexp")
745 (string :tag "Method")))) 742 (string :tag "Method"))))
746 743
747;; Default values for non-Unices seeked 744(defcustom tramp-default-user
745 nil
746 "*Default user to use for transferring files.
747It is nil by default; otherwise settings in configuration files like
748\"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'.
749
750This variable is regarded as obsolete, and will be removed soon."
751 :group 'tramp
752 :type '(choice (const nil) string))
753
754(defcustom tramp-default-user-alist
755 `(("\\`su\\(do\\)?\\'" nil "root")
756 ("\\`r\\(em\\)?\\(cp\\|sh\\)\\|telnet\\|plink1?\\'"
757 nil ,(user-login-name)))
758 "*Default user to use for specific method/host pairs.
759This is an alist of items (METHOD HOST USER). The first matching item
760specifies the user to use for a file name which does not specify a
761user. METHOD and USER are regular expressions or nil, which is
762interpreted as a regular expression which always matches. If no entry
763matches, the variable `tramp-default-user' takes effect.
764
765If the file name does not specify the method, lookup is done using the
766empty string for the method name."
767 :group 'tramp
768 :type '(repeat (list (regexp :tag "Method regexp")
769 (regexp :tag "Host regexp")
770 (string :tag "User"))))
771
772(defcustom tramp-default-host
773 (system-name)
774 "*Default host to use for transferring files.
775Useful for su and sudo methods mostly."
776 :group 'tramp
777 :type 'string)
778
779(defcustom tramp-default-proxies-alist nil
780 "*Route to be followed for specific host/user pairs.
781This is an alist of items (HOST USER PROXY). The first matching
782item specifies the proxy to be passed for a file name located on
783a remote target matching USER@HOST. HOST and USER are regular
784expressions or nil, which is interpreted as a regular expression
785which always matches. PROXY must be a Tramp filename without a
786localname part. Method and user name on PROXY are optional,
787which is interpreted with the default values. PROXY can contain
788the patterns %h and %u, which are replaced by the strings
789matching HOST or USER, respectively."
790 :group 'tramp
791 :type '(repeat (list (regexp :tag "Host regexp")
792 (regexp :tag "User regexp")
793 (string :tag "Proxy remote name"))))
794
748(defconst tramp-completion-function-alist-rsh 795(defconst tramp-completion-function-alist-rsh
749 (unless (memq system-type '(windows-nt)) 796 '((tramp-parse-rhosts "/etc/hosts.equiv")
750 '((tramp-parse-rhosts "/etc/hosts.equiv") 797 (tramp-parse-rhosts "~/.rhosts"))
751 (tramp-parse-rhosts "~/.rhosts")))
752 "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.") 798 "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.")
753 799
754;; Default values for non-Unices seeked
755(defconst tramp-completion-function-alist-ssh 800(defconst tramp-completion-function-alist-ssh
756 (unless (memq system-type '(windows-nt)) 801 '((tramp-parse-rhosts "/etc/hosts.equiv")
757 '((tramp-parse-rhosts "/etc/hosts.equiv") 802 (tramp-parse-rhosts "/etc/shosts.equiv")
758 (tramp-parse-rhosts "/etc/shosts.equiv") 803 (tramp-parse-shosts "/etc/ssh_known_hosts")
759 (tramp-parse-shosts "/etc/ssh_known_hosts") 804 (tramp-parse-sconfig "/etc/ssh_config")
760 (tramp-parse-sconfig "/etc/ssh_config") 805 (tramp-parse-shostkeys "/etc/ssh2/hostkeys")
761 (tramp-parse-shostkeys "/etc/ssh2/hostkeys") 806 (tramp-parse-sknownhosts "/etc/ssh2/knownhosts")
762 (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") 807 (tramp-parse-rhosts "~/.rhosts")
763 (tramp-parse-rhosts "~/.rhosts") 808 (tramp-parse-rhosts "~/.shosts")
764 (tramp-parse-rhosts "~/.shosts") 809 (tramp-parse-shosts "~/.ssh/known_hosts")
765 (tramp-parse-shosts "~/.ssh/known_hosts") 810 (tramp-parse-sconfig "~/.ssh/config")
766 (tramp-parse-sconfig "~/.ssh/config") 811 (tramp-parse-shostkeys "~/.ssh2/hostkeys")
767 (tramp-parse-shostkeys "~/.ssh2/hostkeys") 812 (tramp-parse-sknownhosts "~/.ssh2/knownhosts"))
768 (tramp-parse-sknownhosts "~/.ssh2/knownhosts")))
769 "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") 813 "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.")
770 814
771;; Default values for non-Unices seeked
772(defconst tramp-completion-function-alist-telnet 815(defconst tramp-completion-function-alist-telnet
773 (unless (memq system-type '(windows-nt)) 816 '((tramp-parse-hosts "/etc/hosts"))
774 '((tramp-parse-hosts "/etc/hosts")))
775 "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.") 817 "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.")
776 818
777;; Default values for non-Unices seeked
778(defconst tramp-completion-function-alist-su 819(defconst tramp-completion-function-alist-su
779 (unless (memq system-type '(windows-nt)) 820 '((tramp-parse-passwd "/etc/passwd"))
780 '((tramp-parse-passwd "/etc/passwd")))
781 "Default list of (FUNCTION FILE) pairs to be examined for su methods.") 821 "Default list of (FUNCTION FILE) pairs to be examined for su methods.")
782 822
823(defconst tramp-completion-function-alist-putty
824 '((tramp-parse-putty
825 "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions"))
826 "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.")
827
783(defvar tramp-completion-function-alist nil 828(defvar tramp-completion-function-alist nil
784 "*Alist of methods for remote files. 829 "*Alist of methods for remote files.
785This is a list of entries of the form (NAME PAIR1 PAIR2 ...). 830This is a list of entries of the form (NAME PAIR1 PAIR2 ...).
@@ -795,6 +840,7 @@ names from FILE for completion. The following predefined FUNCTIONs exists:
795 * `tramp-parse-hosts' for \"/etc/hosts\" like files, 840 * `tramp-parse-hosts' for \"/etc/hosts\" like files,
796 * `tramp-parse-passwd' for \"/etc/passwd\" like files. 841 * `tramp-parse-passwd' for \"/etc/passwd\" like files.
797 * `tramp-parse-netrc' for \"~/.netrc\" like files. 842 * `tramp-parse-netrc' for \"~/.netrc\" like files.
843 * `tramp-parse-putty' for PuTTY registry keys.
798 844
799FUNCTION can also be a customer defined function. For more details see 845FUNCTION can also be a customer defined function. For more details see
800the info pages.") 846the info pages.")
@@ -838,8 +884,6 @@ the info pages.")
838 (tramp-set-completion-function 884 (tramp-set-completion-function
839 "sudo" tramp-completion-function-alist-su) 885 "sudo" tramp-completion-function-alist-su)
840 (tramp-set-completion-function 886 (tramp-set-completion-function
841 "multi" nil)
842 (tramp-set-completion-function
843 "scpx" tramp-completion-function-alist-ssh) 887 "scpx" tramp-completion-function-alist-ssh)
844 (tramp-set-completion-function 888 (tramp-set-completion-function
845 "sshx" tramp-completion-function-alist-ssh) 889 "sshx" tramp-completion-function-alist-ssh)
@@ -850,10 +894,26 @@ the info pages.")
850 (tramp-set-completion-function 894 (tramp-set-completion-function
851 "plink1" tramp-completion-function-alist-ssh) 895 "plink1" tramp-completion-function-alist-ssh)
852 (tramp-set-completion-function 896 (tramp-set-completion-function
897 "plinkx" tramp-completion-function-alist-putty)
898 (tramp-set-completion-function
853 "pscp" tramp-completion-function-alist-ssh) 899 "pscp" tramp-completion-function-alist-ssh)
854 (tramp-set-completion-function 900 (tramp-set-completion-function
855 "fcp" tramp-completion-function-alist-ssh))) 901 "fcp" tramp-completion-function-alist-ssh)))
856 902
903(defconst tramp-echo-mark "_echo\b\b\b\b\b"
904 "String mark to be transmitted around shell commands.
905Used to separate their echo from the output they produce. This
906will only be used if we cannot disable remote echo via stty.
907This string must have no effect on the remote shell except for
908producing some echo which can later be detected by
909`tramp-echoed-echo-mark-regexp'. Using some characters followed
910by an equal number of backspaces to erase them will usually
911suffice.")
912
913(defconst tramp-echoed-echo-mark-regexp "_echo\\(\b\\( \b\\)?\\)\\{5\\}"
914 "Regexp which matches `tramp-echo-mark' as it gets echoed by
915the remote shell.")
916
857(defcustom tramp-rsh-end-of-line "\n" 917(defcustom tramp-rsh-end-of-line "\n"
858 "*String used for end of line in rsh connections. 918 "*String used for end of line in rsh connections.
859I don't think this ever needs to be changed, so please tell me about it 919I don't think this ever needs to be changed, so please tell me about it
@@ -878,17 +938,53 @@ The default value is to use the same value as `tramp-rsh-end-of-line'."
878 :group 'tramp 938 :group 'tramp
879 :type 'string) 939 :type 'string)
880 940
941;; "getconf PATH" yields:
942;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin
943;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin
944;; Linux (Debian, Suse): /bin:/usr/bin
945;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
881(defcustom tramp-remote-path 946(defcustom tramp-remote-path
882 ;; "/usr/xpg4/bin" has been placed first, because on Solaris a POSIX 947 '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin"
883 ;; compatible "id" is needed. 948 "/local/bin" "/local/freeware/bin" "/local/gnu/bin"
884 '("/usr/xpg4/bin" "/bin" "/usr/bin" "/usr/sbin" "/usr/local/bin"
885 "/usr/ccs/bin" "/local/bin" "/local/freeware/bin" "/local/gnu/bin"
886 "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin") 949 "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin")
887 "*List of directories to search for executables on remote host. 950 "*List of directories to search for executables on remote host.
888Please notify me about other semi-standard directories to include here. 951For every remote host, this variable will be set buffer local,
952keeping the list of existing directories on that host.
889 953
890You can use `~' in this list, but when searching for a shell which groks 954You can use `~' in this list, but when searching for a shell which groks
891tilde expansion, all directory names starting with `~' will be ignored." 955tilde expansion, all directory names starting with `~' will be ignored.
956
957`Default Directories' represent the list of directories given by
958the command \"getconf PATH\". It is recommended to use this
959entry on top of this list, because these are the default
960directories for POSIX compatible commands."
961 :group 'tramp
962 :type '(repeat (choice
963 (const :tag "Default Directories" tramp-default-remote-path)
964 (string :tag "Directory"))))
965
966(defcustom tramp-terminal-type "dumb"
967 "*Value of TERM environment variable for logging in to remote host.
968Because Tramp wants to parse the output of the remote shell, it is easily
969confused by ANSI color escape sequences and suchlike. Often, shell init
970files conditionalize this setup based on the TERM environment variable."
971 :group 'tramp
972 :type 'string)
973
974(defcustom tramp-remote-process-environment
975 `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_TIME=C"
976 ,(concat "TERM=" tramp-terminal-type)
977 "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH="
978 "autocorrect=" "correct=")
979
980 "*List of environment variables to be set on the remote host.
981
982Each element should be a string of the form ENVVARNAME=VALUE. An
983entry ENVVARNAME= diables the corresponding environment variable,
984which might have been set in the init files like ~/.profile.
985
986Special handling is applied to the PATH environment, which should
987not be set here. Instead of, it should be set via `tramp-remote-path'."
892 :group 'tramp 988 :group 'tramp
893 :type '(repeat string)) 989 :type '(repeat string))
894 990
@@ -915,7 +1011,7 @@ which should work well in many cases."
915 :type 'regexp) 1011 :type 'regexp)
916 1012
917(defcustom tramp-password-prompt-regexp 1013(defcustom tramp-password-prompt-regexp
918 "^.*\\([pP]assword\\|passphrase\\).*:\^@? *" 1014 "^.*\\([pP]assword\\|[pP]assphrase\\).*:\^@? *"
919 "*Regexp matching password-like prompts. 1015 "*Regexp matching password-like prompts.
920The regexp should match at end of buffer. 1016The regexp should match at end of buffer.
921 1017
@@ -930,10 +1026,12 @@ The `sudo' program appears to insert a `^@' character into the prompt."
930 "Login incorrect" 1026 "Login incorrect"
931 "Login Incorrect" 1027 "Login Incorrect"
932 "Connection refused" 1028 "Connection refused"
933 "Connection closed" 1029 "Connection closed by foreign host."
934 "Sorry, try again." 1030 "Sorry, try again."
935 "Name or service not known" 1031 "Name or service not known"
936 "Host key verification failed.") t) 1032 "Host key verification failed."
1033 "No supported authentication methods left to try!"
1034 "Tramp connection closed") t)
937 ".*" 1035 ".*"
938 "\\|" 1036 "\\|"
939 "^.*\\(" 1037 "^.*\\("
@@ -1006,7 +1104,7 @@ be ignored safely."
1006In fact this expression is empty by intention, it will be used only to 1104In fact this expression is empty by intention, it will be used only to
1007check regularly the status of the associated process. 1105check regularly the status of the associated process.
1008The answer will be provided by `tramp-action-process-alive', 1106The answer will be provided by `tramp-action-process-alive',
1009`tramp-multi-action-process-alive' and`tramp-action-out-of-band', which see." 1107`tramp-action-out-of-band', which see."
1010 :group 'tramp 1108 :group 'tramp
1011 :type 'regexp) 1109 :type 'regexp)
1012 1110
@@ -1020,12 +1118,6 @@ part, though."
1020 :group 'tramp 1118 :group 'tramp
1021 :type 'string) 1119 :type 'string)
1022 1120
1023(defcustom tramp-discard-garbage nil
1024 "*If non-nil, try to discard garbage sent by remote shell.
1025Some shells send such garbage upon connection setup."
1026 :group 'tramp
1027 :type 'boolean)
1028
1029(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile")) 1121(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile"))
1030 "*Alist specifying extra arguments to pass to the remote shell. 1122 "*Alist specifying extra arguments to pass to the remote shell.
1031Entries are (REGEXP . ARGS) where REGEXP is a regular expression 1123Entries are (REGEXP . ARGS) where REGEXP is a regular expression
@@ -1042,139 +1134,134 @@ shell from reading its init file."
1042 '(alist :key-type string :value-type string) 1134 '(alist :key-type string :value-type string)
1043 '(repeat (cons string string)))) 1135 '(repeat (cons string string))))
1044 1136
1045(defcustom tramp-prefix-format 1137;; XEmacs is distributed with few Lisp packages. Further packages are
1046 (if tramp-unified-filenames "/" "/[") 1138;; installed using EFS. If we use a unified filename format, then
1047 "*String matching the very beginning of tramp file names. 1139;; Tramp is required in addition to EFS. (But why can't Tramp just
1048Used in `tramp-make-tramp-file-name' and `tramp-make-tramp-multi-file-name'." 1140;; disable EFS when Tramp is loaded? Then XEmacs can ship with EFS
1141;; just like before.) Another reason for using a separate filename
1142;; syntax on XEmacs is that EFS hooks into XEmacs in many places, but
1143;; Tramp only knows how to deal with `file-name-handler-alist', not
1144;; the other places.
1145
1146;; Currently, we have the choice between 'ftp, 'sep, and 'url.
1147;;;###autoload
1148(defcustom tramp-syntax
1149 (if (featurep 'xemacs) 'sep 'ftp)
1150 "Tramp filename syntax to be used.
1151
1152It can have the following values:
1153
1154 'ftp -- Ange-FTP respective EFS like syntax (GNU Emacs default)
1155 'sep -- Syntax as defined for XEmacs (not available yet for GNU Emacs)
1156 'url -- URL-like syntax."
1049 :group 'tramp 1157 :group 'tramp
1050 :type 'string) 1158 :type (if (featurep 'xemacs)
1159 '(choice (const :tag "EFS" ftp)
1160 (const :tag "XEmacs" sep)
1161 (const :tag "URL" url))
1162 '(choice (const :tag "Ange-FTP" ftp)
1163 (const :tag "URL" url))))
1164
1165(defconst tramp-prefix-format
1166 (cond ((equal tramp-syntax 'ftp) "/")
1167 ((equal tramp-syntax 'sep) "/[")
1168 ((equal tramp-syntax 'url) "/")
1169 (t (error "Wrong `tramp-syntax' defined")))
1170 "*String matching the very beginning of tramp file names.
1171Used in `tramp-make-tramp-file-name'.")
1051 1172
1052(defcustom tramp-prefix-regexp 1173(defconst tramp-prefix-regexp
1053 (concat "^" (regexp-quote tramp-prefix-format)) 1174 (concat "^" (regexp-quote tramp-prefix-format))
1054 "*Regexp matching the very beginning of tramp file names. 1175 "*Regexp matching the very beginning of tramp file names.
1055Should always start with \"^\". Derived from `tramp-prefix-format'." 1176Should always start with \"^\". Derived from `tramp-prefix-format'.")
1056 :group 'tramp
1057 :type 'regexp)
1058 1177
1059(defcustom tramp-method-regexp 1178(defconst tramp-method-regexp
1060 "[a-zA-Z_0-9-]+" 1179 "[a-zA-Z_0-9-]+"
1061 "*Regexp matching methods identifiers." 1180 "*Regexp matching methods identifiers.")
1062 :group 'tramp
1063 :type 'regexp)
1064
1065;; It is a little bit annoying that in XEmacs case this delimeter is different
1066;; for single-hop and multi-hop cases.
1067(defcustom tramp-postfix-single-method-format
1068 (if tramp-unified-filenames ":" "/")
1069 "*String matching delimeter between method and user or host names.
1070Applicable for single-hop methods.
1071Used in `tramp-make-tramp-file-name'."
1072 :group 'tramp
1073 :type 'string)
1074
1075(defcustom tramp-postfix-single-method-regexp
1076 (regexp-quote tramp-postfix-single-method-format)
1077 "*Regexp matching delimeter between method and user or host names.
1078Applicable for single-hop methods.
1079Derived from `tramp-postfix-single-method-format'."
1080 :group 'tramp
1081 :type 'regexp)
1082 1181
1083(defcustom tramp-postfix-multi-method-format 1182(defconst tramp-postfix-method-format
1084 ":" 1183 (cond ((equal tramp-syntax 'ftp) ":")
1184 ((equal tramp-syntax 'sep) "/")
1185 ((equal tramp-syntax 'url) "://")
1186 (t (error "Wrong `tramp-syntax' defined")))
1085 "*String matching delimeter between method and user or host names. 1187 "*String matching delimeter between method and user or host names.
1086Applicable for multi-hop methods. 1188Used in `tramp-make-tramp-file-name'.")
1087Used in `tramp-make-tramp-multi-file-name'."
1088 :group 'tramp
1089 :type 'string)
1090 1189
1091(defcustom tramp-postfix-multi-method-regexp 1190(defconst tramp-postfix-method-regexp
1092 (regexp-quote tramp-postfix-multi-method-format) 1191 (regexp-quote tramp-postfix-method-format)
1093 "*Regexp matching delimeter between method and user or host names. 1192 "*Regexp matching delimeter between method and user or host names.
1094Applicable for multi-hop methods. 1193Derived from `tramp-postfix-method-format'.")
1095Derived from `tramp-postfix-multi-method-format'."
1096 :group 'tramp
1097 :type 'regexp)
1098
1099(defcustom tramp-postfix-multi-hop-format
1100 (if tramp-unified-filenames ":" "/")
1101 "*String matching delimeter between host and next method.
1102Applicable for multi-hop methods.
1103Used in `tramp-make-tramp-multi-file-name'."
1104 :group 'tramp
1105 :type 'string)
1106
1107(defcustom tramp-postfix-multi-hop-regexp
1108 (regexp-quote tramp-postfix-multi-hop-format)
1109 "*Regexp matching delimeter between host and next method.
1110Applicable for multi-hop methods.
1111Derived from `tramp-postfix-multi-hop-format'."
1112 :group 'tramp
1113 :type 'regexp)
1114 1194
1115(defcustom tramp-user-regexp 1195(defconst tramp-user-regexp
1116 "[^:/ \t]*" 1196 "[^:/ \t]+"
1117 "*Regexp matching user names." 1197 "*Regexp matching user names.")
1118 :group 'tramp
1119 :type 'regexp)
1120 1198
1121(defcustom tramp-postfix-user-format 1199(defconst tramp-postfix-user-format
1122 "@" 1200 "@"
1123 "*String matching delimeter between user and host names. 1201 "*String matching delimeter between user and host names.
1124Used in `tramp-make-tramp-file-name' and `tramp-make-tramp-multi-file-name'." 1202Used in `tramp-make-tramp-file-name'.")
1125 :group 'tramp
1126 :type 'string)
1127 1203
1128(defcustom tramp-postfix-user-regexp 1204(defconst tramp-postfix-user-regexp
1129 (regexp-quote tramp-postfix-user-format) 1205 (regexp-quote tramp-postfix-user-format)
1130 "*Regexp matching delimeter between user and host names. 1206 "*Regexp matching delimeter between user and host names.
1131Derived from `tramp-postfix-user-format'." 1207Derived from `tramp-postfix-user-format'.")
1132 :group 'tramp 1208
1133 :type 'regexp) 1209(defconst tramp-host-regexp
1134 1210 "[a-zA-Z0-9_.-]+"
1135(defcustom tramp-host-regexp 1211 "*Regexp matching host names.")
1136 "[a-zA-Z0-9_.-]*" 1212
1137 "*Regexp matching host names." 1213(defconst tramp-prefix-port-format
1138 :group 'tramp 1214 (cond ((equal tramp-syntax 'ftp) "#")
1139 :type 'regexp) 1215 ((equal tramp-syntax 'sep) "#")
1140 1216 ((equal tramp-syntax 'url) ":")
1141(defcustom tramp-host-with-port-regexp 1217 (t (error "Wrong `tramp-syntax' defined")))
1142 "[a-zA-Z0-9_.#-]*" 1218 "*String matching delimeter between host names and port numbers.")
1143 "*Regexp matching host names." 1219
1144 :group 'tramp 1220(defconst tramp-prefix-port-regexp
1145 :type 'regexp) 1221 (regexp-quote tramp-prefix-port-format)
1146 1222 "*Regexp matching delimeter between host names and port numbers.
1147(defcustom tramp-postfix-host-format 1223Derived from `tramp-prefix-port-format'.")
1148 (if tramp-unified-filenames ":" "]") 1224
1225(defconst tramp-port-regexp
1226 "[0-9]+"
1227 "*Regexp matching port numbers.")
1228
1229(defconst tramp-host-with-port-regexp
1230 (concat "\\(" tramp-host-regexp "\\)"
1231 tramp-prefix-port-regexp
1232 "\\(" tramp-port-regexp "\\)")
1233 "*Regexp matching host names with port numbers.")
1234
1235(defconst tramp-postfix-host-format
1236 (cond ((equal tramp-syntax 'ftp) ":")
1237 ((equal tramp-syntax 'sep) "]")
1238 ((equal tramp-syntax 'url) "")
1239 (t (error "Wrong `tramp-syntax' defined")))
1149 "*String matching delimeter between host names and localnames. 1240 "*String matching delimeter between host names and localnames.
1150Used in `tramp-make-tramp-file-name' and `tramp-make-tramp-multi-file-name'." 1241Used in `tramp-make-tramp-file-name'.")
1151 :group 'tramp
1152 :type 'string)
1153 1242
1154(defcustom tramp-postfix-host-regexp 1243(defconst tramp-postfix-host-regexp
1155 (regexp-quote tramp-postfix-host-format) 1244 (regexp-quote tramp-postfix-host-format)
1156 "*Regexp matching delimeter between host names and localnames. 1245 "*Regexp matching delimeter between host names and localnames.
1157Derived from `tramp-postfix-host-format'." 1246Derived from `tramp-postfix-host-format'.")
1158 :group 'tramp
1159 :type 'regexp)
1160 1247
1161(defcustom tramp-localname-regexp 1248(defconst tramp-localname-regexp
1162 ".*$" 1249 ".*$"
1163 "*Regexp matching localnames." 1250 "*Regexp matching localnames.")
1164 :group 'tramp
1165 :type 'regexp)
1166 1251
1167;; File name format. 1252;; File name format.
1168 1253
1169(defcustom tramp-file-name-structure 1254(defconst tramp-file-name-structure
1170 (list 1255 (list
1171 (concat 1256 (concat
1172 tramp-prefix-regexp 1257 tramp-prefix-regexp
1173 "\\(" "\\(" tramp-method-regexp "\\)" tramp-postfix-single-method-regexp "\\)?" 1258 "\\(" "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\)?"
1174 "\\(" "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\)?" 1259 "\\(" "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\)?"
1175 "\\(" tramp-host-with-port-regexp "\\)" tramp-postfix-host-regexp 1260 "\\(" tramp-host-regexp
1176 "\\(" tramp-localname-regexp "\\)") 1261 "\\(" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?"
1177 2 4 5 6) 1262 tramp-postfix-host-regexp
1263 "\\(" tramp-localname-regexp "\\)")
1264 2 4 5 7)
1178 1265
1179 "*List of five elements (REGEXP METHOD USER HOST FILE), detailing \ 1266 "*List of five elements (REGEXP METHOD USER HOST FILE), detailing \
1180the tramp file name structure. 1267the tramp file name structure.
@@ -1190,69 +1277,81 @@ but for the host name. The fifth element FILE is for the file name.
1190These numbers are passed directly to `match-string', which see. That 1277These numbers are passed directly to `match-string', which see. That
1191means the opening parentheses are counted to identify the pair. 1278means the opening parentheses are counted to identify the pair.
1192 1279
1193See also `tramp-file-name-regexp'." 1280See also `tramp-file-name-regexp'.")
1194 :group 'tramp
1195 :type '(list (regexp :tag "File name regexp")
1196 (integer :tag "Paren pair for method name")
1197 (integer :tag "Paren pair for user name ")
1198 (integer :tag "Paren pair for host name ")
1199 (integer :tag "Paren pair for file name ")))
1200 1281
1201;;;###autoload 1282;;;###autoload
1202(defconst tramp-file-name-regexp-unified 1283(defconst tramp-file-name-regexp-unified
1203 "\\`/[^/:]+:" 1284 "\\`/[^/:]+:"
1204 "Value for `tramp-file-name-regexp' for unified remoting. 1285 "Value for `tramp-file-name-regexp' for unified remoting.
1205Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and 1286Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and
1206Tramp. See `tramp-file-name-structure-unified' for more explanations.") 1287Tramp. See `tramp-file-name-structure' for more explanations.")
1207 1288
1208;;;###autoload 1289;;;###autoload
1209(defconst tramp-file-name-regexp-separate 1290(defconst tramp-file-name-regexp-separate
1210 "\\`/\\[.*\\]" 1291 "\\`/\\[.*\\]"
1211 "Value for `tramp-file-name-regexp' for separate remoting. 1292 "Value for `tramp-file-name-regexp' for separate remoting.
1212XEmacs uses a separate filename syntax for Tramp and EFS. 1293XEmacs uses a separate filename syntax for Tramp and EFS.
1213See `tramp-file-name-structure-separate' for more explanations.") 1294See `tramp-file-name-structure' for more explanations.")
1214 1295
1215;;;###autoload 1296;;;###autoload
1216(defcustom tramp-file-name-regexp 1297(defconst tramp-file-name-regexp-url
1217 (if tramp-unified-filenames 1298 "\\`/[^/:]+://"
1218 tramp-file-name-regexp-unified 1299 "Value for `tramp-file-name-regexp' for URL-like remoting.
1219 tramp-file-name-regexp-separate) 1300See `tramp-file-name-structure' for more explanations.")
1301
1302;;;###autoload
1303(defconst tramp-file-name-regexp
1304 (cond ((equal tramp-syntax 'ftp) tramp-file-name-regexp-unified)
1305 ((equal tramp-syntax 'sep) tramp-file-name-regexp-separate)
1306 ((equal tramp-syntax 'url) tramp-file-name-regexp-url)
1307 (t (error "Wrong `tramp-syntax' defined")))
1220 "*Regular expression matching file names handled by tramp. 1308 "*Regular expression matching file names handled by tramp.
1221This regexp should match tramp file names but no other file names. 1309This regexp should match tramp file names but no other file names.
1222\(When tramp.el is loaded, this regular expression is prepended to 1310\(When tramp.el is loaded, this regular expression is prepended to
1223`file-name-handler-alist', and that is searched sequentially. Thus, 1311`file-name-handler-alist', and that is searched sequentially. Thus,
1224if the tramp entry appears rather early in the `file-name-handler-alist' 1312if the tramp entry appears rather early in the `file-name-handler-alist'
1225and is a bit too general, then some files might be considered tramp 1313and is a bit too general, then some files might be considered tramp
1226files which are not really tramp files. 1314files which are not really Tramp files.
1227 1315
1228Please note that the entry in `file-name-handler-alist' is made when 1316Please note that the entry in `file-name-handler-alist' is made when
1229this file (tramp.el) is loaded. This means that this variable must be set 1317this file (tramp.el) is loaded. This means that this variable must be set
1230before loading tramp.el. Alternatively, `file-name-handler-alist' can be 1318before loading tramp.el. Alternatively, `file-name-handler-alist' can be
1231updated after changing this variable. 1319updated after changing this variable.
1232 1320
1233Also see `tramp-file-name-structure'." 1321Also see `tramp-file-name-structure'.")
1234 :group 'tramp
1235 :type 'regexp)
1236 1322
1237;;;###autoload 1323;;;###autoload
1238(defconst tramp-completion-file-name-regexp-unified 1324(defconst tramp-completion-file-name-regexp-unified
1239 "^/$\\|^/[^/:][^/]*$" 1325 (if (memq system-type '(cygwin windows-nt))
1326 "^\\([a-zA-Z]:\\)?/$\\|^\\([a-zA-Z]:\\)?/[^/:][^/]*$"
1327 "^/$\\|^/[^/:][^/]*$")
1240 "Value for `tramp-completion-file-name-regexp' for unified remoting. 1328 "Value for `tramp-completion-file-name-regexp' for unified remoting.
1241Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and 1329Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and
1242Tramp. See `tramp-file-name-structure-unified' for more explanations.") 1330Tramp. See `tramp-file-name-structure' for more explanations.")
1243 1331
1244;;;###autoload 1332;;;###autoload
1245(defconst tramp-completion-file-name-regexp-separate 1333(defconst tramp-completion-file-name-regexp-separate
1246 "^/\\([[][^]]*\\)?$" 1334 (if (memq system-type '(cygwin windows-nt))
1335 "^\\([a-zA-Z]:\\)?/\\([[][^]]*\\)?$"
1336 "^/\\([[][^]]*\\)?$")
1247 "Value for `tramp-completion-file-name-regexp' for separate remoting. 1337 "Value for `tramp-completion-file-name-regexp' for separate remoting.
1248XEmacs uses a separate filename syntax for Tramp and EFS. 1338XEmacs uses a separate filename syntax for Tramp and EFS.
1249See `tramp-file-name-structure-separate' for more explanations.") 1339See `tramp-file-name-structure' for more explanations.")
1340
1341;;;###autoload
1342(defconst tramp-completion-file-name-regexp-url
1343 (if (memq system-type '(cygwin windows-nt))
1344 "^\\([a-zA-Z]:\\)?/$\\|^\\([a-zA-Z]:\\)?/[^/:]+\\(:\\(/\\(/[^/]*\\)?\\)?\\)?$"
1345 "^/$\\|^/[^/:]+\\(:\\(/\\(/[^/]*\\)?\\)?\\)?$")
1346 "Value for `tramp-completion-file-name-regexp' for URL-like remoting.
1347See `tramp-file-name-structure' for more explanations.")
1250 1348
1251;;;###autoload 1349;;;###autoload
1252(defcustom tramp-completion-file-name-regexp 1350(defconst tramp-completion-file-name-regexp
1253 (if tramp-unified-filenames 1351 (cond ((equal tramp-syntax 'ftp) tramp-completion-file-name-regexp-unified)
1254 tramp-completion-file-name-regexp-unified 1352 ((equal tramp-syntax 'sep) tramp-completion-file-name-regexp-separate)
1255 tramp-completion-file-name-regexp-separate) 1353 ((equal tramp-syntax 'url) tramp-completion-file-name-regexp-url)
1354 (t (error "Wrong `tramp-syntax' defined")))
1256 "*Regular expression matching file names handled by tramp completion. 1355 "*Regular expression matching file names handled by tramp completion.
1257This regexp should match partial tramp file names only. 1356This regexp should match partial tramp file names only.
1258 1357
@@ -1261,121 +1360,14 @@ this file (tramp.el) is loaded. This means that this variable must be set
1261before loading tramp.el. Alternatively, `file-name-handler-alist' can be 1360before loading tramp.el. Alternatively, `file-name-handler-alist' can be
1262updated after changing this variable. 1361updated after changing this variable.
1263 1362
1264Also see `tramp-file-name-structure'." 1363Also see `tramp-file-name-structure'.")
1265 :group 'tramp
1266 :type 'regexp)
1267
1268(defcustom tramp-multi-file-name-structure
1269 (list
1270 (concat
1271 tramp-prefix-regexp
1272 "\\(" "\\(" tramp-method-regexp "\\)" "\\)?"
1273 "\\(" "\\(" tramp-postfix-multi-hop-regexp "%s" "\\)+" "\\)?"
1274 tramp-postfix-host-regexp "\\(" tramp-localname-regexp "\\)")
1275 2 3 -1)
1276 "*Describes the file name structure of `multi' files.
1277Multi files allow you to contact a remote host in several hops.
1278This is a list of four elements (REGEXP METHOD HOP LOCALNAME).
1279
1280The first element, REGEXP, gives a regular expression to match against
1281the file name. In this regular expression, `%s' is replaced with the
1282value of `tramp-multi-file-name-hop-structure'. (Note: in order to
1283allow multiple hops, you normally want to use something like
1284\"\\\\(\\\\(%s\\\\)+\\\\)\" in the regular expression. The outer pair
1285of parentheses is used for the HOP element, see below.)
1286
1287All remaining elements are numbers. METHOD gives the number of the
1288paren pair which matches the method name. HOP gives the number of the
1289paren pair which matches the hop sequence. LOCALNAME gives the number of
1290the paren pair which matches the localname (pathname) on the remote host.
1291
1292LOCALNAME can also be negative, which means to count from the end. Ie, a
1293value of -1 means the last paren pair.
1294
1295I think it would be good if the regexp matches the whole of the
1296string, but I haven't actually tried what happens if it doesn't..."
1297 :group 'tramp
1298 :type '(list (regexp :tag "File name regexp")
1299 (integer :tag "Paren pair for method name")
1300 (integer :tag "Paren pair for hops")
1301 (integer :tag "Paren pair to match localname")))
1302
1303(defcustom tramp-multi-file-name-hop-structure
1304 (list
1305 (concat
1306 "\\(" tramp-method-regexp "\\)" tramp-postfix-multi-method-regexp
1307 "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp
1308 "\\(" tramp-host-with-port-regexp "\\)")
1309 1 2 3)
1310 "*Describes the structure of a hop in multi files.
1311This is a list of four elements (REGEXP METHOD USER HOST). First
1312element REGEXP is used to match against the hop. Pair number METHOD
1313matches the method of one hop, pair number USER matches the user of
1314one hop, pair number HOST matches the host of one hop.
1315
1316This regular expression should match exactly all of one hop."
1317 :group 'tramp
1318 :type '(list (regexp :tag "Hop regexp")
1319 (integer :tag "Paren pair for method name")
1320 (integer :tag "Paren pair for user name")
1321 (integer :tag "Paren pair for host name")))
1322
1323(defcustom tramp-make-multi-tramp-file-format
1324 (list
1325 (concat tramp-prefix-format "%m")
1326 (concat tramp-postfix-multi-hop-format
1327 "%m" tramp-postfix-multi-method-format
1328 "%u" tramp-postfix-user-format
1329 "%h")
1330 (concat tramp-postfix-host-format "%p"))
1331 "*Describes how to construct a `multi' file name.
1332This is a list of three elements PREFIX, HOP and LOCALNAME.
1333
1334The first element PREFIX says how to construct the prefix, the second
1335element HOP specifies what each hop looks like, and the final element
1336LOCALNAME says how to construct the localname (pathname).
1337 1364
1338In PREFIX, `%%' means `%' and `%m' means the method name. 1365(defconst tramp-actions-before-shell
1339 1366 '((tramp-login-prompt-regexp tramp-action-login)
1340In HOP, `%%' means `%' and `%m', `%u', `%h' mean the hop method, hop 1367 (tramp-password-prompt-regexp tramp-action-password)
1341user and hop host, respectively. 1368 (tramp-wrong-passwd-regexp tramp-action-permission-denied)
1342
1343In LOCALNAME, `%%' means `%' and `%p' means the localname.
1344
1345The resulting file name always contains one copy of PREFIX and one
1346copy of LOCALNAME, but there is one copy of HOP for each hop in the file
1347name.
1348
1349Note: the current implementation requires the prefix to contain the
1350method name, followed by all the hops, and the localname must come
1351last."
1352 :group 'tramp
1353 :type '(list string string string))
1354
1355(defcustom tramp-terminal-type "dumb"
1356 "*Value of TERM environment variable for logging in to remote host.
1357Because Tramp wants to parse the output of the remote shell, it is easily
1358confused by ANSI color escape sequences and suchlike. Often, shell init
1359files conditionalize this setup based on the TERM environment variable."
1360 :group 'tramp
1361 :type 'string)
1362
1363(defcustom tramp-completion-without-shell-p nil
1364 "*If nil, use shell wildcards for completion, else rely on Lisp only.
1365Using shell wildcards for completions has the advantage that it can be
1366fast even in large directories, but completion is always
1367case-sensitive. Relying on Lisp only means that case-insensitive
1368completion is possible (subject to the variable `completion-ignore-case'),
1369but it might be slow on large directories."
1370 :group 'tramp
1371 :type 'boolean)
1372
1373(defcustom tramp-actions-before-shell
1374 '((tramp-password-prompt-regexp tramp-action-password)
1375 (tramp-login-prompt-regexp tramp-action-login)
1376 (shell-prompt-pattern tramp-action-succeed) 1369 (shell-prompt-pattern tramp-action-succeed)
1377 (tramp-shell-prompt-pattern tramp-action-succeed) 1370 (tramp-shell-prompt-pattern tramp-action-succeed)
1378 (tramp-wrong-passwd-regexp tramp-action-permission-denied)
1379 (tramp-yesno-prompt-regexp tramp-action-yesno) 1371 (tramp-yesno-prompt-regexp tramp-action-yesno)
1380 (tramp-yn-prompt-regexp tramp-action-yn) 1372 (tramp-yn-prompt-regexp tramp-action-yn)
1381 (tramp-terminal-prompt-regexp tramp-action-terminal) 1373 (tramp-terminal-prompt-regexp tramp-action-terminal)
@@ -1390,51 +1382,19 @@ regexp must match at the end of the buffer, \"\\'\" is implicitly
1390appended to it. 1382appended to it.
1391 1383
1392The ACTION should also be a symbol, but a function. When the 1384The ACTION should also be a symbol, but a function. When the
1393corresponding PATTERN matches, the ACTION function is called." 1385corresponding PATTERN matches, the ACTION function is called.")
1394 :group 'tramp
1395 :type '(repeat (list variable function)))
1396 1386
1397(defcustom tramp-actions-copy-out-of-band 1387(defconst tramp-actions-copy-out-of-band
1398 '((tramp-password-prompt-regexp tramp-action-password) 1388 '((tramp-password-prompt-regexp tramp-action-password)
1399 (tramp-wrong-passwd-regexp tramp-action-permission-denied) 1389 (tramp-wrong-passwd-regexp tramp-action-permission-denied)
1400 (tramp-copy-failed-regexp tramp-action-copy-failed) 1390 (tramp-copy-failed-regexp tramp-action-permission-denied)
1401 (tramp-process-alive-regexp tramp-action-out-of-band)) 1391 (tramp-process-alive-regexp tramp-action-out-of-band))
1402 "List of pattern/action pairs. 1392 "List of pattern/action pairs.
1403This list is used for copying/renaming with out-of-band methods. 1393This list is used for copying/renaming with out-of-band methods.
1404See `tramp-actions-before-shell' for more info."
1405 :group 'tramp
1406 :type '(repeat (list variable function)))
1407
1408(defcustom tramp-multi-actions
1409 '((tramp-password-prompt-regexp tramp-multi-action-password)
1410 (tramp-login-prompt-regexp tramp-multi-action-login)
1411 (shell-prompt-pattern tramp-multi-action-succeed)
1412 (tramp-shell-prompt-pattern tramp-multi-action-succeed)
1413 (tramp-wrong-passwd-regexp tramp-multi-action-permission-denied)
1414 (tramp-process-alive-regexp tramp-multi-action-process-alive))
1415 "List of pattern/action pairs.
1416This list is used for each hop in multi-hop connections.
1417See `tramp-actions-before-shell' for more info."
1418 :group 'tramp
1419 :type '(repeat (list variable function)))
1420
1421(defcustom tramp-initial-commands
1422 '("unset HISTORY"
1423 "unset correct"
1424 "unset autocorrect")
1425 "List of commands to send to the first remote shell that we see.
1426These commands will be sent to any shell, and thus they should be
1427designed to work in such circumstances. Also, restrict the commands
1428to the bare necessity for getting the remote shell into a state
1429where it is possible to execute the Bourne-ish shell.
1430
1431At the moment, the command to execute the Bourne-ish shell uses strange
1432quoting which `tcsh' tries to correct, so we send the command \"unset
1433autocorrect\" to the remote host."
1434 :group 'tramp
1435 :type '(repeat string))
1436 1394
1437;; Chunked sending kluge. We set this to 500 for black-listed constellations 1395See `tramp-actions-before-shell' for more info.")
1396
1397;; Chunked sending kludge. We set this to 500 for black-listed constellations
1438;; known to have a bug in `process-send-string'; some ssh connections appear 1398;; known to have a bug in `process-send-string'; some ssh connections appear
1439;; to drop bytes when data is sent too quickly. There is also a connection 1399;; to drop bytes when data is sent too quickly. There is also a connection
1440;; buffer local variable, which is computed depending on remote host properties 1400;; buffer local variable, which is computed depending on remote host properties
@@ -1490,16 +1450,16 @@ You will see the number of bytes sent successfully to the remote host.
1490If that number exceeds 1000, you can stop the execution by hitting 1450If that number exceeds 1000, you can stop the execution by hitting
1491C-g, because your Emacs is likely clean. 1451C-g, because your Emacs is likely clean.
1492 1452
1493If your Emacs is buggy, the code stops and gives you an indication
1494about the value `tramp-chunksize' should be set. Maybe you could just
1495experiment a bit, e.g. changing the values of `init' and `step'
1496in the third line of the code.
1497
1498When it is necessary to set `tramp-chunksize', you might consider to 1453When it is necessary to set `tramp-chunksize', you might consider to
1499use an out-of-the-band method (like \"scp\") instead of an internal one 1454use an out-of-the-band method (like \"scp\") instead of an internal one
1500\(like \"ssh\"), because setting `tramp-chunksize' to non-nil decreases 1455\(like \"ssh\"), because setting `tramp-chunksize' to non-nil decreases
1501performance. 1456performance.
1502 1457
1458If your Emacs is buggy, the code stops and gives you an indication
1459about the value `tramp-chunksize' should be set. Maybe you could just
1460experiment a bit, e.g. changing the values of `init' and `step'
1461in the third line of the code.
1462
1503Please raise a bug report via \"M-x tramp-bug\" if your system needs 1463Please raise a bug report via \"M-x tramp-bug\" if your system needs
1504this variable to be set as well." 1464this variable to be set as well."
1505 :group 'tramp 1465 :group 'tramp
@@ -1518,144 +1478,25 @@ opening a connection to a remote host."
1518 1478
1519;;; Internal Variables: 1479;;; Internal Variables:
1520 1480
1521(defvar tramp-buffer-file-attributes nil
1522 "Holds the `ls -ild' output for the current buffer.
1523This variable is local to each buffer. It is not used if the remote
1524machine groks Perl. If it is used, it's used as an emulation for
1525the visited file modtime.")
1526(make-variable-buffer-local 'tramp-buffer-file-attributes)
1527
1528(defvar tramp-md5-function
1529 (cond ((and (require 'md5) (fboundp 'md5)) 'md5)
1530 ((fboundp 'md5-encode)
1531 (lambda (x) (base64-encode-string
1532 (funcall (symbol-function 'md5-encode) x))))
1533 (t (error "Couldn't find an `md5' function")))
1534 "Function to call for running the MD5 algorithm.")
1535
1536(defvar tramp-end-of-output 1481(defvar tramp-end-of-output
1537 (concat "///" 1482 (concat
1538 (funcall tramp-md5-function 1483 "///" (md5 (concat
1539 (concat 1484 (prin1-to-string process-environment) (current-time-string))))
1540 (prin1-to-string process-environment)
1541 (current-time-string)
1542;; (prin1-to-string
1543;; (if (fboundp 'directory-files-and-attributes)
1544;; (funcall 'directory-files-and-attributes
1545;; (or (getenv "HOME")
1546;; (tramp-temporary-file-directory)))
1547;; (mapcar
1548;; (lambda (x)
1549;; (cons x (file-attributes x)))
1550;; (directory-files (or (getenv "HOME")
1551;; (tramp-temporary-file-directory))
1552;; t))))
1553 )))
1554 "String used to recognize end of output.") 1485 "String used to recognize end of output.")
1555 1486
1556(defvar tramp-connection-function nil
1557 "This internal variable holds a parameter for `tramp-methods'.
1558In the connection buffer, this variable has the value of the like-named
1559method parameter, as specified in `tramp-methods' (which see).")
1560
1561(defvar tramp-remote-sh nil
1562 "This internal variable holds a parameter for `tramp-methods'.
1563In the connection buffer, this variable has the value of the like-named
1564method parameter, as specified in `tramp-methods' (which see).")
1565
1566(defvar tramp-login-program nil
1567 "This internal variable holds a parameter for `tramp-methods'.
1568In the connection buffer, this variable has the value of the like-named
1569method parameter, as specified in `tramp-methods' (which see).")
1570
1571(defvar tramp-login-args nil
1572 "This internal variable holds a parameter for `tramp-methods'.
1573In the connection buffer, this variable has the value of the like-named
1574method parameter, as specified in `tramp-methods' (which see).")
1575
1576(defvar tramp-copy-program nil
1577 "This internal variable holds a parameter for `tramp-methods'.
1578In the connection buffer, this variable has the value of the like-named
1579method parameter, as specified in `tramp-methods' (which see).")
1580
1581(defvar tramp-copy-args nil
1582 "This internal variable holds a parameter for `tramp-methods'.
1583In the connection buffer, this variable has the value of the like-named
1584method parameter, as specified in `tramp-methods' (which see).")
1585
1586(defvar tramp-copy-keep-date-arg nil
1587 "This internal variable holds a parameter for `tramp-methods'.
1588In the connection buffer, this variable has the value of the like-named
1589method parameter, as specified in `tramp-methods' (which see).")
1590
1591(defvar tramp-encoding-command nil
1592 "This internal variable holds a parameter for `tramp-methods'.
1593In the connection buffer, this variable has the value of the like-named
1594method parameter, as specified in `tramp-methods' (which see).")
1595
1596(defvar tramp-decoding-command nil
1597 "This internal variable holds a parameter for `tramp-methods'.
1598In the connection buffer, this variable has the value of the like-named
1599method parameter, as specified in `tramp-methods' (which see).")
1600
1601(defvar tramp-encoding-function nil
1602 "This internal variable holds a parameter for `tramp-methods'.
1603In the connection buffer, this variable has the value of the like-named
1604method parameter, as specified in `tramp-methods' (which see).")
1605
1606(defvar tramp-decoding-function nil
1607 "This internal variable holds a parameter for `tramp-methods'.
1608In the connection buffer, this variable has the value of the like-named
1609method parameter, as specified in `tramp-methods' (which see).")
1610
1611(defvar tramp-password-end-of-line nil
1612 "This internal variable holds a parameter for `tramp-methods'.
1613In the connection buffer, this variable has the value of the like-named
1614method parameter, as specified in `tramp-methods' (which see).")
1615
1616;; CCC `local in each buffer'?
1617(defvar tramp-ls-command nil
1618 "This command is used to get a long listing with numeric user and group ids.
1619This variable is automatically made buffer-local to each rsh process buffer
1620upon opening the connection.")
1621
1622(defvar tramp-current-multi-method nil
1623 "Name of `multi' connection method for this *tramp* buffer, or nil if not multi.
1624This variable is automatically made buffer-local to each rsh process buffer
1625upon opening the connection.")
1626
1627(defvar tramp-current-method nil 1487(defvar tramp-current-method nil
1628 "Connection method for this *tramp* buffer. 1488 "Connection method for this *tramp* buffer.")
1629This variable is automatically made buffer-local to each rsh process buffer
1630upon opening the connection.")
1631 1489
1632(defvar tramp-current-user nil 1490(defvar tramp-current-user nil
1633 "Remote login name for this *tramp* buffer. 1491 "Remote login name for this *tramp* buffer.")
1634This variable is automatically made buffer-local to each rsh process buffer
1635upon opening the connection.")
1636 1492
1637(defvar tramp-current-host nil 1493(defvar tramp-current-host nil
1638 "Remote host for this *tramp* buffer. 1494 "Remote host for this *tramp* buffer.")
1639This variable is automatically made buffer-local to each rsh process buffer 1495
1640upon opening the connection.") 1496(defconst tramp-uudecode
1641 1497 "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode
1642(defvar tramp-test-groks-nt nil
1643 "Whether the `test' command groks the `-nt' switch.
1644\(`test A -nt B' tests if file A is newer than file B.)
1645This variable is automatically made buffer-local to each rsh process buffer
1646upon opening the connection.")
1647
1648(defvar tramp-file-exists-command nil
1649 "Command to use for checking if a file exists.
1650This variable is automatically made buffer-local to each rsh process buffer
1651upon opening the connection.")
1652
1653(defconst tramp-uudecode "\
1654tramp_uudecode () {
1655\(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode
1656cat /tmp/tramp.$$ 1498cat /tmp/tramp.$$
1657rm -f /tmp/tramp.$$ 1499rm -f /tmp/tramp.$$"
1658}"
1659 "Shell function to implement `uudecode' to standard output. 1500 "Shell function to implement `uudecode' to standard output.
1660Many systems support `uudecode -o /dev/stdout' or `uudecode -o -' 1501Many systems support `uudecode -o /dev/stdout' or `uudecode -o -'
1661for this or `uudecode -p', but some systems don't, and for them 1502for this or `uudecode -p', but some systems don't, and for them
@@ -1667,7 +1508,8 @@ we have this shell function.")
1667;; end. 1508;; end.
1668;; The device number is returned as "-1", because there will be a virtual 1509;; The device number is returned as "-1", because there will be a virtual
1669;; device number set in `tramp-handle-file-attributes' 1510;; device number set in `tramp-handle-file-attributes'
1670(defconst tramp-perl-file-attributes "\ 1511(defconst tramp-perl-file-attributes
1512 "%s -e '
1671@stat = lstat($ARGV[0]); 1513@stat = lstat($ARGV[0]);
1672if (($stat[2] & 0170000) == 0120000) 1514if (($stat[2] & 0170000) == 0120000)
1673{ 1515{
@@ -1685,7 +1527,7 @@ else
1685$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; 1527$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
1686$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; 1528$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
1687printf( 1529printf(
1688 \"(%s %u %s %s (%u %u) (%u %u) (%u %u) %u %u t (%u . %u) -1)\\n\", 1530 \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t (%%u . %%u) -1)\\n\",
1689 $type, 1531 $type,
1690 $stat[3], 1532 $stat[3],
1691 $uid, 1533 $uid,
@@ -1700,11 +1542,14 @@ printf(
1700 $stat[2], 1542 $stat[2],
1701 $stat[1] >> 16 & 0xffff, 1543 $stat[1] >> 16 & 0xffff,
1702 $stat[1] & 0xffff 1544 $stat[1] & 0xffff
1703);" 1545);' \"$1\" \"$2\" \"$3\" 2>/dev/null"
1704 "Perl script to produce output suitable for use with `file-attributes' 1546 "Perl script to produce output suitable for use with `file-attributes'
1705on the remote file system.") 1547on the remote file system.
1548Escape sequence %s is replaced with name of Perl binary.
1549This string is passed to `format', so percent characters need to be doubled.")
1706 1550
1707(defconst tramp-perl-directory-files-and-attributes "\ 1551(defconst tramp-perl-directory-files-and-attributes
1552 "%s -e '
1708chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); 1553chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit();
1709opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit(); 1554opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit();
1710@list = readdir(DIR); 1555@list = readdir(DIR);
@@ -1731,7 +1576,7 @@ for($i = 0; $i < $n; $i++)
1731 $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; 1576 $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
1732 $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; 1577 $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
1733 printf( 1578 printf(
1734 \"(\\\"%s\\\" %s %u %s %s (%u %u) (%u %u) (%u %u) %u %u t (%u . %u) (%u %u))\\n\", 1579 \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t (%%u . %%u) (%%u %%u))\\n\",
1735 $filename, 1580 $filename,
1736 $type, 1581 $type,
1737 $stat[3], 1582 $stat[3],
@@ -1750,9 +1595,11 @@ for($i = 0; $i < $n; $i++)
1750 $stat[0] >> 16 & 0xffff, 1595 $stat[0] >> 16 & 0xffff,
1751 $stat[0] & 0xffff); 1596 $stat[0] & 0xffff);
1752} 1597}
1753printf(\")\\n\");" 1598printf(\")\\n\");' \"$1\" \"$2\" \"$3\" 2>/dev/null"
1754 "Perl script implementing `directory-files-attributes' as Lisp `read'able 1599 "Perl script implementing `directory-files-attributes' as Lisp `read'able
1755output.") 1600output.
1601Escape sequence %s is replaced with name of Perl binary.
1602This string is passed to `format', so percent characters need to be doubled.")
1756 1603
1757;; ;; These two use uu encoding. 1604;; ;; These two use uu encoding.
1758;; (defvar tramp-perl-encode "%s -e'\ 1605;; (defvar tramp-perl-encode "%s -e'\
@@ -1775,25 +1622,25 @@ output.")
1775;; Escape sequence %s is replaced with name of Perl binary.") 1622;; Escape sequence %s is replaced with name of Perl binary.")
1776 1623
1777;; These two use base64 encoding. 1624;; These two use base64 encoding.
1778(defvar tramp-perl-encode-with-module 1625(defconst tramp-perl-encode-with-module
1779 "perl -MMIME::Base64 -0777 -ne 'print encode_base64($_)'" 1626 "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null"
1780 "Perl program to use for encoding a file. 1627 "Perl program to use for encoding a file.
1781Escape sequence %s is replaced with name of Perl binary. 1628Escape sequence %s is replaced with name of Perl binary.
1782This string is passed to `format', so percent characters need to be doubled. 1629This string is passed to `format', so percent characters need to be doubled.
1783This implementation requires the MIME::Base64 Perl module to be installed 1630This implementation requires the MIME::Base64 Perl module to be installed
1784on the remote host.") 1631on the remote host.")
1785 1632
1786(defvar tramp-perl-decode-with-module 1633(defconst tramp-perl-decode-with-module
1787 "perl -MMIME::Base64 -0777 -ne 'print decode_base64($_)'" 1634 "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null"
1788 "Perl program to use for decoding a file. 1635 "Perl program to use for decoding a file.
1789Escape sequence %s is replaced with name of Perl binary. 1636Escape sequence %s is replaced with name of Perl binary.
1790This string is passed to `format', so percent characters need to be doubled. 1637This string is passed to `format', so percent characters need to be doubled.
1791This implementation requires the MIME::Base64 Perl module to be installed 1638This implementation requires the MIME::Base64 Perl module to be installed
1792on the remote host.") 1639on the remote host.")
1793 1640
1794(defvar tramp-perl-encode 1641(defconst tramp-perl-encode
1795 "%s -e ' 1642 "%s -e '
1796# This script contributed by Juanma Barranquero <lektu@terra.es>. 1643# This script is contributed by Juanma Barranquero <lektu@terra.es>.
1797# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 1644# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
1798# Free Software Foundation, Inc. 1645# Free Software Foundation, Inc.
1799use strict; 1646use strict;
@@ -1828,15 +1675,14 @@ while (my $data = <STDIN>) {
1828 (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)), 1675 (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)),
1829 $pad, 1676 $pad,
1830 qq(\\n); 1677 qq(\\n);
1831} 1678}' 2>/dev/null"
1832'"
1833 "Perl program to use for encoding a file. 1679 "Perl program to use for encoding a file.
1834Escape sequence %s is replaced with name of Perl binary. 1680Escape sequence %s is replaced with name of Perl binary.
1835This string is passed to `format', so percent characters need to be doubled.") 1681This string is passed to `format', so percent characters need to be doubled.")
1836 1682
1837(defvar tramp-perl-decode 1683(defconst tramp-perl-decode
1838 "%s -e ' 1684 "%s -e '
1839# This script contributed by Juanma Barranquero <lektu@terra.es>. 1685# This script is contributed by Juanma Barranquero <lektu@terra.es>.
1840# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 1686# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
1841# Free Software Foundation, Inc. 1687# Free Software Foundation, Inc.
1842use strict; 1688use strict;
@@ -1874,8 +1720,7 @@ while (my $data = <STDIN>) {
1874 ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g); 1720 ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g);
1875 1721
1876 last if $finished; 1722 last if $finished;
1877} 1723}' 2>/dev/null"
1878'"
1879 "Perl program to use for decoding a file. 1724 "Perl program to use for decoding a file.
1880Escape sequence %s is replaced with name of Perl binary. 1725Escape sequence %s is replaced with name of Perl binary.
1881This string is passed to `format', so percent characters need to be doubled.") 1726This string is passed to `format', so percent characters need to be doubled.")
@@ -1898,44 +1743,12 @@ This string is passed to `format', so percent characters need to be doubled.")
1898 "A list of file types returned from the `stat' system call. 1743 "A list of file types returned from the `stat' system call.
1899This is used to map a mode number to a permission string.") 1744This is used to map a mode number to a permission string.")
1900 1745
1901(defvar tramp-dos-coding-system
1902 (if (and (fboundp 'coding-system-p)
1903 (funcall 'coding-system-p '(dos)))
1904 'dos
1905 'undecided-dos)
1906 "Some Emacsen know the `dos' coding system, others need `undecided-dos'.")
1907
1908(defvar tramp-last-cmd nil
1909 "Internal Tramp variable recording the last command sent.
1910This variable is buffer-local in every buffer.")
1911(make-variable-buffer-local 'tramp-last-cmd)
1912
1913(defvar tramp-process-echoes nil
1914 "Whether to process echoes from the remote shell.")
1915
1916(defvar tramp-last-cmd-time nil
1917 "Internal Tramp variable recording the time when the last cmd was sent.
1918This variable is buffer-local in every buffer.")
1919(make-variable-buffer-local 'tramp-last-cmd-time)
1920
1921;; This variable does not have the right value in XEmacs. What should
1922;; I use instead of find-operation-coding-system in XEmacs?
1923(defvar tramp-feature-write-region-fix
1924 (when (fboundp 'find-operation-coding-system)
1925 (let ((file-coding-system-alist '(("test" emacs-mule))))
1926 (funcall (symbol-function 'find-operation-coding-system)
1927 'write-region 0 0 "" nil "test")))
1928 "Internal variable to say if `write-region' chooses the right coding.
1929Older versions of Emacs chose the coding system for `write-region' based
1930on the FILENAME argument, even if VISIT was a string.")
1931
1932;; New handlers should be added here. The following operations can be 1746;; New handlers should be added here. The following operations can be
1933;; handled using the normal primitives: file-name-as-directory, 1747;; handled using the normal primitives: file-name-as-directory,
1934;; file-name-directory, file-name-nondirectory, 1748;; file-name-directory, file-name-nondirectory,
1935;; file-name-sans-versions, get-file-buffer. 1749;; file-name-sans-versions, get-file-buffer.
1936(defconst tramp-file-name-handler-alist 1750(defconst tramp-file-name-handler-alist
1937 '( 1751 '((load . tramp-handle-load)
1938 (load . tramp-handle-load)
1939 (make-symbolic-link . tramp-handle-make-symbolic-link) 1752 (make-symbolic-link . tramp-handle-make-symbolic-link)
1940 (file-name-directory . tramp-handle-file-name-directory) 1753 (file-name-directory . tramp-handle-file-name-directory)
1941 (file-name-nondirectory . tramp-handle-file-name-nondirectory) 1754 (file-name-nondirectory . tramp-handle-file-name-nondirectory)
@@ -1943,7 +1756,6 @@ on the FILENAME argument, even if VISIT was a string.")
1943 (file-exists-p . tramp-handle-file-exists-p) 1756 (file-exists-p . tramp-handle-file-exists-p)
1944 (file-directory-p . tramp-handle-file-directory-p) 1757 (file-directory-p . tramp-handle-file-directory-p)
1945 (file-executable-p . tramp-handle-file-executable-p) 1758 (file-executable-p . tramp-handle-file-executable-p)
1946 (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
1947 (file-readable-p . tramp-handle-file-readable-p) 1759 (file-readable-p . tramp-handle-file-readable-p)
1948 (file-regular-p . tramp-handle-file-regular-p) 1760 (file-regular-p . tramp-handle-file-regular-p)
1949 (file-symlink-p . tramp-handle-file-symlink-p) 1761 (file-symlink-p . tramp-handle-file-symlink-p)
@@ -1964,10 +1776,14 @@ on the FILENAME argument, even if VISIT was a string.")
1964 (delete-directory . tramp-handle-delete-directory) 1776 (delete-directory . tramp-handle-delete-directory)
1965 (delete-file . tramp-handle-delete-file) 1777 (delete-file . tramp-handle-delete-file)
1966 (directory-file-name . tramp-handle-directory-file-name) 1778 (directory-file-name . tramp-handle-directory-file-name)
1967 (shell-command . tramp-handle-shell-command) 1779 ;; `executable-find' is not official yet.
1780 (executable-find . tramp-handle-executable-find)
1781 (start-file-process . tramp-handle-start-file-process)
1968 (process-file . tramp-handle-process-file) 1782 (process-file . tramp-handle-process-file)
1783 (shell-command . tramp-handle-shell-command)
1969 (insert-directory . tramp-handle-insert-directory) 1784 (insert-directory . tramp-handle-insert-directory)
1970 (expand-file-name . tramp-handle-expand-file-name) 1785 (expand-file-name . tramp-handle-expand-file-name)
1786 (substitute-in-file-name . tramp-handle-substitute-in-file-name)
1971 (file-local-copy . tramp-handle-file-local-copy) 1787 (file-local-copy . tramp-handle-file-local-copy)
1972 (file-remote-p . tramp-handle-file-remote-p) 1788 (file-remote-p . tramp-handle-file-remote-p)
1973 (insert-file-contents . tramp-handle-insert-file-contents) 1789 (insert-file-contents . tramp-handle-insert-file-contents)
@@ -1976,7 +1792,6 @@ on the FILENAME argument, even if VISIT was a string.")
1976 (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) 1792 (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
1977 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) 1793 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
1978 (dired-compress-file . tramp-handle-dired-compress-file) 1794 (dired-compress-file . tramp-handle-dired-compress-file)
1979 (dired-call-process . tramp-handle-dired-call-process)
1980 (dired-recursive-delete-directory 1795 (dired-recursive-delete-directory
1981 . tramp-handle-dired-recursive-delete-directory) 1796 . tramp-handle-dired-recursive-delete-directory)
1982 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) 1797 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
@@ -2006,37 +1821,115 @@ calling HANDLER.")
2006 1821
2007;;; Internal functions which must come first. 1822;;; Internal functions which must come first.
2008 1823
2009(defsubst tramp-message (level fmt-string &rest args) 1824(defsubst tramp-debug-message (vec fmt-string &rest args)
1825 "Append message to debug buffer.
1826Message is formatted with FMT-STRING as control string and the remaining
1827ARGS to actually emit the message (if applicable)."
1828 (when (get-buffer (tramp-buffer-name vec))
1829 (with-current-buffer (tramp-get-debug-buffer vec)
1830 (goto-char (point-max))
1831 (unless (bolp)
1832 (insert "\n"))
1833 ;; Timestamp
1834 (insert (format-time-string "%T "))
1835 ;; Calling function
1836 (let ((btn 1) btf fn)
1837 (while (not fn)
1838 (setq btf (nth 1 (backtrace-frame btn)))
1839 (if (not btf)
1840 (setq fn "")
1841 (when (symbolp btf)
1842 (setq fn (symbol-name btf))
1843 (unless (and (string-match "^tramp" fn)
1844 (not (string-match
1845 "^tramp\\(-debug\\)?\\(-message\\|-error\\)$"
1846 fn)))
1847 (setq fn nil)))
1848 (setq btn (1+ btn))))
1849 ;; The following code inserts filename and line number.
1850 ;; Should be deactivated by default, because it is time
1851 ;; consuming.
1852; (let ((ffn (find-function-noselect (intern fn))))
1853; (insert
1854; (format
1855; "%s:%d: "
1856; (file-name-nondirectory (buffer-file-name (car ffn)))
1857; (with-current-buffer (car ffn)
1858; (1+ (count-lines (point-min) (cdr ffn)))))))
1859 (insert (format "%s " fn)))
1860 ;; The message
1861 (insert (apply 'format fmt-string args)))))
1862
1863(defsubst tramp-message (vec-or-proc level fmt-string &rest args)
2010 "Emit a message depending on verbosity level. 1864 "Emit a message depending on verbosity level.
2011First arg LEVEL says to be quiet if `tramp-verbose' is less than LEVEL. The 1865VEC-OR-PROC identifies the tramp buffer to use. It can be either a
2012message is emitted only if `tramp-verbose' is greater than or equal to LEVEL. 1866vector or a process. LEVEL says to be quiet if `tramp-verbose' is
2013Calls function `message' with FMT-STRING as control string and the remaining 1867less than LEVEL. The message is emitted only if `tramp-verbose' is
2014ARGS to actually emit the message (if applicable). 1868greater than or equal to LEVEL.
2015 1869
2016This function expects to be called from the tramp buffer only!" 1870The message is also logged into the debug buffer when `tramp-verbose'
2017 (when (<= level tramp-verbose) 1871is greater than or equal 4.
2018 (apply #'message (concat "tramp: " fmt-string) args) 1872
2019 (when tramp-debug-buffer 1873Calls functions `message' and `tramp-debug-message' with FMT-STRING as
2020 (save-excursion 1874control string and the remaining ARGS to actually emit the message (if
2021 (set-buffer 1875applicable)."
2022 (tramp-get-debug-buffer 1876 (condition-case nil
2023 tramp-current-multi-method tramp-current-method 1877 (when (<= level tramp-verbose)
2024 tramp-current-user tramp-current-host)) 1878 ;; Match data must be preserved!
2025 (goto-char (point-max)) 1879 (save-match-data
2026 (unless (bolp) 1880 ;; Display only when there is a minimum level.
2027 (insert "\n")) 1881 (when (<= level 3)
2028 (tramp-insert-with-face 1882 (apply 'message
2029 'italic 1883 (concat
2030 (concat "# " (apply #'format fmt-string args) "\n")))))) 1884 (cond
2031 1885 ((= level 0) "")
2032(defun tramp-message-for-buffer 1886 ((= level 1) "")
2033 (multi-method method user host level fmt-string &rest args) 1887 ((= level 2) "Warning: ")
2034 "Like `tramp-message' but temporarily switches to the tramp buffer. 1888 (t "Tramp: "))
2035First three args METHOD, USER, and HOST identify the tramp buffer to use, 1889 fmt-string)
2036remaining args passed to `tramp-message'." 1890 args))
2037 (save-excursion 1891 ;; Log only when there is a minimum level.
2038 (set-buffer (tramp-get-buffer multi-method method user host)) 1892 (when (>= tramp-verbose 4)
2039 (apply 'tramp-message level fmt-string args))) 1893 (when (and vec-or-proc
1894 (processp vec-or-proc)
1895 (buffer-name (process-buffer vec-or-proc)))
1896 (with-current-buffer (process-buffer vec-or-proc)
1897 ;; Translate proc to vec.
1898 (setq vec-or-proc (tramp-dissect-file-name default-directory))))
1899 (when (and vec-or-proc (vectorp vec-or-proc))
1900 (apply 'tramp-debug-message
1901 vec-or-proc
1902 (concat (format "(%d) # " level) fmt-string)
1903 args)))))
1904 ;; Suppress all errors.
1905 (error nil)))
1906
1907(defsubst tramp-error (vec-or-proc signal fmt-string &rest args)
1908 "Emit an error.
1909VEC-OR-PROC identifies the connection to use, SIGNAL is the
1910signal identifier to be raised, remaining args passed to
1911`tramp-message'. Finally, signal SIGNAL is raised."
1912 (tramp-message
1913 vec-or-proc 1 "%s"
1914 (error-message-string
1915 (list signal (get signal 'error-message) (apply 'format fmt-string args))))
1916 (signal signal (list (apply 'format fmt-string args))))
1917
1918(defsubst tramp-error-with-buffer
1919 (buffer vec-or-proc signal fmt-string &rest args)
1920 "Emit an error, and show BUFFER.
1921If BUFFER is nil, show the connection buffer. Wait for 30\", or until
1922an input event arrives. The other arguments are passed to `tramp-error'."
1923 (save-window-excursion
1924 (unwind-protect
1925 (apply 'tramp-error vec-or-proc signal fmt-string args)
1926 (when (and vec-or-proc (not (zerop tramp-verbose)))
1927 (let ((enable-recursive-minibuffers t))
1928 (pop-to-buffer
1929 (or (and (bufferp buffer) buffer)
1930 (and (processp vec-or-proc) (process-buffer vec-or-proc))
1931 (tramp-get-buffer vec-or-proc)))
1932 (sit-for 30))))))
2040 1933
2041(defsubst tramp-line-end-position nil 1934(defsubst tramp-line-end-position nil
2042 "Return point at end of line. 1935 "Return point at end of line.
@@ -2054,18 +1947,15 @@ First arg FILENAME is evaluated and dissected into its components.
2054Second arg VAR is a symbol. It is used as a variable name to hold 1947Second arg VAR is a symbol. It is used as a variable name to hold
2055the filename structure. It is also used as a prefix for the variables 1948the filename structure. It is also used as a prefix for the variables
2056holding the components. For example, if VAR is the symbol `foo', then 1949holding the components. For example, if VAR is the symbol `foo', then
2057`foo' will be bound to the whole structure, `foo-multi-method' will 1950`foo' will be bound to the whole structure, `foo-method' will be bound to
2058be bound to the multi-method component, and so on for `foo-method', 1951the method component, and so on for `foo-user', `foo-host', `foo-localname'.
2059`foo-user', `foo-host', `foo-localname'.
2060 1952
2061Remaining args are Lisp expressions to be evaluated (inside an implicit 1953Remaining args are Lisp expressions to be evaluated (inside an implicit
2062`progn'). 1954`progn').
2063 1955
2064If VAR is nil, then we bind `v' to the structure and `multi-method', 1956If VAR is nil, then we bind `v' to the structure and `method', `user',
2065`method', `user', `host', `localname' to the components." 1957`host', `localname' to the components."
2066 `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) 1958 `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename))
2067 (,(if var (intern (concat (symbol-name var) "-multi-method")) 'multi-method)
2068 (tramp-file-name-multi-method ,(or var 'v)))
2069 (,(if var (intern (concat (symbol-name var) "-method")) 'method) 1959 (,(if var (intern (concat (symbol-name var) "-method")) 'method)
2070 (tramp-file-name-method ,(or var 'v))) 1960 (tramp-file-name-method ,(or var 'v)))
2071 (,(if var (intern (concat (symbol-name var) "-user")) 'user) 1961 (,(if var (intern (concat (symbol-name var) "-user")) 'user)
@@ -2077,15 +1967,45 @@ If VAR is nil, then we bind `v' to the structure and `multi-method',
2077 ,@body)) 1967 ,@body))
2078 1968
2079(put 'with-parsed-tramp-file-name 'lisp-indent-function 2) 1969(put 'with-parsed-tramp-file-name 'lisp-indent-function 2)
1970(put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body))
2080;; Enable debugging. 1971;; Enable debugging.
2081(eval-and-compile 1972;(eval-and-compile
2082 (when (featurep 'edebug) 1973; (when (featurep 'edebug)
2083 (def-edebug-spec with-parsed-tramp-file-name (form symbolp body)))) 1974; (def-edebug-spec with-parsed-tramp-file-name (form symbolp body))))
2084;; Highlight as keyword. 1975;; Highlight as keyword.
2085(when (functionp 'font-lock-add-keywords) 1976(when (functionp 'font-lock-add-keywords)
2086 (funcall 'font-lock-add-keywords 1977 (funcall 'font-lock-add-keywords
2087 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>"))) 1978 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")))
2088 1979
1980(defmacro with-file-property (vec file property &rest body)
1981 "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache.
1982FILE must be a local file name on a connection identified via VEC."
1983 `(if (file-name-absolute-p ,file)
1984 (let ((value (tramp-get-file-property ,vec ,file ,property 'undef)))
1985 (when (eq value 'undef)
1986 ;; We cannot pass @body as parameter to
1987 ;; `tramp-set-file-property' because it mangles our
1988 ;; debug messages.
1989 (setq value (progn ,@body))
1990 (tramp-set-file-property ,vec ,file ,property value))
1991 value)
1992 ,@body))
1993(put 'with-file-property 'lisp-indent-function 3)
1994(put 'with-file-property 'edebug-form-spec t)
1995
1996(defmacro with-connection-property (key property &rest body)
1997 "Checks in Tramp for property PROPERTY, otherwise executes BODY and set."
1998 `(let ((value (tramp-get-connection-property ,key ,property 'undef)))
1999 (when (eq value 'undef)
2000 ;; We cannot pass ,@body as parameter to
2001 ;; `tramp-set-connection-property' because it mangles our debug
2002 ;; messages.
2003 (setq value (progn ,@body))
2004 (tramp-set-connection-property ,key ,property value))
2005 value))
2006(put 'with-connection-property 'lisp-indent-function 2)
2007(put 'with-connection-property 'edebug-form-spec t)
2008
2089(defmacro tramp-let-maybe (variable value &rest body) 2009(defmacro tramp-let-maybe (variable value &rest body)
2090 "Let-bind VARIABLE to VALUE in BODY, but only if VARIABLE is not obsolete. 2010 "Let-bind VARIABLE to VALUE in BODY, but only if VARIABLE is not obsolete.
2091BODY is executed whether or not the variable is obsolete. 2011BODY is executed whether or not the variable is obsolete.
@@ -2122,12 +2042,17 @@ Example:
2122 tramp-completion-function-alist)) 2042 tramp-completion-function-alist))
2123 2043
2124 (while v 2044 (while v
2125 ;; Remove double entries 2045 ;; Remove double entries.
2126 (when (member (car v) (cdr v)) 2046 (when (member (car v) (cdr v))
2127 (setcdr v (delete (car v) (cdr v)))) 2047 (setcdr v (delete (car v) (cdr v))))
2128 ;; Check for function and file 2048 ;; Check for function and file or registry key.
2129 (unless (and (functionp (nth 0 (car v))) 2049 (unless (and (functionp (nth 0 (car v)))
2130 (file-exists-p (nth 1 (car v)))) 2050 (if (string-match "^HKEY_CURRENT_USER" (nth 1 (car v)))
2051 ;; Windows registry.
2052 (and (memq system-type '(cygwin windows-nt))
2053 (zerop (call-process "reg" nil nil nil "query" (nth 1 (car v)))))
2054 ;; Configuration file.
2055 (file-exists-p (nth 1 (car v)))))
2131 (setq r (delete (car v) r))) 2056 (setq r (delete (car v) r)))
2132 (setq v (cdr v))) 2057 (setq v (cdr v)))
2133 2058
@@ -2136,15 +2061,19 @@ Example:
2136 (cons method r))))) 2061 (cons method r)))))
2137 2062
2138(defun tramp-get-completion-function (method) 2063(defun tramp-get-completion-function (method)
2139 "Returns list of completion functions for METHOD. 2064 "Returns a list of completion functions for METHOD.
2140For definition of that list see `tramp-set-completion-function'." 2065For definition of that list see `tramp-set-completion-function'."
2141 (cdr (assoc method tramp-completion-function-alist))) 2066 (cons
2067 ;; Hosts visited once shall be remembered.
2068 `(tramp-parse-connection-properties ,method)
2069 ;; The method related defaults.
2070 (cdr (assoc method tramp-completion-function-alist))))
2142 2071
2143;;; File Name Handler Functions: 2072;;; File Name Handler Functions:
2144 2073
2145(defun tramp-handle-make-symbolic-link 2074(defun tramp-handle-make-symbolic-link
2146 (filename linkname &optional ok-if-already-exists) 2075 (filename linkname &optional ok-if-already-exists)
2147 "Like `make-symbolic-link' for tramp files. 2076 "Like `make-symbolic-link' for Tramp files.
2148If LINKNAME is a non-Tramp file, it is used verbatim as the target of 2077If LINKNAME is a non-Tramp file, it is used verbatim as the target of
2149the symlink. If LINKNAME is a Tramp file, only the localname component is 2078the symlink. If LINKNAME is a Tramp file, only the localname component is
2150used as the target of the symlink. 2079used as the target of the symlink.
@@ -2154,12 +2083,12 @@ it is expanded first, before the localname component is taken. Note that
2154this can give surprising results if the user/host for the source and 2083this can give surprising results if the user/host for the source and
2155target of the symlink differ." 2084target of the symlink differ."
2156 (with-parsed-tramp-file-name linkname l 2085 (with-parsed-tramp-file-name linkname l
2157 (let ((ln (tramp-get-remote-ln l-multi-method l-method l-user l-host)) 2086 (let ((ln (tramp-get-remote-ln l))
2158 (cwd (file-name-directory l-localname))) 2087 (cwd (file-name-directory l-localname)))
2159 (unless ln 2088 (unless ln
2160 (signal 'file-error 2089 (tramp-error
2161 (list "Making a symbolic link." 2090 l 'file-error
2162 "ln(1) does not exist on the remote host."))) 2091 "Making a symbolic link. ln(1) does not exist on the remote host."))
2163 2092
2164 ;; Do the 'confirm if exists' thing. 2093 ;; Do the 'confirm if exists' thing.
2165 (when (file-exists-p linkname) 2094 (when (file-exists-p linkname)
@@ -2170,7 +2099,8 @@ target of the symlink differ."
2170 (format 2099 (format
2171 "File %s already exists; make it a link anyway? " 2100 "File %s already exists; make it a link anyway? "
2172 l-localname))))) 2101 l-localname)))))
2173 (signal 'file-already-exists (list "File already exists" l-localname)) 2102 (tramp-error
2103 l 'file-already-exists "File %s already exists" l-localname)
2174 (delete-file linkname))) 2104 (delete-file linkname)))
2175 2105
2176 ;; If FILENAME is a Tramp name, use just the localname component. 2106 ;; If FILENAME is a Tramp name, use just the localname component.
@@ -2184,19 +2114,12 @@ target of the symlink differ."
2184 ;; that FILENAME belongs to. 2114 ;; that FILENAME belongs to.
2185 (zerop 2115 (zerop
2186 (tramp-send-command-and-check 2116 (tramp-send-command-and-check
2187 l-multi-method l-method l-user l-host 2117 l (format "cd %s && %s -sf %s %s" cwd ln filename l-localname) t)))))
2188 (format "cd %s && %s -sf %s %s"
2189 cwd ln
2190 filename
2191 l-localname)
2192 t)))))
2193 2118
2194 2119
2195(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) 2120(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix)
2196 "Like `load' for tramp files. Not implemented!" 2121 "Like `load' for Tramp files."
2197 (unless (file-name-absolute-p file) 2122 (with-parsed-tramp-file-name (expand-file-name file) nil
2198 (error "Tramp cannot `load' files without absolute file name"))
2199 (with-parsed-tramp-file-name file nil
2200 (unless nosuffix 2123 (unless nosuffix
2201 (cond ((file-exists-p (concat file ".elc")) 2124 (cond ((file-exists-p (concat file ".elc"))
2202 (setq file (concat file ".elc"))) 2125 (setq file (concat file ".elc")))
@@ -2207,138 +2130,138 @@ target of the symlink differ."
2207 ;; Included for safety's sake. 2130 ;; Included for safety's sake.
2208 (unless (or (file-name-directory file) 2131 (unless (or (file-name-directory file)
2209 (string-match "\\.elc?\\'" file)) 2132 (string-match "\\.elc?\\'" file))
2210 (error "File `%s' does not include a `.el' or `.elc' suffix" 2133 (tramp-error
2211 file))) 2134 v 'file-error
2135 "File `%s' does not include a `.el' or `.elc' suffix" file)))
2212 (unless noerror 2136 (unless noerror
2213 (when (not (file-exists-p file)) 2137 (when (not (file-exists-p file))
2214 (error "Cannot load nonexistent file `%s'" file))) 2138 (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file)))
2215 (if (not (file-exists-p file)) 2139 (if (not (file-exists-p file))
2216 nil 2140 nil
2217 (unless nomessage 2141 (unless nomessage (tramp-message v 0 "Loading %s..." file))
2218 (message "Loading %s..." file))
2219 (let ((local-copy (file-local-copy file))) 2142 (let ((local-copy (file-local-copy file)))
2220 ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil. 2143 ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil.
2221 (load local-copy noerror t t) 2144 (load local-copy noerror t t)
2222 (delete-file local-copy)) 2145 (delete-file local-copy))
2223 (unless nomessage 2146 (unless nomessage (tramp-message v 0 "Loading %s...done" file))
2224 (message "Loading %s...done" file))
2225 t))) 2147 t)))
2226 2148
2227;; Localname manipulation functions that grok TRAMP localnames... 2149;; Localname manipulation functions that grok TRAMP localnames...
2228(defun tramp-handle-file-name-directory (file) 2150(defun tramp-handle-file-name-directory (file)
2229 "Like `file-name-directory' but aware of TRAMP files." 2151 "Like `file-name-directory' but aware of Tramp files."
2230 ;; Everything except the last filename thing is the directory. 2152 ;; Everything except the last filename thing is the directory.
2231 (with-parsed-tramp-file-name file nil 2153 (with-parsed-tramp-file-name file nil
2232 ;; Run the command on the localname portion only. 2154 ;; Run the command on the localname portion only.
2233 (tramp-make-tramp-file-name 2155 (tramp-make-tramp-file-name
2234 multi-method method user host (file-name-directory (or localname ""))))) 2156 method user host (file-name-directory (or localname "")))))
2235 2157
2236(defun tramp-handle-file-name-nondirectory (file) 2158(defun tramp-handle-file-name-nondirectory (file)
2237 "Like `file-name-nondirectory' but aware of TRAMP files." 2159 "Like `file-name-nondirectory' but aware of Tramp files."
2238 (with-parsed-tramp-file-name file nil 2160 (with-parsed-tramp-file-name file nil
2239 (file-name-nondirectory localname))) 2161 (file-name-nondirectory localname)))
2240 2162
2241(defun tramp-handle-file-truename (filename &optional counter prev-dirs) 2163(defun tramp-handle-file-truename (filename &optional counter prev-dirs)
2242 "Like `file-truename' for tramp files." 2164 "Like `file-truename' for Tramp files."
2243 (with-parsed-tramp-file-name (expand-file-name filename) nil 2165 (with-parsed-tramp-file-name (expand-file-name filename) nil
2244 (let* ((steps (tramp-split-string localname "/")) 2166 (with-file-property v localname "file-truename"
2245 (localnamedir (tramp-let-maybe directory-sep-char ?/ ;for XEmacs 2167 (let* ((steps (tramp-split-string localname "/"))
2246 (file-name-as-directory localname))) 2168 (localnamedir (tramp-let-maybe directory-sep-char ?/ ;for XEmacs
2247 (is-dir (string= localname localnamedir)) 2169 (file-name-as-directory localname)))
2248 (thisstep nil) 2170 (is-dir (string= localname localnamedir))
2249 (numchase 0) 2171 (thisstep nil)
2250 ;; Don't make the following value larger than necessary. 2172 (numchase 0)
2251 ;; People expect an error message in a timely fashion when 2173 ;; Don't make the following value larger than necessary.
2252 ;; something is wrong; otherwise they might think that Emacs 2174 ;; People expect an error message in a timely fashion when
2253 ;; is hung. Of course, correctness has to come first. 2175 ;; something is wrong; otherwise they might think that Emacs
2254 (numchase-limit 20) 2176 ;; is hung. Of course, correctness has to come first.
2255 (result nil) ;result steps in reverse order 2177 (numchase-limit 20)
2256 symlink-target) 2178 (result nil) ;result steps in reverse order
2257 (tramp-message-for-buffer 2179 symlink-target)
2258 multi-method method user host 2180 (tramp-message v 4 "Finding true name for `%s'" filename)
2259 10 "Finding true name for `%s'" filename) 2181 (while (and steps (< numchase numchase-limit))
2260 (while (and steps (< numchase numchase-limit)) 2182 (setq thisstep (pop steps))
2261 (setq thisstep (pop steps)) 2183 (tramp-message
2262 (tramp-message-for-buffer 2184 v 5 "Check %s"
2263 multi-method method user host 2185 (mapconcat 'identity
2264 10 "Check %s" 2186 (append '("") (reverse result) (list thisstep))
2265 (mapconcat 'identity 2187 "/"))
2266 (append '("") (reverse result) (list thisstep)) 2188 (setq symlink-target
2267 "/")) 2189 (nth 0 (file-attributes
2268 (setq symlink-target 2190 (tramp-make-tramp-file-name
2269 (nth 0 (file-attributes 2191 method user host
2270 (tramp-make-tramp-file-name 2192 (mapconcat 'identity
2271 multi-method method user host 2193 (append '("")
2272 (mapconcat 'identity 2194 (reverse result)
2273 (append '("") 2195 (list thisstep))
2274 (reverse result) 2196 "/")))))
2275 (list thisstep)) 2197 (cond ((string= "." thisstep)
2276 "/"))))) 2198 (tramp-message v 5 "Ignoring step `.'"))
2277 (cond ((string= "." thisstep) 2199 ((string= ".." thisstep)
2278 (tramp-message-for-buffer multi-method method user host 2200 (tramp-message v 5 "Processing step `..'")
2279 10 "Ignoring step `.'")) 2201 (pop result))
2280 ((string= ".." thisstep) 2202 ((stringp symlink-target)
2281 (tramp-message-for-buffer multi-method method user host 2203 ;; It's a symlink, follow it.
2282 10 "Processing step `..'") 2204 (tramp-message v 5 "Follow symlink to %s" symlink-target)
2283 (pop result)) 2205 (setq numchase (1+ numchase))
2284 ((stringp symlink-target) 2206 (when (file-name-absolute-p symlink-target)
2285 ;; It's a symlink, follow it. 2207 (setq result nil))
2286 (tramp-message-for-buffer 2208 ;; If the symlink was absolute, we'll get a string like
2287 multi-method method user host 2209 ;; "/user@host:/some/target"; extract the
2288 10 "Follow symlink to %s" symlink-target) 2210 ;; "/some/target" part from it.
2289 (setq numchase (1+ numchase)) 2211 (when (tramp-tramp-file-p symlink-target)
2290 (when (file-name-absolute-p symlink-target) 2212 (unless (tramp-equal-remote filename symlink-target)
2291 (setq result nil)) 2213 (tramp-error
2292 ;; If the symlink was absolute, we'll get a string like 2214 v 'file-error
2293 ;; "/user@host:/some/target"; extract the 2215 "Symlink target `%s' on wrong host" symlink-target))
2294 ;; "/some/target" part from it. 2216 (setq symlink-target localname))
2295 (when (tramp-tramp-file-p symlink-target) 2217 (setq steps
2296 (with-parsed-tramp-file-name symlink-target sym 2218 (append (tramp-split-string symlink-target "/")
2297 (unless (equal (list multi-method method user host) 2219 steps)))
2298 (list sym-multi-method sym-method 2220 (t
2299 sym-user sym-host)) 2221 ;; It's a file.
2300 (error "Symlink target `%s' on wrong host" 2222 (setq result (cons thisstep result)))))
2301 symlink-target)) 2223 (when (>= numchase numchase-limit)
2302 (setq symlink-target localname))) 2224 (tramp-error
2303 (setq steps 2225 v 'file-error
2304 (append (tramp-split-string symlink-target "/") steps))) 2226 "Maximum number (%d) of symlinks exceeded" numchase-limit))
2305 (t 2227 (setq result (reverse result))
2306 ;; It's a file. 2228 ;; Combine list to form string.
2307 (setq result (cons thisstep result))))) 2229 (setq result
2308 (when (>= numchase numchase-limit) 2230 (if result
2309 (error "Maximum number (%d) of symlinks exceeded" numchase-limit)) 2231 (mapconcat 'identity (cons "" result) "/")
2310 (setq result (reverse result)) 2232 "/"))
2311 ;; Combine list to form string. 2233 (when (and is-dir (or (string= "" result)
2312 (setq result 2234 (not (string= (substring result -1) "/"))))
2313 (if result 2235 (setq result (concat result "/")))
2314 (mapconcat 'identity (cons "" result) "/") 2236 (tramp-message v 4 "True name of `%s' is `%s'" filename result)
2315 "/")) 2237 (tramp-make-tramp-file-name method user host result)))))
2316 (when (and is-dir (or (string= "" result)
2317 (not (string= (substring result -1) "/"))))
2318 (setq result (concat result "/")))
2319 (tramp-message-for-buffer
2320 multi-method method user host
2321 10 "True name of `%s' is `%s'" filename result)
2322 (tramp-make-tramp-file-name
2323 multi-method method user host result))))
2324 2238
2325;; Basic functions. 2239;; Basic functions.
2326 2240
2327(defun tramp-handle-file-exists-p (filename) 2241(defun tramp-handle-file-exists-p (filename)
2328 "Like `file-exists-p' for tramp files." 2242 "Like `file-exists-p' for Tramp files."
2329 (with-parsed-tramp-file-name filename nil 2243 (with-parsed-tramp-file-name filename nil
2330 (save-excursion 2244 (with-file-property v localname "file-exists-p"
2331 (zerop (tramp-send-command-and-check 2245 (zerop (tramp-send-command-and-check
2332 multi-method method user host 2246 v
2333 (format 2247 (format
2334 (tramp-get-file-exists-command multi-method method user host) 2248 "%s %s"
2249 (tramp-get-file-exists-command v)
2335 (tramp-shell-quote-argument localname))))))) 2250 (tramp-shell-quote-argument localname)))))))
2336 2251
2252;; Inodes don't exist for some file systems. Therefore we must
2253;; generate virtual ones. Used in `find-buffer-visiting'. The method
2254;; applied might be not so efficient (Ange-FTP uses hashes). But
2255;; performance isn't the major issue given that file transfer will
2256;; take time.
2257(defvar tramp-inodes nil
2258 "Keeps virtual inodes numbers.")
2259
2337;; Devices must distinguish physical file systems. The device numbers 2260;; Devices must distinguish physical file systems. The device numbers
2338;; provided by "lstat" aren't unique, because we operate on different hosts. 2261;; provided by "lstat" aren't unique, because we operate on different hosts.
2339;; So we use virtual device numbers, generated by Tramp. Both Ange-FTP and 2262;; So we use virtual device numbers, generated by Tramp. Both Ange-FTP and
2340;; EFS use device number "-1". In order to be different, we use device number 2263;; EFS use device number "-1". In order to be different, we use device number
2341;; (-1 x), whereby "x" is unique for a given (multi-method method user host). 2264;; (-1 x), whereby "x" is unique for a given (method user host).
2342(defvar tramp-devices nil 2265(defvar tramp-devices nil
2343 "Keeps virtual device numbers.") 2266 "Keeps virtual device numbers.")
2344 2267
@@ -2346,123 +2269,133 @@ target of the symlink differ."
2346;; when something goes wrong. 2269;; when something goes wrong.
2347;; Daniel Pittman <daniel@danann.net> 2270;; Daniel Pittman <daniel@danann.net>
2348(defun tramp-handle-file-attributes (filename &optional id-format) 2271(defun tramp-handle-file-attributes (filename &optional id-format)
2349 "Like `file-attributes' for tramp files." 2272 "Like `file-attributes' for Tramp files."
2350 (when (file-exists-p filename) 2273 (unless id-format (setq id-format 'integer))
2351 ;; file exists, find out stuff 2274 (with-parsed-tramp-file-name (expand-file-name filename) nil
2352 (unless id-format (setq id-format 'integer)) 2275 (with-file-property v localname (format "file-attributes-%s" id-format)
2353 (with-parsed-tramp-file-name filename nil 2276 (when (file-exists-p filename)
2354 (save-excursion 2277 ;; file exists, find out stuff
2355 (tramp-convert-file-attributes 2278 (save-excursion
2356 multi-method method user host 2279 (tramp-convert-file-attributes
2357 (if (tramp-get-remote-perl multi-method method user host) 2280 v
2358 (tramp-handle-file-attributes-with-perl multi-method method user host 2281 (if (tramp-get-remote-stat v)
2359 localname id-format) 2282 (tramp-handle-file-attributes-with-stat v localname id-format)
2360 (tramp-handle-file-attributes-with-ls multi-method method user host 2283 (if (tramp-get-remote-perl v)
2361 localname id-format))))))) 2284 (tramp-handle-file-attributes-with-perl v localname id-format)
2362 2285 (tramp-handle-file-attributes-with-ls
2363(defun tramp-handle-file-attributes-with-ls 2286 v localname id-format)))))))))
2364 (multi-method method user host localname &optional id-format) 2287
2365 "Implement `file-attributes' for tramp files using the ls(1) command." 2288(defun tramp-handle-file-attributes-with-ls (vec localname &optional id-format)
2289 "Implement `file-attributes' for Tramp files using the ls(1) command."
2366 (let (symlinkp dirp 2290 (let (symlinkp dirp
2367 res-inode res-filemodes res-numlinks 2291 res-inode res-filemodes res-numlinks
2368 res-uid res-gid res-size res-symlink-target) 2292 res-uid res-gid res-size res-symlink-target)
2369 (tramp-message-for-buffer multi-method method user host 10 2293 (tramp-message vec 5 "file attributes with ls: %s" localname)
2370 "file attributes with ls: %s"
2371 (tramp-make-tramp-file-name
2372 multi-method method user host localname))
2373 (tramp-send-command 2294 (tramp-send-command
2374 multi-method method user host 2295 vec
2375 (format "%s %s %s" 2296 (format "%s %s %s"
2376 (tramp-get-ls-command multi-method method user host) 2297 (tramp-get-ls-command vec)
2377 (if (eq id-format 'integer) "-ildn" "-ild") 2298 (if (eq id-format 'integer) "-ildn" "-ild")
2378 (tramp-shell-quote-argument localname))) 2299 (tramp-shell-quote-argument localname)))
2379 (tramp-wait-for-output)
2380 ;; parse `ls -l' output ... 2300 ;; parse `ls -l' output ...
2381 ;; ... inode 2301 (with-current-buffer (tramp-get-buffer vec)
2382 (setq res-inode 2302 (goto-char (point-min))
2383 (condition-case err 2303 ;; ... inode
2384 (read (current-buffer)) 2304 (setq res-inode
2385 (invalid-read-syntax 2305 (condition-case err
2386 (when (and (equal (cadr err) 2306 (read (current-buffer))
2387 "Integer constant overflow in reader") 2307 (invalid-read-syntax
2388 (string-match 2308 (when (and (equal (cadr err)
2389 "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'" 2309 "Integer constant overflow in reader")
2390 (car (cddr err)))) 2310 (string-match
2391 (let* ((big (read (substring (car (cddr err)) 0 2311 "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'"
2392 (match-beginning 1)))) 2312 (car (cddr err))))
2393 (small (read (match-string 1 (car (cddr err))))) 2313 (let* ((big (read (substring (car (cddr err)) 0
2394 (twiddle (/ small 65536))) 2314 (match-beginning 1))))
2395 (cons (+ big twiddle) 2315 (small (read (match-string 1 (car (cddr err)))))
2396 (- small (* twiddle 65536)))))))) 2316 (twiddle (/ small 65536)))
2397 ;; ... file mode flags 2317 (cons (+ big twiddle)
2398 (setq res-filemodes (symbol-name (read (current-buffer)))) 2318 (- small (* twiddle 65536))))))))
2399 ;; ... number links 2319 ;; ... file mode flags
2400 (setq res-numlinks (read (current-buffer))) 2320 (setq res-filemodes (symbol-name (read (current-buffer))))
2401 ;; ... uid and gid 2321 ;; ... number links
2402 (setq res-uid (read (current-buffer))) 2322 (setq res-numlinks (read (current-buffer)))
2403 (setq res-gid (read (current-buffer))) 2323 ;; ... uid and gid
2404 (when (eq id-format 'integer) 2324 (setq res-uid (read (current-buffer)))
2405 (unless (numberp res-uid) (setq res-uid -1)) 2325 (setq res-gid (read (current-buffer)))
2406 (unless (numberp res-gid) (setq res-gid -1))) 2326 (if (eq id-format 'integer)
2407 ;; ... size 2327 (progn
2408 (setq res-size (read (current-buffer))) 2328 (unless (numberp res-uid) (setq res-uid -1))
2409 ;; From the file modes, figure out other stuff. 2329 (unless (numberp res-gid) (setq res-gid -1)))
2410 (setq symlinkp (eq ?l (aref res-filemodes 0))) 2330 (progn
2411 (setq dirp (eq ?d (aref res-filemodes 0))) 2331 (unless (stringp res-uid) (setq res-uid (symbol-name res-uid)))
2412 ;; if symlink, find out file name pointed to 2332 (unless (stringp res-gid) (setq res-gid (symbol-name res-gid)))))
2413 (when symlinkp 2333 ;; ... size
2414 (search-forward "-> ") 2334 (setq res-size (read (current-buffer)))
2415 (setq res-symlink-target 2335 ;; From the file modes, figure out other stuff.
2416 (buffer-substring (point) 2336 (setq symlinkp (eq ?l (aref res-filemodes 0)))
2417 (tramp-line-end-position)))) 2337 (setq dirp (eq ?d (aref res-filemodes 0)))
2418 ;; return data gathered 2338 ;; if symlink, find out file name pointed to
2419 (list 2339 (when symlinkp
2420 ;; 0. t for directory, string (name linked to) for symbolic 2340 (search-forward "-> ")
2421 ;; link, or nil. 2341 (setq res-symlink-target
2422 (or dirp res-symlink-target nil) 2342 (buffer-substring (point) (tramp-line-end-position))))
2423 ;; 1. Number of links to file. 2343 ;; return data gathered
2424 res-numlinks 2344 (list
2425 ;; 2. File uid. 2345 ;; 0. t for directory, string (name linked to) for symbolic
2426 res-uid 2346 ;; link, or nil.
2427 ;; 3. File gid. 2347 (or dirp res-symlink-target)
2428 res-gid 2348 ;; 1. Number of links to file.
2429 ;; 4. Last access time, as a list of two integers. First 2349 res-numlinks
2430 ;; integer has high-order 16 bits of time, second has low 16 2350 ;; 2. File uid.
2431 ;; bits. 2351 res-uid
2432 ;; 5. Last modification time, likewise. 2352 ;; 3. File gid.
2433 ;; 6. Last status change time, likewise. 2353 res-gid
2434 '(0 0) '(0 0) '(0 0) ;CCC how to find out? 2354 ;; 4. Last access time, as a list of two integers. First
2435 ;; 7. Size in bytes (-1, if number is out of range). 2355 ;; integer has high-order 16 bits of time, second has low 16
2436 res-size 2356 ;; bits.
2437 ;; 8. File modes, as a string of ten letters or dashes as in ls -l. 2357 ;; 5. Last modification time, likewise.
2438 res-filemodes 2358 ;; 6. Last status change time, likewise.
2439 ;; 9. t iff file's gid would change if file were deleted and 2359 '(0 0) '(0 0) '(0 0) ;CCC how to find out?
2440 ;; recreated. Will be set in `tramp-convert-file-attributes' 2360 ;; 7. Size in bytes (-1, if number is out of range).
2441 t 2361 res-size
2442 ;; 10. inode number. 2362 ;; 8. File modes, as a string of ten letters or dashes as in ls -l.
2443 res-inode 2363 res-filemodes
2444 ;; 11. Device number. Will be replaced by a virtual device number. 2364 ;; 9. t iff file's gid would change if file were deleted and
2445 -1 2365 ;; recreated. Will be set in `tramp-convert-file-attributes'
2446 ))) 2366 t
2367 ;; 10. inode number.
2368 res-inode
2369 ;; 11. Device number. Will be replaced by a virtual device number.
2370 -1
2371 ))))
2447 2372
2448(defun tramp-handle-file-attributes-with-perl 2373(defun tramp-handle-file-attributes-with-perl
2449 (multi-method method user host localname &optional id-format) 2374 (vec localname &optional id-format)
2450 "Implement `file-attributes' for tramp files using a Perl script." 2375 "Implement `file-attributes' for Tramp files using a Perl script."
2451 (tramp-message-for-buffer multi-method method user host 10 2376 (tramp-message vec 5 "file attributes with perl: %s" localname)
2452 "file attributes with perl: %s" 2377 (tramp-maybe-send-script
2453 (tramp-make-tramp-file-name 2378 vec tramp-perl-file-attributes "tramp_perl_file_attributes")
2454 multi-method method user host localname)) 2379 (tramp-send-command-and-read
2455 (tramp-maybe-send-perl-script multi-method method user host 2380 vec
2456 tramp-perl-file-attributes 2381 (format "tramp_perl_file_attributes %s %s"
2457 "tramp_file_attributes") 2382 (tramp-shell-quote-argument localname) id-format)))
2458 (tramp-send-command multi-method method user host 2383
2459 (format "tramp_file_attributes %s %s" 2384(defun tramp-handle-file-attributes-with-stat
2460 (tramp-shell-quote-argument localname) id-format)) 2385 (vec localname &optional id-format)
2461 (tramp-wait-for-output) 2386 "Implement `file-attributes' for Tramp files using stat(1) command."
2462 (read (current-buffer))) 2387 (tramp-message vec 5 "file attributes with stat: %s" localname)
2388 (tramp-send-command-and-read
2389 vec
2390 (format
2391 "%s -c '((\"%%N\") %%h %s %s %%X.0 %%Y.0 %%Z.0 %%s \"%%A\" t %%i.0 -1)' %s"
2392 (tramp-get-remote-stat vec)
2393 (if (eq id-format 'integer) "%u" "\"%U\"")
2394 (if (eq id-format 'integer) "%g" "\"%G\"")
2395 (tramp-shell-quote-argument localname))))
2463 2396
2464(defun tramp-handle-set-visited-file-modtime (&optional time-list) 2397(defun tramp-handle-set-visited-file-modtime (&optional time-list)
2465 "Like `set-visited-file-modtime' for tramp files." 2398 "Like `set-visited-file-modtime' for Tramp files."
2466 (unless (buffer-file-name) 2399 (unless (buffer-file-name)
2467 (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" 2400 (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file"
2468 (buffer-name))) 2401 (buffer-name)))
@@ -2480,16 +2413,16 @@ target of the symlink differ."
2480 ;; `tramp-handle-file-attributes-with-ls'. 2413 ;; `tramp-handle-file-attributes-with-ls'.
2481 (if (not (equal modtime '(0 0))) 2414 (if (not (equal modtime '(0 0)))
2482 (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) 2415 (tramp-run-real-handler 'set-visited-file-modtime (list modtime))
2483 (save-excursion 2416 (progn
2484 (tramp-send-command 2417 (tramp-send-command
2485 multi-method method user host 2418 v
2486 (format "%s -ild %s" 2419 (format "%s -ild %s"
2487 (tramp-get-ls-command multi-method method user host) 2420 (tramp-get-ls-command v)
2488 (tramp-shell-quote-argument localname))) 2421 (tramp-shell-quote-argument localname)))
2489 (tramp-wait-for-output)
2490 (setq attr (buffer-substring (point) 2422 (setq attr (buffer-substring (point)
2491 (progn (end-of-line) (point))))) 2423 (progn (end-of-line) (point)))))
2492 (setq tramp-buffer-file-attributes attr)) 2424 (tramp-set-file-property
2425 v localname "visited-file-modtime-ild" attr))
2493 (when (boundp 'last-coding-system-used) 2426 (when (boundp 'last-coding-system-used)
2494 (set 'last-coding-system-used coding-system-used)) 2427 (set 'last-coding-system-used coding-system-used))
2495 nil))))) 2428 nil)))))
@@ -2499,7 +2432,7 @@ target of the symlink differ."
2499;; This function makes the same assumption as 2432;; This function makes the same assumption as
2500;; `tramp-handle-set-visited-file-modtime'. 2433;; `tramp-handle-set-visited-file-modtime'.
2501(defun tramp-handle-verify-visited-file-modtime (buf) 2434(defun tramp-handle-verify-visited-file-modtime (buf)
2502 "Like `verify-visited-file-modtime' for tramp files. 2435 "Like `verify-visited-file-modtime' for Tramp files.
2503At the time `verify-visited-file-modtime' calls this function, we 2436At the time `verify-visited-file-modtime' calls this function, we
2504already know that the buffer is visiting a file and that 2437already know that the buffer is visiting a file and that
2505`visited-file-modtime' does not return 0. Do not call this 2438`visited-file-modtime' does not return 0. Do not call this
@@ -2531,53 +2464,48 @@ of."
2531 2)) 2464 2))
2532 ;; modtime has the don't know value. 2465 ;; modtime has the don't know value.
2533 (attr 2466 (attr
2534 (save-excursion 2467 (tramp-send-command
2535 (tramp-send-command 2468 v
2536 multi-method method user host 2469 (format "%s -ild %s"
2537 (format "%s -ild %s" 2470 (tramp-get-ls-command v)
2538 (tramp-get-ls-command multi-method method user host) 2471 (tramp-shell-quote-argument localname)))
2539 (tramp-shell-quote-argument localname))) 2472 (with-current-buffer (tramp-get-buffer v)
2540 (tramp-wait-for-output)
2541 (setq attr (buffer-substring 2473 (setq attr (buffer-substring
2542 (point) (progn (end-of-line) (point))))) 2474 (point) (progn (end-of-line) (point)))))
2543 (equal tramp-buffer-file-attributes attr)) 2475 (equal
2476 attr
2477 (tramp-get-file-property
2478 v localname "visited-file-modtime-ild" "")))
2544 ;; If file does not exist, say it is not modified 2479 ;; If file does not exist, say it is not modified
2545 ;; if and only if that agrees with the buffer's record. 2480 ;; if and only if that agrees with the buffer's record.
2546 (t (equal mt '(-1 65535)))))))))) 2481 (t (equal mt '(-1 65535))))))))))
2547 2482
2548(defun tramp-handle-set-file-modes (filename mode) 2483(defun tramp-handle-set-file-modes (filename mode)
2549 "Like `set-file-modes' for tramp files." 2484 "Like `set-file-modes' for Tramp files."
2550 (with-parsed-tramp-file-name filename nil 2485 (with-parsed-tramp-file-name filename nil
2551 (save-excursion 2486 (tramp-flush-file-property v localname)
2552 (unless (zerop (tramp-send-command-and-check 2487 (unless (zerop (tramp-send-command-and-check
2553 multi-method method user host 2488 v
2554 (format "chmod %s %s" 2489 (format "chmod %s %s"
2555 (tramp-decimal-to-octal mode) 2490 (tramp-decimal-to-octal mode)
2556 (tramp-shell-quote-argument localname)))) 2491 (tramp-shell-quote-argument localname))))
2557 (signal 'file-error 2492 ;; FIXME: extract the proper text from chmod's stderr.
2558 (list "Doing chmod" 2493 (tramp-error
2559 ;; FIXME: extract the proper text from chmod's stderr. 2494 v 'file-error "Error while changing file's mode %s" filename))))
2560 "error while changing file's mode"
2561 filename))))))
2562 2495
2563;; Simple functions using the `test' command. 2496;; Simple functions using the `test' command.
2564 2497
2565(defun tramp-handle-file-executable-p (filename) 2498(defun tramp-handle-file-executable-p (filename)
2566 "Like `file-executable-p' for tramp files." 2499 "Like `file-executable-p' for Tramp files."
2567 (with-parsed-tramp-file-name filename nil 2500 (with-parsed-tramp-file-name filename nil
2568 (zerop (tramp-run-test "-x" filename)))) 2501 (with-file-property v localname "file-executable-p"
2502 (zerop (tramp-run-test "-x" filename)))))
2569 2503
2570(defun tramp-handle-file-readable-p (filename) 2504(defun tramp-handle-file-readable-p (filename)
2571 "Like `file-readable-p' for tramp files." 2505 "Like `file-readable-p' for Tramp files."
2572 (with-parsed-tramp-file-name filename nil
2573 (zerop (tramp-run-test "-r" filename))))
2574
2575(defun tramp-handle-file-accessible-directory-p (filename)
2576 "Like `file-accessible-directory-p' for tramp files."
2577 (with-parsed-tramp-file-name filename nil 2506 (with-parsed-tramp-file-name filename nil
2578 (and (zerop (tramp-run-test "-d" filename)) 2507 (with-file-property v localname "file-readable-p"
2579 (zerop (tramp-run-test "-r" filename)) 2508 (zerop (tramp-run-test "-r" filename)))))
2580 (zerop (tramp-run-test "-x" filename)))))
2581 2509
2582;; When the remote shell is started, it looks for a shell which groks 2510;; When the remote shell is started, it looks for a shell which groks
2583;; tilde expansion. Here, we assume that all shells which grok tilde 2511;; tilde expansion. Here, we assume that all shells which grok tilde
@@ -2585,7 +2513,7 @@ of."
2585;; newer than). If this breaks, tell me about it and I'll try to do 2513;; newer than). If this breaks, tell me about it and I'll try to do
2586;; something smarter about it. 2514;; something smarter about it.
2587(defun tramp-handle-file-newer-than-file-p (file1 file2) 2515(defun tramp-handle-file-newer-than-file-p (file1 file2)
2588 "Like `file-newer-than-file-p' for tramp files." 2516 "Like `file-newer-than-file-p' for Tramp files."
2589 (cond ((not (file-exists-p file1)) 2517 (cond ((not (file-exists-p file1))
2590 nil) 2518 nil)
2591 ((not (file-exists-p file2)) 2519 ((not (file-exists-p file2))
@@ -2606,44 +2534,27 @@ of."
2606 ;; However, this only works if both files are Tramp 2534 ;; However, this only works if both files are Tramp
2607 ;; files and both have the same method, same user, same 2535 ;; files and both have the same method, same user, same
2608 ;; host. 2536 ;; host.
2609 (unless (and (tramp-tramp-file-p file1) 2537 (unless (tramp-equal-remote file1 file2)
2610 (tramp-tramp-file-p file2)) 2538 (with-parsed-tramp-file-name
2611 (signal 2539 (if (tramp-tramp-file-p file1) file1 file2) nil
2612 'file-error 2540 (tramp-error
2613 (list 2541 v 'file-error
2614 "Cannot check if Tramp file is newer than non-Tramp file" 2542 "Files %s and %s must have same method, user, host"
2615 file1 file2))) 2543 file1 file2)))
2616 (with-parsed-tramp-file-name file1 v1 2544 (with-parsed-tramp-file-name file1 nil
2617 (with-parsed-tramp-file-name file2 v2 2545 (zerop (tramp-run-test2
2618 (unless (and (equal v1-multi-method v2-multi-method) 2546 (tramp-get-test-nt-command v) file1 file2)))))))))
2619 (equal v1-method v2-method)
2620 (equal v1-user v2-user)
2621 (equal v1-host v2-host))
2622 (signal 'file-error
2623 (list "Files must have same method, user, host"
2624 file1 file2)))
2625 (unless (and (tramp-tramp-file-p file1)
2626 (tramp-tramp-file-p file2))
2627 (signal 'file-error
2628 (list "Files must be tramp files on same host"
2629 file1 file2)))
2630 (if (tramp-get-test-groks-nt
2631 v1-multi-method v1-method v1-user v1-host)
2632 (zerop (tramp-run-test2 "test" file1 file2 "-nt"))
2633 (zerop (tramp-run-test2
2634 "tramp_test_nt" file1 file2)))))))))))
2635 2547
2636;; Functions implemented using the basic functions above. 2548;; Functions implemented using the basic functions above.
2637 2549
2638(defun tramp-handle-file-modes (filename) 2550(defun tramp-handle-file-modes (filename)
2639 "Like `file-modes' for tramp files." 2551 "Like `file-modes' for Tramp files."
2640 (with-parsed-tramp-file-name filename nil 2552 (when (file-exists-p filename)
2641 (when (file-exists-p filename) 2553 (tramp-mode-string-to-int
2642 (tramp-mode-string-to-int 2554 (nth 8 (file-attributes filename)))))
2643 (nth 8 (file-attributes filename))))))
2644 2555
2645(defun tramp-handle-file-directory-p (filename) 2556(defun tramp-handle-file-directory-p (filename)
2646 "Like `file-directory-p' for tramp files." 2557 "Like `file-directory-p' for Tramp files."
2647 ;; Care must be taken that this function returns `t' for symlinks 2558 ;; Care must be taken that this function returns `t' for symlinks
2648 ;; pointing to directories. Surely the most obvious implementation 2559 ;; pointing to directories. Surely the most obvious implementation
2649 ;; would be `test -d', but that returns false for such symlinks. 2560 ;; would be `test -d', but that returns false for such symlinks.
@@ -2653,78 +2564,52 @@ of."
2653 ;; 2564 ;;
2654 ;; Alternatives: `cd %s', `test -d %s' 2565 ;; Alternatives: `cd %s', `test -d %s'
2655 (with-parsed-tramp-file-name filename nil 2566 (with-parsed-tramp-file-name filename nil
2656 (save-excursion 2567 (with-file-property v localname "file-directory-p"
2657 (zerop 2568 (zerop (tramp-run-test "-d" filename)))))
2658 (tramp-send-command-and-check
2659 multi-method method user host
2660 (format "test -d %s"
2661 (tramp-shell-quote-argument localname))
2662 t))))) ;run command in subshell
2663 2569
2664(defun tramp-handle-file-regular-p (filename) 2570(defun tramp-handle-file-regular-p (filename)
2665 "Like `file-regular-p' for tramp files." 2571 "Like `file-regular-p' for Tramp files."
2666 (with-parsed-tramp-file-name filename nil 2572 (and (file-exists-p filename)
2667 (and (file-exists-p filename) 2573 (eq ?- (aref (nth 8 (file-attributes filename)) 0))))
2668 (eq ?- (aref (nth 8 (file-attributes filename)) 0)))))
2669 2574
2670(defun tramp-handle-file-symlink-p (filename) 2575(defun tramp-handle-file-symlink-p (filename)
2671 "Like `file-symlink-p' for tramp files." 2576 "Like `file-symlink-p' for Tramp files."
2672 (with-parsed-tramp-file-name filename nil 2577 (with-parsed-tramp-file-name filename nil
2673 (let ((x (car (file-attributes filename)))) 2578 (let ((x (car (file-attributes filename))))
2674 (when (stringp x) 2579 (when (stringp x)
2675 ;; When Tramp is running on VMS, then `file-name-absolute-p' 2580 ;; When Tramp is running on VMS, then `file-name-absolute-p'
2676 ;; might do weird things. 2581 ;; might do weird things.
2677 (if (file-name-absolute-p x) 2582 (if (file-name-absolute-p x)
2678 (tramp-make-tramp-file-name 2583 (tramp-make-tramp-file-name method user host x)
2679 multi-method method user host x)
2680 x))))) 2584 x)))))
2681 2585
2682(defun tramp-handle-file-writable-p (filename) 2586(defun tramp-handle-file-writable-p (filename)
2683 "Like `file-writable-p' for tramp files." 2587 "Like `file-writable-p' for Tramp files."
2684 (with-parsed-tramp-file-name filename nil 2588 (with-parsed-tramp-file-name filename nil
2685 (if (file-exists-p filename) 2589 (with-file-property v localname "file-writable-p"
2686 ;; Existing files must be writable. 2590 (if (file-exists-p filename)
2687 (zerop (tramp-run-test "-w" filename)) 2591 ;; Existing files must be writable.
2688 ;; If file doesn't exist, check if directory is writable. 2592 (zerop (tramp-run-test "-w" filename))
2689 (and (zerop (tramp-run-test 2593 ;; If file doesn't exist, check if directory is writable.
2690 "-d" (file-name-directory filename))) 2594 (and (zerop (tramp-run-test
2691 (zerop (tramp-run-test 2595 "-d" (file-name-directory filename)))
2692 "-w" (file-name-directory filename))))))) 2596 (zerop (tramp-run-test
2597 "-w" (file-name-directory filename))))))))
2693 2598
2694(defun tramp-handle-file-ownership-preserved-p (filename) 2599(defun tramp-handle-file-ownership-preserved-p (filename)
2695 "Like `file-ownership-preserved-p' for tramp files." 2600 "Like `file-ownership-preserved-p' for Tramp files."
2696 (with-parsed-tramp-file-name filename nil 2601 (with-parsed-tramp-file-name filename nil
2697 (let ((attributes (file-attributes filename))) 2602 (with-file-property v localname "file-ownership-preserved-p"
2698 ;; Return t if the file doesn't exist, since it's true that no 2603 (let ((attributes (file-attributes filename)))
2699 ;; information would be lost by an (attempted) delete and create. 2604 ;; Return t if the file doesn't exist, since it's true that no
2700 (or (null attributes) 2605 ;; information would be lost by an (attempted) delete and create.
2701 (= (nth 2 attributes) 2606 (or (null attributes)
2702 (tramp-get-remote-uid multi-method method user host)))))) 2607 (= (nth 2 attributes) (tramp-get-remote-uid v 'integer)))))))
2703 2608
2704;; Other file name ops. 2609;; Other file name ops.
2705 2610
2706;; ;; Matthias K,Av(Bppe <mkoeppe@mail.math.uni-magdeburg.de>
2707;; (defun tramp-handle-directory-file-name (directory)
2708;; "Like `directory-file-name' for tramp files."
2709;; (if (and (eq (aref directory (- (length directory) 1)) ?/)
2710;; (not (eq (aref directory (- (length directory) 2)) ?:)))
2711;; (substring directory 0 (- (length directory) 1))
2712;; directory))
2713
2714;; ;; Philippe Troin <phil@fifi.org>
2715;; (defun tramp-handle-directory-file-name (directory)
2716;; "Like `directory-file-name' for tramp files."
2717;; (with-parsed-tramp-file-name directory nil
2718;; (let ((directory-length-1 (1- (length directory))))
2719;; (save-match-data
2720;; (if (and (eq (aref directory directory-length-1) ?/)
2721;; (eq (string-match tramp-file-name-regexp directory) 0)
2722;; (/= (match-end 0) directory-length-1))
2723;; (substring directory 0 directory-length-1)
2724;; directory)))))
2725
2726(defun tramp-handle-directory-file-name (directory) 2611(defun tramp-handle-directory-file-name (directory)
2727 "Like `directory-file-name' for tramp files." 2612 "Like `directory-file-name' for Tramp files."
2728 ;; If localname component of filename is "/", leave it unchanged. 2613 ;; If localname component of filename is "/", leave it unchanged.
2729 ;; Otherwise, remove any trailing slash from localname component. 2614 ;; Otherwise, remove any trailing slash from localname component.
2730 ;; Method, host, etc, are unchanged. Does it make sense to try 2615 ;; Method, host, etc, are unchanged. Does it make sense to try
@@ -2738,145 +2623,137 @@ of."
2738 2623
2739;; Directory listings. 2624;; Directory listings.
2740 2625
2741(defun tramp-handle-directory-files (directory 2626(defun tramp-handle-directory-files
2742 &optional full match nosort files-only) 2627 (directory &optional full match nosort files-only)
2743 "Like `directory-files' for tramp files." 2628 "Like `directory-files' for Tramp files."
2744 (with-parsed-tramp-file-name directory nil 2629 ;; FILES-ONLY is valid for XEmacs only.
2745 (let (result x) 2630 (when (file-directory-p directory)
2746 (save-excursion 2631 (setq directory (expand-file-name directory))
2747 (tramp-barf-unless-okay 2632 (let ((temp (nreverse (file-name-all-completions "" directory)))
2748 multi-method method user host 2633 result item)
2749 (concat "cd " (tramp-shell-quote-argument localname)) 2634
2750 nil 2635 (while temp
2751 'file-error 2636 (setq item (directory-file-name (pop temp)))
2752 "tramp-handle-directory-files: couldn't `cd %s'" 2637 (when (and (or (null match) (string-match match item))
2753 (tramp-shell-quote-argument localname)) 2638 (or (null files-only)
2754 (tramp-send-command 2639 ;; files only
2755 multi-method method user host 2640 (and (equal files-only t) (file-regular-p item))
2756 (concat (tramp-get-ls-command multi-method method user host) 2641 ;; directories only
2757 " -a | cat")) 2642 (file-directory-p item)))
2758 (tramp-wait-for-output) 2643 (push (if full (expand-file-name item directory) item)
2759 (goto-char (point-max)) 2644 result)))
2760 (while (zerop (forward-line -1))
2761 (setq x (buffer-substring (point)
2762 (tramp-line-end-position)))
2763 (when (or (not match) (string-match match x))
2764 (if full
2765 (push (concat (file-name-as-directory directory)
2766 x)
2767 result)
2768 (push x result))))
2769 (tramp-send-command multi-method method user host "cd")
2770 (tramp-wait-for-output)
2771 ;; Remove non-files or non-directories if necessary. Using
2772 ;; the remote shell for this would probably be way faster.
2773 ;; Maybe something could be adapted from
2774 ;; tramp-handle-file-name-all-completions.
2775 (when files-only
2776 (let ((temp (nreverse result))
2777 item)
2778 (setq result nil)
2779 (if (equal files-only t)
2780 ;; files only
2781 (while temp
2782 (setq item (pop temp))
2783 (when (file-regular-p item)
2784 (push item result)))
2785 ;; directories only
2786 (while temp
2787 (setq item (pop temp))
2788 (when (file-directory-p item)
2789 (push item result)))))))
2790 result))) 2645 result)))
2791 2646
2792(defun tramp-handle-directory-files-and-attributes 2647(defun tramp-handle-directory-files-and-attributes
2793 (directory &optional full match nosort id-format) 2648 (directory &optional full match nosort id-format)
2794 "Like `directory-files-and-attributes' for tramp files." 2649 "Like `directory-files-and-attributes' for Tramp files."
2795 (when (tramp-handle-file-exists-p directory) 2650 (unless id-format (setq id-format 'integer))
2796 (save-excursion 2651 (when (file-directory-p directory)
2797 (setq directory (tramp-handle-expand-file-name directory)) 2652 (setq directory (expand-file-name directory))
2798 (with-parsed-tramp-file-name directory nil 2653 (let* ((temp
2799 (tramp-maybe-send-perl-script multi-method method user host 2654 (copy-tree
2800 tramp-perl-directory-files-and-attributes 2655 (with-parsed-tramp-file-name directory nil
2801 "tramp_directory_files_and_attributes") 2656 (with-file-property
2802 (tramp-send-command multi-method method user host 2657 v localname
2803 (format "tramp_directory_files_and_attributes %s %s" 2658 (format "directory-files-and-attributes-%s" id-format)
2804 (tramp-shell-quote-argument localname) 2659 (save-excursion
2805 (or id-format 'integer))) 2660 (mapcar
2806 (tramp-wait-for-output) 2661 '(lambda (x)
2807 (let* ((root (cons nil (let ((object (read (current-buffer)))) 2662 (cons (car x)
2808 (when (stringp object) 2663 (tramp-convert-file-attributes v (cdr x))))
2809 (error object)) 2664 (if (tramp-get-remote-stat v)
2810 object))) 2665 (tramp-handle-directory-files-and-attributes-with-stat
2811 (cell root)) 2666 v localname id-format)
2812 (while (cdr cell) 2667 (if (tramp-get-remote-perl v)
2813 (if (and match (not (string-match match (car (cadr cell))))) 2668 (tramp-handle-directory-files-and-attributes-with-perl
2814 ;; Remove from list 2669 v localname id-format)))))))))
2815 (setcdr cell (cddr cell)) 2670 result item)
2816 ;; Include in list 2671
2817 (setq cell (cdr cell)) 2672 (while temp
2818 (let ((l (car cell))) 2673 (setq item (pop temp))
2819 (tramp-convert-file-attributes multi-method method user host 2674 (when (or (null match) (string-match match (car item)))
2820 (cdr l)) 2675 (when full
2821 ;; If FULL, make file name absolute 2676 (setcar item (expand-file-name (car item) directory)))
2822 (when full (setcar l (concat directory "/" (car l))))))) 2677 (push item result)))
2823 (if nosort 2678
2824 (cdr root) 2679 (if nosort
2825 (sort (cdr root) (lambda (x y) (string< (car x) (car y)))))))))) 2680 result
2681 (sort result (lambda (x y) (string< (car x) (car y))))))))
2682
2683(defun tramp-handle-directory-files-and-attributes-with-perl
2684 (vec localname &optional id-format)
2685 "Implement `directory-files-and-attributes' for Tramp files using a Perl script."
2686 (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname)
2687 (tramp-maybe-send-script
2688 vec tramp-perl-directory-files-and-attributes
2689 "tramp_perl_directory_files_and_attributes")
2690 (let ((object
2691 (tramp-send-command-and-read
2692 vec
2693 (format "tramp_perl_directory_files_and_attributes %s %s"
2694 (tramp-shell-quote-argument localname) id-format))))
2695 (when (stringp object) (tramp-error vec 'file-error object))
2696 object))
2697
2698(defun tramp-handle-directory-files-and-attributes-with-stat
2699 (vec localname &optional id-format)
2700 "Implement `directory-files-and-attributes' for Tramp files using stat(1) command."
2701 (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname)
2702 (tramp-send-command-and-read
2703 vec
2704 (format
2705 (concat
2706 "cd %s; echo \"(\"; (%s -ab | xargs "
2707 "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%X.0 %%Y.0 %%Z.0 %%s \"%%A\" t %%i.0 -1)'); "
2708 "echo \")\"")
2709 (tramp-shell-quote-argument localname)
2710 (tramp-get-ls-command vec)
2711 (tramp-get-remote-stat vec)
2712 (if (eq id-format 'integer) "%u" "\"%U\"")
2713 (if (eq id-format 'integer) "%g" "\"%G\""))))
2826 2714
2827;; This function should return "foo/" for directories and "bar" for 2715;; This function should return "foo/" for directories and "bar" for
2828;; files. We use `ls -ad' to get a list of files (including 2716;; files.
2829;; directories), and `find . -type d \! -name . -prune' to get a list
2830;; of directories.
2831(defun tramp-handle-file-name-all-completions (filename directory) 2717(defun tramp-handle-file-name-all-completions (filename directory)
2832 "Like `file-name-all-completions' for tramp files." 2718 "Like `file-name-all-completions' for Tramp files."
2833 (with-parsed-tramp-file-name directory nil 2719 (unless (save-match-data (string-match "/" filename))
2834 (unless (save-match-data (string-match "/" filename)) 2720 (with-parsed-tramp-file-name directory nil
2835 (let* ((nowild tramp-completion-without-shell-p) 2721 (all-completions
2836 result) 2722 filename
2837 (save-excursion 2723 (mapcar
2838 (tramp-barf-unless-okay 2724 'list
2839 multi-method method user host 2725 (with-file-property v localname "file-name-all-completions"
2840 (format "cd %s" (tramp-shell-quote-argument localname)) 2726 (let (result)
2841 nil 'file-error 2727 (tramp-barf-unless-okay
2842 "tramp-handle-file-name-all-completions: Couldn't `cd %s'" 2728 v
2843 (tramp-shell-quote-argument localname)) 2729 (format "cd %s" (tramp-shell-quote-argument localname))
2844 2730 "tramp-handle-file-name-all-completions: Couldn't `cd %s'"
2845 ;; Get a list of directories and files, including reliably 2731 (tramp-shell-quote-argument localname))
2846 ;; tagging the directories with a trailing '/'. Because I 2732
2847 ;; rock. --daniel@danann.net 2733 ;; Get a list of directories and files, including reliably
2848 (tramp-send-command 2734 ;; tagging the directories with a trailing '/'. Because I
2849 multi-method method user host 2735 ;; rock. --daniel@danann.net
2850 (format (concat "%s -a %s 2>/dev/null | while read f; do " 2736 (tramp-send-command
2851 "if test -d \"$f\" 2>/dev/null; " 2737 v
2852 "then echo \"$f/\"; else echo \"$f\"; fi; done") 2738 (format (concat "%s -ab 2>/dev/null | while read f; do "
2853 (tramp-get-ls-command multi-method method user host) 2739 "if %s -d \"$f\" 2>/dev/null; "
2854 (if (or nowild (zerop (length filename))) 2740 "then echo \"$f/\"; else echo \"$f\"; fi; done")
2855 "" 2741 (tramp-get-ls-command v)
2856 (format "-d %s*" 2742 (tramp-get-test-command v)))
2857 (tramp-shell-quote-argument filename))))) 2743
2858 2744 ;; Now grab the output.
2859 ;; Now grab the output. 2745 (with-current-buffer (tramp-get-buffer v)
2860 (tramp-wait-for-output) 2746 (goto-char (point-max))
2861 (goto-char (point-max)) 2747 (while (zerop (forward-line -1))
2862 (while (zerop (forward-line -1)) 2748 (push (buffer-substring (point) (tramp-line-end-position))
2863 (push (buffer-substring (point) 2749 result)))
2864 (tramp-line-end-position)) 2750
2865 result)) 2751 result)))))))
2866
2867 (tramp-send-command multi-method method user host "cd")
2868 (tramp-wait-for-output)
2869
2870 ;; Return the list.
2871 (if nowild
2872 (all-completions filename (mapcar 'list result))
2873 result))))))
2874
2875 2752
2876;; The following isn't needed for Emacs 20 but for 19.34? 2753;; The following isn't needed for Emacs 20 but for 19.34?
2877(defun tramp-handle-file-name-completion 2754(defun tramp-handle-file-name-completion
2878 (filename directory &optional predicate) 2755 (filename directory &optional predicate)
2879 "Like `file-name-completion' for tramp files." 2756 "Like `file-name-completion' for Tramp files."
2880 (unless (tramp-tramp-file-p directory) 2757 (unless (tramp-tramp-file-p directory)
2881 (error 2758 (error
2882 "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" 2759 "tramp-handle-file-name-completion invoked on non-tramp directory `%s'"
@@ -2891,18 +2768,17 @@ of."
2891 2768
2892(defun tramp-handle-add-name-to-file 2769(defun tramp-handle-add-name-to-file
2893 (filename newname &optional ok-if-already-exists) 2770 (filename newname &optional ok-if-already-exists)
2894 "Like `add-name-to-file' for tramp files." 2771 "Like `add-name-to-file' for Tramp files."
2772 (unless (tramp-equal-remote filename newname)
2773 (with-parsed-tramp-file-name
2774 (if (tramp-tramp-file-p filename) filename newname) nil
2775 (tramp-error
2776 v 'file-error
2777 "add-name-to-file: %s"
2778 "only implemented for same method, same user, same host")))
2895 (with-parsed-tramp-file-name filename v1 2779 (with-parsed-tramp-file-name filename v1
2896 (with-parsed-tramp-file-name newname v2 2780 (with-parsed-tramp-file-name newname v2
2897 (let ((ln (when v1 (tramp-get-remote-ln 2781 (let ((ln (when v1 (tramp-get-remote-ln v1))))
2898 v1-multi-method v1-method v1-user v1-host))))
2899 (unless (and v1-method v2-method v1-user v2-user v1-host v2-host
2900 (equal v1-multi-method v2-multi-method)
2901 (equal v1-method v2-method)
2902 (equal v1-user v2-user)
2903 (equal v1-host v2-host))
2904 (error "add-name-to-file: %s"
2905 "only implemented for same method, same user, same host"))
2906 (when (and (not ok-if-already-exists) 2782 (when (and (not ok-if-already-exists)
2907 (file-exists-p newname) 2783 (file-exists-p newname)
2908 (not (numberp ok-if-already-exists)) 2784 (not (numberp ok-if-already-exists))
@@ -2910,18 +2786,20 @@ of."
2910 (format 2786 (format
2911 "File %s already exists; make it a new name anyway? " 2787 "File %s already exists; make it a new name anyway? "
2912 newname))) 2788 newname)))
2913 (error "add-name-to-file: file %s already exists" newname)) 2789 (tramp-error
2790 v2 'file-error
2791 "add-name-to-file: file %s already exists" newname))
2792 (tramp-flush-file-property v2 v2-localname)
2914 (tramp-barf-unless-okay 2793 (tramp-barf-unless-okay
2915 v1-multi-method v1-method v1-user v1-host 2794 v1
2916 (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname) 2795 (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname)
2917 (tramp-shell-quote-argument v2-localname)) 2796 (tramp-shell-quote-argument v2-localname))
2918 nil 'file-error
2919 "error with add-name-to-file, see buffer `%s' for details" 2797 "error with add-name-to-file, see buffer `%s' for details"
2920 (buffer-name)))))) 2798 (buffer-name))))))
2921 2799
2922(defun tramp-handle-copy-file 2800(defun tramp-handle-copy-file
2923 (filename newname &optional ok-if-already-exists keep-date) 2801 (filename newname &optional ok-if-already-exists keep-date)
2924 "Like `copy-file' for tramp files." 2802 "Like `copy-file' for Tramp files."
2925 ;; Check if both files are local -- invoke normal copy-file. 2803 ;; Check if both files are local -- invoke normal copy-file.
2926 ;; Otherwise, use tramp from local system. 2804 ;; Otherwise, use tramp from local system.
2927 (setq filename (expand-file-name filename)) 2805 (setq filename (expand-file-name filename))
@@ -2932,12 +2810,11 @@ of."
2932 (tramp-do-copy-or-rename-file 2810 (tramp-do-copy-or-rename-file
2933 'copy filename newname ok-if-already-exists keep-date) 2811 'copy filename newname ok-if-already-exists keep-date)
2934 (tramp-run-real-handler 2812 (tramp-run-real-handler
2935 'copy-file 2813 'copy-file (list filename newname ok-if-already-exists keep-date))))
2936 (list filename newname ok-if-already-exists keep-date))))
2937 2814
2938(defun tramp-handle-rename-file 2815(defun tramp-handle-rename-file
2939 (filename newname &optional ok-if-already-exists) 2816 (filename newname &optional ok-if-already-exists)
2940 "Like `rename-file' for tramp files." 2817 "Like `rename-file' for Tramp files."
2941 ;; Check if both files are local -- invoke normal rename-file. 2818 ;; Check if both files are local -- invoke normal rename-file.
2942 ;; Otherwise, use tramp from local system. 2819 ;; Otherwise, use tramp from local system.
2943 (setq filename (expand-file-name filename)) 2820 (setq filename (expand-file-name filename))
@@ -2946,9 +2823,9 @@ of."
2946 (if (or (tramp-tramp-file-p filename) 2823 (if (or (tramp-tramp-file-p filename)
2947 (tramp-tramp-file-p newname)) 2824 (tramp-tramp-file-p newname))
2948 (tramp-do-copy-or-rename-file 2825 (tramp-do-copy-or-rename-file
2949 'rename filename newname ok-if-already-exists) 2826 'rename filename newname ok-if-already-exists t)
2950 (tramp-run-real-handler 'rename-file 2827 (tramp-run-real-handler
2951 (list filename newname ok-if-already-exists)))) 2828 'rename-file (list filename newname ok-if-already-exists))))
2952 2829
2953(defun tramp-do-copy-or-rename-file 2830(defun tramp-do-copy-or-rename-file
2954 (op filename newname &optional ok-if-already-exists keep-date) 2831 (op filename newname &optional ok-if-already-exists keep-date)
@@ -2965,169 +2842,148 @@ This function is invoked by `tramp-handle-copy-file' and
2965and `rename'. FILENAME and NEWNAME must be absolute file names." 2842and `rename'. FILENAME and NEWNAME must be absolute file names."
2966 (unless (memq op '(copy rename)) 2843 (unless (memq op '(copy rename))
2967 (error "Unknown operation `%s', must be `copy' or `rename'" op)) 2844 (error "Unknown operation `%s', must be `copy' or `rename'" op))
2968 (unless ok-if-already-exists
2969 (when (file-exists-p newname)
2970 (signal 'file-already-exists
2971 (list "File already exists" newname))))
2972 (let ((t1 (tramp-tramp-file-p filename)) 2845 (let ((t1 (tramp-tramp-file-p filename))
2973 (t2 (tramp-tramp-file-p newname)) 2846 (t2 (tramp-tramp-file-p newname)))
2974 v1-multi-method v1-method v1-user v1-host v1-localname
2975 v2-multi-method v2-method v2-user v2-host v2-localname)
2976
2977 ;; Check which ones of source and target are Tramp files.
2978 ;; We cannot invoke `with-parsed-tramp-file-name';
2979 ;; it fails if the file isn't a Tramp file name.
2980 (if t1
2981 (with-parsed-tramp-file-name filename l
2982 (setq v1-multi-method l-multi-method
2983 v1-method l-method
2984 v1-user l-user
2985 v1-host l-host
2986 v1-localname l-localname))
2987 (setq v1-localname filename))
2988 (if t2
2989 (with-parsed-tramp-file-name newname l
2990 (setq v2-multi-method l-multi-method
2991 v2-method l-method
2992 v2-user l-user
2993 v2-host l-host
2994 v2-localname l-localname))
2995 (setq v2-localname newname))
2996 2847
2997 (cond 2848 (unless ok-if-already-exists
2998 ;; Both are Tramp files. 2849 (when (and t2 (file-exists-p newname))
2999 ((and t1 t2) 2850 (with-parsed-tramp-file-name newname nil
3000 (cond 2851 (tramp-error
3001 ;; Shortcut: if method, host, user are the same for both 2852 v 'file-already-exists "File %s already exists" newname))))
3002 ;; files, we invoke `cp' or `mv' on the remote host
3003 ;; directly.
3004 ((and (equal v1-multi-method v2-multi-method)
3005 (equal v1-method v2-method)
3006 (equal v1-user v2-user)
3007 (equal v1-host v2-host))
3008 (tramp-do-copy-or-rename-file-directly
3009 op v1-multi-method v1-method v1-user v1-host
3010 v1-localname v2-localname keep-date))
3011 ;; If both source and target are Tramp files,
3012 ;; both are using the same copy-program, then we
3013 ;; can invoke rcp directly. Note that
3014 ;; default-directory should point to a local
3015 ;; directory if we want to invoke rcp.
3016 ((and (not v1-multi-method)
3017 (not v2-multi-method)
3018 (equal v1-method v2-method)
3019 (tramp-method-out-of-band-p
3020 v1-multi-method v1-method v1-user v1-host)
3021 (not (string-match "\\([^#]*\\)#\\(.*\\)" v1-host))
3022 (not (string-match "\\([^#]*\\)#\\(.*\\)" v2-host)))
3023 (tramp-do-copy-or-rename-file-out-of-band
3024 op filename newname keep-date))
3025 ;; No shortcut was possible. So we copy the
3026 ;; file first. If the operation was `rename', we go
3027 ;; back and delete the original file (if the copy was
3028 ;; successful). The approach is simple-minded: we
3029 ;; create a new buffer, insert the contents of the
3030 ;; source file into it, then write out the buffer to
3031 ;; the target file. The advantage is that it doesn't
3032 ;; matter which filename handlers are used for the
3033 ;; source and target file.
3034 (t
3035 (tramp-do-copy-or-rename-file-via-buffer
3036 op filename newname keep-date))))
3037
3038 ;; One file is a Tramp file, the other one is local.
3039 ((or t1 t2)
3040 ;; If the Tramp file has an out-of-band method, the corresponding
3041 ;; copy-program can be invoked.
3042 (if (and (not v1-multi-method)
3043 (not v2-multi-method)
3044 (or (and t1 (tramp-method-out-of-band-p
3045 v1-multi-method v1-method v1-user v1-host))
3046 (and t2 (tramp-method-out-of-band-p
3047 v2-multi-method v2-method v2-user v2-host))))
3048 (tramp-do-copy-or-rename-file-out-of-band
3049 op filename newname keep-date)
3050 ;; Use the generic method via a Tramp buffer.
3051 (tramp-do-copy-or-rename-file-via-buffer
3052 op filename newname keep-date)))
3053 2853
3054 (t 2854 (prog1
3055 ;; One of them must be a Tramp file. 2855 (cond
3056 (error "Tramp implementation says this cannot happen"))))) 2856 ;; Both are Tramp files.
2857 ((and t1 t2)
2858 (with-parsed-tramp-file-name filename v1
2859 (with-parsed-tramp-file-name newname v2
2860 (cond
2861 ;; Shortcut: if method, host, user are the same for both
2862 ;; files, we invoke `cp' or `mv' on the remote host
2863 ;; directly.
2864 ((tramp-equal-remote filename newname)
2865 (tramp-do-copy-or-rename-file-directly
2866 op v1 v1-localname v2-localname keep-date))
2867 ;; If both source and target are Tramp files,
2868 ;; both are using the same copy-program, then we
2869 ;; can invoke rcp directly. Note that
2870 ;; default-directory should point to a local
2871 ;; directory if we want to invoke rcp.
2872 ((and (equal v1-method v2-method)
2873 (tramp-method-out-of-band-p v1)
2874 (> (nth 7 (file-attributes filename))
2875 tramp-copy-size-limit))
2876 (tramp-do-copy-or-rename-file-out-of-band
2877 op filename newname keep-date))
2878 ;; No shortcut was possible. So we copy the
2879 ;; file first. If the operation was `rename', we go
2880 ;; back and delete the original file (if the copy was
2881 ;; successful). The approach is simple-minded: we
2882 ;; create a new buffer, insert the contents of the
2883 ;; source file into it, then write out the buffer to
2884 ;; the target file. The advantage is that it doesn't
2885 ;; matter which filename handlers are used for the
2886 ;; source and target file.
2887 (t
2888 (tramp-do-copy-or-rename-file-via-buffer
2889 op filename newname keep-date))))))
2890
2891 ;; One file is a Tramp file, the other one is local.
2892 ((or t1 t2)
2893 (with-parsed-tramp-file-name (if t1 filename newname) nil
2894 ;; If the Tramp file has an out-of-band method, the corresponding
2895 ;; copy-program can be invoked.
2896 (if (and (tramp-method-out-of-band-p v)
2897 (> (nth 7 (file-attributes filename))
2898 tramp-copy-size-limit))
2899 (tramp-do-copy-or-rename-file-out-of-band
2900 op filename newname keep-date)
2901 ;; Use the generic method via a Tramp buffer.
2902 (tramp-do-copy-or-rename-file-via-buffer
2903 op filename newname keep-date))))
2904
2905 (t
2906 ;; One of them must be a Tramp file.
2907 (error "Tramp implementation says this cannot happen")))
2908 ;; When newname did exist, we have wrong cached values.
2909 (when t2
2910 (with-parsed-tramp-file-name newname nil
2911 (tramp-flush-file-property v localname))))))
3057 2912
3058(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) 2913(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date)
3059 "Use an Emacs buffer to copy or rename a file. 2914 "Use an Emacs buffer to copy or rename a file.
3060First arg OP is either `copy' or `rename' and indicates the operation. 2915First arg OP is either `copy' or `rename' and indicates the operation.
3061FILENAME is the source file, NEWNAME the target file. 2916FILENAME is the source file, NEWNAME the target file.
3062KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." 2917KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
3063 (let ((trampbuf (get-buffer-create "*tramp output*")) 2918 (let ((modtime (nth 5 (file-attributes filename))))
3064 (modtime (nth 5 (file-attributes filename)))) 2919 (unwind-protect
3065 (when (and keep-date (or (null modtime) (equal modtime '(0 0)))) 2920 (with-temp-buffer
3066 (tramp-message 2921 (let ((coding-system-for-read 'binary))
3067 1 (concat "Warning: cannot preserve file time stamp" 2922 (insert-file-contents-literally filename))
3068 " with inline copying across machines"))) 2923 ;; We don't want the target file to be compressed, so we
3069 (save-excursion 2924 ;; let-bind `jka-compr-inhibit' to t.
3070 (set-buffer trampbuf) (erase-buffer) 2925 (let ((coding-system-for-write 'binary)
3071 (insert-file-contents-literally filename) 2926 (jka-compr-inhibit t))
3072 ;; We don't want the target file to be compressed, so we let-bind 2927 (write-region (point-min) (point-max) newname))))
3073 ;; `jka-compr-inhibit' to t. 2928 ;; KEEP-DATE handling.
3074 (let ((coding-system-for-write 'binary) 2929 (when keep-date
3075 (jka-compr-inhibit t)) 2930 (when (and (not (null modtime))
3076 (write-region (point-min) (point-max) newname)) 2931 (not (equal modtime '(0 0))))
3077 ;; KEEP-DATE handling. 2932 (tramp-touch newname modtime)))
3078 (when keep-date 2933 ;; Set the mode.
3079 (when (and (not (null modtime)) 2934 (set-file-modes newname (file-modes filename))
3080 (not (equal modtime '(0 0))))
3081 (tramp-touch newname modtime)))
3082 ;; Set the mode.
3083 (set-file-modes newname (file-modes filename)))
3084 ;; If the operation was `rename', delete the original file. 2935 ;; If the operation was `rename', delete the original file.
3085 (unless (eq op 'copy) 2936 (unless (eq op 'copy)
3086 (delete-file filename)))) 2937 (delete-file filename))))
3087 2938
3088(defun tramp-do-copy-or-rename-file-directly 2939(defun tramp-do-copy-or-rename-file-directly
3089 (op multi-method method user host localname1 localname2 keep-date) 2940 (op vec localname1 localname2 keep-date)
3090 "Invokes `cp' or `mv' on the remote system. 2941 "Invokes `cp' or `mv' on the remote system.
3091OP must be one of `copy' or `rename', indicating `cp' or `mv', 2942OP must be one of `copy' or `rename', indicating `cp' or `mv',
3092respectively. METHOD, USER, and HOST specify the connection. 2943respectively. VEC specifies the connection. LOCALNAME1 and
3093LOCALNAME1 and LOCALNAME2 specify the two arguments of `cp' or `mv'. 2944LOCALNAME2 specify the two arguments of `cp' or `mv'. If
3094If KEEP-DATE is non-nil, preserve the time stamp when copying." 2945KEEP-DATE is non-nil, preserve the time stamp when copying."
3095 ;; CCC: What happens to the timestamp when renaming? 2946 ;; CCC: What happens to the timestamp when renaming?
3096 (let ((cmd (cond ((and (eq op 'copy) keep-date) "cp -f -p") 2947 (let ((cmd (cond ((and (eq op 'copy) keep-date) "cp -f -p")
3097 ((eq op 'copy) "cp -f") 2948 ((eq op 'copy) "cp -f")
3098 ((eq op 'rename) "mv -f") 2949 ((eq op 'rename) "mv -f")
3099 (t (error 2950 (t (tramp-error
2951 vec 'file-error
3100 "Unknown operation `%s', must be `copy' or `rename'" 2952 "Unknown operation `%s', must be `copy' or `rename'"
3101 op))))) 2953 op)))))
3102 (save-excursion 2954 (tramp-send-command
3103 (tramp-send-command 2955 vec
3104 multi-method method user host 2956 (format "%s %s %s"
3105 (format "%s %s %s" 2957 cmd
3106 cmd 2958 (tramp-shell-quote-argument localname1)
3107 (tramp-shell-quote-argument localname1) 2959 (tramp-shell-quote-argument localname2)))
3108 (tramp-shell-quote-argument localname2))) 2960 (with-current-buffer (tramp-get-buffer vec)
3109 (tramp-wait-for-output)
3110 (goto-char (point-min)) 2961 (goto-char (point-min))
3111 (unless 2962 (unless
3112 (or 2963 (or
3113 (and (eq op 'copy) keep-date 2964 (and (eq op 'copy) keep-date
3114 ;; Mask cp -f error. 2965 ;; Mask cp -f error.
3115 (re-search-forward tramp-operation-not-permitted-regexp nil t)) 2966 (re-search-forward tramp-operation-not-permitted-regexp nil t))
3116 (zerop (tramp-send-command-and-check 2967 (zerop (tramp-send-command-and-check vec nil)))
3117 multi-method method user host nil nil))) 2968 (tramp-error-with-buffer
3118 (pop-to-buffer (current-buffer)) 2969 nil vec 'file-error
3119 (signal 'file-error 2970 "Copying directly failed, see buffer `%s' for details."
3120 (format "Copying directly failed, see buffer `%s' for details." 2971 (buffer-name))))
3121 (buffer-name)))))
3122 ;; Set the mode. 2972 ;; Set the mode.
3123 ;; CCC: Maybe `chmod --reference=localname1 localname2' could be used 2973 ;; CCC: Maybe `chmod --reference=localname1 localname2' could be used
3124 ;; where available? 2974 ;; where available?
3125 (unless (or (eq op 'rename) keep-date) 2975 (unless (or (eq op 'rename) keep-date)
3126 (set-file-modes 2976 (set-file-modes
3127 (tramp-make-tramp-file-name multi-method method user host localname2) 2977 (tramp-make-tramp-file-name
3128 (file-modes 2978 (tramp-file-name-method vec)
3129 (tramp-make-tramp-file-name 2979 (tramp-file-name-user vec)
3130 multi-method method user host localname1)))))) 2980 (tramp-file-name-host vec)
2981 localname2)
2982 (file-modes (tramp-make-tramp-file-name
2983 (tramp-file-name-method vec)
2984 (tramp-file-name-user vec)
2985 (tramp-file-name-host vec)
2986 localname1))))))
3131 2987
3132(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) 2988(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date)
3133 "Invoke rcp program to copy. 2989 "Invoke rcp program to copy.
@@ -3135,176 +2991,137 @@ One of FILENAME and NEWNAME must be a Tramp name, the other must
3135be a local filename. The method used must be an out-of-band method." 2991be a local filename. The method used must be an out-of-band method."
3136 (let ((t1 (tramp-tramp-file-p filename)) 2992 (let ((t1 (tramp-tramp-file-p filename))
3137 (t2 (tramp-tramp-file-p newname)) 2993 (t2 (tramp-tramp-file-p newname))
3138 v1-multi-method v1-method v1-user v1-host v1-localname 2994 copy-program copy-args copy-keep-date port spec
3139 v2-multi-method v2-method v2-user v2-host v2-localname 2995 source target)
3140 multi-method method user host copy-program copy-args 2996
3141 source target trampbuf) 2997 (with-parsed-tramp-file-name (if t1 filename newname) nil
3142 2998
3143 ;; Check which ones of source and target are Tramp files. 2999 ;; Expand hops. Might be necessary for gateway methods.
3144 ;; We cannot invoke `with-parsed-tramp-file-name'; 3000 (setq v (car (tramp-compute-multi-hops v)))
3145 ;; it fails if the file isn't a Tramp file name. 3001 (aset v 3 localname)
3146 (if t1 3002
3147 (with-parsed-tramp-file-name filename l 3003 ;; Check which ones of source and target are Tramp files.
3148 (setq v1-multi-method l-multi-method 3004 (setq source (if t1 (tramp-make-copy-program-file-name v) filename)
3149 v1-method l-method 3005 target (if t2 (tramp-make-copy-program-file-name v) newname))
3150 v1-user l-user 3006
3151 v1-host l-host 3007 ;; Check for port number. Until now, there's no need for handling
3152 v1-localname l-localname 3008 ;; like method, user, host.
3153 multi-method l-multi-method 3009 (setq host (tramp-file-name-real-host v)
3154 method (tramp-find-method 3010 port (tramp-file-name-port v)
3155 v1-multi-method v1-method v1-user v1-host) 3011 port (or (and port (number-to-string port)) ""))
3156 user l-user 3012
3157 host l-host 3013 ;; Compose copy command.
3158 copy-program (tramp-get-method-parameter 3014 (setq spec `((?h . ,host) (?u . ,user) (?p . ,port)
3159 v1-multi-method method 3015 (?t . ,(tramp-make-tramp-temp-file v))
3160 v1-user v1-host 'tramp-copy-program) 3016 (?k . ,(if keep-date " " "")))
3161 copy-args (tramp-get-method-parameter 3017 copy-program (tramp-get-method-parameter
3162 v1-multi-method method 3018 method 'tramp-copy-program)
3163 v1-user v1-host 'tramp-copy-args))) 3019 copy-keep-date (tramp-get-method-parameter
3164 (setq v1-localname filename)) 3020 method 'tramp-copy-keep-date)
3165 3021 copy-args
3166 (if t2 3022 (delq
3167 (with-parsed-tramp-file-name newname l 3023 nil
3168 (setq v2-multi-method l-multi-method 3024 (mapcar
3169 v2-method l-method 3025 '(lambda (x)
3170 v2-user l-user 3026 (setq
3171 v2-host l-host 3027 ;; " " is indication for keep-date argument.
3172 v2-localname l-localname 3028 x (delete " " (mapcar '(lambda (y) (format-spec y spec)) x)))
3173 multi-method l-multi-method 3029 (unless (member "" x) (mapconcat 'identity x " ")))
3174 method (tramp-find-method 3030 (tramp-get-method-parameter
3175 v2-multi-method v2-method v2-user v2-host) 3031 method 'tramp-copy-args))))
3176 user l-user
3177 host l-host
3178 copy-program (tramp-get-method-parameter
3179 v2-multi-method method
3180 v2-user v2-host 'tramp-copy-program)
3181 copy-args (tramp-get-method-parameter
3182 v2-multi-method method
3183 v2-user v2-host 'tramp-copy-args)))
3184 (setq v2-localname newname))
3185
3186 ;; The following should be changed. We need a more general
3187 ;; mechanism to parse extra host args.
3188 (if (not t1)
3189 (setq source v1-localname)
3190 (when (string-match "\\([^#]*\\)#\\(.*\\)" v1-host)
3191 (setq copy-args (cons "-P" (cons (match-string 2 v1-host) copy-args)))
3192 (setq v1-host (match-string 1 v1-host)))
3193 (setq source
3194 (tramp-make-copy-program-file-name
3195 v1-user v1-host
3196 (tramp-shell-quote-argument v1-localname))))
3197
3198 (if (not t2)
3199 (setq target v2-localname)
3200 (when (string-match "\\([^#]*\\)#\\(.*\\)" v2-host)
3201 (setq copy-args (cons "-P" (cons (match-string 2 v2-host) copy-args)))
3202 (setq v2-host (match-string 1 v2-host)))
3203 (setq target
3204 (tramp-make-copy-program-file-name
3205 v2-user v2-host
3206 (tramp-shell-quote-argument v2-localname))))
3207
3208 ;; Handle ControlMaster/ControlPath
3209 (setq copy-args
3210 (mapcar
3211 (lambda (x)
3212 (format-spec
3213 x `((?t . ,(format "/tmp/%s" tramp-temp-name-prefix)))))
3214 copy-args))
3215
3216 ;; Handle keep-date argument
3217 (when keep-date
3218 (if t1
3219 (setq copy-args
3220 (cons (tramp-get-method-parameter
3221 v1-multi-method method
3222 v1-user v1-host 'tramp-copy-keep-date-arg)
3223 copy-args))
3224 (setq copy-args
3225 (cons (tramp-get-method-parameter
3226 v2-multi-method method
3227 v2-user v2-host 'tramp-copy-keep-date-arg)
3228 copy-args))))
3229
3230 (setq copy-args (append copy-args (list source target))
3231 trampbuf (generate-new-buffer
3232 (tramp-buffer-name multi-method method user host)))
3233
3234 ;; Use an asynchronous process. By this, password can be handled.
3235 (save-excursion
3236 3032
3237 ;; Check for program. 3033 ;; Check for program.
3238 (when (and (fboundp 'executable-find) 3034 (when (and (fboundp 'executable-find)
3239 (not (executable-find copy-program))) 3035 (not (let ((default-directory
3240 (error "Cannot find copy program: %s" copy-program)) 3036 (tramp-temporary-file-directory)))
3037 (executable-find copy-program))))
3038 (tramp-error
3039 v 'file-error "Cannot find copy program: %s" copy-program))
3241 3040
3242 (set-buffer trampbuf) 3041 (tramp-message v 0 "Transferring %s to %s..." filename newname)
3243 (setq tramp-current-multi-method multi-method
3244 tramp-current-method method
3245 tramp-current-user user
3246 tramp-current-host host)
3247 (message "Transferring %s to %s..." filename newname)
3248 3042
3249 ;; Use rcp-like program for file transfer.
3250 (unwind-protect 3043 (unwind-protect
3251 (let* ((default-directory 3044 (with-temp-buffer
3252 (if (and (stringp default-directory) 3045 ;; The default directory must be remote.
3253 (file-accessible-directory-p default-directory)) 3046 (let ((default-directory
3254 default-directory 3047 (file-name-directory (if t1 filename newname))))
3255 (tramp-temporary-file-directory))) 3048 ;; Set the transfer process properties.
3256 (p (apply 'start-process (buffer-name trampbuf) trampbuf 3049 (tramp-set-connection-property
3257 copy-program copy-args))) 3050 v "process-name" (buffer-name (current-buffer)))
3258 (tramp-set-process-query-on-exit-flag p nil) 3051 (tramp-set-connection-property
3259 (tramp-process-actions p multi-method method user host 3052 v "process-buffer" (current-buffer))
3260 tramp-actions-copy-out-of-band)) 3053
3261 (kill-buffer trampbuf)) 3054 ;; Use an asynchronous process. By this, password can
3262 (message "Transferring %s to %s...done" filename newname) 3055 ;; be handled. The default directory must be local, in
3056 ;; order to apply the correct `copy-program'. We don't
3057 ;; set a timeout, because the copying of large files can
3058 ;; last longer than 60 secs.
3059 (let ((p (let ((default-directory
3060 (tramp-temporary-file-directory)))
3061 (apply 'start-process
3062 (tramp-get-connection-property
3063 v "process-name" nil)
3064 (tramp-get-connection-property
3065 v "process-buffer" nil)
3066 copy-program
3067 (append copy-args (list source target))))))
3068 (tramp-message
3069 v 6 "%s" (mapconcat 'identity (process-command p) " "))
3070 (set-process-sentinel p 'tramp-flush-connection-property)
3071 (tramp-set-process-query-on-exit-flag p nil)
3072 (tramp-process-actions p v tramp-actions-copy-out-of-band))))
3073
3074 ;; Reset the transfer process properties.
3075 (tramp-set-connection-property v "process-name" nil)
3076 (tramp-set-connection-property v "process-buffer" nil))
3077
3078 (tramp-message v 0 "Transferring %s to %s...done" filename newname)
3079
3080 ;; Handle KEEP-DATE argument.
3081 (when (and keep-date (not copy-keep-date))
3082 (set-file-times newname (nth 5 (file-attributes filename))))
3263 3083
3264 ;; Set the mode. 3084 ;; Set the mode.
3265 (unless keep-date 3085 (unless (and keep-date copy-keep-date)
3266 (set-file-modes newname (file-modes filename)))) 3086 (set-file-modes newname (file-modes filename))))
3267 3087
3268 ;; If the operation was `rename', delete the original file. 3088 ;; If the operation was `rename', delete the original file.
3269 (unless (eq op 'copy) 3089 (unless (eq op 'copy)
3270 (delete-file filename)))) 3090 (delete-file filename))))
3271 3091
3272;; mkdir
3273(defun tramp-handle-make-directory (dir &optional parents) 3092(defun tramp-handle-make-directory (dir &optional parents)
3274 "Like `make-directory' for tramp files." 3093 "Like `make-directory' for Tramp files."
3275 (setq dir (expand-file-name dir)) 3094 (setq dir (expand-file-name dir))
3276 (with-parsed-tramp-file-name dir nil 3095 (with-parsed-tramp-file-name dir nil
3277 (save-excursion 3096 (save-excursion
3278 (tramp-barf-unless-okay 3097 (tramp-barf-unless-okay
3279 multi-method method user host 3098 v
3280 (format " %s %s" 3099 (format " %s %s"
3281 (if parents "mkdir -p" "mkdir") 3100 (if parents "mkdir -p" "mkdir")
3282 (tramp-shell-quote-argument localname)) 3101 (tramp-shell-quote-argument localname))
3283 nil 'file-error
3284 "Couldn't make directory %s" dir)))) 3102 "Couldn't make directory %s" dir))))
3285 3103
3286;; CCC error checking?
3287(defun tramp-handle-delete-directory (directory) 3104(defun tramp-handle-delete-directory (directory)
3288 "Like `delete-directory' for tramp files." 3105 "Like `delete-directory' for Tramp files."
3289 (setq directory (expand-file-name directory)) 3106 (setq directory (expand-file-name directory))
3290 (with-parsed-tramp-file-name directory nil 3107 (with-parsed-tramp-file-name directory nil
3291 (save-excursion 3108 (tramp-flush-directory-property v localname)
3292 (tramp-send-command 3109 (unless (zerop (tramp-send-command-and-check
3293 multi-method method user host 3110 v
3294 (format "rmdir %s ; echo ok" 3111 (format "rmdir %s"
3295 (tramp-shell-quote-argument localname))) 3112 (tramp-shell-quote-argument localname))))
3296 (tramp-wait-for-output)))) 3113 (tramp-error v 'file-error "Couldn't delete %s" directory))))
3297 3114
3298(defun tramp-handle-delete-file (filename) 3115(defun tramp-handle-delete-file (filename)
3299 "Like `delete-file' for tramp files." 3116 "Like `delete-file' for Tramp files."
3300 (setq filename (expand-file-name filename)) 3117 (setq filename (expand-file-name filename))
3301 (with-parsed-tramp-file-name filename nil 3118 (with-parsed-tramp-file-name filename nil
3302 (save-excursion 3119 (tramp-flush-file-property v localname)
3303 (unless (zerop (tramp-send-command-and-check 3120 (unless (zerop (tramp-send-command-and-check
3304 multi-method method user host 3121 v
3305 (format "rm -f %s" 3122 (format "rm -f %s"
3306 (tramp-shell-quote-argument localname)))) 3123 (tramp-shell-quote-argument localname))))
3307 (signal 'file-error "Couldn't delete Tramp file"))))) 3124 (tramp-error v 'file-error "Couldn't delete %s" filename))))
3308 3125
3309;; Dired. 3126;; Dired.
3310 3127
@@ -3312,57 +3129,33 @@ be a local filename. The method used must be an out-of-band method."
3312;; we try and delete two directories under TRAMP :/ 3129;; we try and delete two directories under TRAMP :/
3313(defun tramp-handle-dired-recursive-delete-directory (filename) 3130(defun tramp-handle-dired-recursive-delete-directory (filename)
3314 "Recursively delete the directory given. 3131 "Recursively delete the directory given.
3315This is like `dired-recursive-delete-directory' for tramp files." 3132This is like `dired-recursive-delete-directory' for Tramp files."
3316 (with-parsed-tramp-file-name filename nil 3133 (with-parsed-tramp-file-name filename nil
3317 ;; run a shell command 'rm -r <localname>' 3134 (tramp-flush-directory-property v filename)
3135 ;; Run a shell command 'rm -r <localname>'
3318 ;; Code shamelessly stolen for the dired implementation and, um, hacked :) 3136 ;; Code shamelessly stolen for the dired implementation and, um, hacked :)
3319 (or (file-exists-p filename) 3137 (unless (file-exists-p filename)
3320 (signal 3138 (tramp-error v 'file-error "No such directory: %s" filename))
3321 'file-error
3322 (list "Removing old file name" "no such directory" filename)))
3323 ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>) 3139 ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>)
3324 (tramp-send-command multi-method method user host 3140 (tramp-send-command
3325 (format "rm -r %s" (tramp-shell-quote-argument localname))) 3141 v
3142 (format "rm -r %s" (tramp-shell-quote-argument localname))
3143 ;; Don't read the output, do it explicitely.
3144 nil t)
3326 ;; Wait for the remote system to return to us... 3145 ;; Wait for the remote system to return to us...
3327 ;; This might take a while, allow it plenty of time. 3146 ;; This might take a while, allow it plenty of time.
3328 (tramp-wait-for-output 120) 3147 (tramp-wait-for-output (tramp-get-connection-process v) 120)
3329 ;; Make sure that it worked... 3148 ;; Make sure that it worked...
3330 (and (file-exists-p filename) 3149 (and (file-exists-p filename)
3331 (error "Failed to recursively delete %s" filename)))) 3150 (tramp-error
3332 3151 v 'file-error "Failed to recursively delete %s" filename))))
3333(defun tramp-handle-dired-call-process (program discard &rest arguments)
3334 "Like `dired-call-process' for tramp files."
3335 (with-parsed-tramp-file-name default-directory nil
3336 (save-excursion
3337 (tramp-barf-unless-okay
3338 multi-method method user host
3339 (format "cd %s" (tramp-shell-quote-argument localname))
3340 nil 'file-error
3341 "tramp-handle-dired-call-process: Couldn't `cd %s'"
3342 (tramp-shell-quote-argument localname))
3343 (tramp-send-command
3344 multi-method method user host
3345 (mapconcat #'tramp-shell-quote-argument (cons program arguments) " "))
3346 (tramp-wait-for-output))
3347 (unless discard
3348 ;; We cannot use `insert-buffer' because the tramp buffer
3349 ;; changes its contents before insertion due to calling
3350 ;; `expand-file' and alike.
3351 (insert
3352 (with-current-buffer
3353 (tramp-get-buffer multi-method method user host)
3354 (buffer-string))))
3355 (save-excursion
3356 (prog1
3357 (tramp-send-command-and-check multi-method method user host nil)
3358 (tramp-send-command multi-method method user host "cd")
3359 (tramp-wait-for-output)))))
3360 3152
3361(defun tramp-handle-dired-compress-file (file &rest ok-flag) 3153(defun tramp-handle-dired-compress-file (file &rest ok-flag)
3362 "Like `dired-compress-file' for tramp files." 3154 "Like `dired-compress-file' for Tramp files."
3363 ;; OK-FLAG is valid for XEmacs only, but not implemented. 3155 ;; OK-FLAG is valid for XEmacs only, but not implemented.
3364 ;; Code stolen mainly from dired-aux.el. 3156 ;; Code stolen mainly from dired-aux.el.
3365 (with-parsed-tramp-file-name file nil 3157 (with-parsed-tramp-file-name file nil
3158 (tramp-flush-file-property v localname)
3366 (save-excursion 3159 (save-excursion
3367 (let ((suffixes 3160 (let ((suffixes
3368 (if (not (featurep 'xemacs)) 3161 (if (not (featurep 'xemacs))
@@ -3388,11 +3181,10 @@ This is like `dired-recursive-delete-directory' for tramp files."
3388 nil) 3181 nil)
3389 ((and suffix (nth 2 suffix)) 3182 ((and suffix (nth 2 suffix))
3390 ;; We found an uncompression rule. 3183 ;; We found an uncompression rule.
3391 (message "Uncompressing %s..." file) 3184 (tramp-message v 0 "Uncompressing %s..." file)
3392 (when (zerop (tramp-send-command-and-check 3185 (when (zerop (tramp-send-command-and-check
3393 multi-method method user host 3186 v (concat (nth 2 suffix) " " localname)))
3394 (concat (nth 2 suffix) " " localname))) 3187 (tramp-message v 0 "Uncompressing %s...done" file)
3395 (message "Uncompressing %s...done" file)
3396 ;; `dired-remove-file' is not defined in XEmacs 3188 ;; `dired-remove-file' is not defined in XEmacs
3397 (funcall (symbol-function 'dired-remove-file) file) 3189 (funcall (symbol-function 'dired-remove-file) file)
3398 (string-match (car suffix) file) 3190 (string-match (car suffix) file)
@@ -3400,11 +3192,10 @@ This is like `dired-recursive-delete-directory' for tramp files."
3400 (t 3192 (t
3401 ;; We don't recognize the file as compressed, so compress it. 3193 ;; We don't recognize the file as compressed, so compress it.
3402 ;; Try gzip. 3194 ;; Try gzip.
3403 (message "Compressing %s..." file) 3195 (tramp-message v 0 "Compressing %s..." file)
3404 (when (zerop (tramp-send-command-and-check 3196 (when (zerop (tramp-send-command-and-check
3405 multi-method method user host 3197 v (concat "gzip -f " localname)))
3406 (concat "gzip -f " localname))) 3198 (tramp-message v 0 "Compressing %s...done" file)
3407 (message "Compressing %s...done" file)
3408 ;; `dired-remove-file' is not defined in XEmacs 3199 ;; `dired-remove-file' is not defined in XEmacs
3409 (funcall (symbol-function 'dired-remove-file) file) 3200 (funcall (symbol-function 'dired-remove-file) file)
3410 (cond ((file-exists-p (concat file ".gz")) 3201 (cond ((file-exists-p (concat file ".gz"))
@@ -3428,21 +3219,21 @@ This is like `dired-recursive-delete-directory' for tramp files."
3428 3219
3429(defun tramp-handle-insert-directory 3220(defun tramp-handle-insert-directory
3430 (filename switches &optional wildcard full-directory-p) 3221 (filename switches &optional wildcard full-directory-p)
3431 "Like `insert-directory' for tramp files." 3222 "Like `insert-directory' for Tramp files."
3432 (if (and (featurep 'ls-lisp) 3223 (setq filename (expand-file-name filename))
3433 (not (symbol-value 'ls-lisp-use-insert-directory-program))) 3224 (with-parsed-tramp-file-name filename nil
3434 (tramp-run-real-handler 3225 (tramp-flush-file-property v localname)
3435 'insert-directory (list filename switches wildcard full-directory-p)) 3226 (if (and (featurep 'ls-lisp)
3436 ;; For the moment, we assume that the remote "ls" program does not 3227 (not (symbol-value 'ls-lisp-use-insert-directory-program)))
3437 ;; grok "--dired". In the future, we should detect this on 3228 (tramp-run-real-handler
3438 ;; connection setup. 3229 'insert-directory (list filename switches wildcard full-directory-p))
3439 (when (string-match "^--dired\\s-+" switches) 3230 ;; For the moment, we assume that the remote "ls" program does not
3440 (setq switches (replace-match "" nil t switches))) 3231 ;; grok "--dired". In the future, we should detect this on
3441 (setq filename (expand-file-name filename)) 3232 ;; connection setup.
3442 (with-parsed-tramp-file-name filename nil 3233 (when (string-match "^--dired\\s-+" switches)
3443 (tramp-message-for-buffer 3234 (setq switches (replace-match "" nil t switches)))
3444 multi-method method user host 10 3235 (tramp-message
3445 "Inserting directory `ls %s %s', wildcard %s, fulldir %s" 3236 v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s"
3446 switches filename (if wildcard "yes" "no") 3237 switches filename (if wildcard "yes" "no")
3447 (if full-directory-p "yes" "no")) 3238 (if full-directory-p "yes" "no"))
3448 (when wildcard 3239 (when wildcard
@@ -3454,80 +3245,45 @@ This is like `dired-recursive-delete-directory' for tramp files."
3454 (setq switches (concat "-d " switches))) 3245 (setq switches (concat "-d " switches)))
3455 (when wildcard 3246 (when wildcard
3456 (setq switches (concat switches " " wildcard))) 3247 (setq switches (concat switches " " wildcard)))
3457 (save-excursion 3248 ;; If `full-directory-p', we just say `ls -l FILENAME'.
3458 ;; If `full-directory-p', we just say `ls -l FILENAME'. 3249 ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'.
3459 ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'. 3250 (if full-directory-p
3460 (if full-directory-p 3251 (tramp-send-command
3461 (tramp-send-command 3252 v
3462 multi-method method user host 3253 (format "%s %s %s"
3463 (format "%s %s %s" 3254 (tramp-get-ls-command v)
3464 (tramp-get-ls-command multi-method method user host) 3255 switches
3465 switches 3256 (if wildcard
3466 (if wildcard 3257 localname
3467 localname 3258 (tramp-shell-quote-argument (concat localname ".")))))
3468 (tramp-shell-quote-argument (concat localname "."))))) 3259 (tramp-barf-unless-okay
3469 (tramp-barf-unless-okay 3260 v
3470 multi-method method user host 3261 (format "cd %s" (tramp-shell-quote-argument
3471 (format "cd %s" (tramp-shell-quote-argument 3262 (file-name-directory localname)))
3472 (file-name-directory localname))) 3263 "Couldn't `cd %s'"
3473 nil 'file-error 3264 (tramp-shell-quote-argument (file-name-directory localname)))
3474 "Couldn't `cd %s'" 3265 (tramp-send-command
3475 (tramp-shell-quote-argument (file-name-directory localname))) 3266 v
3476 (tramp-send-command 3267 (format "%s %s %s"
3477 multi-method method user host 3268 (tramp-get-ls-command v)
3478 (format "%s %s %s" 3269 switches
3479 (tramp-get-ls-command multi-method method user host) 3270 (if (or wildcard
3480 switches 3271 (zerop (length (file-name-nondirectory localname))))
3481 (if wildcard 3272 ""
3482 localname 3273 (tramp-shell-quote-argument
3483 (if (zerop (length (file-name-nondirectory localname))) 3274 (file-name-nondirectory localname))))))
3484 "" 3275 ;; We cannot use `insert-buffer-substring' because the tramp buffer
3485 (tramp-shell-quote-argument 3276 ;; changes its contents before insertion due to calling
3486 (file-name-nondirectory localname))))))) 3277 ;; `expand-file' and alike.
3487 (sit-for 1) ;needed for rsh but not ssh? 3278 (insert
3488 (tramp-wait-for-output)) 3279 (with-current-buffer (tramp-get-buffer v)
3489 ;; The following let-binding is used by code that's commented 3280 (buffer-string))))))
3490 ;; out. Let's leave the let-binding in for a while to see
3491 ;; that the commented-out code is really not needed. Commenting-out
3492 ;; happened on 2003-03-13.
3493 (let ((old-pos (point)))
3494 ;; We cannot use `insert-buffer' because the tramp buffer
3495 ;; changes its contents before insertion due to calling
3496 ;; `expand-file' and alike.
3497 (insert
3498 (with-current-buffer
3499 (tramp-get-buffer multi-method method user host)
3500 (buffer-string)))
3501 ;; On XEmacs, we want to call (exchange-point-and-mark t), but
3502 ;; that doesn't exist on Emacs, so we use this workaround instead.
3503 ;; Since zmacs-region-stays doesn't exist in Emacs, this ought to
3504 ;; be safe. Thanks to Daniel Pittman <daniel@danann.net>.
3505 ;; (let ((zmacs-region-stays t))
3506 ;; (exchange-point-and-mark))
3507 (save-excursion
3508 (tramp-send-command multi-method method user host "cd")
3509 (tramp-wait-for-output))
3510 ;; For the time being, the XEmacs kludge is commented out.
3511 ;; Please test it on various XEmacs versions to see if it works.
3512 ;; ;; Another XEmacs specialty follows. What's the right way to do
3513 ;; ;; it?
3514 ;; (when (and (featurep 'xemacs)
3515 ;; (eq major-mode 'dired-mode))
3516 ;; (save-excursion
3517 ;; (require 'dired)
3518 ;; (dired-insert-set-properties old-pos (point))))
3519 ))))
3520
3521;; Continuation of kluge to pacify byte-compiler.
3522;;(eval-when-compile
3523;; (when (eq (symbol-function 'dired-insert-set-properties) 'ignore)
3524;; (fmakunbound 'dired-insert-set-properties)))
3525 3281
3526;; CCC is this the right thing to do? 3282;; CCC is this the right thing to do?
3527(defun tramp-handle-unhandled-file-name-directory (filename) 3283(defun tramp-handle-unhandled-file-name-directory (filename)
3528 "Like `unhandled-file-name-directory' for tramp files." 3284 "Like `unhandled-file-name-directory' for Tramp files."
3529 (with-parsed-tramp-file-name filename nil 3285 (with-parsed-tramp-file-name filename nil
3530 (expand-file-name "~/"))) 3286 (expand-file-name (tramp-make-tramp-file-name method user host "~/"))))
3531 3287
3532;; Canonicalization of file names. 3288;; Canonicalization of file names.
3533 3289
@@ -3548,7 +3304,7 @@ Doesn't do anything if the NAME does not start with a drive letter."
3548 name)) 3304 name))
3549 3305
3550(defun tramp-handle-expand-file-name (name &optional dir) 3306(defun tramp-handle-expand-file-name (name &optional dir)
3551 "Like `expand-file-name' for tramp files. 3307 "Like `expand-file-name' for Tramp files.
3552If the localname part of the given filename starts with \"/../\" then 3308If the localname part of the given filename starts with \"/../\" then
3553the result will be a local, non-Tramp, filename." 3309the result will be a local, non-Tramp, filename."
3554 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". 3310 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
@@ -3556,223 +3312,107 @@ the result will be a local, non-Tramp, filename."
3556 ;; Unless NAME is absolute, concat DIR and NAME. 3312 ;; Unless NAME is absolute, concat DIR and NAME.
3557 (unless (file-name-absolute-p name) 3313 (unless (file-name-absolute-p name)
3558 (setq name (concat (file-name-as-directory dir) name))) 3314 (setq name (concat (file-name-as-directory dir) name)))
3559 ;; If NAME is not a tramp file, run the real handler 3315 ;; If NAME is not a Tramp file, run the real handler.
3560 (if (not (tramp-tramp-file-p name)) 3316 (if (not (tramp-tramp-file-p name))
3561 (tramp-run-real-handler 'expand-file-name 3317 (tramp-run-real-handler 'expand-file-name (list name nil))
3562 (list name nil))
3563 ;; Dissect NAME. 3318 ;; Dissect NAME.
3564 (with-parsed-tramp-file-name name nil 3319 (with-parsed-tramp-file-name name nil
3565 (unless (file-name-absolute-p localname) 3320 (unless (file-name-absolute-p localname)
3566 (setq localname (concat "~/" localname))) 3321 (setq localname (concat "~/" localname)))
3567 (save-excursion 3322 ;; Tilde expansion if necessary. This needs a shell which
3568 ;; Tilde expansion if necessary. This needs a shell which 3323 ;; groks tilde expansion! The function `tramp-find-shell' is
3569 ;; groks tilde expansion! The function `tramp-find-shell' is 3324 ;; supposed to find such a shell on the remote host. Please
3570 ;; supposed to find such a shell on the remote host. Please 3325 ;; tell me about it when this doesn't work on your system.
3571 ;; tell me about it when this doesn't work on your system. 3326 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
3572 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) 3327 (let ((uname (match-string 1 localname))
3573 (let ((uname (match-string 1 localname)) 3328 (fname (match-string 2 localname)))
3574 (fname (match-string 2 localname))) 3329 ;; We cannot simply apply "~/", because under sudo "~/" is
3575 ;; We cannot simply apply "~/", because under sudo "~/" is 3330 ;; expanded to the local user home directory but to the
3576 ;; expanded to the local user home directory but to the 3331 ;; root home directory. On the other hand, using always
3577 ;; root home directory. On the other hand, using always 3332 ;; the default user name for tilde expansion is not
3578 ;; the default user name for tilde expansion is not 3333 ;; appropriate either, because ssh and companions might
3579 ;; appropriate either, because ssh and companions might 3334 ;; use a user name from the config file.
3580 ;; use a user name from the config file. 3335 (when (and (string-equal uname "~")
3581 (when (and (string-equal uname "~") 3336 (string-match "\\`su\\(do\\)?\\'" method))
3582 (string-match 3337 (setq uname (concat uname user)))
3583 "\\`su\\(do\\)?\\'" 3338 (setq uname
3584 (tramp-find-method multi-method method user host))) 3339 (with-connection-property v uname
3585 (setq uname (concat uname (or user "root")))) 3340 (tramp-send-command v (format "cd %s; pwd" uname))
3586 ;; CCC fanatic error checking? 3341 (with-current-buffer (tramp-get-buffer v)
3587 (set-buffer (tramp-get-buffer multi-method method user host)) 3342 (goto-char (point-min))
3588 (erase-buffer) 3343 (buffer-substring (point) (tramp-line-end-position)))))
3589 (tramp-send-command 3344 (setq localname (concat uname fname))))
3590 multi-method method user host 3345 ;; There might be a double slash, for example when "~/"
3591 (format "cd %s; pwd" uname) 3346 ;; expands to "/". Remove this.
3592 t) 3347 (while (string-match "//" localname)
3593 (tramp-wait-for-output) 3348 (setq localname (replace-match "/" t t localname)))
3594 (goto-char (point-min)) 3349 ;; No tilde characters in file name, do normal
3595 (setq uname (buffer-substring (point) (tramp-line-end-position))) 3350 ;; expand-file-name (this does "/./" and "/../"). We bind
3596 (setq localname (concat uname fname)) 3351 ;; `directory-sep-char' here for XEmacs on Windows, which
3597 (erase-buffer))) 3352 ;; would otherwise use backslash. `default-directory' is
3598 ;; There might be a double slash, for example when "~/" 3353 ;; bound, because on Windows there would be problems with UNC
3599 ;; expands to "/". Remove this. 3354 ;; shares or Cygwin mounts.
3600 (while (string-match "//" localname) 3355 (tramp-let-maybe directory-sep-char ?/
3601 (setq localname (replace-match "/" t t localname))) 3356 (let ((default-directory (tramp-temporary-file-directory)))
3602 ;; No tilde characters in file name, do normal 3357 (tramp-make-tramp-file-name
3603 ;; expand-file-name (this does "/./" and "/../"). We bind 3358 method user host
3604 ;; directory-sep-char here for XEmacs on Windows, which would 3359 (tramp-drop-volume-letter
3605 ;; otherwise use backslash. `default-directory' is bound to 3360 (tramp-run-real-handler 'expand-file-name
3606 ;; "/", because on Windows there would be problems with UNC 3361 (list localname)))))))))
3607 ;; shares or Cygwin mounts. 3362
3608 (tramp-let-maybe directory-sep-char ?/ 3363(defun tramp-handle-substitute-in-file-name (filename)
3609 (let ((default-directory "/")) 3364 "Like `substitute-in-file-name' for Tramp files.
3610 (tramp-make-tramp-file-name 3365\"//\" and \"/~\" substitute only in the local filename part.
3611 multi-method (or method (tramp-find-default-method user host)) 3366If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at
3612 user host 3367beginning of local filename are not substituted."
3613 (tramp-drop-volume-letter 3368 (with-parsed-tramp-file-name filename nil
3614 (tramp-run-real-handler 'expand-file-name 3369 (if (equal tramp-syntax 'url)
3615 (list localname)))))))))) 3370 ;; We need to check localname only. The other parts cannot contain
3616 3371 ;; "//" or "/~".
3617;; old version follows. it uses ".." to cross file handler 3372 (if (and (> (length localname) 1)
3618;; boundaries. 3373 (or (string-match "//" localname)
3619;; ;; Look if localname starts with "/../" construct. If this is 3374 (string-match "/~" localname 1)))
3620;; ;; the case, then we return a local name instead of a remote name. 3375 (tramp-run-real-handler 'substitute-in-file-name (list filename))
3621;; (if (string-match "^/\\.\\./" localname) 3376 (tramp-make-tramp-file-name
3622;; (expand-file-name (substring localname 3)) 3377 (when method (substitute-in-file-name method))
3623;; ;; No tilde characters in file name, do normal 3378 (when user (substitute-in-file-name user))
3624;; ;; expand-file-name (this does "/./" and "/../"). We bind 3379 (when host (substitute-in-file-name host))
3625;; ;; directory-sep-char here for XEmacs on Windows, which 3380 (when localname (substitute-in-file-name localname))))
3626;; ;; would otherwise use backslash. 3381 ;; Ignore in LOCALNAME everything before "//" or "/~".
3627;; (let ((directory-sep-char ?/)) 3382 (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname))
3628;; (tramp-make-tramp-file-name 3383 (setq filename
3629;; multi-method method user host 3384 (tramp-make-tramp-file-name
3630;; (tramp-drop-volume-letter 3385 method user host (replace-match "\\1" nil nil localname)))
3631;; (tramp-run-real-handler 'expand-file-name 3386 ;; "/m:h:~" does not work for completion. We use "/m:h:~/".
3632;; (list localname)))))))))) 3387 (when (string-match "~$" filename)
3633 3388 (setq filename (concat filename "/"))))
3634;; Remote commands. 3389 (tramp-run-real-handler 'substitute-in-file-name (list filename)))))
3635 3390
3636(defvar tramp-async-proc nil 3391;; In XEmacs, electricity is implemented via a key map for ?/ and ?~,
3637 "Global variable keeping asynchronous process object. 3392;; which calls corresponding functions (see minibuf.el).
3638Used in `tramp-handle-shell-command'") 3393(when (fboundp 'minibuffer-electric-separator)
3639 3394 (mapcar
3640(defvar tramp-display-shell-command-buffer t 3395 '(lambda (x)
3641 "Whether to display output buffer of `shell-command'. 3396 (eval
3642This is necessary for handling DISPLAY of `process-file'.") 3397 `(defadvice ,x
3643 3398 (around ,(intern (format "tramp-advice-%s" x)) activate)
3644(defun tramp-handle-shell-command (command &optional output-buffer error-buffer) 3399 "Invoke `substitute-in-file-name' for Tramp files."
3645 "Like `shell-command' for tramp files. 3400 (if (and (symbol-value 'minibuffer-electric-file-name-behavior)
3646This will break if COMMAND prints a newline, followed by the value of 3401 (tramp-tramp-file-p (buffer-substring)))
3647`tramp-end-of-output', followed by another newline." 3402 ;; We don't need to handle `last-input-event', because
3648 ;; Asynchronous processes are far from being perfect. But it works at least 3403 ;; due to the key map we know it must be ?/ or ?~.
3649 ;; for `find-grep-dired' and `find-name-dired' in Emacs 22. 3404 (let ((s (concat (buffer-substring (point-min) (point))
3650 (if (tramp-tramp-file-p default-directory) 3405 (string last-command-char))))
3651 (with-parsed-tramp-file-name default-directory nil 3406 (delete-region (point-min) (point))
3652 (let ((curbuf (current-buffer)) 3407 (insert (substitute-in-file-name s))
3653 (asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) 3408 (setq ad-return-value last-command-char))
3654 status) 3409 ad-do-it))))
3655 (unless output-buffer 3410
3656 (setq output-buffer 3411 '(minibuffer-electric-separator
3657 (get-buffer-create 3412 minibuffer-electric-tilde)))
3658 (if asynchronous 3413
3659 "*Async Shell Command*" 3414
3660 "*Shell Command Output*"))) 3415;;; Remote commands.
3661 (set-buffer output-buffer)
3662 (erase-buffer))
3663 (unless (bufferp output-buffer)
3664 (setq output-buffer (current-buffer)))
3665 (set-buffer output-buffer)
3666 ;; Tramp doesn't handle the asynchronous case by an asynchronous
3667 ;; process. Instead of, another asynchronous process is opened
3668 ;; which gets the output of the (synchronous) Tramp process
3669 ;; via process-filter. ERROR-BUFFER is disabled.
3670 (when asynchronous
3671 (setq command (substring command 0 (match-beginning 0))
3672 error-buffer nil
3673 tramp-async-proc (start-process (buffer-name output-buffer)
3674 output-buffer "cat")))
3675 (save-excursion
3676 (tramp-barf-unless-okay
3677 multi-method method user host
3678 (format "cd %s" (tramp-shell-quote-argument localname))
3679 nil 'file-error
3680 "tramp-handle-shell-command: Couldn't `cd %s'"
3681 (tramp-shell-quote-argument localname))
3682 ;; Define the process filter
3683 (when asynchronous
3684 (set-process-filter
3685 (get-buffer-process
3686 (tramp-get-buffer multi-method method user host))
3687 '(lambda (process string)
3688 ;; Write the output into the Tramp Process
3689 (save-current-buffer
3690 (set-buffer (process-buffer process))
3691 (goto-char (point-max))
3692 (insert string))
3693 ;; Hand-over output to asynchronous process.
3694 (let ((end
3695 (string-match
3696 (regexp-quote tramp-end-of-output) string)))
3697 (when end
3698 (setq string
3699 (substring string 0 (1- (match-beginning 0)))))
3700 (process-send-string tramp-async-proc string)
3701 (when end
3702 (set-process-filter process nil)
3703 (process-send-eof tramp-async-proc))))))
3704 ;; Send the command
3705 (tramp-send-command
3706 multi-method method user host
3707 (if error-buffer
3708 (format "( %s ) 2>/tmp/tramp.$$.err; tramp_old_status=$?"
3709 command)
3710 (format "%s; tramp_old_status=$?" command)))
3711 (unless asynchronous
3712 (tramp-wait-for-output)))
3713 (unless asynchronous
3714 ;; We cannot use `insert-buffer' because the tramp buffer
3715 ;; changes its contents before insertion due to calling
3716 ;; `expand-file' and alike.
3717 (insert
3718 (with-current-buffer
3719 (tramp-get-buffer multi-method method user host)
3720 (buffer-string))))
3721 (when error-buffer
3722 (save-excursion
3723 (unless (bufferp error-buffer)
3724 (setq error-buffer (get-buffer-create error-buffer)))
3725 (tramp-send-command
3726 multi-method method user host
3727 "cat /tmp/tramp.$$.err")
3728 (tramp-wait-for-output)
3729 (set-buffer error-buffer)
3730 ;; Same comment as above
3731 (insert
3732 (with-current-buffer
3733 (tramp-get-buffer multi-method method user host)
3734 (buffer-string)))
3735 (tramp-send-command-and-check
3736 multi-method method user host "rm -f /tmp/tramp.$$.err")))
3737 (save-excursion
3738 (tramp-send-command multi-method method user host "cd")
3739 (unless asynchronous
3740 (tramp-wait-for-output))
3741 (tramp-send-command
3742 multi-method method user host
3743 (concat "tramp_set_exit_status $tramp_old_status;"
3744 " echo tramp_exit_status $?"))
3745 (unless asynchronous
3746 (tramp-wait-for-output)
3747 (goto-char (point-max))
3748 (unless (search-backward "tramp_exit_status " nil t)
3749 (error "Couldn't find exit status of `%s'" command))
3750 (skip-chars-forward "^ ")
3751 (setq status (read (current-buffer)))))
3752 (unless (zerop (buffer-size))
3753 (when tramp-display-shell-command-buffer
3754 (display-buffer output-buffer)))
3755 (set-buffer curbuf)
3756 status))
3757 ;; The following is only executed if something strange was
3758 ;; happening. Emit a helpful message and do it anyway.
3759 (message "tramp-handle-shell-command called with non-tramp directory: `%s'"
3760 default-directory)
3761 (tramp-run-real-handler 'shell-command
3762 (list command output-buffer error-buffer))))
3763
3764(defun tramp-handle-process-file (program &optional infile buffer display &rest args)
3765 "Like `process-file' for Tramp files."
3766 (when infile (error "Implementation does not handle input from file"))
3767 (when (and (numberp buffer) (zerop buffer))
3768 (error "Implementation does not handle immediate return"))
3769 (when (consp buffer) (error "Implementation does not handle error files"))
3770 (let ((tramp-display-shell-command-buffer display))
3771 (shell-command
3772 (mapconcat 'tramp-shell-quote-argument (cons program args) " ")
3773 buffer)))
3774
3775;; File Editing.
3776 3416
3777(defsubst tramp-make-temp-file (filename) 3417(defsubst tramp-make-temp-file (filename)
3778 (concat 3418 (concat
@@ -3781,102 +3421,254 @@ This will break if COMMAND prints a newline, followed by the value of
3781 (tramp-temporary-file-directory))) 3421 (tramp-temporary-file-directory)))
3782 (file-name-extension filename t))) 3422 (file-name-extension filename t)))
3783 3423
3424(defsubst tramp-make-tramp-temp-file (vec)
3425 (format
3426 "/tmp/%s%s"
3427 tramp-temp-name-prefix
3428 (if (get-buffer-process (tramp-get-connection-buffer vec))
3429 (process-id (get-buffer-process (tramp-get-connection-buffer vec)))
3430 (emacs-pid))))
3431
3432(defun tramp-handle-executable-find (command)
3433 "Like `executable-find' for Tramp files."
3434 (with-parsed-tramp-file-name default-directory nil
3435 (tramp-find-executable v command tramp-remote-path t)))
3436
3437;; We use BUFFER also as connection buffer during setup. Because of
3438;; this, its original contents must be saved, and restored once
3439;; connection has been setup.
3440(defun tramp-handle-start-file-process (name buffer program &rest args)
3441 "Like `start-file-process' for Tramp files."
3442 (with-parsed-tramp-file-name default-directory nil
3443 (unwind-protect
3444 (progn
3445 ;; Set the new process properties.
3446 (tramp-set-connection-property v "process-name" name)
3447 (tramp-set-connection-property
3448 v "process-buffer"
3449 (get-buffer-create
3450 ;; BUFFER can be nil.
3451 (or buffer (generate-new-buffer-name (tramp-buffer-name v)))))
3452 ;; Activate narrowing in order to save BUFFER contents.
3453 (with-current-buffer (tramp-get-connection-buffer v)
3454 (narrow-to-region (point-max) (point-max)))
3455 ;; Goto working directory. `tramp-send-command' opens a new
3456 ;; connection.
3457 (tramp-send-command
3458 v (format "cd %s" (tramp-shell-quote-argument localname)))
3459 ;; Send the command.
3460 (tramp-send-command
3461 v
3462 (format "%s; exit"
3463 (mapconcat 'tramp-shell-quote-argument
3464 (cons program args) " "))
3465 nil t) ; nooutput
3466 ;; Return process.
3467 (tramp-get-connection-process v))
3468 ;; Save exit.
3469 (with-current-buffer (tramp-get-connection-buffer v) (widen))
3470 (tramp-set-connection-property v "process-name" nil)
3471 (tramp-set-connection-property v "process-buffer" nil))))
3472
3473(defun tramp-handle-process-file
3474 (program &optional infile destination display &rest args)
3475 "Like `process-file' for Tramp files."
3476 ;; The implementation is not complete yet.
3477 (when (and (numberp destination) (zerop destination))
3478 (error "Implementation does not handle immediate return"))
3479
3480 (with-parsed-tramp-file-name default-directory nil
3481 (let ((temp-name-prefix (tramp-make-tramp-temp-file v))
3482 command input stderr outbuf ret)
3483 ;; Compute command.
3484 (setq command (mapconcat 'tramp-shell-quote-argument
3485 (cons program args) " "))
3486 ;; Determine input.
3487 (if (null infile)
3488 (setq input "/dev/null")
3489 (setq infile (expand-file-name infile))
3490 (if (tramp-equal-remote default-directory infile)
3491 ;; INFILE is on the same remote host.
3492 (setq input (with-parsed-tramp-file-name infile nil localname))
3493 ;; INFILE must be copied to remote host.
3494 (setq input (concat temp-name-prefix ".in"))
3495 (copy-file
3496 infile
3497 (tramp-make-tramp-file-name method user host input)
3498 t)))
3499 (when input (setq command (format "%s <%s" command input)))
3500
3501 ;; Determine output.
3502 (cond
3503 ;; Just a buffer
3504 ((bufferp destination)
3505 (setq outbuf destination))
3506 ;; A buffer name
3507 ((stringp destination)
3508 (setq outbuf (get-buffer-create destination)))
3509 ;; (REAL-DESTINATION ERROR-DESTINATION)
3510 ((consp destination)
3511 ;; output
3512 (cond
3513 ((bufferp (car destination))
3514 (setq outbuf (car destination)))
3515 ((stringp (car destination))
3516 (setq outbuf (get-buffer-create (car destination)))))
3517 ;; stderr
3518 (cond
3519 ((stringp (cadr destination))
3520 (setcar (cdr destination) (expand-file-name (cadr destination)))
3521 (if (tramp-equal-remote default-directory (cadr destination))
3522 ;; stderr is on the same remote host.
3523 (setq stderr (with-parsed-tramp-file-name
3524 (cadr destination) nil localname))
3525 ;; stderr must be copied to remote host. The temporary
3526 ;; file must be deleted after execution.
3527 (setq stderr (concat temp-name-prefix ".err"))))
3528 ;; stderr to be discarded
3529 ((null (cadr destination))
3530 (setq stderr "/dev/null"))))
3531 ;; 't
3532 (destination
3533 (setq outbuf (current-buffer))))
3534 (when stderr (setq command (format "%s 2>%s" command stderr)))
3535
3536 ;; If we have a temporary file, it must be removed after operation.
3537 (when (and input (string-match temp-name-prefix input))
3538 (setq command (format "%s; rm %s" command input)))
3539 ;; Goto working directory.
3540 (tramp-send-command
3541 v (format "cd %s" (tramp-shell-quote-argument localname)))
3542 ;; Send the command. It might not return in time, so we protect it.
3543 (condition-case nil
3544 (unwind-protect
3545 (tramp-send-command v command)
3546 ;; We should show the output anyway.
3547 (when outbuf
3548 (with-current-buffer outbuf
3549 (insert-buffer-substring (tramp-get-connection-buffer v)))
3550 (when display (display-buffer outbuf))))
3551 ;; When the user did interrupt, we should do it also.
3552 (error
3553 (kill-buffer (tramp-get-connection-buffer v))
3554 (setq ret 1)))
3555 (unless ret
3556 ;; Check return code.
3557 (setq ret (tramp-send-command-and-check v nil))
3558 ;; Provide error file.
3559 (when (and stderr (string-match temp-name-prefix stderr))
3560 (rename-file (tramp-make-tramp-file-name method user host stderr)
3561 (cadr destination) t)))
3562 ;; Return exit status.
3563 ret)))
3564
3565(defun tramp-handle-call-process-region
3566 (start end program &optional delete buffer display &rest args)
3567 "Like `call-process-region' for Tramp files."
3568 (let ((tmpfile (tramp-make-temp-file "")))
3569 (write-region start end tmpfile)
3570 (when delete (delete-region start end))
3571 (unwind-protect
3572 (apply 'call-process program tmpfile buffer display args)
3573 (delete-file tmpfile))))
3574
3575(defun tramp-handle-shell-command
3576 (command &optional output-buffer error-buffer)
3577 "Like `shell-command' for Tramp files."
3578 (with-parsed-tramp-file-name default-directory nil
3579 (let ((shell-file-name
3580 (tramp-get-connection-property v "remote-shell" "/bin/sh"))
3581 (shell-command-switch "-c"))
3582 (tramp-run-real-handler
3583 'shell-command (list command output-buffer error-buffer)))))
3584
3585;; File Editing.
3586
3587(defvar tramp-handle-file-local-copy-hook nil
3588 "Normal hook to be run at the end of `tramp-handle-file-local-copy'.")
3589
3784(defun tramp-handle-file-local-copy (filename) 3590(defun tramp-handle-file-local-copy (filename)
3785 "Like `file-local-copy' for tramp files." 3591 "Like `file-local-copy' for Tramp files."
3786 (with-parsed-tramp-file-name filename nil 3592 (with-parsed-tramp-file-name filename nil
3787 (let ((tramp-buf (tramp-get-buffer multi-method method user host)) 3593 (let (;; We used to bind the following as late as possible.
3788 ;; We used to bind the following as late as possible. 3594 ;; loc-dec was bound directly before the if statement that
3789 ;; loc-enc and loc-dec were bound directly before the if 3595 ;; checks them. But the functions tramp-get-* might invoke
3790 ;; statement that checks them. But the functions 3596 ;; the "are you awake" check in `tramp-maybe-open-connection',
3791 ;; tramp-get-* might invoke the "are you awake" check in 3597 ;; which is an unfortunate time since we rely on the buffer
3792 ;; tramp-maybe-open-connection, which is an unfortunate time 3598 ;; contents at that spot.
3793 ;; since we rely on the buffer contents at that spot. 3599 (rem-enc (tramp-get-remote-coding v "remote-encoding"))
3794 (rem-enc (tramp-get-remote-encoding multi-method method user host)) 3600 (loc-dec (tramp-get-local-coding v "local-decoding"))
3795 (rem-dec (tramp-get-remote-decoding multi-method method user host))
3796 (loc-enc (tramp-get-local-encoding multi-method method user host))
3797 (loc-dec (tramp-get-local-decoding multi-method method user host))
3798 tmpfil) 3601 tmpfil)
3799 (unless (file-exists-p filename) 3602 (unless (file-exists-p filename)
3800 (error "Cannot make local copy of non-existing file `%s'" 3603 (tramp-error
3801 filename)) 3604 v 'file-error
3605 "Cannot make local copy of non-existing file `%s'" filename))
3802 (setq tmpfil (tramp-make-temp-file filename)) 3606 (setq tmpfil (tramp-make-temp-file filename))
3803 3607
3804 (cond ((tramp-method-out-of-band-p multi-method method user host) 3608 (cond ((and (tramp-method-out-of-band-p v)
3609 (> (nth 7 (file-attributes filename))
3610 tramp-copy-size-limit))
3805 ;; `copy-file' handles out-of-band methods 3611 ;; `copy-file' handles out-of-band methods
3806 (copy-file filename tmpfil t t)) 3612 (copy-file filename tmpfil t t))
3807 3613
3808 ((and rem-enc rem-dec) 3614 (rem-enc
3809 ;; Use inline encoding for file transfer. 3615 ;; Use inline encoding for file transfer.
3810 (save-excursion 3616 (save-excursion
3811 ;; Following line for setting tramp-current-method, 3617 (tramp-message v 5 "Encoding remote file %s..." filename)
3812 ;; tramp-current-user, tramp-current-host.
3813 (set-buffer tramp-buf)
3814 (tramp-message 5 "Encoding remote file %s..." filename)
3815 (tramp-barf-unless-okay 3618 (tramp-barf-unless-okay
3816 multi-method method user host 3619 v
3817 (concat rem-enc " < " (tramp-shell-quote-argument localname)) 3620 (concat rem-enc " < " (tramp-shell-quote-argument localname))
3818 nil 'file-error 3621 "Encoding remote file failed")
3819 "Encoding remote file failed, see buffer `%s' for details"
3820 tramp-buf)
3821 ;; Remove trailing status code
3822 (goto-char (point-max))
3823 (delete-region (point) (progn (forward-line -1) (point)))
3824 3622
3825 (tramp-message 5 "Decoding remote file %s..." filename) 3623 (tramp-message v 5 "Decoding remote file %s..." filename)
3826 3624 ;; Here is where loc-dec used to be let-bound.
3827 ;; Here is where loc-enc and loc-dec used to be let-bound.
3828 (if (and (symbolp loc-dec) (fboundp loc-dec)) 3625 (if (and (symbolp loc-dec) (fboundp loc-dec))
3829 ;; If local decoding is a function, we call it. We 3626 ;; If local decoding is a function, we call it. We
3830 ;; must disable multibyte, because 3627 ;; must disable multibyte, because
3831 ;; `uudecode-decode-region' doesn't handle it 3628 ;; `uudecode-decode-region' doesn't handle it
3832 ;; correctly. 3629 ;; correctly.
3833 (let ((tmpbuf (get-buffer-create " *tramp tmp*"))) 3630 (unwind-protect
3834 (set-buffer tmpbuf) 3631 (with-temp-buffer
3835 (erase-buffer) 3632 (set-buffer-multibyte nil)
3836 (set-buffer-multibyte nil) 3633 (insert-buffer-substring (tramp-get-buffer v))
3837 (insert-buffer-substring tramp-buf) 3634 (tramp-message
3838 (tramp-message-for-buffer 3635 v 5 "Decoding remote file %s with function %s..."
3839 multi-method method user host 3636 filename loc-dec)
3840 6 "Decoding remote file %s with function %s..." 3637 (funcall loc-dec (point-min) (point-max))
3841 filename loc-dec) 3638 (let ((coding-system-for-write 'binary))
3842 (set-buffer tmpbuf) 3639 (write-region (point-min) (point-max) tmpfil))))
3843 ;; Douglas Gray Stephens <DGrayStephens@slb.com>
3844 ;; says that we need to strip tramp_exit_status
3845 ;; line from the output here. Go to point-max,
3846 ;; search backward for tramp_exit_status, delete
3847 ;; between point and point-max if found.
3848 (let ((coding-system-for-write 'binary))
3849 (funcall loc-dec (point-min) (point-max))
3850 (write-region (point-min) (point-max) tmpfil))
3851 (kill-buffer tmpbuf))
3852 ;; If tramp-decoding-function is not defined for this 3640 ;; If tramp-decoding-function is not defined for this
3853 ;; method, we invoke tramp-decoding-command instead. 3641 ;; method, we invoke tramp-decoding-command instead.
3854 (let ((tmpfil2 (tramp-make-temp-file filename))) 3642 (let ((tmpfil2 (tramp-make-temp-file filename)))
3855 (write-region (point-min) (point-max) tmpfil2) 3643 (let ((coding-system-for-write 'binary))
3644 (write-region (point-min) (point-max) tmpfil2))
3856 (tramp-message 3645 (tramp-message
3857 6 "Decoding remote file %s with command %s..." 3646 v 5 "Decoding remote file %s with command %s..."
3858 filename loc-dec) 3647 filename loc-dec)
3859 (tramp-call-local-coding-command 3648 (tramp-call-local-coding-command
3860 loc-dec tmpfil2 tmpfil) 3649 loc-dec tmpfil2 tmpfil)
3861 (delete-file tmpfil2))) 3650 (delete-file tmpfil2)))
3862 (tramp-message-for-buffer 3651 (tramp-message v 5 "Decoding remote file %s...done" filename)
3863 multi-method method user host
3864 5 "Decoding remote file %s...done" filename)
3865 ;; Set proper permissions. 3652 ;; Set proper permissions.
3866 (set-file-modes tmpfil (file-modes filename)))) 3653 (set-file-modes tmpfil (file-modes filename))))
3867 3654
3868 (t (error "Wrong method specification for `%s'" method))) 3655 (t (tramp-error
3656 v 'file-error "Wrong method specification for `%s'" method)))
3657 (run-hooks 'tramp-handle-file-local-copy-hook)
3869 tmpfil))) 3658 tmpfil)))
3870 3659
3871(defun tramp-handle-file-remote-p (filename) 3660(defun tramp-handle-file-remote-p (filename &optional connected)
3872 "Like `file-remote-p' for tramp files." 3661 "Like `file-remote-p' for Tramp files."
3873 (when (tramp-tramp-file-p filename) 3662 (when (tramp-tramp-file-p filename)
3874 (with-parsed-tramp-file-name filename nil 3663 (with-parsed-tramp-file-name filename nil
3875 (vector multi-method method user host "")))) 3664 (and (or (not connected)
3665 (let ((p (tramp-get-connection-process v)))
3666 (and p (processp p) (memq (process-status p) '(run open)))))
3667 (tramp-make-tramp-file-name method user host "")))))
3876 3668
3877(defun tramp-handle-insert-file-contents 3669(defun tramp-handle-insert-file-contents
3878 (filename &optional visit beg end replace) 3670 (filename &optional visit beg end replace)
3879 "Like `insert-file-contents' for tramp files." 3671 "Like `insert-file-contents' for Tramp files."
3880 (barf-if-buffer-read-only) 3672 (barf-if-buffer-read-only)
3881 (setq filename (expand-file-name filename)) 3673 (setq filename (expand-file-name filename))
3882 (with-parsed-tramp-file-name filename nil 3674 (with-parsed-tramp-file-name filename nil
@@ -3886,8 +3678,8 @@ This will break if COMMAND prints a newline, followed by the value of
3886 (setq buffer-file-name filename) 3678 (setq buffer-file-name filename)
3887 (set-visited-file-modtime) 3679 (set-visited-file-modtime)
3888 (set-buffer-modified-p nil)) 3680 (set-buffer-modified-p nil))
3889 (signal 'file-error 3681 (tramp-error
3890 (format "File `%s' not found on remote host" filename)) 3682 v 'file-error "File %s not found on remote host" filename)
3891 (list (expand-file-name filename) 0)) 3683 (list (expand-file-name filename) 0))
3892 ;; `insert-file-contents-literally' takes care to avoid calling 3684 ;; `insert-file-contents-literally' takes care to avoid calling
3893 ;; jka-compr. By let-binding inhibit-file-name-operation, we 3685 ;; jka-compr. By let-binding inhibit-file-name-operation, we
@@ -3899,20 +3691,16 @@ This will break if COMMAND prints a newline, followed by the value of
3899 'file-local-copy))) 3691 'file-local-copy)))
3900 (file-local-copy filename))) 3692 (file-local-copy filename)))
3901 coding-system-used result) 3693 coding-system-used result)
3694 (tramp-message v 4 "Inserting local temp file `%s'..." local-copy)
3695 (setq result (insert-file-contents local-copy nil beg end replace))
3902 (when visit 3696 (when visit
3903 (setq buffer-file-name filename) 3697 (setq buffer-file-name filename)
3904 (set-visited-file-modtime) 3698 (set-visited-file-modtime)
3905 (set-buffer-modified-p nil)) 3699 (set-buffer-modified-p nil))
3906 (tramp-message-for-buffer
3907 multi-method method user host
3908 9 "Inserting local temp file `%s'..." local-copy)
3909 (setq result (insert-file-contents local-copy nil beg end replace))
3910 ;; Now `last-coding-system-used' has right value. Remember it. 3700 ;; Now `last-coding-system-used' has right value. Remember it.
3911 (when (boundp 'last-coding-system-used) 3701 (when (boundp 'last-coding-system-used)
3912 (setq coding-system-used (symbol-value 'last-coding-system-used))) 3702 (setq coding-system-used (symbol-value 'last-coding-system-used)))
3913 (tramp-message-for-buffer 3703 (tramp-message v 4 "Inserting local temp file `%s'...done" local-copy)
3914 multi-method method user host
3915 9 "Inserting local temp file `%s'...done" local-copy)
3916 (delete-file local-copy) 3704 (delete-file local-copy)
3917 (when (boundp 'last-coding-system-used) 3705 (when (boundp 'last-coding-system-used)
3918 (set 'last-coding-system-used coding-system-used)) 3706 (set 'last-coding-system-used coding-system-used))
@@ -3921,7 +3709,7 @@ This will break if COMMAND prints a newline, followed by the value of
3921 3709
3922 3710
3923(defun tramp-handle-find-backup-file-name (filename) 3711(defun tramp-handle-find-backup-file-name (filename)
3924 "Like `find-backup-file-name' for tramp files." 3712 "Like `find-backup-file-name' for Tramp files."
3925 (with-parsed-tramp-file-name filename nil 3713 (with-parsed-tramp-file-name filename nil
3926 ;; We set both variables. It doesn't matter whether it is 3714 ;; We set both variables. It doesn't matter whether it is
3927 ;; Emacs or XEmacs 3715 ;; Emacs or XEmacs
@@ -3936,8 +3724,7 @@ This will break if COMMAND prints a newline, followed by the value of
3936 (if (and (stringp (cdr x)) 3724 (if (and (stringp (cdr x))
3937 (file-name-absolute-p (cdr x)) 3725 (file-name-absolute-p (cdr x))
3938 (not (tramp-file-name-p (cdr x)))) 3726 (not (tramp-file-name-p (cdr x))))
3939 (tramp-make-tramp-file-name 3727 (tramp-make-tramp-file-name method user host (cdr x))
3940 multi-method method user host (cdr x))
3941 (cdr x)))) 3728 (cdr x))))
3942 (symbol-value 'tramp-backup-directory-alist)) 3729 (symbol-value 'tramp-backup-directory-alist))
3943 (symbol-value 'backup-directory-alist)))) 3730 (symbol-value 'backup-directory-alist))))
@@ -3955,7 +3742,7 @@ This will break if COMMAND prints a newline, followed by the value of
3955 (file-name-absolute-p (car (cdr x))) 3742 (file-name-absolute-p (car (cdr x)))
3956 (not (tramp-file-name-p (car (cdr x))))) 3743 (not (tramp-file-name-p (car (cdr x)))))
3957 (tramp-make-tramp-file-name 3744 (tramp-make-tramp-file-name
3958 multi-method method user host (car (cdr x))) 3745 method user host (car (cdr x)))
3959 (car (cdr x)))) 3746 (car (cdr x))))
3960 (cdr (cdr x)))) 3747 (cdr (cdr x))))
3961 (symbol-value 'tramp-bkup-backup-directory-info)) 3748 (symbol-value 'tramp-bkup-backup-directory-info))
@@ -3964,9 +3751,18 @@ This will break if COMMAND prints a newline, followed by the value of
3964 (tramp-run-real-handler 'find-backup-file-name (list filename))))) 3751 (tramp-run-real-handler 'find-backup-file-name (list filename)))))
3965 3752
3966(defun tramp-handle-make-auto-save-file-name () 3753(defun tramp-handle-make-auto-save-file-name ()
3967 "Like `make-auto-save-file-name' for tramp files. 3754 "Like `make-auto-save-file-name' for Tramp files.
3968Returns a file name in `tramp-auto-save-directory' for autosaving this file." 3755Returns a file name in `tramp-auto-save-directory' for autosaving this file."
3969 (let ((tramp-auto-save-directory tramp-auto-save-directory)) 3756 (let ((tramp-auto-save-directory tramp-auto-save-directory)
3757 (buffer-file-name
3758 (tramp-subst-strs-in-string
3759 '(("_" . "|")
3760 ("/" . "_a")
3761 (":" . "_b")
3762 ("|" . "__")
3763 ("[" . "_l")
3764 ("]" . "_r"))
3765 (buffer-file-name))))
3970 ;; File name must be unique. This is ensured with Emacs 22 (see 3766 ;; File name must be unique. This is ensured with Emacs 22 (see
3971 ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for 3767 ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for
3972 ;; all other cases we must do it ourselves. 3768 ;; all other cases we must do it ourselves.
@@ -3981,68 +3777,49 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file."
3981 (symbol-value 'auto-save-file-name-transforms))) 3777 (symbol-value 'auto-save-file-name-transforms)))
3982 ;; Create directory. 3778 ;; Create directory.
3983 (when tramp-auto-save-directory 3779 (when tramp-auto-save-directory
3780 (setq buffer-file-name
3781 (expand-file-name buffer-file-name tramp-auto-save-directory))
3984 (unless (file-exists-p tramp-auto-save-directory) 3782 (unless (file-exists-p tramp-auto-save-directory)
3985 (make-directory tramp-auto-save-directory t))) 3783 (make-directory tramp-auto-save-directory t)))
3986 ;; jka-compr doesn't like auto-saving, so by appending "~" to the 3784 ;; Run plain `make-auto-save-file-name'. There might be an advice when
3987 ;; file name we make sure that jka-compr isn't used for the 3785 ;; it is not a magic file name operation (since Emacs 22).
3988 ;; auto-save file. 3786 ;; We must deactivate it temporarily.
3989 (let ((buffer-file-name 3787 (if (not (ad-is-active 'make-auto-save-file-name))
3990 (if tramp-auto-save-directory 3788 (tramp-run-real-handler 'make-auto-save-file-name nil)
3991 (expand-file-name 3789 ;; else
3992 (tramp-subst-strs-in-string 3790 (ad-deactivate 'make-auto-save-file-name)
3993 '(("_" . "|") 3791 (prog1
3994 ("/" . "_a") 3792 (tramp-run-real-handler 'make-auto-save-file-name nil)
3995 (":" . "_b") 3793 (ad-activate 'make-auto-save-file-name)))))
3996 ("|" . "__") 3794
3997 ("[" . "_l") 3795(defvar tramp-handle-write-region-hook nil
3998 ("]" . "_r")) 3796 "Normal hook to be run at the end of `tramp-handle-write-region'.")
3999 (buffer-file-name)) 3797
4000 tramp-auto-save-directory) 3798;; CCC grok APPEND, LOCKNAME
4001 (buffer-file-name))))
4002 ;; Run plain `make-auto-save-file-name'. There might be an advice when
4003 ;; it is not a magic file name operation (since Emacs 22).
4004 ;; We must deactivate it temporarily.
4005 (if (not (ad-is-active 'make-auto-save-file-name))
4006 (tramp-run-real-handler
4007 'make-auto-save-file-name nil)
4008 ;; else
4009 (ad-deactivate 'make-auto-save-file-name)
4010 (prog1
4011 (tramp-run-real-handler
4012 'make-auto-save-file-name nil)
4013 (ad-activate 'make-auto-save-file-name))))))
4014
4015
4016;; CCC grok APPEND, LOCKNAME, CONFIRM
4017(defun tramp-handle-write-region 3799(defun tramp-handle-write-region
4018 (start end filename &optional append visit lockname confirm) 3800 (start end filename &optional append visit lockname confirm)
4019 "Like `write-region' for tramp files." 3801 "Like `write-region' for Tramp files."
4020 (unless (eq append nil)
4021 (error "Cannot append to file using tramp (`%s')" filename))
4022 (setq filename (expand-file-name filename)) 3802 (setq filename (expand-file-name filename))
4023 ;; Following part commented out because we don't know what to do about
4024 ;; file locking, and it does not appear to be a problem to ignore it.
4025 ;; Ange-ftp ignores it, too.
4026 ;; (when (and lockname (stringp lockname))
4027 ;; (setq lockname (expand-file-name lockname)))
4028 ;; (unless (or (eq lockname nil)
4029 ;; (string= lockname filename))
4030 ;; (error
4031 ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME"))
4032 ;; XEmacs takes a coding system as the seventh argument, not `confirm'
4033 (when (and (not (featurep 'xemacs))
4034 confirm (file-exists-p filename))
4035 (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
4036 filename))
4037 (error "File not overwritten")))
4038 (with-parsed-tramp-file-name filename nil 3803 (with-parsed-tramp-file-name filename nil
4039 (let ((curbuf (current-buffer)) 3804 (unless (null append)
4040 (rem-enc (tramp-get-remote-encoding multi-method method user host)) 3805 (tramp-error
4041 (rem-dec (tramp-get-remote-decoding multi-method method user host)) 3806 v 'file-error "Cannot append to file using Tramp (`%s')" filename))
4042 (loc-enc (tramp-get-local-encoding multi-method method user host)) 3807 ;; Following part commented out because we don't know what to do about
4043 (loc-dec (tramp-get-local-decoding multi-method method user host)) 3808 ;; file locking, and it does not appear to be a problem to ignore it.
4044 (trampbuf (get-buffer-create "*tramp output*")) 3809 ;; Ange-ftp ignores it, too.
4045 (modes (file-modes filename)) 3810 ;; (when (and lockname (stringp lockname))
3811 ;; (setq lockname (expand-file-name lockname)))
3812 ;; (unless (or (eq lockname nil)
3813 ;; (string= lockname filename))
3814 ;; (error
3815 ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME"))
3816 ;; XEmacs takes a coding system as the seventh argument, not `confirm'
3817 (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename))
3818 (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
3819 (tramp-error v 'file-error "File not overwritten")))
3820 (let ((rem-dec (tramp-get-remote-coding v "remote-decoding"))
3821 (loc-enc (tramp-get-local-coding v "local-encoding"))
3822 (modes (save-excursion (file-modes filename)))
4046 ;; We use this to save the value of `last-coding-system-used' 3823 ;; We use this to save the value of `last-coding-system-used'
4047 ;; after writing the tmp file. At the end of the function, 3824 ;; after writing the tmp file. At the end of the function,
4048 ;; we set `last-coding-system-used' to this saved value. 3825 ;; we set `last-coding-system-used' to this saved value.
@@ -4050,14 +3827,10 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file."
4050 ;; talking to the remote shell or suchlike won't hose this 3827 ;; talking to the remote shell or suchlike won't hose this
4051 ;; variable. This approach was snarfed from ange-ftp.el. 3828 ;; variable. This approach was snarfed from ange-ftp.el.
4052 coding-system-used 3829 coding-system-used
4053 tmpfil) 3830 ;; Write region into a tmp file. This isn't really needed if we
4054 ;; Write region into a tmp file. This isn't really needed if we 3831 ;; use an encoding function, but currently we use it always
4055 ;; use an encoding function, but currently we use it always 3832 ;; because this makes the logic simpler.
4056 ;; because this makes the logic simpler. 3833 (tmpfil (tramp-make-temp-file filename)))
4057 (setq tmpfil (tramp-make-temp-file filename))
4058 ;; Set current buffer. If connection wasn't open, `file-modes' has
4059 ;; changed it accidently.
4060 (set-buffer curbuf)
4061 ;; We say `no-message' here because we don't want the visited file 3834 ;; We say `no-message' here because we don't want the visited file
4062 ;; modtime data to be clobbered from the temp file. We call 3835 ;; modtime data to be clobbered from the temp file. We call
4063 ;; `set-visited-file-modtime' ourselves later on. 3836 ;; `set-visited-file-modtime' ourselves later on.
@@ -4080,96 +3853,106 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file."
4080 ;; decoding command must be specified. However, if the method 3853 ;; decoding command must be specified. However, if the method
4081 ;; _also_ specifies an encoding function, then that is used for 3854 ;; _also_ specifies an encoding function, then that is used for
4082 ;; encoding the contents of the tmp file. 3855 ;; encoding the contents of the tmp file.
4083 (cond ((tramp-method-out-of-band-p multi-method method user host) 3856 (cond ((and (tramp-method-out-of-band-p v)
3857 (integerp start)
3858 (> (- end start) tramp-copy-size-limit))
4084 ;; `copy-file' handles out-of-band methods 3859 ;; `copy-file' handles out-of-band methods
4085 (copy-file tmpfil filename t t)) 3860 (copy-file tmpfil filename t t))
4086 3861
4087 ((and rem-enc rem-dec) 3862 (rem-dec
4088 ;; Use inline file transfer 3863 ;; Use inline file transfer
4089 (let ((tmpbuf (get-buffer-create " *tramp file transfer*"))) 3864 ;; Encode tmpfil
4090 (save-excursion 3865 (tramp-message v 5 "Encoding region...")
4091 ;; Encode tmpfil into tmpbuf 3866 (unwind-protect
4092 (tramp-message-for-buffer multi-method method user host 3867 (with-temp-buffer
4093 5 "Encoding region...") 3868 ;; Use encoding function or command.
4094 (set-buffer tmpbuf) 3869 (if (and (symbolp loc-enc) (fboundp loc-enc))
4095 (erase-buffer) 3870 (progn
4096 ;; Use encoding function or command. 3871 (tramp-message
4097 (if (and (symbolp loc-enc) (fboundp loc-enc)) 3872 v 5 "Encoding region using function `%s'..."
4098 (progn 3873 (symbol-name loc-enc))
4099 (tramp-message-for-buffer 3874 (let ((coding-system-for-read 'binary))
4100 multi-method method user host 3875 (insert-file-contents-literally tmpfil))
4101 6 "Encoding region using function `%s'..." 3876 ;; CCC. The following `let' is a workaround for
4102 (symbol-name loc-enc)) 3877 ;; the base64.el that comes with pgnus-0.84. If
4103 (insert-file-contents-literally tmpfil) 3878 ;; both of the following conditions are
4104 ;; CCC. The following `let' is a workaround for 3879 ;; satisfied, it tries to write to a local file
4105 ;; the base64.el that comes with pgnus-0.84. If 3880 ;; in default-directory, but at this point,
4106 ;; both of the following conditions are 3881 ;; default-directory is remote.
4107 ;; satisfied, it tries to write to a local file 3882 ;; (CALL-PROCESS-REGION can't write to remote
4108 ;; in default-directory, but at this point, 3883 ;; files, it seems.) The file in question is a
4109 ;; default-directory is remote. 3884 ;; tmp file anyway.
4110 ;; (CALL-PROCESS-REGION can't write to remote 3885 (let ((default-directory
4111 ;; files, it seems.) The file in question is a 3886 (tramp-temporary-file-directory)))
4112 ;; tmp file anyway. 3887 (funcall loc-enc (point-min) (point-max))))
4113 (let ((default-directory 3888
4114 (tramp-temporary-file-directory))) 3889 (tramp-message
4115 (funcall loc-enc (point-min) (point-max))) 3890 v 5 "Encoding region using command `%s'..." loc-enc)
4116 (goto-char (point-max)) 3891 (unless (equal 0 (tramp-call-local-coding-command
4117 (unless (bolp) 3892 loc-enc tmpfil t))
4118 (newline))) 3893 (tramp-error
4119 (tramp-message-for-buffer 3894 v 'file-error
4120 multi-method method user host 3895 (concat "Cannot write to `%s', local encoding"
4121 6 "Encoding region using command `%s'..." loc-enc) 3896 " command `%s' failed")
4122 (unless (equal 0 (tramp-call-local-coding-command 3897 filename loc-enc)))
4123 loc-enc tmpfil t)) 3898
4124 (pop-to-buffer trampbuf) 3899 ;; Send buffer into remote decoding command which
4125 (error (concat "Cannot write to `%s', local encoding" 3900 ;; writes to remote file. Because this happens on the
4126 " command `%s' failed") 3901 ;; remote host, we cannot use the function.
4127 filename loc-enc))) 3902 (goto-char (point-max))
4128 ;; Send tmpbuf into remote decoding command which 3903 (unless (bolp) (newline))
4129 ;; writes to remote file. Because this happens on the 3904 (tramp-message
4130 ;; remote host, we cannot use the function. 3905 v 5 "Decoding region into remote file %s..." filename)
4131 (tramp-message-for-buffer 3906 (tramp-send-command
4132 multi-method method user host 3907 v
4133 5 "Decoding region into remote file %s..." filename) 3908 (format
4134 (tramp-send-command 3909 "%s >%s <<'EOF'\n%sEOF"
4135 multi-method method user host 3910 rem-dec
4136 (format "%s >%s <<'EOF'" 3911 (tramp-shell-quote-argument localname)
4137 rem-dec 3912 (buffer-string)))
4138 (tramp-shell-quote-argument localname))) 3913 (tramp-barf-unless-okay
4139 (set-buffer tmpbuf) 3914 v nil
4140 (tramp-message-for-buffer 3915 (concat "Couldn't write region to `%s',"
4141 multi-method method user host 3916 " decode using `%s' failed")
4142 6 "Sending data to remote host...") 3917 filename rem-dec)
4143 (tramp-send-string multi-method method user host 3918 ;; When `file-precious-flag' is set, the region is
4144 (buffer-string)) 3919 ;; written to a temporary file. Check that the
4145 ;; wait for remote decoding to complete 3920 ;; checksum is equal to that from the local tmpfil.
4146 (tramp-message-for-buffer 3921 (when file-precious-flag
4147 multi-method method user host 3922 (erase-buffer)
4148 6 "Sending end of data token...") 3923 (and
4149 (tramp-send-command 3924 ;; cksum runs locally
4150 multi-method method user host "EOF" nil t) 3925 (let ((default-directory
4151 (tramp-message-for-buffer 3926 (tramp-temporary-file-directory)))
4152 multi-method method user host 6 3927 (zerop (call-process "cksum" tmpfil t)))
4153 "Waiting for remote host to process data...") 3928 ;; cksum runs remotely
4154 (set-buffer (tramp-get-buffer multi-method method user host)) 3929 (zerop
4155 (tramp-wait-for-output) 3930 (tramp-send-command-and-check
4156 (tramp-barf-unless-okay 3931 v
4157 multi-method method user host nil nil 'file-error 3932 (format
4158 (concat "Couldn't write region to `%s'," 3933 "cksum <%s"
4159 " decode using `%s' failed") 3934 (tramp-shell-quote-argument localname))))
4160 filename rem-dec) 3935 ;; ... they are different
4161 (tramp-message 5 "Decoding region into remote file %s...done" 3936 (not
4162 filename) 3937 (string-equal
4163 (kill-buffer tmpbuf)))) 3938 (buffer-string)
3939 (with-current-buffer (tramp-get-buffer v)
3940 (buffer-string))))
3941 (tramp-error
3942 v 'file-error
3943 (concat "Couldn't write region to `%s',"
3944 " decode using `%s' failed")
3945 filename rem-dec)))
3946 (tramp-message
3947 v 5 "Decoding region into remote file %s...done" filename)
3948 (tramp-flush-file-property v localname))))
4164 (t 3949 (t
4165 (error 3950 (tramp-error
3951 v 'file-error
4166 (concat "Method `%s' should specify both encoding and " 3952 (concat "Method `%s' should specify both encoding and "
4167 "decoding command or an rcp program") 3953 "decoding command or an rcp program")
4168 method))) 3954 method)))
4169 (delete-file tmpfil) 3955 (delete-file tmpfil)
4170 (unless (equal curbuf (current-buffer))
4171 (error "Buffer has changed from `%s' to `%s'"
4172 curbuf (current-buffer)))
4173 (when (or (eq visit t) (stringp visit)) 3956 (when (or (eq visit t) (stringp visit))
4174 (set-visited-file-modtime 3957 (set-visited-file-modtime
4175 ;; We must pass modtime explicitely, because filename can be different 3958 ;; We must pass modtime explicitely, because filename can be different
@@ -4178,41 +3961,9 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file."
4178 ;; Make `last-coding-system-used' have the right value. 3961 ;; Make `last-coding-system-used' have the right value.
4179 (when (boundp 'last-coding-system-used) 3962 (when (boundp 'last-coding-system-used)
4180 (set 'last-coding-system-used coding-system-used)) 3963 (set 'last-coding-system-used coding-system-used))
4181 (when (or (eq visit t) 3964 (when (or (eq visit t) (null visit) (stringp visit))
4182 (eq visit nil) 3965 (tramp-message v 0 "Wrote %s" filename))
4183 (stringp visit)) 3966 (run-hooks 'tramp-handle-write-region-hook))))
4184 (message "Wrote %s" filename)))))
4185
4186;; Call down to the real handler.
4187;; Because EFS does not play nicely with TRAMP (both systems match a
4188;; TRAMP file name) it is needed to disable efs as well as tramp for the
4189;; operation.
4190;;
4191;; Other than that, this is the canon file-handler code that the doco
4192;; says should be used here. Which is nice.
4193;;
4194;; Under XEmacs current, EFS also hooks in as
4195;; efs-sifn-handler-function to handle any filename with environment
4196;; variables. This has two implications:
4197;; 1) That EFS may not be completely dead (yet) for TRAMP filenames
4198;; 2) That TRAMP might want to do the same thing.
4199;; Details as they come in.
4200;;
4201;; Daniel Pittman <daniel@danann.net>
4202
4203;; (defun tramp-run-real-handler (operation args)
4204;; "Invoke normal file name handler for OPERATION.
4205;; This inhibits EFS and Ange-FTP, too, because they conflict with tramp.
4206;; First arg specifies the OPERATION, remaining ARGS are passed to the
4207;; OPERATION."
4208;; (let ((inhibit-file-name-handlers
4209;; (list 'tramp-file-name-handler
4210;; 'efs-file-handler-function
4211;; 'ange-ftp-hook-function
4212;; (and (eq inhibit-file-name-operation operation)
4213;; inhibit-file-name-handlers)))
4214;; (inhibit-file-name-operation operation))
4215;; (apply operation args)))
4216 3967
4217;;;###autoload 3968;;;###autoload
4218(progn (defun tramp-run-real-handler (operation args) 3969(progn (defun tramp-run-real-handler (operation args)
@@ -4230,10 +3981,6 @@ pass to the OPERATION."
4230 (inhibit-file-name-operation operation)) 3981 (inhibit-file-name-operation operation))
4231 (apply operation args)))) 3982 (apply operation args))))
4232 3983
4233;; This function is used from `tramp-completion-file-name-handler' functions
4234;; only, if `tramp-completion-mode' is true. But this cannot be checked here
4235;; because the check is based on a full filename, not available for all
4236;; basic I/O operations.
4237;;;###autoload 3984;;;###autoload
4238(progn (defun tramp-completion-run-real-handler (operation args) 3985(progn (defun tramp-completion-run-real-handler (operation args)
4239 "Invoke `tramp-file-name-handler' for OPERATION. 3986 "Invoke `tramp-file-name-handler' for OPERATION.
@@ -4306,28 +4053,37 @@ ARGS are the arguments OPERATION has been called with."
4306 (nth 2 args)) 4053 (nth 2 args))
4307 ; BUF 4054 ; BUF
4308 ((member operation 4055 ((member operation
4309 (list 'make-auto-save-file-name 4056 (list 'set-visited-file-modtime 'verify-visited-file-modtime
4310 'set-visited-file-modtime 'verify-visited-file-modtime 4057 ; Emacs 22 only
4311 ; XEmacs only 4058 'make-auto-save-file-name
4059 ; XEmacs only
4312 'backup-buffer)) 4060 'backup-buffer))
4313 (buffer-file-name 4061 (buffer-file-name
4314 (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) 4062 (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer))))
4315 ; COMMAND 4063 ; COMMAND
4316 ((member operation 4064 ((member operation
4317 (list 'dired-call-process 4065 (list ; not in Emacs 23
4066 'dired-call-process
4318 ; Emacs only 4067 ; Emacs only
4319 'shell-command 4068 'shell-command
4320 ; Emacs 22 only 4069 ; since Emacs 22 only
4321 'process-file 4070 'process-file
4071 ; since Emacs 23 only
4072 'start-file-process
4322 ; XEmacs only 4073 ; XEmacs only
4323 'dired-print-file 'dired-shell-call-process)) 4074 'dired-print-file 'dired-shell-call-process
4075 ; nowhere yet
4076 'executable-find 'start-process 'call-process))
4324 default-directory) 4077 default-directory)
4325 ; unknown file primitive 4078 ; unknown file primitive
4326 (t (error "unknown file I/O primitive: %s" operation)))) 4079 (t (error "unknown file I/O primitive: %s" operation))))
4327 4080
4328(defun tramp-find-foreign-file-name-handler (filename) 4081(defun tramp-find-foreign-file-name-handler (filename)
4329 "Return foreign file name handler if exists." 4082 "Return foreign file name handler if exists."
4330 (when (tramp-tramp-file-p filename) 4083 (when (and (stringp filename) (tramp-tramp-file-p filename)
4084 (or (not (tramp-completion-mode))
4085 (not (string-match
4086 tramp-completion-file-name-regexp filename))))
4331 (let (elt 4087 (let (elt
4332 res 4088 res
4333 (handler-alist tramp-foreign-file-name-handler-alist)) 4089 (handler-alist tramp-foreign-file-name-handler-alist))
@@ -4344,27 +4100,25 @@ ARGS are the arguments OPERATION has been called with."
4344(defun tramp-file-name-handler (operation &rest args) 4100(defun tramp-file-name-handler (operation &rest args)
4345 "Invoke Tramp file name handler. 4101 "Invoke Tramp file name handler.
4346Falls back to normal file name handler if no tramp file name handler exists." 4102Falls back to normal file name handler if no tramp file name handler exists."
4347;; (setq edebug-trace t)
4348;; (edebug-trace "%s" (with-output-to-string (backtrace)))
4349 (save-match-data 4103 (save-match-data
4350 (let* ((filename (apply 'tramp-file-name-for-operation operation args)) 4104 (let* ((filename (apply 'tramp-file-name-for-operation operation args))
4351 (completion (tramp-completion-mode filename)) 4105 (completion (tramp-completion-mode))
4352 (foreign (tramp-find-foreign-file-name-handler filename))) 4106 (foreign (tramp-find-foreign-file-name-handler filename)))
4353 (with-parsed-tramp-file-name filename nil 4107 (with-parsed-tramp-file-name filename nil
4354 (cond 4108 (cond
4355 ;; When we are in completion mode, some operations shouldn' be 4109 ;; When we are in completion mode, some operations shouldn't be
4356 ;; handled by backend. 4110 ;; handled by backend.
4357 ((and completion (memq operation '(expand-file-name)))
4358 (tramp-run-real-handler operation args))
4359 ((and completion (zerop (length localname)) 4111 ((and completion (zerop (length localname))
4360 (memq operation '(file-exists-p file-directory-p))) 4112 (memq operation '(file-exists-p file-directory-p)))
4361 t) 4113 t)
4114 ((and completion (zerop (length localname))
4115 (memq operation '(file-name-as-directory)))
4116 filename)
4362 ;; Call the backend function. 4117 ;; Call the backend function.
4363 (foreign (apply foreign operation args)) 4118 (foreign (apply foreign operation args))
4364 ;; Nothing to do for us. 4119 ;; Nothing to do for us.
4365 (t (tramp-run-real-handler operation args))))))) 4120 (t (tramp-run-real-handler operation args)))))))
4366 4121
4367
4368;; In Emacs, there is some concurrency due to timers. If a timer 4122;; In Emacs, there is some concurrency due to timers. If a timer
4369;; interrupts Tramp and wishes to use the same connection buffer as 4123;; interrupts Tramp and wishes to use the same connection buffer as
4370;; the "main" Emacs, then garbage might occur in the connection 4124;; the "main" Emacs, then garbage might occur in the connection
@@ -4396,7 +4150,7 @@ preventing reentrant calls of Tramp.")
4396 "Invoke remote-shell Tramp file name handler. 4150 "Invoke remote-shell Tramp file name handler.
4397Fall back to normal file name handler if no Tramp handler exists." 4151Fall back to normal file name handler if no Tramp handler exists."
4398 (when (and tramp-locked (not tramp-locker)) 4152 (when (and tramp-locked (not tramp-locker))
4399 (signal 'file-error "Forbidden reentrant call of Tramp")) 4153 (signal 'file-error (list "Forbidden reentrant call of Tramp")))
4400 (let ((tl tramp-locked)) 4154 (let ((tl tramp-locked))
4401 (unwind-protect 4155 (unwind-protect
4402 (progn 4156 (progn
@@ -4415,6 +4169,11 @@ Fall back to normal file name handler if no Tramp handler exists."
4415Falls back to normal file name handler if no tramp file name handler exists." 4169Falls back to normal file name handler if no tramp file name handler exists."
4416;; (setq edebug-trace t) 4170;; (setq edebug-trace t)
4417;; (edebug-trace "%s" (with-output-to-string (backtrace))) 4171;; (edebug-trace "%s" (with-output-to-string (backtrace)))
4172
4173;; (mapcar 'trace-function-background
4174;; (mapcar 'intern
4175;; (all-completions "tramp-" obarray 'functionp)))
4176
4418 (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) 4177 (let ((fn (assoc operation tramp-completion-file-name-handler-alist)))
4419 (if fn 4178 (if fn
4420 (save-match-data (apply (cdr fn) args)) 4179 (save-match-data (apply (cdr fn) args))
@@ -4423,6 +4182,11 @@ Falls back to normal file name handler if no tramp file name handler exists."
4423;;;###autoload 4182;;;###autoload
4424(defsubst tramp-register-file-name-handler () 4183(defsubst tramp-register-file-name-handler ()
4425 "Add tramp file name handler to `file-name-handler-alist'." 4184 "Add tramp file name handler to `file-name-handler-alist'."
4185 ;; Remove autoloaded handler from file name handler alist. Useful,
4186 ;; if `tramp-syntax' has been changed.
4187 (let ((a1 (rassq 'tramp-file-name-handler file-name-handler-alist)))
4188 (setq file-name-handler-alist (delete a1 file-name-handler-alist)))
4189 ;; Add the handler.
4426 (add-to-list 'file-name-handler-alist 4190 (add-to-list 'file-name-handler-alist
4427 (cons tramp-file-name-regexp 'tramp-file-name-handler)) 4191 (cons tramp-file-name-regexp 'tramp-file-name-handler))
4428 ;; If jka-compr is already loaded, move it to the front of 4192 ;; If jka-compr is already loaded, move it to the front of
@@ -4432,9 +4196,20 @@ Falls back to normal file name handler if no tramp file name handler exists."
4432 (setq file-name-handler-alist 4196 (setq file-name-handler-alist
4433 (cons jka (delete jka file-name-handler-alist)))))) 4197 (cons jka (delete jka file-name-handler-alist))))))
4434 4198
4199;; `tramp-file-name-handler' must be registered before evaluation of
4200;; site-start and init files, because there might exist remote files
4201;; already, f.e. files kept via recentf-mode.
4202;;;###autoload(tramp-register-file-name-handler)
4203(tramp-register-file-name-handler)
4204
4435;;;###autoload 4205;;;###autoload
4436(defsubst tramp-register-completion-file-name-handler () 4206(defsubst tramp-register-completion-file-name-handler ()
4437 "Add tramp completion file name handler to `file-name-handler-alist'." 4207 "Add tramp completion file name handler to `file-name-handler-alist'."
4208 ;; Remove autoloaded handler from file name handler alist. Useful,
4209 ;; if `tramp-syntax' has been changed.
4210 (let ((a1 (rassq
4211 'tramp-completion-file-name-handler file-name-handler-alist)))
4212 (setq file-name-handler-alist (delete a1 file-name-handler-alist)))
4438 ;; `partial-completion-mode' is unknown in XEmacs. So we should 4213 ;; `partial-completion-mode' is unknown in XEmacs. So we should
4439 ;; load it unconditionally there. In the GNU Emacs case, method/ 4214 ;; load it unconditionally there. In the GNU Emacs case, method/
4440 ;; user/host name completion shall be bound to `partial-completion-mode'. 4215 ;; user/host name completion shall be bound to `partial-completion-mode'.
@@ -4452,17 +4227,12 @@ Falls back to normal file name handler if no tramp file name handler exists."
4452 (setq file-name-handler-alist 4227 (setq file-name-handler-alist
4453 (cons jka (delete jka file-name-handler-alist)))))) 4228 (cons jka (delete jka file-name-handler-alist))))))
4454 4229
4455;; `tramp-file-name-handler' must be registered before evaluation of
4456;; site-start and init files, because there might exist remote files
4457;; already, f.e. files kept via recentf-mode.
4458;;;###autoload(tramp-register-file-name-handler)
4459;; During autoload, it shall be checked whether 4230;; During autoload, it shall be checked whether
4460;; `partial-completion-mode' is active. Therefore registering of 4231;; `partial-completion-mode' is active. Therefore registering of
4461;; `tramp-completion-file-name-handler' will be delayed. 4232;; `tramp-completion-file-name-handler' will be delayed.
4462;;;###autoload(add-hook 4233;;;###autoload(add-hook
4463;;;###autoload 'after-init-hook 4234;;;###autoload 'after-init-hook
4464;;;###autoload '(lambda () (tramp-register-completion-file-name-handler))) 4235;;;###autoload '(lambda () (tramp-register-completion-file-name-handler)))
4465(tramp-register-file-name-handler)
4466(tramp-register-completion-file-name-handler) 4236(tramp-register-completion-file-name-handler)
4467 4237
4468;;;###autoload 4238;;;###autoload
@@ -4476,20 +4246,19 @@ Falls back to normal file name handler if no tramp file name handler exists."
4476 4246
4477(add-hook 'tramp-unload-hook 'tramp-unload-file-name-handlers) 4247(add-hook 'tramp-unload-hook 'tramp-unload-file-name-handlers)
4478 4248
4479
4480;;; Interactions with other packages: 4249;;; Interactions with other packages:
4481 4250
4482;; -- complete.el -- 4251;; -- complete.el --
4483 4252
4484;; This function contributed by Ed Sabol 4253;; This function contributed by Ed Sabol
4485(defun tramp-handle-expand-many-files (name) 4254(defun tramp-handle-expand-many-files (name)
4486 "Like `PC-expand-many-files' for tramp files." 4255 "Like `PC-expand-many-files' for Tramp files."
4487 (with-parsed-tramp-file-name name nil 4256 (with-parsed-tramp-file-name name nil
4488 (save-match-data 4257 (save-match-data
4489 (if (or (string-match "\\*" name) 4258 (if (or (string-match "\\*" name)
4490 (string-match "\\?" name) 4259 (string-match "\\?" name)
4491 (string-match "\\[.*\\]" name)) 4260 (string-match "\\[.*\\]" name))
4492 (save-excursion 4261 (progn
4493 (let (bufstr) 4262 (let (bufstr)
4494 ;; CCC: To do it right, we should quote certain characters 4263 ;; CCC: To do it right, we should quote certain characters
4495 ;; in the file name, but since the echo command is going to 4264 ;; in the file name, but since the echo command is going to
@@ -4499,37 +4268,34 @@ Falls back to normal file name handler if no tramp file name handler exists."
4499 ;;- (set-difference tramp-file-name-quote-list 4268 ;;- (set-difference tramp-file-name-quote-list
4500 ;;- '(?\* ?\? ?[ ?])))) 4269 ;;- '(?\* ?\? ?[ ?]))))
4501 ;;- (tramp-send-command 4270 ;;- (tramp-send-command
4502 ;;- multi-method method user host 4271 ;;- method user host
4503 ;;- (format "echo %s" (comint-quote-filename localname))) 4272 ;;- (format "echo %s" (comint-quote-filename localname))))
4504 ;;- (tramp-wait-for-output)) 4273 (tramp-send-command v (format "echo %s" localname))
4505 (tramp-send-command multi-method method user host
4506 (format "echo %s" localname))
4507 (tramp-wait-for-output)
4508 (setq bufstr (buffer-substring (point-min) 4274 (setq bufstr (buffer-substring (point-min)
4509 (tramp-line-end-position))) 4275 (tramp-line-end-position)))
4510 (goto-char (point-min)) 4276 (with-current-buffer (tramp-get-buffer v)
4511 (if (string-equal localname bufstr)
4512 nil
4513 (insert "(\"")
4514 (while (search-forward " " nil t)
4515 (delete-backward-char 1)
4516 (insert "\" \""))
4517 (goto-char (point-max))
4518 (delete-backward-char 1)
4519 (insert "\")")
4520 (goto-char (point-min)) 4277 (goto-char (point-min))
4521 (mapcar 4278 (if (string-equal localname bufstr)
4522 (function (lambda (x) 4279 nil
4523 (tramp-make-tramp-file-name multi-method method 4280 (insert "(\"")
4524 user host x))) 4281 (while (search-forward " " nil t)
4525 (read (current-buffer)))))) 4282 (delete-backward-char 1)
4283 (insert "\" \""))
4284 (goto-char (point-max))
4285 (delete-backward-char 1)
4286 (insert "\")")
4287 (goto-char (point-min))
4288 (mapcar
4289 (function (lambda (x)
4290 (tramp-make-tramp-file-name method user host x)))
4291 (read (current-buffer)))))))
4526 (list (expand-file-name name)))))) 4292 (list (expand-file-name name))))))
4527 4293
4528(eval-after-load "complete" 4294(eval-after-load "complete"
4529 '(progn 4295 '(progn
4530 (defadvice PC-expand-many-files 4296 (defadvice PC-expand-many-files
4531 (around tramp-advice-PC-expand-many-files (name) activate) 4297 (around tramp-advice-PC-expand-many-files (name) activate)
4532 "Invoke `tramp-handle-expand-many-files' for tramp files." 4298 "Invoke `tramp-handle-expand-many-files' for Tramp files."
4533 (if (tramp-tramp-file-p name) 4299 (if (tramp-tramp-file-p name)
4534 (setq ad-return-value (tramp-handle-expand-many-files name)) 4300 (setq ad-return-value (tramp-handle-expand-many-files name))
4535 ad-do-it)) 4301 ad-do-it))
@@ -4538,142 +4304,118 @@ Falls back to normal file name handler if no tramp file name handler exists."
4538 4304
4539;;; File name handler functions for completion mode 4305;;; File name handler functions for completion mode
4540 4306
4541(defvar tramp-completion-mode nil
4542 "If non-nil, we are in file name completion mode.")
4543
4544;; Necessary because `tramp-file-name-regexp-unified' and 4307;; Necessary because `tramp-file-name-regexp-unified' and
4545;; `tramp-completion-file-name-regexp-unified' aren't different. 4308;; `tramp-completion-file-name-regexp-unified' aren't different. If
4546;; If nil, `tramp-completion-run-real-handler' is called (i.e. forwarding to 4309;; nil, `tramp-completion-run-real-handler' is called (i.e. forwarding
4547;; `tramp-file-name-handler'). Otherwise, it takes `tramp-run-real-handler'. 4310;; to `tramp-file-name-handler'). Otherwise, it takes
4548;; Using `last-input-event' is a little bit risky, because completing a file 4311;; `tramp-run-real-handler'. Using `last-input-event' is a little bit
4549;; might require loading other files, like "~/.netrc", and for them it 4312;; risky, because completing a file might require loading other files,
4550;; shouldn't be decided based on that variable. On the other hand, those files 4313;; like "~/.netrc", and for them it shouldn't be decided based on that
4551;; shouldn't have partial tramp file name syntax. Maybe another variable should 4314;; variable. On the other hand, those files shouldn't have partial
4552;; be introduced overwriting this check in such cases. Or we change tramp 4315;; tramp file name syntax. Maybe another variable should be introduced
4553;; file name syntax in order to avoid ambiguities, like in XEmacs ... 4316;; overwriting this check in such cases. Or we change tramp file name
4554;; In case of non unified file names it can be always true (and wouldn't be 4317;; syntax in order to avoid ambiguities, like in XEmacs ...
4555;; necessary, because there are different regexp). 4318(defun tramp-completion-mode ()
4556(defun tramp-completion-mode (file)
4557 "Checks whether method / user name / host name completion is active." 4319 "Checks whether method / user name / host name completion is active."
4558 (cond 4320 (or (equal last-input-event 'tab)
4559 (tramp-completion-mode t) 4321 ;; Emacs
4560 ((string-match "^/.*:.*:$" file) nil) 4322 (and (natnump last-input-event)
4561 ((string-match 4323 (or
4562 (concat tramp-prefix-regexp 4324 ;; ?\t has event-modifier 'control
4563 "\\(" tramp-method-regexp "\\)" tramp-postfix-single-method-regexp "$") 4325 (char-equal last-input-event ?\t)
4564 file) 4326 (and (not (event-modifiers last-input-event))
4565 (member (match-string 1 file) (mapcar 'car tramp-methods))) 4327 (or (char-equal last-input-event ?\?)
4566 ((or (equal last-input-event 'tab) 4328 (char-equal last-input-event ?\ )))))
4567 ;; Emacs 4329 ;; XEmacs
4568 (and (natnump last-input-event) 4330 (and (featurep 'xemacs)
4569 (or 4331 ;; `last-input-event' might be nil.
4570 ;; ?\t has event-modifier 'control 4332 (not (null last-input-event))
4571 (char-equal last-input-event ?\t) 4333 ;; `last-input-event' may have no character approximation.
4572 (and (not (event-modifiers last-input-event)) 4334 (funcall (symbol-function 'event-to-character) last-input-event)
4573 (or (char-equal last-input-event ?\?) 4335 (or
4574 (char-equal last-input-event ?\ ))))) 4336 ;; ?\t has event-modifier 'control
4575 ;; XEmacs 4337 (char-equal
4576 (and (featurep 'xemacs) 4338 (funcall (symbol-function 'event-to-character)
4577 ;; `last-input-event' might be nil. 4339 last-input-event) ?\t)
4578 (not (null last-input-event)) 4340 (and (not (event-modifiers last-input-event))
4579 ;; `last-input-event' may have no character approximation. 4341 (or (char-equal
4580 (funcall (symbol-function 'event-to-character) last-input-event) 4342 (funcall (symbol-function 'event-to-character)
4581 (or 4343 last-input-event) ?\?)
4582 ;; ?\t has event-modifier 'control 4344 (char-equal
4583 (char-equal 4345 (funcall (symbol-function 'event-to-character)
4584 (funcall (symbol-function 'event-to-character) 4346 last-input-event) ?\ )))))))
4585 last-input-event) ?\t)
4586 (and (not (event-modifiers last-input-event))
4587 (or (char-equal
4588 (funcall (symbol-function 'event-to-character)
4589 last-input-event) ?\?)
4590 (char-equal
4591 (funcall (symbol-function 'event-to-character)
4592 last-input-event) ?\ ))))))
4593 t)))
4594 4347
4595;; Method, host name and user name completion. 4348;; Method, host name and user name completion.
4596;; `tramp-completion-dissect-file-name' returns a list of 4349;; `tramp-completion-dissect-file-name' returns a list of
4597;; tramp-file-name structures. For all of them we return possible completions. 4350;; tramp-file-name structures. For all of them we return possible completions.
4598;;;###autoload 4351;;;###autoload
4599(defun tramp-completion-handle-file-name-all-completions (filename directory) 4352(defun tramp-completion-handle-file-name-all-completions (filename directory)
4600 "Like `file-name-all-completions' for partial tramp files." 4353 "Like `file-name-all-completions' for partial Tramp files."
4601 4354
4602 (unwind-protect 4355 (let* ((fullname (tramp-drop-volume-letter
4603 ;; We need to reset `tramp-completion-mode'. 4356 (expand-file-name filename directory)))
4604 (progn 4357 ;; Possible completion structures.
4605 (setq tramp-completion-mode t) 4358 (v (tramp-completion-dissect-file-name fullname))
4606 (let* 4359 result result1)
4607 ((fullname (concat directory filename)) 4360
4608 ;; possible completion structures 4361 (while v
4609 (v (tramp-completion-dissect-file-name fullname)) 4362 (let* ((car (car v))
4610 result result1) 4363 (method (tramp-file-name-method car))
4611 4364 (user (tramp-file-name-user car))
4612 (while v 4365 (host (tramp-file-name-host car))
4613 (let* ((car (car v)) 4366 (localname (tramp-file-name-localname car))
4614 (multi-method (tramp-file-name-multi-method car)) 4367 (m (tramp-find-method method user host))
4615 (method (tramp-file-name-method car)) 4368 (tramp-current-user user) ; see `tramp-parse-passwd'
4616 (user (tramp-file-name-user car)) 4369 all-user-hosts)
4617 (host (tramp-file-name-host car)) 4370
4618 (localname (tramp-file-name-localname car)) 4371 (unless localname ;; Nothing to complete.
4619 (m (tramp-find-method multi-method method user host)) 4372
4620 (tramp-current-user user) ; see `tramp-parse-passwd' 4373 (if (or user host)
4621 all-user-hosts) 4374
4622 4375 ;; Method dependent user / host combinations.
4623 (unless (or multi-method ;; Not handled (yet). 4376 (progn
4624 localname) ;; Nothing to complete 4377 (mapcar
4625 4378 (lambda (x)
4626 (if (or user host) 4379 (setq all-user-hosts
4627 4380 (append all-user-hosts
4628 ;; Method dependent user / host combinations 4381 (funcall (nth 0 x) (nth 1 x)))))
4629 (progn 4382 (tramp-get-completion-function m))
4630 (mapcar 4383
4631 (lambda (x) 4384 (setq result (append result
4632 (setq all-user-hosts 4385 (mapcar
4633 (append all-user-hosts 4386 (lambda (x)
4634 (funcall (nth 0 x) (nth 1 x))))) 4387 (tramp-get-completion-user-host
4635 (tramp-get-completion-function m)) 4388 method user host (nth 0 x) (nth 1 x)))
4636 4389 (delq nil all-user-hosts)))))
4637 (setq result (append result 4390
4638 (mapcar 4391 ;; Possible methods.
4639 (lambda (x) 4392 (setq result
4640 (tramp-get-completion-user-host 4393 (append result (tramp-get-completion-methods m)))))
4641 method user host (nth 0 x) (nth 1 x))) 4394
4642 (delq nil all-user-hosts))))) 4395 (setq v (cdr v))))
4643 4396
4644 ;; Possible methods 4397 ;; Unify list, remove nil elements.
4645 (setq result 4398 (while result
4646 (append result (tramp-get-completion-methods m))))) 4399 (let ((car (car result)))
4647 4400 (when car
4648 (setq v (cdr v)))) 4401 (add-to-list
4649 4402 'result1
4650 ;; unify list, remove nil elements 4403 (substring car (length (tramp-drop-volume-letter directory)))))
4651 (while result 4404 (setq result (cdr result))))
4652 (let ((car (car result))) 4405
4653 (when car (add-to-list 4406 ;; Complete local parts.
4654 'result1 (substring car (length directory)))) 4407 (append
4655 (setq result (cdr result)))) 4408 result1
4656 4409 (condition-case nil
4657 ;; Complete local parts 4410 (tramp-completion-run-real-handler
4658 (append 4411 'file-name-all-completions (list filename directory))
4659 result1 4412 (error nil)))))
4660 (condition-case nil
4661 (if result1
4662 ;; "/ssh:" does not need to be expanded as hostname.
4663 (tramp-run-real-handler
4664 'file-name-all-completions (list filename directory))
4665 ;; No method/user/host found to be expanded.
4666 (tramp-completion-run-real-handler
4667 'file-name-all-completions (list filename directory)))
4668 (error nil)))))
4669 ;; unwindform
4670 (setq tramp-completion-mode nil)))
4671 4413
4672;; Method, host name and user name completion for a file. 4414;; Method, host name and user name completion for a file.
4673;;;###autoload 4415;;;###autoload
4674(defun tramp-completion-handle-file-name-completion 4416(defun tramp-completion-handle-file-name-completion
4675 (filename directory &optional predicate) 4417 (filename directory &optional predicate)
4676 "Like `file-name-completion' for tramp files." 4418 "Like `file-name-completion' for Tramp files."
4677 (try-completion 4419 (try-completion
4678 filename 4420 filename
4679 (mapcar 'list (file-name-all-completions filename directory)) 4421 (mapcar 'list (file-name-all-completions filename directory))
@@ -4683,26 +4425,26 @@ Falls back to normal file name handler if no tramp file name handler exists."
4683;; I misuse a little bit the tramp-file-name structure in order to handle 4425;; I misuse a little bit the tramp-file-name structure in order to handle
4684;; completion possibilities for partial methods / user names / host names. 4426;; completion possibilities for partial methods / user names / host names.
4685;; Return value is a list of tramp-file-name structures according to possible 4427;; Return value is a list of tramp-file-name structures according to possible
4686;; completions. If "multi-method" or "localname" is non-nil it means there 4428;; completions. If "localname" is non-nil it means there
4687;; shouldn't be a completion anymore. 4429;; shouldn't be a completion anymore.
4688 4430
4689;; Expected results: 4431;; Expected results:
4690 4432
4691;; "/x" "/[x" "/x@" "/[x@" "/x@y" "/[x@y" 4433;; "/x" "/[x" "/x@" "/[x@" "/x@y" "/[x@y"
4692;; [nil nil nil "x" nil] [nil nil "x" nil nil] [nil nil "x" "y" nil] 4434;; [nil nil "x" nil] [nil "x" nil nil] [nil "x" "y" nil]
4693;; [nil nil "x" nil nil] 4435;; [nil "x" nil nil]
4694;; [nil "x" nil nil nil] 4436;; ["x" nil nil nil]
4695 4437
4696;; "/x:" "/x:y" "/x:y:" 4438;; "/x:" "/x:y" "/x:y:"
4697;; [nil nil nil "x" ""] [nil nil nil "x" "y"] [nil "x" nil "y" ""] 4439;; [nil nil "x" ""] [nil nil "x" "y"] ["x" nil "y" ""]
4698;; "/[x/" "/[x/y" 4440;; "/[x/" "/[x/y"
4699;; [nil "x" nil "" nil] [nil "x" nil "y" nil] 4441;; ["x" nil "" nil] ["x" nil "y" nil]
4700;; [nil "x" "" nil nil] [nil "x" "y" nil nil] 4442;; ["x" "" nil nil] ["x" "y" nil nil]
4701 4443
4702;; "/x:y@" "/x:y@z" "/x:y@z:" 4444;; "/x:y@" "/x:y@z" "/x:y@z:"
4703;; [nil nil nil "x" "y@"] [nil nil nil "x" "y@z"] [nil "x" "y" "z" ""] 4445;; [nil nil "x" "y@"] [nil nil "x" "y@z"] ["x" "y" "z" ""]
4704;; "/[x/y@" "/[x/y@z" 4446;; "/[x/y@" "/[x/y@z"
4705;; [nil "x" nil "y" nil] [nil "x" "y" "z" nil] 4447;; ["x" nil "y" nil] ["x" "y" "z" nil]
4706(defun tramp-completion-dissect-file-name (name) 4448(defun tramp-completion-dissect-file-name (name)
4707 "Returns a list of `tramp-file-name' structures. 4449 "Returns a list of `tramp-file-name' structures.
4708They are collected by `tramp-completion-dissect-file-name1'." 4450They are collected by `tramp-completion-dissect-file-name1'."
@@ -4727,25 +4469,49 @@ They are collected by `tramp-completion-dissect-file-name1'."
4727 "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp 4469 "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp
4728 "\\(" tramp-host-regexp x-nil "\\)$") 4470 "\\(" tramp-host-regexp x-nil "\\)$")
4729 nil 1 2 nil)) 4471 nil 1 2 nil))
4730 ;; "/method:user" "/[method/user" 4472 ;; "/method:user" "/[method/user" "/method://user"
4731 (tramp-completion-file-name-structure5 4473 (tramp-completion-file-name-structure5
4732 (list (concat tramp-prefix-regexp 4474 (list (concat tramp-prefix-regexp
4733 "\\(" tramp-method-regexp "\\)" tramp-postfix-single-method-regexp 4475 "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp
4734 "\\(" tramp-user-regexp x-nil "\\)$") 4476 "\\(" tramp-user-regexp x-nil "\\)$")
4735 1 2 nil nil)) 4477 1 2 nil nil))
4736 ;; "/method:host" "/[method/host" 4478 ;; "/method:host" "/[method/host" "/method://host"
4737 (tramp-completion-file-name-structure6 4479 (tramp-completion-file-name-structure6
4738 (list (concat tramp-prefix-regexp 4480 (list (concat tramp-prefix-regexp
4739 "\\(" tramp-method-regexp "\\)" tramp-postfix-single-method-regexp 4481 "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp
4740 "\\(" tramp-host-regexp x-nil "\\)$") 4482 "\\(" tramp-host-regexp x-nil "\\)$")
4741 1 nil 2 nil)) 4483 1 nil 2 nil))
4742 ;; "/method:user@host" "/[method/user@host" 4484 ;; "/method:user@host" "/[method/user@host" "/method://user@host"
4743 (tramp-completion-file-name-structure7 4485 (tramp-completion-file-name-structure7
4744 (list (concat tramp-prefix-regexp 4486 (list (concat tramp-prefix-regexp
4745 "\\(" tramp-method-regexp "\\)" tramp-postfix-single-method-regexp 4487 "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp
4746 "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp 4488 "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp
4747 "\\(" tramp-host-regexp x-nil "\\)$") 4489 "\\(" tramp-host-regexp x-nil "\\)$")
4748 1 2 3 nil))) 4490 1 2 3 nil))
4491 ;; "/method: "/method:/"
4492 (tramp-completion-file-name-structure8
4493 (list
4494 (if (equal tramp-syntax 'url)
4495 (concat tramp-prefix-regexp
4496 "\\(" tramp-method-regexp "\\)"
4497 "\\(" (substring tramp-postfix-method-regexp 0 1)
4498 "\\|" (substring tramp-postfix-method-regexp 1 2) "\\)"
4499 "\\(" "\\)$")
4500 ;; Should not match if not URL syntax.
4501 (concat tramp-prefix-regexp "/$"))
4502 1 3 nil nil))
4503 ;; "/method: "/method:/"
4504 (tramp-completion-file-name-structure9
4505 (list
4506 (if (equal tramp-syntax 'url)
4507 (concat tramp-prefix-regexp
4508 "\\(" tramp-method-regexp "\\)"
4509 "\\(" (substring tramp-postfix-method-regexp 0 1)
4510 "\\|" (substring tramp-postfix-method-regexp 1 2) "\\)"
4511 "\\(" "\\)$")
4512 ;; Should not match if not URL syntax.
4513 (concat tramp-prefix-regexp "/$"))
4514 1 nil 3 nil)))
4749 4515
4750 (mapcar (lambda (regexp) 4516 (mapcar (lambda (regexp)
4751 (add-to-list 'result 4517 (add-to-list 'result
@@ -4758,30 +4524,28 @@ They are collected by `tramp-completion-dissect-file-name1'."
4758 tramp-completion-file-name-structure5 4524 tramp-completion-file-name-structure5
4759 tramp-completion-file-name-structure6 4525 tramp-completion-file-name-structure6
4760 tramp-completion-file-name-structure7 4526 tramp-completion-file-name-structure7
4527 tramp-completion-file-name-structure8
4528 tramp-completion-file-name-structure9
4761 tramp-file-name-structure)) 4529 tramp-file-name-structure))
4762 4530
4763 (delq nil result))) 4531 (delq nil result)))
4764 4532
4765(defun tramp-completion-dissect-file-name1 (structure name) 4533(defun tramp-completion-dissect-file-name1 (structure name)
4766 "Returns a `tramp-file-name' structure matching STRUCTURE. 4534 "Returns a `tramp-file-name' structure matching STRUCTURE.
4767The structure consists of multi-method, remote method, remote user, 4535The structure consists of remote method, remote user,
4768remote host and localname (filename on remote host)." 4536remote host and localname (filename on remote host)."
4769 4537
4770 (let (method) 4538 (save-match-data
4771 (save-match-data 4539 (when (string-match (nth 0 structure) name)
4772 (when (string-match (nth 0 structure) name) 4540 (let ((method (and (nth 1 structure)
4773 (setq method (and (nth 1 structure) 4541 (match-string (nth 1 structure) name)))
4774 (match-string (nth 1 structure) name))) 4542 (user (and (nth 2 structure)
4775 (if (and method (member method tramp-multi-methods)) 4543 (match-string (nth 2 structure) name)))
4776 ;; Not handled (yet). 4544 (host (and (nth 3 structure)
4777 (vector method nil nil nil nil) 4545 (match-string (nth 3 structure) name)))
4778 (let ((user (and (nth 2 structure) 4546 (localname (and (nth 4 structure)
4779 (match-string (nth 2 structure) name))) 4547 (match-string (nth 4 structure) name))))
4780 (host (and (nth 3 structure) 4548 (vector method user host localname)))))
4781 (match-string (nth 3 structure) name)))
4782 (localname (and (nth 4 structure)
4783 (match-string (nth 4 structure) name))))
4784 (vector nil method user host localname)))))))
4785 4549
4786;; This function returns all possible method completions, adding the 4550;; This function returns all possible method completions, adding the
4787;; trailing method delimeter. 4551;; trailing method delimeter.
@@ -4791,8 +4555,8 @@ remote host and localname (filename on remote host)."
4791 (lambda (method) 4555 (lambda (method)
4792 (and method 4556 (and method
4793 (string-match (concat "^" (regexp-quote partial-method)) method) 4557 (string-match (concat "^" (regexp-quote partial-method)) method)
4794 (tramp-make-tramp-file-name nil method nil nil nil))) 4558 (tramp-completion-make-tramp-file-name method nil nil nil)))
4795 (delete "multi" (mapcar 'car tramp-methods)))) 4559 (mapcar 'car tramp-methods)))
4796 4560
4797;; Compares partial user and host names with possible completions. 4561;; Compares partial user and host names with possible completions.
4798(defun tramp-get-completion-user-host (method partial-user partial-host user host) 4562(defun tramp-get-completion-user-host (method partial-user partial-host user host)
@@ -4824,13 +4588,15 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST."
4824 host nil))) 4588 host nil)))
4825 4589
4826 (unless (zerop (+ (length user) (length host))) 4590 (unless (zerop (+ (length user) (length host)))
4827 (tramp-make-tramp-file-name nil method user host nil))) 4591 (tramp-completion-make-tramp-file-name method user host nil)))
4828 4592
4829(defun tramp-parse-rhosts (filename) 4593(defun tramp-parse-rhosts (filename)
4830 "Return a list of (user host) tuples allowed to access. 4594 "Return a list of (user host) tuples allowed to access.
4831Either user or host may be nil." 4595Either user or host may be nil."
4832 4596 ;; On Windows, there are problems in completion when
4833 (let (res) 4597 ;; `default-directory' is remote.
4598 (let ((default-directory (tramp-temporary-file-directory))
4599 res)
4834 (when (file-readable-p filename) 4600 (when (file-readable-p filename)
4835 (with-temp-buffer 4601 (with-temp-buffer
4836 (insert-file-contents filename) 4602 (insert-file-contents filename)
@@ -4839,24 +4605,15 @@ Either user or host may be nil."
4839 (push (tramp-parse-rhosts-group) res)))) 4605 (push (tramp-parse-rhosts-group) res))))
4840 res)) 4606 res))
4841 4607
4842;; Taken from gnus/netrc.el
4843(eval-and-compile
4844 (defalias 'tramp-point-at-eol
4845 (if (fboundp 'point-at-eol)
4846 'point-at-eol
4847 'line-end-position)))
4848
4849(defun tramp-parse-rhosts-group () 4608(defun tramp-parse-rhosts-group ()
4850 "Return a (user host) tuple allowed to access. 4609 "Return a (user host) tuple allowed to access.
4851Either user or host may be nil." 4610Either user or host may be nil."
4852
4853 (let ((result) 4611 (let ((result)
4854 (regexp 4612 (regexp
4855 (concat 4613 (concat
4856 "^\\(" tramp-host-regexp "\\)" 4614 "^\\(" tramp-host-regexp "\\)"
4857 "\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) 4615 "\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?")))
4858 4616 (narrow-to-region (point) (tramp-line-end-position))
4859 (narrow-to-region (point) (tramp-point-at-eol))
4860 (when (re-search-forward regexp nil t) 4617 (when (re-search-forward regexp nil t)
4861 (setq result (append (list (match-string 3) (match-string 1))))) 4618 (setq result (append (list (match-string 3) (match-string 1)))))
4862 (widen) 4619 (widen)
@@ -4866,8 +4623,10 @@ Either user or host may be nil."
4866(defun tramp-parse-shosts (filename) 4623(defun tramp-parse-shosts (filename)
4867 "Return a list of (user host) tuples allowed to access. 4624 "Return a list of (user host) tuples allowed to access.
4868User is always nil." 4625User is always nil."
4869 4626 ;; On Windows, there are problems in completion when
4870 (let (res) 4627 ;; `default-directory' is remote.
4628 (let ((default-directory (tramp-temporary-file-directory))
4629 res)
4871 (when (file-readable-p filename) 4630 (when (file-readable-p filename)
4872 (with-temp-buffer 4631 (with-temp-buffer
4873 (insert-file-contents filename) 4632 (insert-file-contents filename)
@@ -4879,11 +4638,9 @@ User is always nil."
4879(defun tramp-parse-shosts-group () 4638(defun tramp-parse-shosts-group ()
4880 "Return a (user host) tuple allowed to access. 4639 "Return a (user host) tuple allowed to access.
4881User is always nil." 4640User is always nil."
4882
4883 (let ((result) 4641 (let ((result)
4884 (regexp (concat "^\\(" tramp-host-regexp "\\)"))) 4642 (regexp (concat "^\\(" tramp-host-regexp "\\)")))
4885 4643 (narrow-to-region (point) (tramp-line-end-position))
4886 (narrow-to-region (point) (tramp-point-at-eol))
4887 (when (re-search-forward regexp nil t) 4644 (when (re-search-forward regexp nil t)
4888 (setq result (list nil (match-string 1)))) 4645 (setq result (list nil (match-string 1))))
4889 (widen) 4646 (widen)
@@ -4895,8 +4652,10 @@ User is always nil."
4895(defun tramp-parse-sconfig (filename) 4652(defun tramp-parse-sconfig (filename)
4896 "Return a list of (user host) tuples allowed to access. 4653 "Return a list of (user host) tuples allowed to access.
4897User is always nil." 4654User is always nil."
4898 4655 ;; On Windows, there are problems in completion when
4899 (let (res) 4656 ;; `default-directory' is remote.
4657 (let ((default-directory (tramp-temporary-file-directory))
4658 res)
4900 (when (file-readable-p filename) 4659 (when (file-readable-p filename)
4901 (with-temp-buffer 4660 (with-temp-buffer
4902 (insert-file-contents filename) 4661 (insert-file-contents filename)
@@ -4908,11 +4667,9 @@ User is always nil."
4908(defun tramp-parse-sconfig-group () 4667(defun tramp-parse-sconfig-group ()
4909 "Return a (user host) tuple allowed to access. 4668 "Return a (user host) tuple allowed to access.
4910User is always nil." 4669User is always nil."
4911
4912 (let ((result) 4670 (let ((result)
4913 (regexp (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)"))) 4671 (regexp (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)")))
4914 4672 (narrow-to-region (point) (tramp-line-end-position))
4915 (narrow-to-region (point) (tramp-point-at-eol))
4916 (when (re-search-forward regexp nil t) 4673 (when (re-search-forward regexp nil t)
4917 (setq result (list nil (match-string 1)))) 4674 (setq result (list nil (match-string 1))))
4918 (widen) 4675 (widen)
@@ -4924,11 +4681,12 @@ User is always nil."
4924(defun tramp-parse-shostkeys (dirname) 4681(defun tramp-parse-shostkeys (dirname)
4925 "Return a list of (user host) tuples allowed to access. 4682 "Return a list of (user host) tuples allowed to access.
4926User is always nil." 4683User is always nil."
4927 4684 ;; On Windows, there are problems in completion when
4928 (let ((regexp (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$")) 4685 ;; `default-directory' is remote.
4929 (files (when (file-directory-p dirname) (directory-files dirname))) 4686 (let* ((default-directory (tramp-temporary-file-directory))
4930 result) 4687 (regexp (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))
4931 4688 (files (when (file-directory-p dirname) (directory-files dirname)))
4689 result)
4932 (while files 4690 (while files
4933 (when (string-match regexp (car files)) 4691 (when (string-match regexp (car files))
4934 (push (list nil (match-string 1 (car files))) result)) 4692 (push (list nil (match-string 1 (car files))) result))
@@ -4938,12 +4696,13 @@ User is always nil."
4938(defun tramp-parse-sknownhosts (dirname) 4696(defun tramp-parse-sknownhosts (dirname)
4939 "Return a list of (user host) tuples allowed to access. 4697 "Return a list of (user host) tuples allowed to access.
4940User is always nil." 4698User is always nil."
4941 4699 ;; On Windows, there are problems in completion when
4942 (let ((regexp (concat "^\\(" tramp-host-regexp 4700 ;; `default-directory' is remote.
4943 "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$")) 4701 (let* ((default-directory (tramp-temporary-file-directory))
4944 (files (when (file-directory-p dirname) (directory-files dirname))) 4702 (regexp (concat "^\\(" tramp-host-regexp
4945 result) 4703 "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$"))
4946 4704 (files (when (file-directory-p dirname) (directory-files dirname)))
4705 result)
4947 (while files 4706 (while files
4948 (when (string-match regexp (car files)) 4707 (when (string-match regexp (car files))
4949 (push (list nil (match-string 1 (car files))) result)) 4708 (push (list nil (match-string 1 (car files))) result))
@@ -4953,8 +4712,10 @@ User is always nil."
4953(defun tramp-parse-hosts (filename) 4712(defun tramp-parse-hosts (filename)
4954 "Return a list of (user host) tuples allowed to access. 4713 "Return a list of (user host) tuples allowed to access.
4955User is always nil." 4714User is always nil."
4956 4715 ;; On Windows, there are problems in completion when
4957 (let (res) 4716 ;; `default-directory' is remote.
4717 (let ((default-directory (tramp-temporary-file-directory))
4718 res)
4958 (when (file-readable-p filename) 4719 (when (file-readable-p filename)
4959 (with-temp-buffer 4720 (with-temp-buffer
4960 (insert-file-contents filename) 4721 (insert-file-contents filename)
@@ -4966,11 +4727,9 @@ User is always nil."
4966(defun tramp-parse-hosts-group () 4727(defun tramp-parse-hosts-group ()
4967 "Return a (user host) tuple allowed to access. 4728 "Return a (user host) tuple allowed to access.
4968User is always nil." 4729User is always nil."
4969
4970 (let ((result) 4730 (let ((result)
4971 (regexp (concat "^\\(" tramp-host-regexp "\\)"))) 4731 (regexp (concat "^\\(" tramp-host-regexp "\\)")))
4972 4732 (narrow-to-region (point) (tramp-line-end-position))
4973 (narrow-to-region (point) (tramp-point-at-eol))
4974 (when (re-search-forward regexp nil t) 4733 (when (re-search-forward regexp nil t)
4975 (unless (char-equal (or (char-after) ?\n) ?:) ; no IPv6 4734 (unless (char-equal (or (char-after) ?\n) ?:) ; no IPv6
4976 (setq result (list nil (match-string 1))))) 4735 (setq result (list nil (match-string 1)))))
@@ -4982,13 +4741,15 @@ User is always nil."
4982 4741
4983;; For su-alike methods it would be desirable to return "root@localhost" 4742;; For su-alike methods it would be desirable to return "root@localhost"
4984;; as default. Unfortunately, we have no information whether any user name 4743;; as default. Unfortunately, we have no information whether any user name
4985;; has been typed already. So we (mis-)use tramp-current-user as indication, 4744;; has been typed already. So we use `tramp-current-user' as indication,
4986;; assuming it is set in `tramp-completion-handle-file-name-all-completions'. 4745;; assuming it is set in `tramp-completion-handle-file-name-all-completions'.
4987(defun tramp-parse-passwd (filename) 4746(defun tramp-parse-passwd (filename)
4988 "Return a list of (user host) tuples allowed to access. 4747 "Return a list of (user host) tuples allowed to access.
4989Host is always \"localhost\"." 4748Host is always \"localhost\"."
4990 4749 ;; On Windows, there are problems in completion when
4991 (let (res) 4750 ;; `default-directory' is remote.
4751 (let ((default-directory (tramp-temporary-file-directory))
4752 res)
4992 (if (zerop (length tramp-current-user)) 4753 (if (zerop (length tramp-current-user))
4993 '(("root" nil)) 4754 '(("root" nil))
4994 (when (file-readable-p filename) 4755 (when (file-readable-p filename)
@@ -5002,11 +4763,9 @@ Host is always \"localhost\"."
5002(defun tramp-parse-passwd-group () 4763(defun tramp-parse-passwd-group ()
5003 "Return a (user host) tuple allowed to access. 4764 "Return a (user host) tuple allowed to access.
5004Host is always \"localhost\"." 4765Host is always \"localhost\"."
5005
5006 (let ((result) 4766 (let ((result)
5007 (regexp (concat "^\\(" tramp-user-regexp "\\):"))) 4767 (regexp (concat "^\\(" tramp-user-regexp "\\):")))
5008 4768 (narrow-to-region (point) (tramp-line-end-position))
5009 (narrow-to-region (point) (tramp-point-at-eol))
5010 (when (re-search-forward regexp nil t) 4769 (when (re-search-forward regexp nil t)
5011 (setq result (list (match-string 1) "localhost"))) 4770 (setq result (list (match-string 1) "localhost")))
5012 (widen) 4771 (widen)
@@ -5016,8 +4775,10 @@ Host is always \"localhost\"."
5016(defun tramp-parse-netrc (filename) 4775(defun tramp-parse-netrc (filename)
5017 "Return a list of (user host) tuples allowed to access. 4776 "Return a list of (user host) tuples allowed to access.
5018User may be nil." 4777User may be nil."
5019 4778 ;; On Windows, there are problems in completion when
5020 (let (res) 4779 ;; `default-directory' is remote.
4780 (let ((default-directory (tramp-temporary-file-directory))
4781 res)
5021 (when (file-readable-p filename) 4782 (when (file-readable-p filename)
5022 (with-temp-buffer 4783 (with-temp-buffer
5023 (insert-file-contents filename) 4784 (insert-file-contents filename)
@@ -5029,49 +4790,63 @@ User may be nil."
5029(defun tramp-parse-netrc-group () 4790(defun tramp-parse-netrc-group ()
5030 "Return a (user host) tuple allowed to access. 4791 "Return a (user host) tuple allowed to access.
5031User may be nil." 4792User may be nil."
5032
5033 (let ((result) 4793 (let ((result)
5034 (regexp 4794 (regexp
5035 (concat 4795 (concat
5036 "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" 4796 "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)"
5037 "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) 4797 "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?")))
5038 4798 (narrow-to-region (point) (tramp-line-end-position))
5039 (narrow-to-region (point) (tramp-point-at-eol))
5040 (when (re-search-forward regexp nil t) 4799 (when (re-search-forward regexp nil t)
5041 (setq result (list (match-string 3) (match-string 1)))) 4800 (setq result (list (match-string 3) (match-string 1))))
5042 (widen) 4801 (widen)
5043 (forward-line 1) 4802 (forward-line 1)
5044 result)) 4803 result))
5045 4804
4805(defun tramp-parse-putty (registry)
4806 "Return a list of (user host) tuples allowed to access.
4807User is always nil."
4808 ;; On Windows, there are problems in completion when
4809 ;; `default-directory' is remote.
4810 (let ((default-directory (tramp-temporary-file-directory))
4811 res)
4812 (with-temp-buffer
4813 (when (zerop (call-process "reg" nil t nil "query" registry))
4814 (goto-char (point-min))
4815 (while (not (eobp))
4816 (push (tramp-parse-putty-group registry) res))))
4817 res))
4818
4819(defun tramp-parse-putty-group (registry)
4820 "Return a (user host) tuple allowed to access.
4821User is always nil."
4822 (let ((result)
4823 (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)")))
4824 (narrow-to-region (point) (tramp-line-end-position))
4825 (when (re-search-forward regexp nil t)
4826 (setq result (list nil (match-string 1))))
4827 (widen)
4828 (forward-line 1)
4829 result))
4830
5046;;; Internal Functions: 4831;;; Internal Functions:
5047 4832
5048(defun tramp-maybe-send-perl-script (multi-method method user host script name) 4833(defun tramp-maybe-send-script (vec script name)
5049 "Define in remote shell function NAME implemented as perl SCRIPT. 4834 "Define in remote shell function NAME implemented as SCRIPT.
5050Only send the definition if it has not already been done. 4835Only send the definition if it has not already been done."
5051Function may have 0-3 parameters." 4836 (let* ((p (tramp-get-connection-process vec))
5052 (let ((remote-perl (tramp-get-remote-perl multi-method method user host))) 4837 (scripts (tramp-get-connection-property p "scripts" nil)))
5053 (unless remote-perl (error "No remote perl")) 4838 (unless (memq name scripts)
5054 (let ((perl-scripts (tramp-get-connection-property "perl-scripts" nil 4839 (tramp-message vec 5 "Sending script `%s'..." name)
5055 multi-method method user host))) 4840 ;; The script could contain a call of Perl. This is masked with `%s'.
5056 (unless (memq name perl-scripts) 4841 (tramp-send-command-and-check
5057 (with-current-buffer (tramp-get-buffer multi-method method user host) 4842 vec
5058 (tramp-message 5 (concat "Sending the Perl script `" name "'...")) 4843 (format "%s () {\n%s\n}" name
5059 (tramp-send-string multi-method method user host 4844 (format script (tramp-get-remote-perl vec))))
5060 (concat name 4845 (tramp-set-connection-property p "scripts" (cons name scripts))
5061 " () {\n" 4846 (tramp-message vec 5 "Sending script `%s'...done." name))))
5062 remote-perl
5063 " -e '"
5064 script
5065 "' \"$1\" \"$2\" \"$3\" 2>/dev/null\n}"))
5066 (tramp-wait-for-output)
5067 (tramp-set-connection-property "perl-scripts" (cons name perl-scripts)
5068 multi-method method user host)
5069 (tramp-message 5 (concat "Sending the Perl script `" name "'...done.")))))))
5070 4847
5071(defun tramp-set-auto-save () 4848(defun tramp-set-auto-save ()
5072 (when (and (buffer-file-name) 4849 (when (and ;; ange-ftp has its own auto-save mechanism
5073 (tramp-tramp-file-p (buffer-file-name))
5074 ;; ange-ftp has its own auto-save mechanism
5075 (eq (tramp-find-foreign-file-name-handler (buffer-file-name)) 4850 (eq (tramp-find-foreign-file-name-handler (buffer-file-name))
5076 'tramp-sh-file-name-handler) 4851 'tramp-sh-file-name-handler)
5077 auto-save-default) 4852 auto-save-default)
@@ -5084,46 +4859,32 @@ Function may have 0-3 parameters."
5084(defun tramp-run-test (switch filename) 4859(defun tramp-run-test (switch filename)
5085 "Run `test' on the remote system, given a SWITCH and a FILENAME. 4860 "Run `test' on the remote system, given a SWITCH and a FILENAME.
5086Returns the exit code of the `test' program." 4861Returns the exit code of the `test' program."
5087 (let ((v (tramp-dissect-file-name filename))) 4862 (with-parsed-tramp-file-name filename nil
5088 (save-excursion 4863 (tramp-send-command-and-check
5089 (tramp-send-command-and-check 4864 v
5090 (tramp-file-name-multi-method v) (tramp-file-name-method v) 4865 (format
5091 (tramp-file-name-user v) (tramp-file-name-host v) 4866 "%s %s %s"
5092 (format "test %s %s" switch 4867 (tramp-get-test-command v)
5093 (tramp-shell-quote-argument (tramp-file-name-localname v))))))) 4868 switch
5094 4869 (tramp-shell-quote-argument localname)))))
5095(defun tramp-run-test2 (program file1 file2 &optional switch) 4870
5096 "Run `test'-like PROGRAM on the remote system, given FILE1, FILE2. 4871(defun tramp-run-test2 (format-string file1 file2)
5097The optional SWITCH is inserted between the two files. 4872 "Run `test'-like program on the remote system, given FILE1, FILE2.
5098Returns the exit code of the `test' PROGRAM. Barfs if the methods, 4873FORMAT-STRING contains the program name, switches, and place holders.
4874Returns the exit code of the `test' program. Barfs if the methods,
5099hosts, or files, disagree." 4875hosts, or files, disagree."
5100 (let* ((v1 (tramp-dissect-file-name file1)) 4876 (unless (tramp-equal-remote file1 file2)
5101 (v2 (tramp-dissect-file-name file2)) 4877 (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil
5102 (mmethod1 (tramp-file-name-multi-method v1)) 4878 (tramp-error
5103 (mmethod2 (tramp-file-name-multi-method v2)) 4879 v 'file-error
5104 (method1 (tramp-file-name-method v1)) 4880 "tramp-run-test2 only implemented for same method, user, host")))
5105 (method2 (tramp-file-name-method v2)) 4881 (with-parsed-tramp-file-name file1 v1
5106 (user1 (tramp-file-name-user v1)) 4882 (with-parsed-tramp-file-name file1 v2
5107 (user2 (tramp-file-name-user v2))
5108 (host1 (tramp-file-name-host v1))
5109 (host2 (tramp-file-name-host v2))
5110 (localname1 (tramp-file-name-localname v1))
5111 (localname2 (tramp-file-name-localname v2)))
5112 (unless (and method1 method2 host1 host2
5113 (equal mmethod1 mmethod2)
5114 (equal method1 method2)
5115 (equal user1 user2)
5116 (equal host1 host2))
5117 (error "tramp-run-test2: %s"
5118 "only implemented for same method, same user, same host"))
5119 (save-excursion
5120 (tramp-send-command-and-check 4883 (tramp-send-command-and-check
5121 mmethod1 method1 user1 host1 4884 v1
5122 (format "%s %s %s %s" 4885 (format format-string
5123 program 4886 (tramp-shell-quote-argument v1-localname)
5124 (tramp-shell-quote-argument localname1) 4887 (tramp-shell-quote-argument v2-localname))))))
5125 (or switch "")
5126 (tramp-shell-quote-argument localname2))))))
5127 4888
5128(defun tramp-touch (file time) 4889(defun tramp-touch (file time)
5129 "Set the last-modified timestamp of the given file. 4890 "Set the last-modified timestamp of the given file.
@@ -5132,291 +4893,313 @@ TIME is an Emacs internal time value as returned by `current-time'."
5132 ;; With GNU Emacs, `format-time-string' has an optional 4893 ;; With GNU Emacs, `format-time-string' has an optional
5133 ;; parameter UNIVERSAL. This is preferred. 4894 ;; parameter UNIVERSAL. This is preferred.
5134 (and (functionp 'subr-arity) 4895 (and (functionp 'subr-arity)
4896 (subrp (symbol-function 'format-time-string))
5135 (= 3 (cdr (funcall (symbol-function 'subr-arity) 4897 (= 3 (cdr (funcall (symbol-function 'subr-arity)
5136 (symbol-function 'format-time-string)))))) 4898 (symbol-function 'format-time-string))))))
5137 (touch-time 4899 (touch-time
5138 (if utc 4900 (if utc
5139 (format-time-string "%Y%m%d%H%M.%S" time t) 4901 (format-time-string "%Y%m%d%H%M.%S" time t)
5140 (format-time-string "%Y%m%d%H%M.%S" time)))) 4902 (format-time-string "%Y%m%d%H%M.%S" time)))
5141 (if (tramp-tramp-file-p file) 4903 (default-directory (file-name-directory file)))
4904
4905 (if (eq (tramp-find-foreign-file-name-handler file)
4906 'tramp-sh-file-name-handler)
5142 (with-parsed-tramp-file-name file nil 4907 (with-parsed-tramp-file-name file nil
5143 (let ((buf (tramp-get-buffer multi-method method user host))) 4908 (tramp-send-command
5144 (unless (zerop (tramp-send-command-and-check 4909 v (format "%s touch -t %s %s"
5145 multi-method method user host 4910 (if utc "TZ=UTC; export TZ;" "")
5146 (format "%s touch -t %s %s" 4911 touch-time
5147 (if utc "TZ=UTC; export TZ;" "") 4912 (tramp-shell-quote-argument localname))))
5148 touch-time
5149 (tramp-shell-quote-argument localname))
5150 t))
5151 (pop-to-buffer buf)
5152 (error "tramp-touch: touch failed, see buffer `%s' for details"
5153 buf))))
5154 ;; It's a local file
5155 (with-temp-buffer 4913 (with-temp-buffer
5156 (unless (zerop (call-process 4914 (shell-command
5157 "touch" nil (current-buffer) nil "-t" touch-time file)) 4915 (format "%s touch -t %s %s"
5158 (pop-to-buffer (current-buffer)) 4916 (if utc "TZ=UTC; export TZ;" "")
5159 (error "tramp-touch: touch failed")))))) 4917 touch-time
5160 4918 (tramp-shell-quote-argument
5161(defun tramp-buffer-name (multi-method method user host) 4919 (if (tramp-tramp-file-p file)
5162 "A name for the connection buffer for USER at HOST using METHOD." 4920 (with-parsed-tramp-file-name file nil localname) file)))
5163 (if multi-method 4921 (current-buffer))))))
5164 (tramp-buffer-name-multi-method "tramp" multi-method method user host) 4922
5165 (let ((method (tramp-find-method multi-method method user host))) 4923(defun tramp-buffer-name (vec)
5166 (if user 4924 "A name for the connection buffer VEC."
5167 (format "*tramp/%s %s@%s*" method user host) 4925 ;; We must use `tramp-file-name-real-host', because for gateway
5168 (format "*tramp/%s %s*" method host))))) 4926 ;; methods the default port will be expanded later on, which would
5169 4927 ;; tamper the name.
5170(defun tramp-buffer-name-multi-method (prefix multi-method method user host) 4928 (let ((method (tramp-file-name-method vec))
5171 "A name for the multi method connection buffer. 4929 (user (tramp-file-name-user vec))
5172MULTI-METHOD gives the multi method, METHOD the array of methods, 4930 (host (tramp-file-name-real-host vec)))
5173USER the array of user names, HOST the array of host names." 4931 (if (not (zerop (length user)))
5174 (unless (and (= (length method) (length user)) 4932 (format "*tramp/%s %s@%s*" method user host)
5175 (= (length method) (length host))) 4933 (format "*tramp/%s %s*" method host))))
5176 (error "Syntax error in multi method (implementation error)")) 4934
5177 (let ((len (length method)) 4935(defun tramp-get-buffer (vec)
5178 (i 0) 4936 "Get the connection buffer to be used for VEC."
5179 string-list) 4937 (or (get-buffer (tramp-buffer-name vec))
5180 (while (< i len) 4938 (with-current-buffer (get-buffer-create (tramp-buffer-name vec))
5181 (setq string-list 4939 (setq buffer-undo-list t)
5182 (cons (if (aref user i) 4940 (setq default-directory
5183 (format "%s#%s@%s:" (aref method i) 4941 (tramp-make-tramp-file-name
5184 (aref user i) (aref host i)) 4942 (tramp-file-name-method vec)
5185 (format "%s@%s:" (aref method i) (aref host i))) 4943 (tramp-file-name-user vec)
5186 string-list)) 4944 (tramp-file-name-host vec)
5187 (setq i (1+ i))) 4945 "/"))
5188 (format "*%s/%s %s*" 4946 (current-buffer))))
5189 prefix multi-method 4947
5190 (apply 'concat (reverse string-list))))) 4948(defun tramp-get-connection-buffer (vec)
5191 4949 "Get the connection buffer to be used for VEC.
5192(defun tramp-get-buffer (multi-method method user host) 4950In case a second asynchronous communication has been started, it is different
5193 "Get the connection buffer to be used for USER at HOST using METHOD." 4951from `tramp-get-buffer'."
4952 (or (tramp-get-connection-property vec "process-buffer" nil)
4953 (tramp-get-buffer vec)))
4954
4955(defun tramp-get-connection-process (vec)
4956 "Get the connection process to be used for VEC.
4957In case a second asynchronous communication has been started, it is different
4958from the default one."
4959 (get-process
4960 (or (tramp-get-connection-property vec "process-name" nil)
4961 (tramp-buffer-name vec))))
4962
4963(defun tramp-debug-buffer-name (vec)
4964 "A name for the debug buffer for VEC."
4965 ;; We must use `tramp-file-name-real-host', because for gateway
4966 ;; methods the default port will be expanded later on, which would
4967 ;; tamper the name.
4968 (let ((method (tramp-file-name-method vec))
4969 (user (tramp-file-name-user vec))
4970 (host (tramp-file-name-real-host vec)))
4971 (if (not (zerop (length user)))
4972 (format "*debug tramp/%s %s@%s*" method user host)
4973 (format "*debug tramp/%s %s*" method host))))
4974
4975(defun tramp-get-debug-buffer (vec)
4976 "Get the debug buffer for VEC."
5194 (with-current-buffer 4977 (with-current-buffer
5195 (get-buffer-create (tramp-buffer-name multi-method method user host)) 4978 (get-buffer-create (tramp-debug-buffer-name vec))
5196 (setq buffer-undo-list t) 4979 (when (bobp)
4980 (setq buffer-undo-list t)
4981 ;; Activate outline-mode
4982 (make-local-variable 'outline-regexp)
4983 (make-local-variable 'outline-level)
4984 ;; This runs `text-mode-hook' and `outline-mode-hook'. We must
4985 ;; prevent that local processes die. Yes: I've seen
4986 ;; `flyspell-mode', which starts "ispell" ...
4987 (let ((default-directory (tramp-temporary-file-directory)))
4988 (outline-mode))
4989 (setq outline-regexp "[0-9]+:[0-9]+:[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #")
4990; (setq outline-regexp "[a-z.-]+:[0-9]+: [a-z0-9-]+ (\\([0-9]+\\)) #")
4991 (setq outline-level 'tramp-outline-level))
5197 (current-buffer))) 4992 (current-buffer)))
5198 4993
5199(defun tramp-debug-buffer-name (multi-method method user host) 4994(defun tramp-outline-level ()
5200 "A name for the debug buffer for USER at HOST using METHOD." 4995 "Return the depth to which a statement is nested in the outline.
5201 (if multi-method 4996Point must be at the beginning of a header line.
5202 (tramp-buffer-name-multi-method "debug tramp" 4997
5203 multi-method method user host) 4998The outline level is equal to the verbosity of the Tramp message."
5204 (let ((method (tramp-find-method multi-method method user host))) 4999 (1+ (string-to-number (match-string 1))))
5205 (if user
5206 (format "*debug tramp/%s %s@%s*" method user host)
5207 (format "*debug tramp/%s %s*" method host)))))
5208
5209(defun tramp-get-debug-buffer (multi-method method user host)
5210 "Get the debug buffer for USER at HOST using METHOD."
5211 (with-current-buffer
5212 (get-buffer-create
5213 (tramp-debug-buffer-name multi-method method user host))
5214 (setq buffer-undo-list t)
5215 (current-buffer)))
5216 5000
5217(defun tramp-find-executable (multi-method method user host 5001(defun tramp-find-executable
5218 progname dirlist ignore-tilde) 5002 (vec progname dirlist &optional ignore-tilde ignore-path)
5219 "Searches for PROGNAME in all directories mentioned in DIRLIST. 5003 "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST.
5220First args METHOD, USER and HOST specify the connection, PROGNAME 5004First arg VEC specifies the connection, PROGNAME is the program
5221is the program to search for, and DIRLIST gives the list of directories 5005to search for, and DIRLIST gives the list of directories to
5222to search. If IGNORE-TILDE is non-nil, directory names starting 5006search. If IGNORE-TILDE is non-nil, directory names starting
5223with `~' will be ignored. 5007with `~' will be ignored. If IGNORE-PATH is non-nil, searches
5008only in DIRLIST.
5224 5009
5225Returns the absolute file name of PROGNAME, if found, and nil otherwise. 5010Returns the absolute file name of PROGNAME, if found, and nil otherwise.
5226 5011
5227This function expects to be in the right *tramp* buffer." 5012This function expects to be in the right *tramp* buffer."
5228 (let (result) 5013 (with-current-buffer (tramp-get-buffer vec)
5229 (when ignore-tilde 5014 (let (result)
5230 ;; Remove all ~/foo directories from dirlist. In Emacs 20, 5015 ;; Check whether the executable is in $PATH. "which(1)" does not
5231 ;; `remove' is in CL, and we want to avoid CL dependencies. 5016 ;; report always a correct error code; therefore we check the
5232 (let (newdl d) 5017 ;; number of words it returns.
5233 (while dirlist 5018 (unless ignore-path
5234 (setq d (car dirlist)) 5019 (tramp-send-command vec (format "which \\%s | wc -w" progname))
5235 (setq dirlist (cdr dirlist)) 5020 (goto-char (point-min))
5236 (unless (char-equal ?~ (aref d 0)) 5021 (if (looking-at "^1$")
5237 (setq newdl (cons d newdl)))) 5022 (setq result (concat "\\" progname))))
5238 (setq dirlist (nreverse newdl)))) 5023 (unless result
5239 (tramp-send-command 5024 (when ignore-tilde
5240 multi-method method user host 5025 ;; Remove all ~/foo directories from dirlist. In Emacs 20,
5241 (format (concat "while read d; " 5026 ;; `remove' is in CL, and we want to avoid CL dependencies.
5242 "do if test -x $d/%s -a -f $d/%s; " 5027 (let (newdl d)
5243 "then echo tramp_executable $d/%s; " 5028 (while dirlist
5244 "break; fi; done <<'EOF'") 5029 (setq d (car dirlist))
5245 progname progname progname)) 5030 (setq dirlist (cdr dirlist))
5246 (mapcar (lambda (d) 5031 (unless (char-equal ?~ (aref d 0))
5247 (tramp-send-command multi-method method user host d)) 5032 (setq newdl (cons d newdl))))
5248 dirlist) 5033 (setq dirlist (nreverse newdl))))
5249 (tramp-send-command multi-method method user host "EOF") 5034 (tramp-send-command
5250 (tramp-wait-for-output) 5035 vec
5251 (goto-char (point-max)) 5036 (format (concat "while read d; "
5252 (when (search-backward "tramp_executable " nil t) 5037 "do if test -x $d/%s -a -f $d/%s; "
5253 (skip-chars-forward "^ ") 5038 "then echo tramp_executable $d/%s; "
5254 (skip-chars-forward " ") 5039 "break; fi; done <<'EOF'\n"
5255 (buffer-substring (point) (tramp-line-end-position))))) 5040 "%s\nEOF")
5256 5041 progname progname progname (mapconcat 'identity dirlist "\n")))
5257(defun tramp-set-remote-path (multi-method method user host var dirlist) 5042 (goto-char (point-max))
5258 "Sets the remote environment VAR to existing directories from DIRLIST. 5043 (when (search-backward "tramp_executable " nil t)
5259I.e., for each directory in DIRLIST, it is tested whether it exists and if 5044 (skip-chars-forward "^ ")
5260so, it is added to the environment variable VAR." 5045 (skip-chars-forward " ")
5261 (let ((existing-dirs 5046 (setq result (buffer-substring (point) (tramp-line-end-position)))))
5262 (mapcar 5047 result)))
5263 (lambda (x) 5048
5264 (when (and 5049(defun tramp-set-remote-path (vec)
5265 (file-exists-p 5050 "Sets the remote environment PATH to existing directories.
5266 (tramp-make-tramp-file-name multi-method method user host x)) 5051I.e., for each directory in `tramp-remote-path', it is tested
5267 (file-directory-p 5052whether it exists and if so, it is added to the environment
5268 (tramp-make-tramp-file-name multi-method method user host x))) 5053variable PATH."
5269 x)) 5054 (tramp-message vec 5 (format "Setting $PATH environment variable"))
5270 dirlist))) 5055
5056 (with-current-buffer (tramp-get-connection-buffer vec)
5057 (set (make-local-variable 'tramp-remote-path)
5058 (copy-tree tramp-remote-path))
5059 (let* ((elt (memq 'tramp-default-remote-path tramp-remote-path))
5060 (tramp-default-remote-path
5061 (with-connection-property vec "default-remote-path"
5062 (when elt
5063 (condition-case nil
5064 (symbol-name
5065 (tramp-send-command-and-read vec "getconf PATH"))
5066 ;; Default if "getconf" is not available.
5067 (error
5068 (tramp-message
5069 vec 3
5070 "`getconf PATH' not successful, using default value \"%s\"."
5071 "/bin:/usr/bin")
5072 "/bin:/usr/bin"))))))
5073 (when elt
5074 ;; Replace place holder `tramp-default-remote-path'.
5075 (setcdr elt
5076 (append
5077 (tramp-split-string tramp-default-remote-path ":")
5078 (cdr elt)))
5079 (setq tramp-remote-path
5080 (delq 'tramp-default-remote-path tramp-remote-path))))
5081
5082 ;; Check for existence of directories.
5083 (setq tramp-remote-path
5084 (delq
5085 nil
5086 (mapcar
5087 (lambda (x)
5088 (and
5089 (with-connection-property vec x
5090 (file-directory-p
5091 (tramp-make-tramp-file-name
5092 (tramp-file-name-method vec)
5093 (tramp-file-name-user vec)
5094 (tramp-file-name-host vec)
5095 x)))
5096 x))
5097 tramp-remote-path)))
5271 (tramp-send-command 5098 (tramp-send-command
5272 multi-method method user host 5099 vec
5273 (concat var "=" 5100 (format "PATH=%s; export PATH"
5274 (mapconcat 'identity (delq nil existing-dirs) ":") 5101 (mapconcat 'identity tramp-remote-path ":")))))
5275 "; export " var))
5276 (tramp-wait-for-output)))
5277 5102
5278;; -- communication with external shell -- 5103;; -- communication with external shell --
5279 5104
5280(defun tramp-find-file-exists-command (multi-method method user host) 5105(defun tramp-find-file-exists-command (vec)
5281 "Find a command on the remote host for checking if a file exists. 5106 "Find a command on the remote host for checking if a file exists.
5282Here, we are looking for a command which has zero exit status if the 5107Here, we are looking for a command which has zero exit status if the
5283file exists and nonzero exit status otherwise." 5108file exists and nonzero exit status otherwise."
5284 (make-local-variable 'tramp-file-exists-command) 5109 (let ((existing "/")
5285 (tramp-message 9 "Finding command to check if file exists")
5286 (let ((existing
5287 (tramp-make-tramp-file-name
5288 multi-method method user host
5289 "/")) ;assume this file always exists
5290 (nonexisting 5110 (nonexisting
5291 (tramp-make-tramp-file-name 5111 (tramp-shell-quote-argument "/ this file does not exist "))
5292 multi-method method user host 5112 result)
5293 "/ this file does not exist "))) ;assume this never exists
5294 ;; The algorithm is as follows: we try a list of several commands. 5113 ;; The algorithm is as follows: we try a list of several commands.
5295 ;; For each command, we first run `$cmd /' -- this should return 5114 ;; For each command, we first run `$cmd /' -- this should return
5296 ;; true, as the root directory always exists. And then we run 5115 ;; true, as the root directory always exists. And then we run
5297 ;; `$cmd /this\ file\ does\ not\ exist', hoping that the file indeed 5116 ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed
5298 ;; does not exist. This should return false. We use the first 5117 ;; does not exist. This should return false. We use the first
5299 ;; command we find that seems to work. 5118 ;; command we find that seems to work.
5300 ;; The list of commands to try is as follows: 5119 ;; The list of commands to try is as follows:
5301 ;; `ls -d' This works on most systems, but NetBSD 1.4 5120 ;; `ls -d' This works on most systems, but NetBSD 1.4
5302 ;; has a bug: `ls' always returns zero exit 5121 ;; has a bug: `ls' always returns zero exit
5303 ;; status, even for files which don't exist. 5122 ;; status, even for files which don't exist.
5304 ;; `test -e' Some Bourne shells have a `test' builtin 5123 ;; `test -e' Some Bourne shells have a `test' builtin
5305 ;; which does not know the `-e' option. 5124 ;; which does not know the `-e' option.
5306 ;; `/bin/test -e' For those, the `test' binary on disk normally 5125 ;; `/bin/test -e' For those, the `test' binary on disk normally
5307 ;; provides the option. Alas, the binary 5126 ;; provides the option. Alas, the binary
5308 ;; is sometimes `/bin/test' and sometimes it's 5127 ;; is sometimes `/bin/test' and sometimes it's
5309 ;; `/usr/bin/test'. 5128 ;; `/usr/bin/test'.
5310 ;; `/usr/bin/test -e' In case `/bin/test' does not exist. 5129 ;; `/usr/bin/test -e' In case `/bin/test' does not exist.
5311 (unless (or 5130 (unless (or
5312 (and (setq tramp-file-exists-command "test -e %s") 5131 (and (setq result (format "%s -e" (tramp-get-test-command vec)))
5313 (file-exists-p existing) 5132 (zerop (tramp-send-command-and-check
5314 (not (file-exists-p nonexisting))) 5133 vec (format "%s %s" result existing)))
5315 (and (setq tramp-file-exists-command "/bin/test -e %s") 5134 (not (zerop (tramp-send-command-and-check
5316 (file-exists-p existing) 5135 vec (format "%s %s" result nonexisting)))))
5317 (not (file-exists-p nonexisting))) 5136 (and (setq result "/bin/test -e")
5318 (and (setq tramp-file-exists-command "/usr/bin/test -e %s") 5137 (zerop (tramp-send-command-and-check
5319 (file-exists-p existing) 5138 vec (format "%s %s" result existing)))
5320 (not (file-exists-p nonexisting))) 5139 (not (zerop (tramp-send-command-and-check
5321 (and (setq tramp-file-exists-command "ls -d %s") 5140 vec (format "%s %s" result nonexisting)))))
5322 (file-exists-p existing) 5141 (and (setq result "/usr/bin/test -e")
5323 (not (file-exists-p nonexisting)))) 5142 (zerop (tramp-send-command-and-check
5324 (error "Couldn't find command to check if file exists")))) 5143 vec (format "%s %s" result existing)))
5144 (not (zerop (tramp-send-command-and-check
5145 vec (format "%s %s" result nonexisting)))))
5146 (and (setq result (format "%s -d" (tramp-get-ls-command vec)))
5147 (zerop (tramp-send-command-and-check
5148 vec (format "%s %s" result existing)))
5149 (not (zerop (tramp-send-command-and-check
5150 vec (format "%s %s" result nonexisting))))))
5151 (tramp-error
5152 vec 'file-error "Couldn't find command to check if file exists"))
5153 result))
5325 5154
5326 5155
5327;; CCC test ksh or bash found for tilde expansion? 5156;; CCC test ksh or bash found for tilde expansion?
5328(defun tramp-find-shell (multi-method method user host) 5157(defun tramp-find-shell (vec)
5329 "Find a shell on the remote host which groks tilde expansion." 5158 "Opens a shell on the remote host which groks tilde expansion."
5330 (let ((shell nil)) 5159 (unless (tramp-get-connection-property vec "remote-shell" nil)
5331 (tramp-send-command multi-method method user host "echo ~root") 5160 (let (shell)
5332 (tramp-wait-for-output) 5161 (with-current-buffer (tramp-get-buffer vec)
5333 (cond 5162 (tramp-send-command vec "echo ~root")
5334 ((string-match "^~root$" (buffer-string)) 5163 (cond
5335 (setq shell 5164 ((string-match "^~root$" (buffer-string))
5336 (or (tramp-find-executable multi-method method user host 5165 (setq shell
5337 "bash" tramp-remote-path t) 5166 (or (tramp-find-executable vec "bash" tramp-remote-path t)
5338 (tramp-find-executable multi-method method user host 5167 (tramp-find-executable vec "ksh" tramp-remote-path t)))
5339 "ksh" tramp-remote-path t))) 5168 (unless shell
5340 (unless shell 5169 (tramp-error
5341 (error "Couldn't find a shell which groks tilde expansion")) 5170 vec 'file-error
5342 ;; Find arguments for this shell. 5171 "Couldn't find a shell which groks tilde expansion"))
5343 (let ((alist tramp-sh-extra-args) 5172 ;; Find arguments for this shell.
5344 item extra-args) 5173 (let ((alist tramp-sh-extra-args)
5345 (while (and alist (null extra-args)) 5174 item extra-args)
5346 (setq item (pop alist)) 5175 (while (and alist (null extra-args))
5347 (when (string-match (car item) shell) 5176 (setq item (pop alist))
5348 (setq extra-args (cdr item)))) 5177 (when (string-match (car item) shell)
5349 (when extra-args (setq shell (concat shell " " extra-args)))) 5178 (setq extra-args (cdr item))))
5350 (tramp-message 5179 (when extra-args (setq shell (concat shell " " extra-args))))
5351 5 "Starting remote shell `%s' for tilde expansion..." shell) 5180 (tramp-message
5352 (tramp-send-command 5181 vec 5 "Starting remote shell `%s' for tilde expansion..." shell)
5353 multi-method method user host 5182 (tramp-send-command-internal vec (concat "PS1='$ ' exec " shell))
5354 (concat "PS1='$ ' exec " shell)) ; 5183 (tramp-message vec 5 "Setting remote shell prompt...")
5355 (tramp-barf-if-no-shell-prompt 5184 ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we
5356 (get-buffer-process (current-buffer)) 5185 ;; must use "\n" here, not tramp-rsh-end-of-line. Kai left the
5357 60 "Couldn't find remote `%s' prompt" shell) 5186 ;; last tramp-rsh-end-of-line, Douglas wanted to replace that,
5358 (tramp-message 5187 ;; as well.
5359 9 "Setting remote shell prompt...") 5188 (tramp-send-command
5360 ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we 5189 vec
5361 ;; must use "\n" here, not tramp-rsh-end-of-line. Kai left the 5190 (format "PS1='%s%s%s'; PS2=''; PS3=''"
5362 ;; last tramp-rsh-end-of-line, Douglas wanted to replace that, 5191 tramp-rsh-end-of-line
5363 ;; as well. 5192 tramp-end-of-output
5364 (process-send-string nil (format "PS1='%s%s%s'; PS2=''; PS3=''%s" 5193 tramp-rsh-end-of-line))
5365 tramp-rsh-end-of-line 5194 (tramp-message vec 5 "Setting remote shell prompt...done"))
5366 tramp-end-of-output 5195 (t (tramp-message
5367 tramp-rsh-end-of-line 5196 vec 5 "Remote `%s' groks tilde expansion, good"
5368 tramp-rsh-end-of-line)) 5197 (tramp-get-method-parameter
5369 (tramp-wait-for-output) 5198 (tramp-file-name-method vec) 'tramp-remote-sh))
5370 (tramp-message 5199 (tramp-set-connection-property
5371 9 "Setting remote shell prompt...done") 5200 vec "remote-shell"
5372 ) 5201 (tramp-get-method-parameter
5373 (t (tramp-message 5 "Remote `%s' groks tilde expansion, good" 5202 (tramp-file-name-method vec) 'tramp-remote-sh))))))))
5374 (tramp-get-method-parameter
5375 multi-method method user host 'tramp-remote-sh))))))
5376
5377(defun tramp-check-ls-command (multi-method method user host cmd)
5378 "Checks whether the given `ls' executable groks `-n'.
5379METHOD, USER and HOST specify the connection, CMD (the absolute file name of)
5380the `ls' executable. Returns t if CMD supports the `-n' option, nil
5381otherwise."
5382 (tramp-message 9 "Checking remote `%s' command for `-n' option" cmd)
5383 (when (file-executable-p
5384 (tramp-make-tramp-file-name multi-method method user host cmd))
5385 (let ((result nil))
5386 (tramp-message 7 "Testing remote command `%s' for -n..." cmd)
5387 (setq result
5388 (tramp-send-command-and-check
5389 multi-method method user host
5390 (format "%s -lnd / >/dev/null"
5391 cmd)))
5392 (tramp-message 7 "Testing remote command `%s' for -n...%s"
5393 cmd
5394 (if (zerop result) "okay" "failed"))
5395 (zerop result))))
5396
5397(defun tramp-check-ls-commands (multi-method method user host cmd dirlist)
5398 "Checks whether the given `ls' executable in one of the dirs groks `-n'.
5399Returns nil if none was found, else the command is returned."
5400 (let ((dl dirlist)
5401 (result nil))
5402 (tramp-let-maybe directory-sep-char ?/ ;for XEmacs
5403 ;; It would be better to use the CL function `find', but
5404 ;; we don't want run-time dependencies on CL.
5405 (while (and dl (not result))
5406 (let ((x (concat (file-name-as-directory (car dl)) cmd)))
5407 (when (tramp-check-ls-command multi-method method user host x)
5408 (setq result x)))
5409 (setq dl (cdr dl)))
5410 result)))
5411
5412(defun tramp-find-ls-command (multi-method method user host)
5413 "Finds an `ls' command which groks the `-n' option, returning nil if failed.
5414\(This option prints numeric user and group ids in a long listing.)"
5415 (tramp-message 9 "Finding a suitable `ls' command")
5416 (or
5417 (tramp-check-ls-commands multi-method method user host "ls" tramp-remote-path)
5418 (tramp-check-ls-commands multi-method method user host "gnuls" tramp-remote-path)
5419 (tramp-check-ls-commands multi-method method user host "gls" tramp-remote-path)))
5420 5203
5421;; ------------------------------------------------------------ 5204;; ------------------------------------------------------------
5422;; -- Functions for establishing connection -- 5205;; -- Functions for establishing connection --
@@ -5426,635 +5209,208 @@ Returns nil if none was found, else the command is returned."
5426;; prompts from the remote host. See the variable 5209;; prompts from the remote host. See the variable
5427;; `tramp-actions-before-shell' for usage of these functions. 5210;; `tramp-actions-before-shell' for usage of these functions.
5428 5211
5429(defun tramp-action-login (p multi-method method user host) 5212(defun tramp-action-login (proc vec)
5430 "Send the login name." 5213 "Send the login name."
5431 (tramp-message 9 "Sending login name `%s'" 5214 (when (not (stringp tramp-current-user))
5432 (or user (user-login-name))) 5215 (save-window-excursion
5433 (erase-buffer) 5216 (let ((enable-recursive-minibuffers t))
5434 (process-send-string nil (concat (or user (user-login-name)) 5217 (pop-to-buffer (tramp-get-connection-buffer vec))
5435 tramp-rsh-end-of-line))) 5218 (setq tramp-current-user (read-string (match-string 0))))))
5436 5219 (tramp-message vec 3 "Sending login name `%s'" tramp-current-user)
5437(defun tramp-action-password (p multi-method method user host) 5220 (with-current-buffer (tramp-get-connection-buffer vec)
5221 (tramp-message vec 6 "\n%s" (buffer-string)))
5222 (tramp-send-string vec tramp-current-user))
5223
5224(defun tramp-action-password (proc vec)
5438 "Query the user for a password." 5225 "Query the user for a password."
5439 (let ((pw-prompt 5226 (tramp-message vec 3 "Sending password")
5440 (format "Password for %s " 5227 (tramp-enter-password proc))
5441 (tramp-make-tramp-file-name 5228
5442 nil method user host "")))) 5229(defun tramp-action-succeed (proc vec)
5443 (tramp-message 9 "Sending password")
5444 (tramp-enter-password p pw-prompt user host)))
5445
5446(defun tramp-action-succeed (p multi-method method user host)
5447 "Signal success in finding shell prompt." 5230 "Signal success in finding shell prompt."
5448 (tramp-message 9 "Found remote shell prompt.")
5449 (erase-buffer)
5450 (throw 'tramp-action 'ok)) 5231 (throw 'tramp-action 'ok))
5451 5232
5452(defun tramp-action-permission-denied (p multi-method method user host) 5233(defun tramp-action-permission-denied (proc vec)
5453 "Signal permission denied." 5234 "Signal permission denied."
5454 (pop-to-buffer (tramp-get-buffer multi-method method user host)) 5235 (kill-process proc)
5455 (tramp-message 9 "Permission denied by remote host.")
5456 (kill-process p)
5457 (throw 'tramp-action 'permission-denied)) 5236 (throw 'tramp-action 'permission-denied))
5458 5237
5459(defun tramp-action-copy-failed (p multi-method method user host) 5238(defun tramp-action-yesno (proc vec)
5460 "Signal copy failed."
5461 (kill-process p)
5462 (error "%s" (match-string 1)))
5463
5464(defun tramp-action-yesno (p multi-method method user host)
5465 "Ask the user for confirmation using `yes-or-no-p'. 5239 "Ask the user for confirmation using `yes-or-no-p'.
5466Send \"yes\" to remote process on confirmation, abort otherwise. 5240Send \"yes\" to remote process on confirmation, abort otherwise.
5467See also `tramp-action-yn'." 5241See also `tramp-action-yn'."
5468 (save-window-excursion 5242 (save-window-excursion
5469 (pop-to-buffer (tramp-get-buffer multi-method method user host)) 5243 (let ((enable-recursive-minibuffers t))
5470 (unless (yes-or-no-p (match-string 0)) 5244 (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec)))
5471 (kill-process p) 5245 (unless (yes-or-no-p (match-string 0))
5472 (erase-buffer) 5246 (kill-process proc)
5473 (throw 'tramp-action 'permission-denied)) 5247 (throw 'tramp-action 'permission-denied))
5474 (process-send-string p (concat "yes" tramp-rsh-end-of-line)) 5248 (with-current-buffer (tramp-get-connection-buffer vec)
5475 (erase-buffer))) 5249 (tramp-message vec 6 "\n%s" (buffer-string)))
5476 5250 (tramp-send-string vec "yes"))))
5477(defun tramp-action-yn (p multi-method method user host) 5251
5252(defun tramp-action-yn (proc vec)
5478 "Ask the user for confirmation using `y-or-n-p'. 5253 "Ask the user for confirmation using `y-or-n-p'.
5479Send \"y\" to remote process on confirmation, abort otherwise. 5254Send \"y\" to remote process on confirmation, abort otherwise.
5480See also `tramp-action-yesno'." 5255See also `tramp-action-yesno'."
5481 (save-window-excursion 5256 (save-window-excursion
5482 (pop-to-buffer (tramp-get-buffer multi-method method user host)) 5257 (let ((enable-recursive-minibuffers t))
5483 (unless (y-or-n-p (match-string 0)) 5258 (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec)))
5484 (kill-process p) 5259 (unless (y-or-n-p (match-string 0))
5485 (throw 'tramp-action 'permission-denied)) 5260 (kill-process proc)
5486 (erase-buffer) 5261 (throw 'tramp-action 'permission-denied))
5487 (process-send-string p (concat "y" tramp-rsh-end-of-line)))) 5262 (with-current-buffer (tramp-get-connection-buffer vec)
5488 5263 (tramp-message vec 6 "\n%s" (buffer-string)))
5489(defun tramp-action-terminal (p multi-method method user host) 5264 (tramp-send-string vec "y"))))
5265
5266(defun tramp-action-terminal (proc vec)
5490 "Tell the remote host which terminal type to use. 5267 "Tell the remote host which terminal type to use.
5491The terminal type can be configured with `tramp-terminal-type'." 5268The terminal type can be configured with `tramp-terminal-type'."
5492 (tramp-message 9 "Setting `%s' as terminal type." 5269 (tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type)
5493 tramp-terminal-type) 5270 (tramp-send-string vec tramp-terminal-type))
5494 (erase-buffer)
5495 (process-send-string nil (concat tramp-terminal-type
5496 tramp-rsh-end-of-line)))
5497 5271
5498(defun tramp-action-process-alive (p multi-method method user host) 5272(defun tramp-action-process-alive (proc vec)
5499 "Check whether a process has finished." 5273 "Check whether a process has finished."
5500 (unless (memq (process-status p) '(run open)) 5274 (unless (memq (process-status proc) '(run open))
5501 (throw 'tramp-action 'process-died))) 5275 (throw 'tramp-action 'process-died)))
5502 5276
5503(defun tramp-action-out-of-band (p multi-method method user host) 5277(defun tramp-action-out-of-band (proc vec)
5504 "Check whether an out-of-band copy has finished." 5278 "Check whether an out-of-band copy has finished."
5505 (cond ((and (memq (process-status p) '(stop exit)) 5279 (cond ((and (memq (process-status proc) '(stop exit))
5506 (zerop (process-exit-status p))) 5280 (zerop (process-exit-status proc)))
5507 (tramp-message 9 "Process has finished.") 5281 (tramp-message vec 3 "Process has finished.")
5508 (throw 'tramp-action 'ok)) 5282 (throw 'tramp-action 'ok))
5509 ((or (and (memq (process-status p) '(stop exit)) 5283 ((or (and (memq (process-status proc) '(stop exit))
5510 (not (zerop (process-exit-status p)))) 5284 (not (zerop (process-exit-status proc))))
5511 (memq (process-status p) '(signal))) 5285 (memq (process-status proc) '(signal)))
5512 ;; `scp' could have copied correctly, but set modes could have failed. 5286 ;; `scp' could have copied correctly, but set modes could have failed.
5513 ;; This can be ignored. 5287 ;; This can be ignored.
5514 (goto-char (point-min)) 5288 (with-current-buffer (process-buffer proc)
5515 (if (re-search-forward tramp-operation-not-permitted-regexp nil t) 5289 (goto-char (point-min))
5516 (progn 5290 (if (re-search-forward tramp-operation-not-permitted-regexp nil t)
5517 (tramp-message 10 "'set mode' error ignored.") 5291 (progn
5518 (tramp-message 9 "Process has finished.") 5292 (tramp-message vec 5 "'set mode' error ignored.")
5519 (throw 'tramp-action 'ok)) 5293 (tramp-message vec 3 "Process has finished.")
5520 (tramp-message 9 "Process has died.") 5294 (throw 'tramp-action 'ok))
5521 (throw 'tramp-action 'process-died))) 5295 (tramp-message vec 3 "Process has died.")
5296 (throw 'tramp-action 'process-died))))
5522 (t nil))) 5297 (t nil)))
5523 5298
5524;; The following functions are specifically for multi connections.
5525
5526(defun tramp-multi-action-login (p method user host)
5527 "Send the login name."
5528 (tramp-message 9 "Sending login name `%s'" user)
5529 (erase-buffer)
5530 (process-send-string p (concat user tramp-rsh-end-of-line)))
5531
5532(defun tramp-multi-action-password (p method user host)
5533 "Query the user for a password."
5534 (let ((pw-prompt
5535 (format "Password for %s "
5536 (tramp-make-tramp-file-name
5537 nil method user host ""))))
5538 (tramp-message 9 "Sending password")
5539 (tramp-enter-password p pw-prompt user host)))
5540
5541(defun tramp-multi-action-succeed (p method user host)
5542 "Signal success in finding shell prompt."
5543 (tramp-message 9 "Found shell prompt on `%s'" host)
5544 (erase-buffer)
5545 (throw 'tramp-action 'ok))
5546
5547(defun tramp-multi-action-permission-denied (p method user host)
5548 "Signal permission denied."
5549 (tramp-message 9 "Permission denied by remote host `%s'" host)
5550 (kill-process p)
5551 (erase-buffer)
5552 (throw 'tramp-action 'permission-denied))
5553
5554(defun tramp-multi-action-process-alive (p method user host)
5555 "Check whether a process has finished."
5556 (unless (memq (process-status p) '(run open))
5557 (throw 'tramp-action 'process-died)))
5558
5559;; Functions for processing the actions. 5299;; Functions for processing the actions.
5560 5300
5561(defun tramp-process-one-action (p multi-method method user host actions) 5301(defun tramp-process-one-action (proc vec actions)
5562 "Wait for output from the shell and perform one action." 5302 "Wait for output from the shell and perform one action."
5563 (let (found item pattern action todo) 5303 (let (found todo item pattern action)
5564 (erase-buffer)
5565 (tramp-message 9 "Waiting 60s for prompt from remote shell")
5566 (while (not found) 5304 (while (not found)
5567 (tramp-accept-process-output p 1) 5305 ;; Reread output once all actions have been performed.
5568 (goto-char (point-min)) 5306 ;; Obviously, the output was not complete.
5307 (tramp-accept-process-output proc 1)
5569 (setq todo actions) 5308 (setq todo actions)
5570 (while todo 5309 (while todo
5571 (goto-char (point-min))
5572 (setq item (pop todo)) 5310 (setq item (pop todo))
5573 (setq pattern (symbol-value (nth 0 item))) 5311 (setq pattern (concat (symbol-value (nth 0 item)) "\\'"))
5574 (setq action (nth 1 item)) 5312 (setq action (nth 1 item))
5575 (tramp-message 10 "Looking for regexp \"%s\" from remote shell" 5313 (tramp-message
5576 pattern) 5314 vec 5 "Looking for regexp \"%s\" from remote shell" pattern)
5577 (when (re-search-forward (concat pattern "\\'") nil t) 5315 (when (tramp-check-for-regexp proc pattern)
5578 (setq found (funcall action p multi-method method user host))))) 5316 (tramp-message vec 5 "Call `%s'" (symbol-name action))
5317 (setq found (funcall action proc vec)))))
5579 found)) 5318 found))
5580 5319
5581(defun tramp-process-actions 5320(defun tramp-process-actions (proc vec actions &optional timeout)
5582 (p multi-method method user host actions &optional timeout)
5583 "Perform actions until success or TIMEOUT." 5321 "Perform actions until success or TIMEOUT."
5584 (tramp-message 10 "%s" (mapconcat 'identity (process-command p) " "))
5585 (let (exit) 5322 (let (exit)
5586 (while (not exit) 5323 (while (not exit)
5587 (tramp-message 9 "Waiting for prompts from remote shell") 5324 (tramp-message proc 3 "Waiting for prompts from remote shell")
5588 (setq exit 5325 (setq exit
5589 (catch 'tramp-action 5326 (catch 'tramp-action
5590 (if timeout 5327 (if timeout
5591 (with-timeout (timeout) 5328 (with-timeout (timeout)
5592 (tramp-process-one-action 5329 (tramp-process-one-action proc vec actions))
5593 p multi-method method user host actions)) 5330 (tramp-process-one-action proc vec actions)))))
5594 (tramp-process-one-action 5331 (with-current-buffer (tramp-get-connection-buffer vec)
5595 p multi-method method user host actions)) 5332 (tramp-message vec 6 "\n%s" (buffer-string)))
5596 nil)))
5597 (unless (eq exit 'ok)
5598 (tramp-clear-passwd user host)
5599 (error "Login failed"))))
5600
5601;; For multi-actions.
5602
5603(defun tramp-process-one-multi-action (p method user host actions)
5604 "Wait for output from the shell and perform one action."
5605 (let (found item pattern action todo)
5606 (erase-buffer)
5607 (tramp-message 9 "Waiting 60s for prompt from remote shell")
5608 (with-timeout (60 (throw 'tramp-action 'timeout))
5609 (while (not found)
5610 (tramp-accept-process-output p 1)
5611 (setq todo actions)
5612 (goto-char (point-min))
5613 (while todo
5614 (goto-char (point-min))
5615 (setq item (pop todo))
5616 (setq pattern (symbol-value (nth 0 item)))
5617 (setq action (nth 1 item))
5618 (tramp-message 10 "Looking for regexp \"%s\" from remote shell"
5619 pattern)
5620 (when (re-search-forward (concat pattern "\\'") nil t)
5621 (setq found (funcall action p method user host)))))
5622 found)))
5623
5624(defun tramp-process-multi-actions (p method user host actions)
5625 "Perform actions until success."
5626 (let (exit)
5627 (while (not exit)
5628 (tramp-message 9 "Waiting for prompts from remote shell")
5629 (setq exit
5630 (catch 'tramp-action
5631 (tramp-process-one-multi-action p method user host actions)
5632 nil)))
5633 (unless (eq exit 'ok) 5333 (unless (eq exit 'ok)
5634 (tramp-clear-passwd user host) 5334 (tramp-clear-passwd)
5635 (error "Login failed")))) 5335 (tramp-error-with-buffer
5636 5336 nil vec 'file-error
5637;; Functions to execute when we have seen the remote shell prompt but 5337 (cond
5638;; before we exec the Bourne-ish shell. Note that these commands 5338 ((eq exit 'permission-denied) "Permission denied")
5639;; might be sent to any shell, not just a Bourne-ish shell. This 5339 ((eq exit 'process-died) "Process died")
5640;; means that the commands need to work in all shells. (It is also 5340 (t "Login failed"))))))
5641;; okay for some commands to just fail with an error message, but
5642;; please make sure that they at least don't crash the odd shell people
5643;; might be running...)
5644(defun tramp-process-initial-commands (p
5645 multi-method method user host
5646 commands)
5647 "Send list of commands to remote host, in order."
5648 (let (cmd)
5649 (while commands
5650 (setq cmd (pop commands))
5651 (erase-buffer)
5652 (tramp-message 10 "Sending command to remote shell: %s"
5653 cmd)
5654 (tramp-send-command multi-method method user host cmd nil t)
5655 (tramp-barf-if-no-shell-prompt
5656 p 60 "Remote shell command failed: %s" cmd))
5657 (erase-buffer)))
5658
5659;; The actual functions for opening connections.
5660
5661(defun tramp-open-connection-telnet (multi-method method user host)
5662 "Open a connection using a telnet METHOD.
5663This starts the command `telnet HOST ARGS'[*], then waits for a remote
5664login prompt, then sends the user name USER, then waits for a remote
5665password prompt. It queries the user for the password, then sends the
5666password to the remote host.
5667
5668If USER is nil, uses value returned by `(user-login-name)' instead.
5669
5670Recognition of the remote shell prompt is based on the variables
5671`shell-prompt-pattern' and `tramp-shell-prompt-pattern' which must be
5672set up correctly.
5673
5674Please note that it is NOT possible to use this connection method
5675together with an out-of-band transfer method! You must use an inline
5676transfer method.
5677
5678Maybe the different regular expressions need to be tuned.
5679
5680* Actually, the telnet program as well as the args to be used can be
5681 specified in the method parameters, see the variable `tramp-methods'."
5682 (save-match-data
5683 (when (tramp-method-out-of-band-p multi-method method user host)
5684 (error "Cannot use out-of-band method `%s' with telnet connection method"
5685 method))
5686 (when multi-method
5687 (error "Cannot multi-connect using telnet connection method"))
5688 (tramp-pre-connection multi-method method user host tramp-chunksize)
5689 (tramp-message 7 "Opening connection for %s@%s using %s..."
5690 (or user (user-login-name)) host method)
5691 (let ((process-environment (copy-sequence process-environment)))
5692 (setenv "TERM" tramp-terminal-type)
5693 (setenv "PS1" "$ ")
5694 (let* ((default-directory (tramp-temporary-file-directory))
5695 ;; If we omit the conditional here, then we would use
5696 ;; `undecided-dos' in some cases. With the conditional,
5697 ;; we use nil in these cases. Which one is right?
5698 (coding-system-for-read (unless (and (not (featurep 'xemacs))
5699 (> emacs-major-version 20))
5700 tramp-dos-coding-system))
5701 (p (apply 'start-process
5702 (tramp-buffer-name multi-method method user host)
5703 (tramp-get-buffer multi-method method user host)
5704 (tramp-get-method-parameter
5705 multi-method
5706 (tramp-find-method multi-method method user host)
5707 user host 'tramp-login-program)
5708 host
5709 (tramp-get-method-parameter
5710 multi-method
5711 (tramp-find-method multi-method method user host)
5712 user host 'tramp-login-args)))
5713 (found nil)
5714 (pw nil))
5715 (tramp-set-process-query-on-exit-flag p nil)
5716 (set-buffer (tramp-get-buffer multi-method method user host))
5717 (erase-buffer)
5718 (tramp-process-actions p multi-method method user host
5719 tramp-actions-before-shell 60)
5720 (tramp-open-connection-setup-interactive-shell
5721 p multi-method method user host)
5722 (tramp-post-connection multi-method method user host)))))
5723
5724
5725(defun tramp-open-connection-rsh (multi-method method user host)
5726 "Open a connection using an rsh METHOD.
5727This starts the command `rsh HOST -l USER'[*], then waits for a remote
5728password or shell prompt. If a password prompt is seen, the user is
5729queried for a password, this function sends the password to the remote
5730host and waits for a shell prompt.
5731
5732If USER is nil, start the command `rsh HOST'[*] instead
5733
5734Recognition of the remote shell prompt is based on the variables
5735`shell-prompt-pattern' and `tramp-shell-prompt-pattern' which must be
5736set up correctly.
5737
5738Kludgy feature: if HOST has the form \"xx#yy\", then yy is assumed to
5739be a port number for ssh, and \"-p yy\" will be added to the list of
5740arguments, and xx will be used as the host name to connect to.
5741
5742* Actually, the rsh program to be used can be specified in the
5743 method parameters, see the variable `tramp-methods'."
5744 (save-match-data
5745 (when multi-method
5746 (error "Cannot multi-connect using rsh connection method"))
5747 (tramp-pre-connection multi-method method user host tramp-chunksize)
5748 (if (and user (not (string= user "")))
5749 (tramp-message 7 "Opening connection for %s@%s using %s..."
5750 user host method)
5751 (tramp-message 7 "Opening connection at %s using %s..." host method))
5752 (let ((process-environment (copy-sequence process-environment))
5753 (bufnam (tramp-buffer-name multi-method method user host))
5754 (buf (tramp-get-buffer multi-method method user host))
5755 (login-program (tramp-get-method-parameter
5756 multi-method
5757 (tramp-find-method multi-method method user host)
5758 user host 'tramp-login-program))
5759 (login-args (mapcar
5760 (lambda (x)
5761 (format-spec
5762 x `((?t . ,(format "/tmp/%s" tramp-temp-name-prefix)))))
5763 (tramp-get-method-parameter
5764 multi-method
5765 (tramp-find-method multi-method method user host)
5766 user host 'tramp-login-args)))
5767 (real-host host))
5768 ;; The following should be changed. We need a more general
5769 ;; mechanism to parse extra host args.
5770 (when (string-match "\\([^#]*\\)#\\(.*\\)" host)
5771 (setq login-args (cons "-p" (cons (match-string 2 host) login-args)))
5772 (setq real-host (match-string 1 host)))
5773 (setenv "TERM" tramp-terminal-type)
5774 (setenv "PS1" "$ ")
5775 (let* ((default-directory (tramp-temporary-file-directory))
5776 ;; If we omit the conditional, we would use
5777 ;; `undecided-dos' in some cases. With the conditional,
5778 ;; we use nil in these cases. Which one is right?
5779 (coding-system-for-read (unless (and (not (featurep 'xemacs))
5780 (> emacs-major-version 20))
5781 tramp-dos-coding-system))
5782 (p (if (and user (not (string= user "")))
5783 (apply #'start-process bufnam buf login-program
5784 real-host "-l" user login-args)
5785 (apply #'start-process bufnam buf login-program
5786 real-host login-args)))
5787 (found nil))
5788 (tramp-set-process-query-on-exit-flag p nil)
5789
5790 (set-buffer buf)
5791 (tramp-process-actions p multi-method method user host
5792 tramp-actions-before-shell 60)
5793 (tramp-message 7 "Initializing remote shell")
5794 (tramp-open-connection-setup-interactive-shell
5795 p multi-method method user host)
5796 (tramp-post-connection multi-method method user host)))))
5797
5798(defun tramp-open-connection-su (multi-method method user host)
5799 "Open a connection using the `su' program with METHOD.
5800This starts `su - USER', then waits for a password prompt. The HOST
5801name must be equal to the local host name or to `localhost'.
5802
5803If USER is nil, uses value returned by user-login-name instead.
5804
5805Recognition of the remote shell prompt is based on the variables
5806`shell-prompt-pattern' and `tramp-shell-prompt-pattern' which must be
5807set up correctly. Note that the other user may have a different shell
5808prompt than you do, so it is not at all unlikely that the variable
5809`shell-prompt-pattern' is set up wrongly!"
5810 (save-match-data
5811 (when (tramp-method-out-of-band-p multi-method method user host)
5812 (error "Cannot use out-of-band method `%s' with `su' connection method"
5813 method))
5814 (unless (or (string-match (concat "^" (regexp-quote host))
5815 (system-name))
5816 (string= "localhost" host)
5817 (string= "" host))
5818 (error
5819 "Cannot connect to different host `%s' with `su' connection method"
5820 host))
5821 (tramp-pre-connection multi-method method user host tramp-chunksize)
5822 (tramp-message 7 "Opening connection for `%s' using `%s'..."
5823 (or user "<root>") method)
5824 (let ((process-environment (copy-sequence process-environment)))
5825 (setenv "TERM" tramp-terminal-type)
5826 (setenv "PS1" "$ ")
5827 (let* ((default-directory (tramp-temporary-file-directory))
5828 ;; If we omit the conditional, we use `undecided-dos' in
5829 ;; some cases. With the conditional, we use nil in these
5830 ;; cases. What's the difference? Which one is right?
5831 (coding-system-for-read (unless (and (not (featurep 'xemacs))
5832 (> emacs-major-version 20))
5833 tramp-dos-coding-system))
5834 (p (apply 'start-process
5835 (tramp-buffer-name multi-method method user host)
5836 (tramp-get-buffer multi-method method user host)
5837 (tramp-get-method-parameter
5838 multi-method
5839 (tramp-find-method multi-method method user host)
5840 user host 'tramp-login-program)
5841 (mapcar
5842 (lambda (x)
5843 (format-spec x `((?u . ,(or user "root")))))
5844 (tramp-get-method-parameter
5845 multi-method
5846 (tramp-find-method multi-method method user host)
5847 user host 'tramp-login-args))))
5848 (found nil)
5849 (pw nil))
5850 (tramp-set-process-query-on-exit-flag p nil)
5851 (set-buffer (tramp-get-buffer multi-method method user host))
5852 (tramp-process-actions p multi-method method user host
5853 tramp-actions-before-shell 60)
5854 (tramp-open-connection-setup-interactive-shell
5855 p multi-method method user host)
5856 (tramp-post-connection multi-method method
5857 user host)))))
5858
5859;; HHH: Not Changed. Multi method. It is not clear to me how this can
5860;; handle not giving a user name in the "file name".
5861;;
5862;; This is more difficult than for the single-hop method. In the
5863;; multi-hop-method, the desired behaviour should be that the
5864;; user must specify names for the telnet hops of which the user
5865;; name is different than the "original" name (or different from
5866;; the previous hop.
5867(defun tramp-open-connection-multi (multi-method method user host)
5868 "Open a multi-hop connection using METHOD.
5869This uses a slightly changed file name syntax. The idea is to say
5870 [multi/telnet:u1@h1/rsh:u2@h2]/path/to/file
5871This will use telnet to log in as u1 to h1, then use rsh from there to
5872log in as u2 to h2."
5873 (save-match-data
5874 (unless multi-method
5875 (error "Multi-hop open connection function called on non-multi method"))
5876 (when (tramp-method-out-of-band-p multi-method method user host)
5877 (error "No out of band multi-hop connections"))
5878 (unless (and (arrayp method) (not (stringp method)))
5879 (error "METHOD must be an array of strings for multi methods"))
5880 (unless (and (arrayp user) (not (stringp user)))
5881 (error "USER must be an array of strings for multi methods"))
5882 (unless (and (arrayp host) (not (stringp host)))
5883 (error "HOST must be an array of strings for multi methods"))
5884 (unless (and (= (length method) (length user))
5885 (= (length method) (length host)))
5886 (error "Arrays METHOD, USER, HOST must have equal length"))
5887 (tramp-pre-connection multi-method method user host tramp-chunksize)
5888 (tramp-message 7 "Opening `%s' connection..." multi-method)
5889 (let ((process-environment (copy-sequence process-environment)))
5890 (setenv "TERM" tramp-terminal-type)
5891 (setenv "PS1" "$ ")
5892 (let* ((default-directory (tramp-temporary-file-directory))
5893 ;; If we omit the conditional, we use `undecided-dos' in
5894 ;; some cases. With the conditional, we use nil in these
5895 ;; cases. What's the difference? Which one is right?
5896 (coding-system-for-read (unless (and (not (featurep 'xemacs))
5897 (> emacs-major-version 20))
5898 tramp-dos-coding-system))
5899 (p (start-process (tramp-buffer-name multi-method method user host)
5900 (tramp-get-buffer multi-method method user host)
5901 tramp-multi-sh-program))
5902 (num-hops (length method))
5903 (i 0))
5904 (tramp-set-process-query-on-exit-flag p nil)
5905 (tramp-message 9 "Waiting 60s for local shell to come up...")
5906 (unless (tramp-wait-for-regexp
5907 p 60 (format "\\(%s\\)\\'\\|\\(%s\\)\\'"
5908 shell-prompt-pattern tramp-shell-prompt-pattern))
5909 (pop-to-buffer (buffer-name))
5910 (kill-process p)
5911 (error "Couldn't find local shell prompt"))
5912 ;; Now do all the connections as specified.
5913 (while (< i num-hops)
5914 (let* ((m (aref method i))
5915 (u (aref user i))
5916 (h (aref host i))
5917 (entry (assoc m tramp-multi-connection-function-alist))
5918 (multi-func (nth 1 entry))
5919 (command (nth 2 entry)))
5920 ;; The multi-funcs don't need to do save-match-data, as that
5921 ;; is done here.
5922 (funcall multi-func p m u h command)
5923 (erase-buffer)
5924 (setq i (1+ i))))
5925 (tramp-open-connection-setup-interactive-shell
5926 p multi-method method user host)
5927 (tramp-post-connection multi-method method user host)))))
5928
5929;; HHH: Changed. Multi method. Don't know how to handle this in the case
5930;; of no user name provided. Hack to make it work as it did before:
5931;; changed `user' to `(or user (user-login-name))' in the places where
5932;; the value is actually used.
5933(defun tramp-multi-connect-telnet (p method user host command)
5934 "Issue `telnet' command.
5935Uses shell COMMAND to issue a `telnet' command to log in as USER to
5936HOST. You can use percent escapes in COMMAND: `%h' is replaced with
5937the host name, and `%n' is replaced with an end of line character, as
5938set in `tramp-rsh-end-of-line'. Use `%%' if you want a literal percent
5939character.
5940
5941If USER is nil, uses the return value of (user-login-name) instead."
5942 (let ((cmd (format-spec command
5943 `((?h . ,host) (?n . ,tramp-rsh-end-of-line))))
5944 (cmd1 (format-spec command `((?h . ,host) (?n . ""))))
5945 found pw)
5946 (erase-buffer)
5947 (tramp-message 9 "Sending telnet command `%s'" cmd1)
5948 (process-send-string p cmd)
5949 (tramp-process-multi-actions p method user host
5950 tramp-multi-actions)))
5951
5952;; HHH: Changed. Multi method. Don't know how to handle this in the case
5953;; of no user name provided. Hack to make it work as it did before:
5954;; changed `user' to `(or user (user-login-name))' in the places where
5955;; the value is actually used.
5956(defun tramp-multi-connect-rlogin (p method user host command)
5957 "Issue `rlogin' command.
5958Uses shell COMMAND to issue an `rlogin' command to log in as USER to
5959HOST. You can use percent escapes in COMMAND. `%u' will be replaced
5960with the user name, `%h' will be replaced with the host name, and `%n'
5961will be replaced with the value of `tramp-rsh-end-of-line'. You can use
5962`%%' if you want to use a literal percent character.
5963
5964If USER is nil, uses the return value of (user-login-name) instead."
5965 (let ((cmd (format-spec command `((?h . ,host)
5966 (?u . ,(or user (user-login-name)))
5967 (?n . ,tramp-rsh-end-of-line))))
5968 (cmd1 (format-spec command `((?h . ,host)
5969 (?u . ,(or user (user-login-name)))
5970 (?n . ""))))
5971 found)
5972 (erase-buffer)
5973 (tramp-message 9 "Sending rlogin command `%s'" cmd1)
5974 (process-send-string p cmd)
5975 (tramp-process-multi-actions p method user host
5976 tramp-multi-actions)))
5977
5978;; HHH: Changed. Multi method. Don't know how to handle this in the case
5979;; of no user name provided. Hack to make it work as it did before:
5980;; changed `user' to `(or user (user-login-name))' in the places where
5981;; the value is actually used.
5982(defun tramp-multi-connect-su (p method user host command)
5983 "Issue `su' command.
5984Uses shell COMMAND to issue a `su' command to log in as USER on
5985HOST. The HOST name is ignored, this just changes the user id on the
5986host currently logged in to.
5987
5988If USER is nil, uses the return value of (user-login-name) instead.
5989
5990You can use percent escapes in the COMMAND. `%u' is replaced with the
5991user name, and `%n' is replaced with the value of
5992`tramp-rsh-end-of-line'. Use `%%' if you want a literal percent
5993character."
5994 (let ((cmd (format-spec command `((?u . ,(or user (user-login-name)))
5995 (?n . ,tramp-rsh-end-of-line))))
5996 (cmd1 (format-spec command `((?u . ,(or user (user-login-name)))
5997 (?n . ""))))
5998 found)
5999 (erase-buffer)
6000 (tramp-message 9 "Sending su command `%s'" cmd1)
6001 (process-send-string p cmd)
6002 (tramp-process-multi-actions p method user host
6003 tramp-multi-actions)))
6004 5341
6005;; Utility functions. 5342;; Utility functions.
6006 5343
6007(defun tramp-accept-process-output 5344(defun tramp-accept-process-output (&optional proc timeout timeout-msecs)
6008 (&optional process timeout timeout-msecs)
6009 "Like `accept-process-output' for Tramp processes. 5345 "Like `accept-process-output' for Tramp processes.
6010This is needed in order to hide `last-coding-system-used', which is set 5346This is needed in order to hide `last-coding-system-used', which is set
6011for process communication also." 5347for process communication also."
6012 (let (last-coding-system-used) 5348 (with-current-buffer (process-buffer proc)
6013 (accept-process-output process timeout timeout-msecs))) 5349 (tramp-message proc 10 "%s %s" proc (process-status proc))
5350 (let (buffer-read-only last-coding-system-used)
5351 ;; Under Windows XP, accept-process-output doesn't return
5352 ;; sometimes. So we add an additional timeout.
5353 (with-timeout ((or timeout 1))
5354 (accept-process-output proc timeout timeout-msecs)))
5355 (tramp-message proc 10 "\n%s" (buffer-string))))
5356
5357(defun tramp-check-for-regexp (proc regexp)
5358 "Check whether REGEXP is contained in process buffer of PROC.
5359Erase echoed commands if exists."
5360 (with-current-buffer (process-buffer proc)
5361 (goto-char (point-min))
5362 ;; Check whether we need to remove echo output.
5363 (when (and (tramp-get-connection-property proc "check-remote-echo" nil)
5364 (re-search-forward tramp-echoed-echo-mark-regexp nil t))
5365 (let ((begin (match-beginning 0)))
5366 (when (re-search-forward tramp-echoed-echo-mark-regexp nil t)
5367 ;; Discard echo from remote output.
5368 (tramp-set-connection-property proc "check-remote-echo" nil)
5369 (tramp-message proc 5 "echo-mark found")
5370 (forward-line)
5371 (delete-region begin (point))
5372 (goto-char (point-min)))))
5373 ;; No echo to be handled, now we can look for the regexp.
5374 (when (not (tramp-get-connection-property proc "check-remote-echo" nil))
5375 (re-search-forward regexp nil t))))
6014 5376
6015(defun tramp-wait-for-regexp (proc timeout regexp) 5377(defun tramp-wait-for-regexp (proc timeout regexp)
6016 "Wait for a REGEXP to appear from process PROC within TIMEOUT seconds. 5378 "Wait for a REGEXP to appear from process PROC within TIMEOUT seconds.
6017Expects the output of PROC to be sent to the current buffer. Returns 5379Expects the output of PROC to be sent to the current buffer. Returns
6018the string that matched, or nil. Waits indefinitely if TIMEOUT is 5380the string that matched, or nil. Waits indefinitely if TIMEOUT is
6019nil." 5381nil."
6020 (let ((found nil) 5382 (with-current-buffer (process-buffer proc)
6021 (start-time (current-time))) 5383 (let ((found (tramp-check-for-regexp proc regexp))
6022 (cond (timeout 5384 (start-time (current-time)))
6023 ;; Work around a bug in XEmacs 21, where the timeout 5385 (cond (timeout
6024 ;; expires faster than it should. This degenerates 5386 ;; Work around a bug in XEmacs 21, where the timeout
6025 ;; to polling for buggy XEmacsen, but oh, well. 5387 ;; expires faster than it should. This degenerates
6026 (while (and (not found) 5388 ;; to polling for buggy XEmacsen, but oh, well.
6027 (< (tramp-time-diff (current-time) start-time) 5389 (while (and (not found)
6028 timeout)) 5390 (< (tramp-time-diff (current-time) start-time)
6029 (with-timeout (timeout) 5391 timeout))
6030 (while (not found) 5392 (with-timeout (timeout)
6031 (tramp-accept-process-output proc 1) 5393 (while (not found)
6032 (unless (memq (process-status proc) '(run open)) 5394 (tramp-accept-process-output proc 1)
6033 (error "Process has died")) 5395 (unless (memq (process-status proc) '(run open))
6034 (goto-char (point-min)) 5396 (tramp-error-with-buffer
6035 (setq found (re-search-forward regexp nil t)))))) 5397 nil proc 'file-error "Process has died"))
6036 (t 5398 (setq found (tramp-check-for-regexp proc regexp))))))
6037 (while (not found) 5399 (t
6038 (tramp-accept-process-output proc 1) 5400 (while (not found)
6039 (unless (memq (process-status proc) '(run open)) 5401 (tramp-accept-process-output proc 1)
6040 (error "Process has died")) 5402 (unless (memq (process-status proc) '(run open))
6041 (goto-char (point-min)) 5403 (tramp-error-with-buffer
6042 (setq found (re-search-forward regexp nil t))))) 5404 nil proc 'file-error "Process has died"))
6043 (when tramp-debug-buffer 5405 (setq found (tramp-check-for-regexp proc regexp)))))
6044 (append-to-buffer 5406 (tramp-message proc 6 "\n%s" (buffer-string))
6045 (tramp-get-debug-buffer tramp-current-multi-method tramp-current-method
6046 tramp-current-user tramp-current-host)
6047 (point-min) (point-max))
6048 (when (not found) 5407 (when (not found)
6049 (save-excursion 5408 (if timeout
6050 (set-buffer 5409 (tramp-error
6051 (tramp-get-debug-buffer tramp-current-multi-method tramp-current-method 5410 proc 'file-error "[[Regexp `%s' not found in %d secs]]"
6052 tramp-current-user tramp-current-host)) 5411 regexp timeout)
6053 (goto-char (point-max)) 5412 (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp)))
6054 (insert "[[Regexp `" regexp "' not found" 5413 found)))
6055 (if timeout (format " in %d secs" timeout) "")
6056 "]]"))))
6057 found))
6058 5414
6059(defun tramp-wait-for-shell-prompt (proc timeout) 5415(defun tramp-wait-for-shell-prompt (proc timeout)
6060 "Wait for the shell prompt to appear from process PROC within TIMEOUT seconds. 5416 "Wait for the shell prompt to appear from process PROC within TIMEOUT seconds.
@@ -6071,51 +5427,23 @@ and `tramp-shell-prompt-pattern'."
6071Looks at process PROC to see if a shell prompt appears in TIMEOUT 5427Looks at process PROC to see if a shell prompt appears in TIMEOUT
6072seconds. If not, it produces an error message with the given ERROR-ARGS." 5428seconds. If not, it produces an error message with the given ERROR-ARGS."
6073 (unless (tramp-wait-for-shell-prompt proc timeout) 5429 (unless (tramp-wait-for-shell-prompt proc timeout)
6074 (pop-to-buffer (buffer-name)) 5430 (apply 'tramp-error-with-buffer nil proc 'file-error error-args)))
6075 (apply 'error error-args))) 5431
6076 5432;; We don't call `tramp-send-string' in order to hide the password from the
6077(defun tramp-enter-password (p prompt user host) 5433;; debug buffer, and because end-of-line handling of the string.
6078 "Prompt for a password and send it to the remote end. 5434(defun tramp-enter-password (p)
6079Uses PROMPT as a prompt and sends the password to process P." 5435 "Prompt for a password and send it to the remote end."
6080 (let ((pw (tramp-read-passwd user host prompt))) 5436 (process-send-string
6081 (erase-buffer) 5437 p (concat (tramp-read-passwd p)
6082 (process-send-string 5438 (or (tramp-get-method-parameter
6083 p (concat pw 5439 tramp-current-method
6084 (or (tramp-get-method-parameter 5440 'tramp-password-end-of-line)
6085 tramp-current-multi-method 5441 tramp-default-password-end-of-line))))
6086 tramp-current-method 5442
6087 tramp-current-user 5443(defun tramp-open-connection-setup-interactive-shell (proc vec)
6088 tramp-current-host
6089 'tramp-password-end-of-line)
6090 tramp-default-password-end-of-line)))))
6091
6092;; HHH: Not Changed. This might handle the case where USER is not
6093;; given in the "File name" very poorly. Then, the local
6094;; variable tramp-current-user will be set to nil.
6095(defun tramp-pre-connection (multi-method method user host chunksize)
6096 "Do some setup before actually logging in.
6097METHOD, USER and HOST specify the connection."
6098 (set-buffer (tramp-get-buffer multi-method method user host))
6099 (set (make-local-variable 'tramp-current-multi-method) multi-method)
6100 (set (make-local-variable 'tramp-current-method) method)
6101 (set (make-local-variable 'tramp-current-user) user)
6102 (set (make-local-variable 'tramp-current-host) host)
6103 (set (make-local-variable 'tramp-chunksize) chunksize)
6104 (set (make-local-variable 'inhibit-eol-conversion) nil)
6105 (erase-buffer))
6106
6107(defun tramp-open-connection-setup-interactive-shell
6108 (p multi-method method user host)
6109 "Set up an interactive shell. 5444 "Set up an interactive shell.
6110Mainly sets the prompt and the echo correctly. P is the shell process 5445Mainly sets the prompt and the echo correctly. PROC is the shell
6111to set up. METHOD, USER and HOST specify the connection." 5446process to set up. VEC specifies the connection."
6112 ;; Wait a bit in case the remote end feels like sending a little
6113 ;; junk first. It seems that fencepost.gnu.org does this when doing
6114 ;; a Kerberos login.
6115 (sit-for 1)
6116 (tramp-discard-garbage-erase-buffer p multi-method method user host)
6117 (tramp-process-initial-commands p multi-method method user host
6118 tramp-initial-commands)
6119 ;; It is useful to set the prompt in the following command because 5447 ;; It is useful to set the prompt in the following command because
6120 ;; some people have a setting for $PS1 which /bin/sh doesn't know 5448 ;; some people have a setting for $PS1 which /bin/sh doesn't know
6121 ;; about and thus /bin/sh will display a strange prompt. For 5449 ;; about and thus /bin/sh will display a strange prompt. For
@@ -6129,116 +5457,84 @@ to set up. METHOD, USER and HOST specify the connection."
6129 ;; called as sh) on startup; this way, we avoid the startup file 5457 ;; called as sh) on startup; this way, we avoid the startup file
6130 ;; clobbering $PS1. 5458 ;; clobbering $PS1.
6131 (tramp-send-command-internal 5459 (tramp-send-command-internal
6132 multi-method method user host 5460 vec
6133 (format "exec env 'ENV=' 'PS1=$ ' %s" 5461 (format "exec env 'ENV=' 'PS1=$ ' %s"
6134 (tramp-get-method-parameter 5462 (tramp-get-method-parameter
6135 multi-method method user host 'tramp-remote-sh)) 5463 (tramp-file-name-method vec) 'tramp-remote-sh)))
6136 (format "remote `%s' to come up" 5464 (tramp-message vec 5 "Setting up remote shell environment")
6137 (tramp-get-method-parameter 5465 (tramp-send-command-internal vec "stty -inlcr -echo kill '^U' erase '^H'")
6138 multi-method method user host 'tramp-remote-sh))) 5466 ;; Check whether the echo has really been disabled. Some
6139 (tramp-barf-if-no-shell-prompt 5467 ;; implementations, like busybox of embedded GNU/Linux, don't
6140 p 30 5468 ;; support disabling.
6141 "Remote `%s' didn't come up. See buffer `%s' for details" 5469 (tramp-send-command-internal vec "echo foo")
6142 (tramp-get-method-parameter multi-method method user host 'tramp-remote-sh) 5470 (with-current-buffer (process-buffer proc)
6143 (buffer-name))
6144 (tramp-message 8 "Setting up remote shell environment")
6145 (tramp-discard-garbage-erase-buffer p multi-method method user host)
6146 (tramp-send-command-internal multi-method method user host
6147 "stty -inlcr -echo kill '^U'")
6148 (erase-buffer)
6149 ;; Ignore garbage after stty command.
6150 (tramp-send-command-internal multi-method method user host
6151 "echo foo")
6152 (erase-buffer)
6153 (tramp-send-command-internal multi-method method user host
6154 "TERM=dumb; export TERM")
6155 (erase-buffer)
6156 ;; Check whether the remote host suffers from buggy `send-process-string'.
6157 ;; This is known for FreeBSD (see comment in `send_process', file process.c).
6158 ;; I've tested sending 624 bytes successfully, sending 625 bytes failed.
6159 ;; Emacs makes a hack when this host type is detected locally. It cannot
6160 ;; handle remote hosts, though.
6161 (when (or (not tramp-chunksize) (zerop tramp-chunksize))
6162 (tramp-message 9 "Checking remote host type for `send-process-string' bug")
6163 (tramp-send-command-internal multi-method method user host
6164 "(uname -sr) 2>/dev/null")
6165 (goto-char (point-min)) 5471 (goto-char (point-min))
6166 (when (looking-at "FreeBSD") 5472 (when (looking-at "echo foo")
6167 (setq tramp-chunksize 500))) 5473 (tramp-set-connection-property vec "remote-echo" t)
6168 5474 (tramp-message vec 5 "Remote echo still on. Ok.")
5475 ;; Make sure backspaces and their echo are enabled and no line
5476 ;; width magic interferes with them.
5477 (tramp-send-command-internal vec "stty icanon erase ^H cols 32767")))
6169 ;; Try to set up the coding system correctly. 5478 ;; Try to set up the coding system correctly.
6170 ;; CCC this can't be the right way to do it. Hm. 5479 ;; CCC this can't be the right way to do it. Hm.
6171 (save-excursion 5480 (tramp-message vec 5 "Determining coding system")
6172 (erase-buffer) 5481 (tramp-send-command-internal vec "echo foo ; echo bar")
6173 (tramp-message 9 "Determining coding system") 5482 (with-current-buffer (process-buffer proc)
6174 (tramp-send-command-internal multi-method method user host
6175 "echo foo ; echo bar")
6176 (goto-char (point-min)) 5483 (goto-char (point-min))
6177 (if (featurep 'mule) 5484 (if (featurep 'mule)
6178 ;; Use MULE to select the right EOL convention for communicating 5485 ;; Use MULE to select the right EOL convention for communicating
6179 ;; with the process. 5486 ;; with the process.
6180 (let* ((cs (or (process-coding-system p) (cons 'undecided 'undecided))) 5487 (let* ((cs (or (process-coding-system proc)
6181 cs-decode cs-encode) 5488 (cons 'undecided 'undecided)))
6182 (when (symbolp cs) (setq cs (cons cs cs))) 5489 cs-decode cs-encode)
6183 (setq cs-decode (car cs)) 5490 (when (symbolp cs) (setq cs (cons cs cs)))
6184 (setq cs-encode (cdr cs)) 5491 (setq cs-decode (car cs))
6185 (unless cs-decode (setq cs-decode 'undecided)) 5492 (setq cs-encode (cdr cs))
6186 (unless cs-encode (setq cs-encode 'undecided)) 5493 (unless cs-decode (setq cs-decode 'undecided))
6187 (setq cs-encode (tramp-coding-system-change-eol-conversion 5494 (unless cs-encode (setq cs-encode 'undecided))
6188 cs-encode 'unix)) 5495 (setq cs-encode (tramp-coding-system-change-eol-conversion
6189 (when (search-forward "\r" nil t) 5496 cs-encode 'unix))
6190 (setq cs-decode (tramp-coding-system-change-eol-conversion 5497 (when (search-forward "\r" nil t)
6191 cs-decode 'dos))) 5498 (setq cs-decode (tramp-coding-system-change-eol-conversion
6192 (set-buffer-process-coding-system cs-decode cs-encode)) 5499 cs-decode 'dos)))
5500 (set-buffer-process-coding-system cs-decode cs-encode))
6193 ;; Look for ^M and do something useful if found. 5501 ;; Look for ^M and do something useful if found.
6194 (when (search-forward "\r" nil t) 5502 (when (search-forward "\r" nil t)
6195 ;; We have found a ^M but cannot frob the process coding system 5503 ;; We have found a ^M but cannot frob the process coding system
6196 ;; because we're running on a non-MULE Emacs. Let's try 5504 ;; because we're running on a non-MULE Emacs. Let's try
6197 ;; stty, instead. 5505 ;; stty, instead.
6198 (erase-buffer) 5506 (tramp-send-command-internal vec "stty -onlcr"))))
6199 (tramp-message 9 "Trying `stty -onlcr'") 5507 (tramp-send-command-internal vec "set +o vi +o emacs")
6200 (tramp-send-command-internal multi-method method user host 5508 (tramp-message vec 5 "Setting shell prompt")
6201 "stty -onlcr"))))
6202 (erase-buffer)
6203 (tramp-message
6204 9 "Waiting 30s for `HISTFILE=$HOME/.tramp_history; HISTSIZE=1; export HISTFILE; export HISTSIZE'")
6205 (tramp-send-command-internal
6206 multi-method method user host
6207 "HISTFILE=$HOME/.tramp_history; HISTSIZE=1; export HISTFILE; export HISTSIZE")
6208 (erase-buffer)
6209 (tramp-message 9 "Waiting 30s for `set +o vi +o emacs'")
6210 (tramp-send-command-internal multi-method method user host
6211 "set +o vi +o emacs")
6212 (erase-buffer)
6213 (tramp-message 9 "Waiting 30s for `unset MAIL MAILCHECK MAILPATH'")
6214 (tramp-send-command-internal
6215 multi-method method user host
6216 "unset MAIL MAILCHECK MAILPATH 1>/dev/null 2>/dev/null")
6217 (erase-buffer)
6218 (tramp-message 9 "Waiting 30s for `unset CDPATH'")
6219 (tramp-send-command-internal multi-method method user host
6220 "unset CDPATH")
6221 (erase-buffer)
6222 (tramp-message 9 "Setting shell prompt")
6223 ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we must 5509 ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we must
6224 ;; use "\n" here, not tramp-rsh-end-of-line. We also manually frob 5510 ;; use "\n" here, not tramp-rsh-end-of-line. We also manually frob
6225 ;; the last time we sent a command, to avoid tramp-send-command to send 5511 ;; the last time we sent a command, to avoid `tramp-send-command' to
6226 ;; "echo are you awake". 5512 ;; send "echo are you awake".
6227 (setq tramp-last-cmd-time (current-time))
6228 (tramp-send-command 5513 (tramp-send-command
6229 multi-method method user host 5514 vec
6230 (format "PS1='%s%s%s'; PS2=''; PS3=''" 5515 (format "PS1='%s%s%s'; PS2=''; PS3=''"
6231 tramp-rsh-end-of-line 5516 tramp-rsh-end-of-line
6232 tramp-end-of-output 5517 tramp-end-of-output
6233 tramp-rsh-end-of-line)) 5518 tramp-rsh-end-of-line))
6234 (tramp-wait-for-output)) 5519 ;; Check whether the remote host suffers from buggy `send-process-string'.
6235 5520 ;; This is known for FreeBSD (see comment in `send_process', file process.c).
6236(defun tramp-post-connection (multi-method method user host) 5521 ;; I've tested sending 624 bytes successfully, sending 625 bytes failed.
6237 "Prepare a remote shell before being able to work on it. 5522 ;; Emacs makes a hack when this host type is detected locally. It cannot
6238METHOD, USER and HOST specify the connection. 5523 ;; handle remote hosts, though.
6239Among other things, this finds a shell which groks tilde expansion, 5524 (with-connection-property proc "chunksize"
6240tries to find an `ls' command which groks the `-n' option, sets the 5525 (cond
6241locale to C and sets up the remote shell search path." 5526 ((and (integerp tramp-chunksize) (> tramp-chunksize 0))
5527 tramp-chunksize)
5528 (t
5529 (tramp-message
5530 vec 5 "Checking remote host type for `send-process-string' bug")
5531 (if (string-match
5532 "^FreeBSD"
5533 (with-connection-property vec "uname"
5534 (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))
5535 500 0))))
5536 ;; Set remote PATH variable.
5537 (tramp-set-remote-path vec)
6242 ;; Search for a good shell before searching for a command which 5538 ;; Search for a good shell before searching for a command which
6243 ;; checks if a file exists. This is done because Tramp wants to use 5539 ;; checks if a file exists. This is done because Tramp wants to use
6244 ;; "test foo; echo $?" to check if various conditions hold, and 5540 ;; "test foo; echo $?" to check if various conditions hold, and
@@ -6247,168 +5543,23 @@ locale to C and sets up the remote shell search path."
6247 ;; the Solaris /bin/sh is a problem. I'm betting that all systems 5543 ;; the Solaris /bin/sh is a problem. I'm betting that all systems
6248 ;; with buggy /bin/sh implementations will have a working bash or 5544 ;; with buggy /bin/sh implementations will have a working bash or
6249 ;; ksh. Whee... 5545 ;; ksh. Whee...
6250 (tramp-find-shell multi-method method user host) 5546 (tramp-find-shell vec)
6251 ;; Without (sit-for 0.1) at least, my machine will almost always blow 5547 ;; Disable unexpected output.
6252 ;; up on 'not numberp /root' - a race that causes the 'echo ~root' 5548 (tramp-send-command vec "mesg n; biff n")
6253 ;; output of (tramp-find-shell) to show up along with the output of 5549 ;; Set the environment.
6254 ;; (tramp-find-ls-command) testing. 5550 (tramp-message vec 5 "Setting default environment")
6255 ;; 5551 (let ((env (copy-sequence tramp-remote-process-environment))
6256 ;; I can't work out why this is a problem though. The (tramp-wait-for-output) 5552 unset item)
6257 ;; call in (tramp-find-shell) *should* make this not happen, I thought. 5553 (while env
6258 ;; 5554 (setq item (split-string (car env) "="))
6259 ;; After much debugging I couldn't find any problem with the implementation 5555 (if (and (stringp (cadr item)) (not (string-equal (cadr item) "")))
6260 ;; of that function though. The workaround stays for me at least. :/ 5556 (tramp-send-command
6261 ;; 5557 vec (format "%s=%s; export %s" (car item) (cadr item) (car item)))
6262 ;; Daniel Pittman <daniel@danann.net> 5558 (push (car item) unset))
6263 (sleep-for 1) 5559 (setq env (cdr env)))
6264 (erase-buffer) 5560 (when unset
6265 (tramp-find-file-exists-command multi-method method user host)
6266 (make-local-variable 'tramp-ls-command)
6267 (setq tramp-ls-command (tramp-find-ls-command multi-method method user host))
6268 (unless tramp-ls-command
6269 (tramp-message
6270 1
6271 "Danger! Couldn't find ls which groks -n. Muddling through anyway")
6272 (setq tramp-ls-command
6273 (tramp-find-executable multi-method method user host
6274 "ls" tramp-remote-path nil)))
6275 (unless tramp-ls-command
6276 (error "Fatal error: Couldn't find remote executable `ls'"))
6277 (tramp-message 5 "Using remote command `%s' for getting directory listings"
6278 tramp-ls-command)
6279 (tramp-send-command multi-method method user host
6280 (concat "tramp_set_exit_status () {" tramp-rsh-end-of-line
6281 "return $1" tramp-rsh-end-of-line
6282 "}"))
6283 (tramp-wait-for-output)
6284 ;; Set remote PATH variable.
6285 (tramp-set-remote-path multi-method method user host "PATH" tramp-remote-path)
6286 ;; Tell remote shell to use standard time format, needed for
6287 ;; parsing `ls -l' output.
6288 (tramp-send-command multi-method method user host
6289 "LC_TIME=C; export LC_TIME; echo huhu")
6290 (tramp-wait-for-output)
6291 (tramp-send-command multi-method method user host
6292 "mesg n; echo huhu")
6293 (tramp-wait-for-output)
6294 (tramp-send-command multi-method method user host
6295 "biff n ; echo huhu")
6296 (tramp-wait-for-output)
6297 ;; Unalias ls(1) to work around issues with those silly people who make it
6298 ;; spit out ANSI escapes or whatever.
6299 (tramp-send-command multi-method method user host
6300 "unalias ls; echo huhu")
6301 (tramp-wait-for-output)
6302 ;; Does `test A -nt B' work? Use abominable `find' construct if it
6303 ;; doesn't. BSD/OS 4.0 wants the parentheses around the command,
6304 ;; for otherwise the shell crashes.
6305 (erase-buffer)
6306 (make-local-variable 'tramp-test-groks-nt)
6307 (tramp-send-command multi-method method user host
6308 "( test / -nt / )")
6309 (tramp-wait-for-output)
6310 (goto-char (point-min))
6311 (setq tramp-test-groks-nt
6312 (looking-at (format "\n%s\r?\n" (regexp-quote tramp-end-of-output))))
6313 (unless tramp-test-groks-nt
6314 (tramp-send-command
6315 multi-method method user host
6316 (concat "tramp_test_nt () {" tramp-rsh-end-of-line
6317 "test -n \"`find $1 -prune -newer $2 -print`\"" tramp-rsh-end-of-line
6318 "}")))
6319 (tramp-wait-for-output)
6320 ;; Send the fallback `uudecode' script.
6321 (erase-buffer)
6322 (tramp-send-string multi-method method user host tramp-uudecode)
6323 (tramp-wait-for-output)
6324 ;; Find a `perl'.
6325 (erase-buffer)
6326 (tramp-set-connection-property "perl-scripts" nil multi-method method user host)
6327 (let ((tramp-remote-perl
6328 (or (tramp-find-executable multi-method method user host
6329 "perl5" tramp-remote-path nil)
6330 (tramp-find-executable multi-method method user host
6331 "perl" tramp-remote-path nil))))
6332 (when tramp-remote-perl
6333 (tramp-set-connection-property "perl" tramp-remote-perl
6334 multi-method method user host)
6335 (unless (tramp-method-out-of-band-p multi-method method user host)
6336 (tramp-message 5 "Sending the Perl `mime-encode' implementations.")
6337 (tramp-send-string
6338 multi-method method user host
6339 (concat "tramp_encode () {\n"
6340 (format tramp-perl-encode tramp-remote-perl)
6341 " 2>/dev/null"
6342 "\n}"))
6343 (tramp-wait-for-output)
6344 (tramp-send-string
6345 multi-method method user host
6346 (concat "tramp_encode_with_module () {\n"
6347 (format tramp-perl-encode-with-module tramp-remote-perl)
6348 " 2>/dev/null"
6349 "\n}"))
6350 (tramp-wait-for-output)
6351 (tramp-message 5 "Sending the Perl `mime-decode' implementations.")
6352 (tramp-send-string
6353 multi-method method user host
6354 (concat "tramp_decode () {\n"
6355 (format tramp-perl-decode tramp-remote-perl)
6356 " 2>/dev/null"
6357 "\n}"))
6358 (tramp-wait-for-output)
6359 (tramp-send-string
6360 multi-method method user host
6361 (concat "tramp_decode_with_module () {\n"
6362 (format tramp-perl-decode-with-module tramp-remote-perl)
6363 " 2>/dev/null"
6364 "\n}"))
6365 (tramp-wait-for-output))))
6366 ;; Find ln(1)
6367 (erase-buffer)
6368 (let ((ln (tramp-find-executable multi-method method user host
6369 "ln" tramp-remote-path nil)))
6370 (when ln
6371 (tramp-set-connection-property "ln" ln multi-method method user host)))
6372 ;; Set uid and gid.
6373 (erase-buffer)
6374 (tramp-send-command multi-method method user host "id -u; id -g")
6375 (tramp-wait-for-output)
6376 (goto-char (point-min))
6377 (tramp-set-connection-property
6378 "uid" (read (current-buffer)) multi-method method user host)
6379 (tramp-set-connection-property
6380 "gid" (read (current-buffer)) multi-method method user host)
6381 ;; Find the right encoding/decoding commands to use.
6382 (erase-buffer)
6383 (unless (tramp-method-out-of-band-p multi-method method user host)
6384 (tramp-find-inline-encoding multi-method method user host))
6385 ;; If encoding/decoding command are given, test to see if they work.
6386 ;; CCC: Maybe it would be useful to run the encoder both locally and
6387 ;; remotely to see if they produce the same result.
6388 (let ((rem-enc (tramp-get-remote-encoding multi-method method user host))
6389 (rem-dec (tramp-get-remote-decoding multi-method method user host))
6390 (magic-string "xyzzy"))
6391 (when (and (or rem-dec rem-enc) (not (and rem-dec rem-enc)))
6392 (tramp-kill-process multi-method method user host)
6393 ;; Improve error message and/or error check.
6394 (error
6395 "Must give both decoding and encoding command in method definition"))
6396 (when (and rem-enc rem-dec)
6397 (tramp-message
6398 5
6399 "Checking to see if encoding/decoding commands work on remote host...")
6400 (tramp-send-command 5561 (tramp-send-command
6401 multi-method method user host 5562 vec (format "unset %s" (mapconcat 'identity unset " "))))))
6402 (format "echo %s | %s | %s"
6403 (tramp-shell-quote-argument magic-string) rem-enc rem-dec))
6404 (tramp-wait-for-output)
6405 (unless (looking-at (regexp-quote magic-string))
6406 (tramp-kill-process multi-method method user host)
6407 (error "Remote host cannot execute de/encoding commands. See buffer `%s' for details"
6408 (buffer-name)))
6409 (erase-buffer)
6410 (tramp-message
6411 5 "Checking to see if encoding/decoding commands work on remote host...done"))))
6412 5563
6413;; CCC: We should either implement a Perl version of base64 encoding 5564;; CCC: We should either implement a Perl version of base64 encoding
6414;; and decoding. Then we just use that in the last item. The other 5565;; and decoding. Then we just use that in the last item. The other
@@ -6428,38 +5579,22 @@ locale to C and sets up the remote shell search path."
6428;; 5579;;
6429;; For Irix, no solution is known yet. 5580;; For Irix, no solution is known yet.
6430 5581
6431(defvar tramp-coding-commands 5582(defconst tramp-local-coding-commands
6432 '(("mimencode -b" "mimencode -u -b" 5583 '((b64 base64-encode-region base64-decode-region)
6433 base64-encode-region base64-decode-region) 5584 (uu tramp-uuencode-region uudecode-decode-region)
6434 ("mmencode -b" "mmencode -u -b" 5585 (pack
6435 base64-encode-region base64-decode-region) 5586 "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
6436 ("recode data..base64" "recode base64..data" 5587 "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
6437 base64-encode-region base64-decode-region) 5588 "List of local coding commands for inline transfer.
6438 ("uuencode xxx" "uudecode -o /dev/stdout"
6439 tramp-uuencode-region uudecode-decode-region)
6440 ("uuencode xxx" "uudecode -o -"
6441 tramp-uuencode-region uudecode-decode-region)
6442 ("uuencode xxx" "uudecode -p"
6443 tramp-uuencode-region uudecode-decode-region)
6444 ("uuencode xxx" "tramp_uudecode"
6445 tramp-uuencode-region uudecode-decode-region)
6446 ("tramp_encode_with_module" "tramp_decode_with_module"
6447 base64-encode-region base64-decode-region)
6448 ("tramp_encode" "tramp_decode"
6449 base64-encode-region base64-decode-region))
6450 "List of coding commands for inline transfer.
6451Each item is a list that looks like this: 5589Each item is a list that looks like this:
6452 5590
6453\(REMOTE-ENCODING REMOTE-DECODING LOCAL-ENCODING LOCAL-DECODING) 5591\(FORMAT ENCODING DECODING)
6454 5592
6455The REMOTE-ENCODING should be a string, giving a command accepting a 5593FORMAT is symbol describing the encoding/decoding format. It can be
6456plain file on standard input and writing the encoded file to standard 5594`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
6457output. The REMOTE-DECODING should also be a string, giving a command
6458accepting an encoded file on standard input and writing the decoded
6459file to standard output.
6460 5595
6461LOCAL-ENCODING and LOCAL-DECODING can be strings, giving commands, or 5596ENCODING and DECODING can be strings, giving commands, or symbols,
6462symbols, giving functions. If they are strings, then they can contain 5597giving functions. If they are strings, then they can contain
6463the \"%s\" format specifier. If that specifier is present, the input 5598the \"%s\" format specifier. If that specifier is present, the input
6464filename will be put into the command line at that spot. If the 5599filename will be put into the command line at that spot. If the
6465specifier is not present, the input should be read from standard 5600specifier is not present, the input should be read from standard
@@ -6469,83 +5604,139 @@ If they are functions, they will be called with two arguments, start
6469and end of region, and are expected to replace the region contents 5604and end of region, and are expected to replace the region contents
6470with the encoded or decoded results, respectively.") 5605with the encoded or decoded results, respectively.")
6471 5606
6472(defun tramp-find-inline-encoding (multi-method method user host) 5607(defconst tramp-remote-coding-commands
5608 '((b64 "mimencode -b" "mimencode -u -b")
5609 (b64 "mmencode -b" "mmencode -u -b")
5610 (b64 "recode data..base64" "recode base64..data")
5611 (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module)
5612 (b64 tramp-perl-encode tramp-perl-decode)
5613 (uu "uuencode xxx" "uudecode -o /dev/stdout")
5614 (uu "uuencode xxx" "uudecode -o -")
5615 (uu "uuencode xxx" "uudecode -p")
5616 (uu "uuencode xxx" tramp-uudecode)
5617 (pack
5618 "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
5619 "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
5620 "List of remote coding commands for inline transfer.
5621Each item is a list that looks like this:
5622
5623\(FORMAT ENCODING DECODING)
5624
5625FORMAT is symbol describing the encoding/decoding format. It can be
5626`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
5627
5628ENCODING and DECODING can be strings, giving commands, or symbols,
5629giving variables. If they are strings, then they can contain
5630the \"%s\" format specifier. If that specifier is present, the input
5631filename will be put into the command line at that spot. If the
5632specifier is not present, the input should be read from standard
5633input.
5634
5635If they are variables, this variable is a string containing a Perl
5636implementation for this functionality. This Perl program will be transferred
5637to the remote host, and it is avalible as shell function with the same name.")
5638
5639(defun tramp-find-inline-encoding (vec)
6473 "Find an inline transfer encoding that works. 5640 "Find an inline transfer encoding that works.
6474Goes through the list `tramp-coding-commands'." 5641Goes through the list `tramp-local-coding-commands' and
6475 (let ((commands tramp-coding-commands) 5642`tramp-remote-coding-commands'."
6476 (magic "xyzzy") 5643 (save-excursion
6477 item found) 5644 (let ((local-commands tramp-local-coding-commands)
6478 (while (and commands (null found)) 5645 (magic "xyzzy")
6479 (setq item (pop commands)) 5646 loc-enc loc-dec rem-enc rem-dec litem ritem found)
6480 (catch 'wont-work 5647 (while (and local-commands (not found))
6481 (let ((rem-enc (nth 0 item)) 5648 (setq litem (pop local-commands))
6482 (rem-dec (nth 1 item)) 5649 (catch 'wont-work-local
6483 (loc-enc (nth 2 item)) 5650 (let ((format (nth 0 litem))
6484 (loc-dec (nth 3 item))) 5651 (remote-commands tramp-remote-coding-commands))
6485 ;; Check if remote encoding and decoding commands can be 5652 (setq loc-enc (nth 1 litem))
6486 ;; called remotely with null input and output. This makes 5653 (setq loc-dec (nth 2 litem))
6487 ;; sure there are no syntax errors and the command is really 5654 ;; If the local encoder or decoder is a string, the
6488 ;; found. Note that we do not redirect stdout to /dev/null, 5655 ;; corresponding command has to work locally.
6489 ;; for two reaons: when checking the decoding command, we 5656 (if (not (stringp loc-enc))
6490 ;; actually check the output it gives. And also, when 5657 (tramp-message
6491 ;; redirecting "mimencode" output to /dev/null, then as root 5658 vec 5 "Checking local encoding function `%s'" loc-enc)
6492 ;; it might change the permissions of /dev/null! 5659 (tramp-message
6493 (tramp-message-for-buffer 5660 vec 5 "Checking local encoding command `%s' for sanity" loc-enc)
6494 multi-method method user host 9 5661 (unless (zerop (tramp-call-local-coding-command
6495 "Checking remote encoding command `%s' for sanity" rem-enc) 5662 loc-enc nil nil))
6496 (unless (zerop (tramp-send-command-and-check 5663 (throw 'wont-work-local nil)))
6497 multi-method method user host 5664 (if (not (stringp loc-dec))
6498 (format "%s </dev/null" rem-enc) t)) 5665 (tramp-message
6499 (throw 'wont-work nil)) 5666 vec 5 "Checking local decoding function `%s'" loc-dec)
6500 (tramp-message-for-buffer 5667 (tramp-message
6501 multi-method method user host 9 5668 vec 5 "Checking local decoding command `%s' for sanity" loc-dec)
6502 "Checking remote decoding command `%s' for sanity" rem-dec) 5669 (unless (zerop (tramp-call-local-coding-command
6503 (unless (zerop (tramp-send-command-and-check 5670 loc-dec nil nil))
6504 multi-method method user host 5671 (throw 'wont-work-local nil)))
6505 (format "echo %s | %s | %s" 5672 ;; Search for remote coding commands with the same format
6506 magic rem-enc rem-dec) t)) 5673 (while (and remote-commands (not found))
6507 (throw 'wont-work nil)) 5674 (setq ritem (pop remote-commands))
6508 (save-excursion 5675 (catch 'wont-work-remote
6509 (goto-char (point-min)) 5676 (when (equal format (nth 0 ritem))
6510 (unless (looking-at (regexp-quote magic)) 5677 (setq rem-enc (nth 1 ritem))
6511 (throw 'wont-work nil))) 5678 (setq rem-dec (nth 2 ritem))
6512 ;; If the local encoder or decoder is a string, the 5679 ;; Check if remote encoding and decoding commands can be
6513 ;; corresponding command has to work locally. 5680 ;; called remotely with null input and output. This makes
6514 (when (stringp loc-enc) 5681 ;; sure there are no syntax errors and the command is really
6515 (tramp-message-for-buffer 5682 ;; found. Note that we do not redirect stdout to /dev/null,
6516 multi-method method user host 9 5683 ;; for two reasons: when checking the decoding command, we
6517 "Checking local encoding command `%s' for sanity" loc-enc) 5684 ;; actually check the output it gives. And also, when
6518 (unless (zerop (tramp-call-local-coding-command 5685 ;; redirecting "mimencode" output to /dev/null, then as root
6519 loc-enc nil nil)) 5686 ;; it might change the permissions of /dev/null!
6520 (throw 'wont-work nil))) 5687 (when (not (stringp rem-enc))
6521 (when (stringp loc-dec) 5688 (let ((name (symbol-name rem-enc)))
6522 (tramp-message-for-buffer 5689 (while (string-match (regexp-quote "-") name)
6523 multi-method method user host 9 5690 (setq name (replace-match "_" nil t name)))
6524 "Checking local decoding command `%s' for sanity" loc-dec) 5691 (tramp-maybe-send-script vec (symbol-value rem-enc) name)
6525 (unless (zerop (tramp-call-local-coding-command 5692 (setq rem-enc name)))
6526 loc-dec nil nil)) 5693 (tramp-message
6527 (throw 'wont-work nil))) 5694 vec 5
6528 ;; CCC: At this point, maybe we should check that the output 5695 "Checking remote encoding command `%s' for sanity" rem-enc)
6529 ;; of the commands is correct. But for the moment we will 5696 (unless (zerop (tramp-send-command-and-check
6530 ;; assume that commands working on empty input will also 5697 vec (format "%s </dev/null" rem-enc) t))
6531 ;; work in practice. 5698 (throw 'wont-work-remote nil))
6532 (setq found item)))) 5699
6533 ;; Did we find something? If not, issue error. If so, 5700 (when (not (stringp rem-dec))
6534 ;; set connection properties. 5701 (let ((name (symbol-name rem-dec)))
6535 (unless found 5702 (while (string-match (regexp-quote "-") name)
6536 (error "Couldn't find an inline transfer encoding")) 5703 (setq name (replace-match "_" nil t name)))
6537 (let ((rem-enc (nth 0 found)) 5704 (tramp-maybe-send-script vec (symbol-value rem-dec) name)
6538 (rem-dec (nth 1 found)) 5705 (setq rem-dec name)))
6539 (loc-enc (nth 2 found)) 5706 (tramp-message
6540 (loc-dec (nth 3 found))) 5707 vec 5
6541 (tramp-message 10 "Using remote encoding %s" rem-enc) 5708 "Checking remote decoding command `%s' for sanity" rem-dec)
6542 (tramp-set-remote-encoding multi-method method user host rem-enc) 5709 (unless (zerop (tramp-send-command-and-check
6543 (tramp-message 10 "Using remote decoding %s" rem-dec) 5710 vec
6544 (tramp-set-remote-decoding multi-method method user host rem-dec) 5711 (format "echo %s | %s | %s"
6545 (tramp-message 10 "Using local encoding %s" loc-enc) 5712 magic rem-enc rem-dec) t))
6546 (tramp-set-local-encoding multi-method method user host loc-enc) 5713 (throw 'wont-work-remote nil))
6547 (tramp-message 10 "Using local decoding %s" loc-dec) 5714
6548 (tramp-set-local-decoding multi-method method user host loc-dec)))) 5715 (with-current-buffer (tramp-get-buffer vec)
5716 (goto-char (point-min))
5717 (unless (looking-at (regexp-quote magic))
5718 (throw 'wont-work-remote nil)))
5719
5720 ;; `rem-enc' and `rem-dec' could be a string meanwhile.
5721 (setq rem-enc (nth 1 ritem))
5722 (setq rem-dec (nth 2 ritem))
5723 (setq found t)))))))
5724
5725 ;; Did we find something? If not, issue an error.
5726 (unless found
5727 (kill-process (tramp-get-connection-process vec))
5728 (tramp-error
5729 vec 'file-error "Couldn't find an inline transfer encoding"))
5730
5731 ;; Set connection properties.
5732 (tramp-message vec 5 "Using local encoding `%s'" loc-enc)
5733 (tramp-set-connection-property vec "local-encoding" loc-enc)
5734 (tramp-message vec 5 "Using local decoding `%s'" loc-dec)
5735 (tramp-set-connection-property vec "local-decoding" loc-dec)
5736 (tramp-message vec 5 "Using remote encoding `%s'" rem-enc)
5737 (tramp-set-connection-property vec "remote-encoding" rem-enc)
5738 (tramp-message vec 5 "Using remote decoding `%s'" rem-dec)
5739 (tramp-set-connection-property vec "remote-decoding" rem-dec))))
6549 5740
6550(defun tramp-call-local-coding-command (cmd input output) 5741(defun tramp-call-local-coding-command (cmd input output)
6551 "Call the local encoding or decoding command. 5742 "Call the local encoding or decoding command.
@@ -6555,25 +5746,114 @@ INPUT can also be nil which means `/dev/null'.
6555OUTPUT can be a string (which specifies a filename), or t (which 5746OUTPUT can be a string (which specifies a filename), or t (which
6556means standard output and thus the current buffer), or nil (which 5747means standard output and thus the current buffer), or nil (which
6557means discard it)." 5748means discard it)."
6558 (call-process 5749 (let ((default-directory (tramp-temporary-file-directory)))
6559 tramp-encoding-shell ;program 5750 (call-process
6560 (when (and input (not (string-match "%s" cmd))) 5751 tramp-encoding-shell ;program
6561 input) ;input 5752 (when (and input (not (string-match "%s" cmd)))
6562 (if (eq output t) t nil) ;output 5753 input) ;input
6563 nil ;redisplay 5754 (if (eq output t) t nil) ;output
6564 tramp-encoding-command-switch 5755 nil ;redisplay
6565 ;; actual shell command 5756 tramp-encoding-command-switch
6566 (concat 5757 ;; actual shell command
6567 (if (string-match "%s" cmd) (format cmd input) cmd) 5758 (concat
6568 (if (stringp output) (concat "> " output) "")))) 5759 (if (string-match "%s" cmd) (format cmd input) cmd)
6569 5760 (if (stringp output) (concat "> " output) "")))))
6570(defun tramp-maybe-open-connection (multi-method method user host) 5761
6571 "Maybe open a connection to HOST, logging in as USER, using METHOD. 5762(defun tramp-compute-multi-hops (vec)
5763 "Expands VEC according to `tramp-default-proxies-alist'.
5764Gateway hops are already opened."
5765 (let ((target-alist `(,vec))
5766 (choices tramp-default-proxies-alist)
5767 item proxy)
5768
5769 ;; Look for proxy hosts to be passed.
5770 (while choices
5771 (setq item (pop choices)
5772 proxy (nth 2 item))
5773 (when (and
5774 ;; host
5775 (string-match (or (nth 0 item) "")
5776 (or (tramp-file-name-host (car target-alist)) ""))
5777 ;; user
5778 (string-match (or (nth 1 item) "")
5779 (or (tramp-file-name-user (car target-alist)) "")))
5780 (if (null proxy)
5781 ;; No more hops needed.
5782 (setq choices nil)
5783 ;; Replace placeholders.
5784 (setq proxy
5785 (format-spec
5786 proxy
5787 `((?u . ,(or (tramp-file-name-user (car target-alist)) ""))
5788 (?h . ,(or (tramp-file-name-host (car target-alist)) "")))))
5789 (with-parsed-tramp-file-name proxy l
5790 ;; Add the hop.
5791 (add-to-list 'target-alist l)
5792 ;; Start next search.
5793 (setq choices tramp-default-proxies-alist)))))
5794
5795 ;; Handle gateways.
5796 (when (string-match (format
5797 "^\\(%s\\|%s\\)$"
5798 tramp-gw-tunnel-method tramp-gw-socks-method)
5799 (tramp-file-name-method (car target-alist)))
5800 (let ((gw (pop target-alist))
5801 (hop (pop target-alist)))
5802 ;; Is the method prepared for gateways?
5803 (unless (tramp-get-method-parameter
5804 (tramp-file-name-method hop) 'tramp-default-port)
5805 (tramp-error
5806 vec 'file-error
5807 "Method `%s' is not supported for gateway access."
5808 (tramp-file-name-method hop)))
5809 ;; Add default port if needed.
5810 (unless
5811 (string-match
5812 tramp-host-with-port-regexp (tramp-file-name-host hop))
5813 (aset hop 2
5814 (concat
5815 (tramp-file-name-host hop) tramp-prefix-port-format
5816 (number-to-string
5817 (tramp-get-method-parameter
5818 (tramp-file-name-method hop) 'tramp-default-port)))))
5819 ;; Open the gateway connection.
5820 (add-to-list
5821 'target-alist
5822 (vector
5823 (tramp-file-name-method hop) (tramp-file-name-user hop)
5824 (tramp-gw-open-connection vec gw hop) nil))
5825 ;; For the password prompt, we need the correct values.
5826 ;; Therefore, we must remember the gateway vector. But we
5827 ;; cannot do it as connection property, because it shouldn't
5828 ;; be persistent. And we have no started process yet either.
5829 (tramp-set-file-property (car target-alist) "" "gateway" hop)))
5830
5831 ;; Foreign and out-of-band methods are not supported for multi-hops.
5832 (when (cdr target-alist)
5833 (setq choices target-alist)
5834 (while choices
5835 (setq item (pop choices))
5836 (when
5837 (or
5838 (not
5839 (tramp-get-method-parameter
5840 (tramp-file-name-method item) 'tramp-login-program))
5841 (tramp-get-method-parameter
5842 (tramp-file-name-method item) 'tramp-copy-program))
5843 (tramp-error
5844 vec 'file-error
5845 "Method `%s' is not supported for multi-hops."
5846 (tramp-file-name-method item)))))
5847
5848 ;; Result.
5849 target-alist))
5850
5851(defun tramp-maybe-open-connection (vec)
5852 "Maybe open a connection VEC.
6572Does not do anything if a connection is already open, but re-opens the 5853Does not do anything if a connection is already open, but re-opens the
6573connection if a previous connection has died for some reason." 5854connection if a previous connection has died for some reason."
6574 (let ((p (get-buffer-process 5855 (let ((p (tramp-get-connection-process vec)))
6575 (tramp-get-buffer multi-method method user host))) 5856
6576 last-cmd-time)
6577 ;; If too much time has passed since last command was sent, look 5857 ;; If too much time has passed since last command was sent, look
6578 ;; whether process is still alive. If it isn't, kill it. When 5858 ;; whether process is still alive. If it isn't, kill it. When
6579 ;; using ssh, it can sometimes happen that the remote end has hung 5859 ;; using ssh, it can sometimes happen that the remote end has hung
@@ -6581,239 +5861,276 @@ connection if a previous connection has died for some reason."
6581 ;; tries to send some data to the remote end. So that's why we 5861 ;; tries to send some data to the remote end. So that's why we
6582 ;; try to send a command from time to time, then look again 5862 ;; try to send a command from time to time, then look again
6583 ;; whether the process is really alive. 5863 ;; whether the process is really alive.
6584 (save-excursion 5864 (when (and (> (tramp-time-diff
6585 (set-buffer (tramp-get-buffer multi-method method user host)) 5865 (current-time)
6586 (when (and tramp-last-cmd-time 5866 (tramp-get-connection-property p "last-cmd-time" '(0 0 0)))
6587 (> (tramp-time-diff (current-time) tramp-last-cmd-time) 60) 5867 60)
6588 p (processp p) (memq (process-status p) '(run open))) 5868 p (processp p) (memq (process-status p) '(run open)))
6589 (tramp-send-command 5869 (tramp-send-command vec "echo are you awake" t t)
6590 multi-method method user host "echo are you awake" nil t) 5870 (unless (and (memq (process-status p) '(run open))
6591 (unless (and (memq (process-status p) '(run open)) 5871 (tramp-wait-for-output p 10))
6592 (tramp-wait-for-output 10)) 5872 (delete-process p)
6593 (delete-process p) 5873 (setq p nil)))
6594 (setq p nil)) 5874
6595 (erase-buffer))) 5875 ;; New connection must be opened.
6596 (unless (and p (processp p) (memq (process-status p) '(run open))) 5876 (unless (and p (processp p) (memq (process-status p) '(run open)))
5877
5878 ;; We call `tramp-get-buffer' in order to get a debug buffer for
5879 ;; messages from the beginning.
5880 (tramp-get-buffer vec)
5881 (if (zerop (length (tramp-file-name-user vec)))
5882 (tramp-message
5883 vec 3 "Opening connection for %s using %s..."
5884 (tramp-file-name-host vec)
5885 (tramp-file-name-method vec))
5886 (tramp-message
5887 vec 3 "Opening connection for %s@%s using %s..."
5888 (tramp-file-name-user vec)
5889 (tramp-file-name-host vec)
5890 (tramp-file-name-method vec)))
5891
5892 ;; Start new process.
6597 (when (and p (processp p)) 5893 (when (and p (processp p))
6598 (delete-process p)) 5894 (delete-process p))
6599 (let ((process-connection-type tramp-process-connection-type)) 5895 (setenv "TERM" tramp-terminal-type)
6600 (funcall (tramp-get-method-parameter 5896 (setenv "PS1" "$ ")
6601 multi-method 5897 (let* ((target-alist (tramp-compute-multi-hops vec))
6602 (tramp-find-method multi-method method user host) 5898 (process-environment (copy-sequence process-environment))
6603 user host 'tramp-connection-function) 5899 (process-connection-type tramp-process-connection-type)
6604 multi-method method user host))))) 5900 (coding-system-for-read nil)
6605 5901 ;; This must be done in order to avoid our file name handler.
6606(defun tramp-send-command 5902 (p (let ((default-directory (tramp-temporary-file-directory)))
6607 (multi-method method user host command &optional noerase neveropen) 5903 (start-process
6608 "Send the COMMAND to USER at HOST (logged in using METHOD). 5904 (or (tramp-get-connection-property vec "process-name" nil)
6609Erases temporary buffer before sending the command (unless NOERASE 5905 (tramp-buffer-name vec))
6610is true). 5906 (tramp-get-connection-buffer vec)
6611If optional seventh arg NEVEROPEN is non-nil, never try to open the 5907 tramp-encoding-shell)))
6612connection. This is meant to be used from 5908 (first-hop t))
6613`tramp-maybe-open-connection' only." 5909
6614 (or neveropen 5910 (tramp-message
6615 (tramp-maybe-open-connection multi-method method user host)) 5911 vec 6 "%s" (mapconcat 'identity (process-command p) " "))
6616 (setq tramp-last-cmd-time (current-time)) 5912
6617 (setq tramp-last-cmd command) 5913 ;; Check whether process is alive.
6618 (when tramp-debug-buffer 5914 (set-process-sentinel p 'tramp-flush-connection-property)
6619 (save-excursion 5915 (tramp-set-process-query-on-exit-flag p nil)
6620 (set-buffer (tramp-get-debug-buffer multi-method method user host)) 5916 (tramp-message vec 3 "Waiting 60s for local shell to come up...")
6621 (goto-char (point-max)) 5917 (tramp-barf-if-no-shell-prompt
6622 (tramp-insert-with-face 'bold (format "$ %s\n" command)))) 5918 p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell)
6623 (let ((proc nil)) 5919
6624 (set-buffer (tramp-get-buffer multi-method method user host)) 5920 ;; Now do all the connections as specified.
6625 (unless noerase (erase-buffer)) 5921 (while target-alist
6626 (setq proc (get-buffer-process (current-buffer))) 5922 (let* ((hop (car target-alist))
6627 (process-send-string proc 5923 (l-method (tramp-file-name-method hop))
6628 (concat command tramp-rsh-end-of-line)))) 5924 (l-user (tramp-file-name-user hop))
6629 5925 (l-host (tramp-file-name-host hop))
6630(defun tramp-send-command-internal 5926 (l-port nil)
6631 (multi-method method user host command &optional msg) 5927 (login-program
5928 (tramp-get-method-parameter l-method 'tramp-login-program))
5929 (login-args
5930 (tramp-get-method-parameter l-method 'tramp-login-args))
5931 (gw-args
5932 (tramp-get-method-parameter l-method 'tramp-gw-args))
5933 (gw (tramp-get-file-property hop "" "gateway" nil))
5934 (g-method (and gw (tramp-file-name-method gw)))
5935 (g-user (and gw (tramp-file-name-user gw)))
5936 (g-host (and gw (tramp-file-name-host gw)))
5937 (command login-program)
5938 spec)
5939
5940 ;; Add gateway arguments if necessary.
5941 (when (and gw gw-args)
5942 (setq login-args (append login-args gw-args)))
5943
5944 ;; Check for port number. Until now, there's no need for handling
5945 ;; like method, user, host.
5946 (when (string-match tramp-host-with-port-regexp l-host)
5947 (setq l-port (match-string 2 l-host)
5948 l-host (match-string 1 l-host)))
5949
5950 ;; Set variables for computing the prompt for reading password.
5951 ;; They can also be derived from a gatewy.
5952 (setq tramp-current-method (or g-method l-method)
5953 tramp-current-user (or g-user l-user)
5954 tramp-current-host (or g-host l-host))
5955
5956 ;; Replace login-args place holders.
5957 (setq
5958 l-host (or l-host "")
5959 l-user (or l-user "")
5960 l-port (or l-port "")
5961 spec `((?h . ,l-host) (?u . ,l-user) (?p . ,l-port)
5962 (?t . ,(tramp-make-tramp-temp-file vec)))
5963 command
5964 (concat
5965 command " "
5966 (mapconcat
5967 '(lambda (x)
5968 (setq x (mapcar '(lambda (y) (format-spec y spec)) x))
5969 (unless (member "" x) (mapconcat 'identity x " ")))
5970 login-args " ")
5971 ;; String to detect failed connection. Every single word must
5972 ;; be enclosed with '\"'; otherwise it is detected
5973 ;; during connection setup.
5974 ;; Local shell could be a Windows COMSPEC. It doesn't know
5975 ;; the ";" syntax, but we must exit always for `start-process'.
5976 ;; "exec" does not work either.
5977 (if first-hop
5978 " && exit || exit"
5979 "; echo \"Tramp\" \"connection\" \"closed\"; sleep 1"))
5980 ;; We don't reach a Windows shell. Could be initial only.
5981 first-hop nil)
5982
5983 ;; Send the command.
5984 (tramp-message vec 3 "Sending command `%s'" command)
5985 (tramp-send-command vec command t t)
5986 (tramp-process-actions p vec tramp-actions-before-shell 60)
5987 (tramp-message vec 3 "Found remote shell prompt on `%s'" l-host))
5988 ;; Next hop.
5989 (setq target-alist (cdr target-alist)))
5990
5991 ;; Make initial shell settings.
5992 (tramp-open-connection-setup-interactive-shell p vec)))))
5993
5994(defun tramp-send-command (vec command &optional neveropen nooutput)
5995 "Send the COMMAND to connection VEC.
5996Erases temporary buffer before sending the command. If optional
5997arg NEVEROPEN is non-nil, never try to open the connection. This
5998is meant to be used from `tramp-maybe-open-connection' only. The
5999function waits for output unless NOOUTPUT is set."
6000 (unless neveropen (tramp-maybe-open-connection vec))
6001 (let ((p (tramp-get-connection-process vec)))
6002 (when (tramp-get-connection-property vec "remote-echo" nil)
6003 ;; We mark the command string that it can be erased in the output buffer.
6004 (tramp-set-connection-property p "check-remote-echo" t)
6005 (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark)))
6006 (tramp-message vec 6 "%s" command)
6007 (tramp-send-string vec command)
6008 (unless nooutput (tramp-wait-for-output p))))
6009
6010(defun tramp-send-command-internal (vec command)
6632 "Send command to remote host and wait for success. 6011 "Send command to remote host and wait for success.
6633Sends COMMAND, then waits 30 seconds for shell prompt." 6012Sends COMMAND, then waits 30 seconds for shell prompt."
6634 (tramp-send-command multi-method method user host command t t) 6013 (let ((p (tramp-get-connection-process vec)))
6635 (when msg 6014 (when (tramp-get-connection-property vec "remote-echo" nil)
6636 (tramp-message 9 "Waiting 30s for %s..." msg)) 6015 ;; We mark the command string that it can be erased in the output buffer.
6637 (tramp-barf-if-no-shell-prompt 6016 (tramp-set-connection-property p "check-remote-echo" t)
6638 nil 30 6017 (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark)))
6639 "Couldn't `%s', see buffer `%s'" command (buffer-name))) 6018 (tramp-message vec 6 "%s" command)
6640 6019 (tramp-send-string vec command)
6641(defun tramp-wait-for-output (&optional timeout) 6020 (tramp-barf-if-no-shell-prompt
6021 p 30 "Couldn't `%s', see buffer `%s'" command (buffer-name))))
6022
6023(defun tramp-wait-for-output (proc &optional timeout)
6642 "Wait for output from remote rsh command." 6024 "Wait for output from remote rsh command."
6643 (let ((proc (get-buffer-process (current-buffer))) 6025 (with-current-buffer (process-buffer proc)
6644 (found nil) 6026 (let ((found
6645 (start-time (current-time)) 6027 (tramp-wait-for-regexp
6646 (start-point (point)) 6028 proc timeout
6647 (end-of-output (concat "^" 6029 (format "^%s\r?$" (regexp-quote tramp-end-of-output)))))
6648 (regexp-quote tramp-end-of-output) 6030 (if found
6649 "\r?$"))) 6031 (let (buffer-read-only)
6650 ;; Algorithm: get waiting output. See if last line contains 6032 (goto-char (point-max))
6651 ;; end-of-output sentinel. If not, wait a bit and again get 6033 (forward-line -2)
6652 ;; waiting output. Repeat until timeout expires or end-of-output 6034 (delete-region (point) (point-max)))
6653 ;; sentinel is seen. Will hang if timeout is nil and 6035 (if timeout
6654 ;; end-of-output sentinel never appears. 6036 (tramp-error
6655 (save-match-data 6037 proc 'file-error
6656 (cond (timeout 6038 "[[Remote prompt `%s' not found in %d secs]]"
6657 ;; Work around an XEmacs bug, where the timeout expires 6039 tramp-end-of-output timeout)
6658 ;; faster than it should. This degenerates into polling 6040 (tramp-error
6659 ;; for buggy XEmacsen, but oh, well. 6041 proc 'file-error
6660 (while (and (not found) 6042 "[[Remote prompt `%s' not found]]" tramp-end-of-output)))
6661 (< (tramp-time-diff (current-time) start-time) 6043 ;; Return value is whether end-of-output sentinel was found.
6662 timeout)) 6044 found)))
6663 (with-timeout (timeout)
6664 (while (not found)
6665 (tramp-accept-process-output proc 1)
6666 (unless (memq (process-status proc) '(run open))
6667 (error "Process has died"))
6668 (goto-char (point-max))
6669 (forward-line -1)
6670 (setq found (looking-at end-of-output))))))
6671 (t
6672 (while (not found)
6673 (tramp-accept-process-output proc 1)
6674 (unless (memq (process-status proc) '(run open))
6675 (error "Process has died"))
6676 (goto-char (point-max))
6677 (forward-line -1)
6678 (setq found (looking-at end-of-output))))))
6679 ;; At this point, either the timeout has expired or we have found
6680 ;; the end-of-output sentinel.
6681 (when found
6682 (goto-char (point-max))
6683 (forward-line -2)
6684 (delete-region (point) (point-max)))
6685 ;; If processing echoes, look for it in the first line and delete.
6686 (when tramp-process-echoes
6687 (save-excursion
6688 (goto-char start-point)
6689 (when (looking-at (regexp-quote tramp-last-cmd))
6690 (delete-region (point) (progn (forward-line 1) (point))))))
6691 ;; Add output to debug buffer if appropriate.
6692 (when tramp-debug-buffer
6693 (append-to-buffer
6694 (tramp-get-debug-buffer tramp-current-multi-method tramp-current-method
6695 tramp-current-user tramp-current-host)
6696 (point-min) (point-max))
6697 (when (not found)
6698 (save-excursion
6699 (set-buffer
6700 (tramp-get-debug-buffer tramp-current-multi-method tramp-current-method
6701 tramp-current-user tramp-current-host))
6702 (goto-char (point-max))
6703 (insert "[[Remote prompt `" end-of-output "' not found"
6704 (if timeout (format " in %d secs" timeout) "")
6705 "]]"))))
6706 (goto-char (point-min))
6707 ;; Return value is whether end-of-output sentinel was found.
6708 found))
6709 6045
6710(defun tramp-send-command-and-check (multi-method method user host command 6046(defun tramp-send-command-and-check (vec command &optional subshell)
6711 &optional subshell)
6712 "Run COMMAND and check its exit status. 6047 "Run COMMAND and check its exit status.
6713MULTI-METHOD and METHOD specify how to log in (as USER) to the remote HOST.
6714Sends `echo $?' along with the COMMAND for checking the exit status. If 6048Sends `echo $?' along with the COMMAND for checking the exit status. If
6715COMMAND is nil, just sends `echo $?'. Returns the exit status found. 6049COMMAND is nil, just sends `echo $?'. Returns the exit status found.
6716 6050
6717If the optional argument SUBSHELL is non-nil, the command is executed in 6051If the optional argument SUBSHELL is non-nil, the command is executed in
6718a subshell, ie surrounded by parentheses." 6052a subshell, ie surrounded by parentheses."
6719 (tramp-send-command multi-method method user host 6053 (tramp-send-command
6720 (concat (if subshell "( " "") 6054 vec
6721 command 6055 (concat (if subshell "( " "")
6722 (if command " 2>/dev/null; " "") 6056 command
6723 "echo tramp_exit_status $?" 6057 (if command " 2>/dev/null; " "")
6724 (if subshell " )" " "))) 6058 "echo tramp_exit_status $?"
6725 (tramp-wait-for-output) 6059 (if subshell " )" " ")))
6726 (goto-char (point-max)) 6060 (with-current-buffer (tramp-get-connection-buffer vec)
6727 (unless (search-backward "tramp_exit_status " nil t) 6061 (goto-char (point-max))
6728 (error "Couldn't find exit status of `%s'" command)) 6062 (unless (re-search-backward "tramp_exit_status [0-9]+" nil t)
6729 (skip-chars-forward "^ ") 6063 (tramp-error
6730 (read (current-buffer))) 6064 vec 'file-error "Couldn't find exit status of `%s'" command))
6731 6065 (skip-chars-forward "^ ")
6732(defun tramp-barf-unless-okay (multi-method method user host command subshell 6066 (prog1
6733 signal fmt &rest args) 6067 (read (current-buffer))
6068 (let (buffer-read-only) (delete-region (match-beginning 0) (point-max))))))
6069
6070(defun tramp-barf-unless-okay (vec command fmt &rest args)
6734 "Run COMMAND, check exit status, throw error if exit status not okay. 6071 "Run COMMAND, check exit status, throw error if exit status not okay.
6735Similar to `tramp-send-command-and-check' but accepts two more arguments 6072Similar to `tramp-send-command-and-check' but accepts two more arguments
6736FMT and ARGS which are passed to `error'." 6073FMT and ARGS which are passed to `error'."
6737 (unless (zerop (tramp-send-command-and-check 6074 (unless (zerop (tramp-send-command-and-check vec command))
6738 multi-method method user host command subshell)) 6075 (apply 'tramp-error vec 'file-error fmt args)))
6739 ;; CCC: really pop-to-buffer? Maybe it's appropriate to be more 6076
6740 ;; silent. 6077(defun tramp-send-command-and-read (vec command)
6741 (pop-to-buffer (current-buffer)) 6078 "Run COMMAND and return the output, which must be a Lisp expression.
6742 (funcall 'signal signal (apply 'format fmt args)))) 6079In case there is no valid Lisp expression, it raises an error"
6080 (tramp-barf-unless-okay vec command "`%s' returns with error" command)
6081 (with-current-buffer (tramp-get-connection-buffer vec)
6082 ;; Read the expression.
6083 (goto-char (point-min))
6084 (condition-case nil
6085 (prog1 (read (current-buffer))
6086 ;; Error handling.
6087 (when (re-search-forward "\\S-" nil t) (error)))
6088 (error (tramp-error
6089 vec 'file-error
6090 "`%s' does not return a valid Lisp expression: `%s'"
6091 command (buffer-string))))))
6743 6092
6744;; It seems that Tru64 Unix does not like it if long strings are sent 6093;; It seems that Tru64 Unix does not like it if long strings are sent
6745;; to it in one go. (This happens when sending the Perl 6094;; to it in one go. (This happens when sending the Perl
6746;; `file-attributes' implementation, for instance.) Therefore, we 6095;; `file-attributes' implementation, for instance.) Therefore, we
6747;; have this function which waits a bit at each line. 6096;; have this function which waits a bit at each line.
6748(defun tramp-send-string 6097(defun tramp-send-string (vec string)
6749 (multi-method method user host string) 6098 "Send the STRING via connection VEC.
6750 "Send the STRING to USER at HOST using METHOD.
6751 6099
6752The STRING is expected to use Unix line-endings, but the lines sent to 6100The STRING is expected to use Unix line-endings, but the lines sent to
6753the remote host use line-endings as defined in the variable 6101the remote host use line-endings as defined in the variable
6754`tramp-rsh-end-of-line'." 6102`tramp-rsh-end-of-line'. The communication buffer is erased before sending."
6755 (let ((proc (get-buffer-process 6103 (let* ((p (tramp-get-connection-process vec))
6756 (tramp-get-buffer multi-method method user host)))) 6104 (chunksize (tramp-get-connection-property p "chunksize" nil)))
6757 (unless proc 6105 (unless p
6758 (error "Can't send string to remote host -- not logged in")) 6106 (tramp-error
6759 ;; debug message 6107 vec 'file-error "Can't send string to remote host -- not logged in"))
6760 (when tramp-debug-buffer 6108 (tramp-set-connection-property p "last-cmd-time" (current-time))
6761 (save-excursion 6109 (tramp-message vec 10 "%s" string)
6762 (set-buffer (tramp-get-debug-buffer multi-method method user host)) 6110 (with-current-buffer (tramp-get-connection-buffer vec)
6763 (goto-char (point-max)) 6111 ;; Clean up the buffer. We cannot call `erase-buffer' because
6764 (tramp-insert-with-face 'bold (format "$ %s\n" string)))) 6112 ;; narrowing might be in effect.
6765 ;; replace "\n" by `tramp-rsh-end-of-line' 6113 (let (buffer-read-only) (delete-region (point-min) (point-max)))
6766 (setq string 6114 ;; replace "\n" by `tramp-rsh-end-of-line'
6767 (mapconcat 'identity 6115 (setq string
6768 (split-string string "\n") 6116 (mapconcat 'identity
6769 tramp-rsh-end-of-line)) 6117 (split-string string "\n")
6770 (unless (or (string= string "") 6118 tramp-rsh-end-of-line))
6771 (string-equal (substring string -1) tramp-rsh-end-of-line)) 6119 (unless (or (string= string "")
6772 (setq string (concat string tramp-rsh-end-of-line))) 6120 (string-equal (substring string -1) tramp-rsh-end-of-line))
6773 ;; send the string 6121 (setq string (concat string tramp-rsh-end-of-line)))
6774 (if (and tramp-chunksize (not (zerop tramp-chunksize))) 6122 ;; send the string
6775 (let ((pos 0) 6123 (if (and chunksize (not (zerop chunksize)))
6776 (end (length string))) 6124 (let ((pos 0)
6777 (while (< pos end) 6125 (end (length string)))
6778 (tramp-message-for-buffer 6126 (while (< pos end)
6779 multi-method method user host 10 6127 (tramp-message
6780 "Sending chunk from %s to %s" 6128 vec 10 "Sending chunk from %s to %s"
6781 pos (min (+ pos tramp-chunksize) end)) 6129 pos (min (+ pos chunksize) end))
6782 (process-send-string 6130 (process-send-string
6783 proc (substring string pos (min (+ pos tramp-chunksize) end))) 6131 p (substring string pos (min (+ pos chunksize) end)))
6784 (setq pos (+ pos tramp-chunksize)) 6132 (setq pos (+ pos chunksize))))
6785 (sleep-for 0.1))) 6133 (process-send-string p string)))))
6786 (process-send-string proc string))))
6787
6788(defun tramp-send-eof (multi-method method user host)
6789 "Send EOF to the remote end.
6790METHOD, HOST and USER specify the connection."
6791 (let ((proc (get-buffer-process
6792 (tramp-get-buffer multi-method method user host))))
6793 (unless proc
6794 (error "Can't send EOF to remote host -- not logged in"))
6795 (process-send-eof proc)))
6796; (process-send-string proc "\^D")))
6797
6798(defun tramp-kill-process (multi-method method user host)
6799 "Kill the connection process used by Tramp.
6800MULTI-METHOD, METHOD, USER, and HOST specify the connection."
6801 (let ((proc (get-buffer-process
6802 (tramp-get-buffer multi-method method user host))))
6803 (kill-process proc)))
6804
6805(defun tramp-discard-garbage-erase-buffer (p multi-method method user host)
6806 "Erase buffer, then discard subsequent garbage.
6807If `tramp-discard-garbage' is nil, just erase buffer."
6808 (if (not tramp-discard-garbage)
6809 (erase-buffer)
6810 (while (prog1 (erase-buffer) (tramp-accept-process-output p 0.25))
6811 (when tramp-debug-buffer
6812 (save-excursion
6813 (set-buffer (tramp-get-debug-buffer multi-method method user host))
6814 (goto-char (point-max))
6815 (tramp-insert-with-face
6816 'bold (format "Additional characters detected\n")))))))
6817 6134
6818(defun tramp-mode-string-to-int (mode-string) 6135(defun tramp-mode-string-to-int (mode-string)
6819 "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." 6136 "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits."
@@ -6886,27 +6203,70 @@ If `tramp-discard-garbage' is nil, just erase buffer."
6886 (t (error "Tenth char `%c' must be one of `xtT-'" 6203 (t (error "Tenth char `%c' must be one of `xtT-'"
6887 other-execute-or-sticky))))))) 6204 other-execute-or-sticky)))))))
6888 6205
6889(defun tramp-convert-file-attributes (multi-method method user host attr) 6206(defun tramp-convert-file-attributes (vec attr)
6890 "Convert file-attributes ATTR generated by perl script or ls. 6207 "Convert file-attributes ATTR generated by perl script, stat or ls.
6891Convert file mode bits to string and set virtual device number. 6208Convert file mode bits to string and set virtual device number.
6892Return ATTR." 6209Return ATTR."
6210 ;; Convert last access time.
6211 (unless (listp (nth 4 attr))
6212 (setcar (nthcdr 4 attr)
6213 (list (floor (nth 4 attr) 65536)
6214 (floor (mod (nth 4 attr) 65536)))))
6215 ;; Convert last modification time.
6216 (unless (listp (nth 5 attr))
6217 (setcar (nthcdr 5 attr)
6218 (list (floor (nth 5 attr) 65536)
6219 (floor (mod (nth 5 attr) 65536)))))
6220 ;; Convert last status change time.
6221 (unless (listp (nth 6 attr))
6222 (setcar (nthcdr 6 attr)
6223 (list (floor (nth 6 attr) 65536)
6224 (floor (mod (nth 6 attr) 65536)))))
6893 ;; Convert file mode bits to string. 6225 ;; Convert file mode bits to string.
6894 (unless (stringp (nth 8 attr)) 6226 (unless (stringp (nth 8 attr))
6895 (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr)))) 6227 (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))))
6896 ;; Set file's gid change bit. Possible only when id-format is 'integer. 6228 ;; Convert directory indication bit.
6897 (when (numberp (nth 3 attr)) 6229 (if (string-match "^d" (nth 8 attr))
6898 (setcar (nthcdr 9 attr) 6230 (setcar attr t)
6899 (not (eql (nth 3 attr) 6231 (if (and (listp (car attr)) (stringp (caar attr))
6900 (tramp-get-remote-gid multi-method method user host))))) 6232 (string-match ".+ -> .\\(.+\\)." (caar attr)))
6233 (setcar attr (match-string 1 (caar attr)))
6234 (setcar attr nil)))
6235 ;; Set file's gid change bit.
6236 (setcar (nthcdr 9 attr)
6237 (if (numberp (nth 3 attr))
6238 (not (= (nth 3 attr)
6239 (tramp-get-remote-gid vec 'integer)))
6240 (not (string-equal
6241 (nth 3 attr)
6242 (tramp-get-remote-gid vec 'string)))))
6243 ;; Convert inode.
6244 (unless (listp (nth 10 attr))
6245 (setcar (nthcdr 10 attr)
6246 (list (floor (nth 10 attr) 65536)
6247 (floor (mod (nth 10 attr) 65536)))))
6901 ;; Set virtual device number. 6248 ;; Set virtual device number.
6902 (setcar (nthcdr 11 attr) 6249 (setcar (nthcdr 11 attr)
6903 (tramp-get-device multi-method method user host)) 6250 (tramp-get-device vec))
6904 attr) 6251 attr)
6905 6252
6906(defun tramp-get-device (multi-method method user host) 6253(defun tramp-get-inode (file)
6254 "Returns the virtual inode number.
6255If it doesn't exist, generate a new one."
6256 (let ((string (directory-file-name file)))
6257 (unless (assoc string tramp-inodes)
6258 (add-to-list 'tramp-inodes
6259 (list string (length tramp-inodes))))
6260 (nth 1 (assoc string tramp-inodes))))
6261
6262(defun tramp-get-device (vec)
6907 "Returns the virtual device number. 6263 "Returns the virtual device number.
6908If it doesn't exist, generate a new one." 6264If it doesn't exist, generate a new one."
6909 (let ((string (tramp-make-tramp-file-name multi-method method user host ""))) 6265 (let ((string (tramp-make-tramp-file-name
6266 (tramp-file-name-method vec)
6267 (tramp-file-name-user vec)
6268 (tramp-file-name-host vec)
6269 "")))
6910 (unless (assoc string tramp-devices) 6270 (unless (assoc string tramp-devices)
6911 (add-to-list 'tramp-devices 6271 (add-to-list 'tramp-devices
6912 (list string (length tramp-devices)))) 6272 (list string (length tramp-devices))))
@@ -6926,7 +6286,6 @@ If it doesn't exist, generate a new one."
6926 (setq other (tramp-file-mode-permissions other sticky "t")) 6286 (setq other (tramp-file-mode-permissions other sticky "t"))
6927 (concat type user group other))) 6287 (concat type user group other)))
6928 6288
6929
6930(defun tramp-file-mode-permissions (perm suid suid-text) 6289(defun tramp-file-mode-permissions (perm suid suid-text)
6931 "Convert a permission bitset into a string. 6290 "Convert a permission bitset into a string.
6932This is used internally by `tramp-file-mode-from-int'." 6291This is used internally by `tramp-file-mode-from-int'."
@@ -6939,7 +6298,6 @@ This is used internally by `tramp-file-mode-from-int'."
6939 (and suid (upcase suid-text)) ; suid, !execute 6298 (and suid (upcase suid-text)) ; suid, !execute
6940 (and x "x") "-")))) ; !suid 6299 (and x "x") "-")))) ; !suid
6941 6300
6942
6943(defun tramp-decimal-to-octal (i) 6301(defun tramp-decimal-to-octal (i)
6944 "Return a string consisting of the octal digits of I. 6302 "Return a string consisting of the octal digits of I.
6945Not actually used. Use `(format \"%o\" i)' instead?" 6303Not actually used. Use `(format \"%o\" i)' instead?"
@@ -6950,16 +6308,6 @@ Not actually used. Use `(format \"%o\" i)' instead?"
6950 (number-to-string (% i 8)))))) 6308 (number-to-string (% i 8))))))
6951 6309
6952 6310
6953;;(defun tramp-octal-to-decimal (ostr)
6954;; "Given a string of octal digits, return a decimal number."
6955;; (cond ((null ostr) 0)
6956;; ((string= "" ostr) 0)
6957;; (t (let ((last (aref ostr (1- (length ostr))))
6958;; (rest (substring ostr 0 (1- (length ostr)))))
6959;; (unless (and (>= last ?0)
6960;; (<= last ?7))
6961;; (error "Not an octal digit: %c" last))
6962;; (+ (- last ?0) (* 8 (tramp-octal-to-decimal rest)))))))
6963;; Kudos to Gerd Moellmann for this suggestion. 6311;; Kudos to Gerd Moellmann for this suggestion.
6964(defun tramp-octal-to-decimal (ostr) 6312(defun tramp-octal-to-decimal (ostr)
6965 "Given a string of octal digits, return a decimal number." 6313 "Given a string of octal digits, return a decimal number."
@@ -6987,289 +6335,368 @@ Not actually used. Use `(format \"%o\" i)' instead?"
6987;; internal data structure. Convenience functions for internal 6335;; internal data structure. Convenience functions for internal
6988;; data structure. 6336;; data structure.
6989 6337
6990(defun tramp-file-name-p (obj) 6338(defun tramp-file-name-p (vec)
6991 "Check whether TRAMP-FILE-NAME is a Tramp object." 6339 "Check whether VEC is a Tramp object."
6992 (and (vectorp obj) (= 5 (length obj)))) 6340 (and (vectorp vec) (= 4 (length vec))))
6993 6341
6994(defun tramp-file-name-multi-method (obj) 6342(defun tramp-file-name-method (vec)
6995 "Return MULTI-METHOD component of TRAMP-FILE-NAME." 6343 "Return method component of VEC."
6996 (and (tramp-file-name-p obj) (aref obj 0))) 6344 (and (tramp-file-name-p vec) (aref vec 0)))
6997 6345
6998(defun tramp-file-name-method (obj) 6346(defun tramp-file-name-user (vec)
6999 "Return METHOD component of TRAMP-FILE-NAME." 6347 "Return user component of VEC."
7000 (and (tramp-file-name-p obj) (aref obj 1))) 6348 (and (tramp-file-name-p vec) (aref vec 1)))
7001 6349
7002(defun tramp-file-name-user (obj) 6350(defun tramp-file-name-host (vec)
7003 "Return USER component of TRAMP-FILE-NAME." 6351 "Return host component of VEC."
7004 (and (tramp-file-name-p obj) (aref obj 2))) 6352 (and (tramp-file-name-p vec) (aref vec 2)))
7005 6353
7006(defun tramp-file-name-host (obj) 6354(defun tramp-file-name-localname (vec)
7007 "Return HOST component of TRAMP-FILE-NAME." 6355 "Return localname component of VEC."
7008 (and (tramp-file-name-p obj) (aref obj 3))) 6356 (and (tramp-file-name-p vec) (aref vec 3)))
7009 6357
7010(defun tramp-file-name-localname (obj) 6358;; The host part of a Tramp file name vector can be of kind
7011 "Return LOCALNAME component of TRAMP-FILE-NAME." 6359;; "host#port". Sometimes, we must extract these parts.
7012 (and (tramp-file-name-p obj) (aref obj 4))) 6360(defsubst tramp-file-name-real-host (vec)
6361 "Return the host name of VEC without port."
6362 (let ((host (tramp-file-name-host vec)))
6363 (if (and (stringp host)
6364 (string-match tramp-host-with-port-regexp host))
6365 (match-string 1 host)
6366 host)))
6367
6368(defsubst tramp-file-name-port (vec)
6369 "Return the port number of VEC."
6370 (let ((host (tramp-file-name-host vec)))
6371 (and (stringp host)
6372 (string-match tramp-host-with-port-regexp host)
6373 (string-to-number (match-string 2 host)))))
7013 6374
7014(defun tramp-tramp-file-p (name) 6375(defun tramp-tramp-file-p (name)
7015 "Return t iff NAME is a tramp file." 6376 "Return t iff NAME is a tramp file."
7016 (save-match-data 6377 (save-match-data
7017 (string-match tramp-file-name-regexp name))) 6378 (string-match tramp-file-name-regexp name)))
7018 6379
7019;; HHH: Changed. Used to assign the return value of (user-login-name) 6380(defsubst tramp-find-method (method user host)
7020;; to the `user' part of the structure if a user name was not 6381 "Return the right method string to use.
7021;; provided, now it assigns nil. 6382This is METHOD, if non-nil. Otherwise, do a lookup in
6383`tramp-default-method-alist'."
6384 (or method
6385 (let ((choices tramp-default-method-alist)
6386 lmethod item)
6387 (while choices
6388 (setq item (pop choices))
6389 (when (and (string-match (or (nth 0 item) "") (or host ""))
6390 (string-match (or (nth 1 item) "") (or user "")))
6391 (setq lmethod (nth 2 item))
6392 (setq choices nil)))
6393 lmethod)
6394 tramp-default-method))
6395
6396(defsubst tramp-find-user (method user host)
6397 "Return the right user string to use.
6398This is USER, if non-nil. Otherwise, do a lookup in
6399`tramp-default-user-alist'."
6400 (or user
6401 (let ((choices tramp-default-user-alist)
6402 luser item)
6403 (while choices
6404 (setq item (pop choices))
6405 (when (and (string-match (or (nth 0 item) "") (or method ""))
6406 (string-match (or (nth 1 item) "") (or host "")))
6407 (setq luser (nth 2 item))
6408 (setq choices nil)))
6409 luser)
6410 tramp-default-user))
6411
6412(defsubst tramp-find-host (method user host)
6413 "Return the right host string to use.
6414This is HOST, if non-nil. Otherwise, it is `tramp-default-host'."
6415 (or (and (> (length host) 0) host)
6416 tramp-default-host))
6417
7022(defun tramp-dissect-file-name (name) 6418(defun tramp-dissect-file-name (name)
7023 "Return an `tramp-file-name' structure. 6419 "Return a `tramp-file-name' structure.
7024The structure consists of remote method, remote user, remote host and 6420The structure consists of remote method, remote user, remote host and
7025localname (file name on remote host)." 6421localname (file name on remote host)."
7026 (save-match-data 6422 (save-match-data
7027 (let* ((match (string-match (nth 0 tramp-file-name-structure) name)) 6423 (let ((match (string-match (nth 0 tramp-file-name-structure) name)))
7028 (method 6424 (unless match (error "Not a tramp file name: %s" name))
7029 ; single-hop 6425 (let ((method (match-string (nth 1 tramp-file-name-structure) name))
7030 (if match (match-string (nth 1 tramp-file-name-structure) name) 6426 (user (match-string (nth 2 tramp-file-name-structure) name))
7031 ; maybe multi-hop 6427 (host (match-string (nth 3 tramp-file-name-structure) name))
7032 (string-match 6428 (localname (match-string (nth 4 tramp-file-name-structure) name)))
7033 (format (nth 0 tramp-multi-file-name-structure) 6429 (vector
7034 (nth 0 tramp-multi-file-name-hop-structure)) name) 6430 (tramp-find-method method user host)
7035 (match-string (nth 1 tramp-multi-file-name-structure) name)))) 6431 (tramp-find-user method user host)
7036 (if (and method (member method tramp-multi-methods)) 6432 (tramp-find-host method user host)
7037 ;; If it's a multi method, the file name structure contains 6433 localname)))))
7038 ;; arrays of method, user and host. 6434
7039 (tramp-dissect-multi-file-name name) 6435(defun tramp-equal-remote (file1 file2)
7040 ;; Normal method. First, find out default method. 6436 "Checks, whether the remote parts of FILE1 and FILE2 are identical.
7041 (unless match (error "Not a tramp file name: %s" name)) 6437The check depends on method, user and host name of the files. If
7042 (let ((user (match-string (nth 2 tramp-file-name-structure) name)) 6438one of the components is missing, the default values are used.
7043 (host (match-string (nth 3 tramp-file-name-structure) name)) 6439The local file name parts of FILE1 and FILE2 are not taken into
7044 (localname (match-string (nth 4 tramp-file-name-structure) name))) 6440account.
7045 (vector nil method (or user nil) host localname))))))
7046
7047(defun tramp-find-default-method (user host)
7048 "Look up the right method to use in `tramp-default-method-alist'."
7049 (let ((choices tramp-default-method-alist)
7050 (method tramp-default-method)
7051 item)
7052 (while choices
7053 (setq item (pop choices))
7054 (when (and (string-match (or (nth 0 item) "") (or host ""))
7055 (string-match (or (nth 1 item) "") (or user "")))
7056 (setq method (nth 2 item))
7057 (setq choices nil)))
7058 method))
7059
7060(defun tramp-find-method (multi-method method user host)
7061 "Return the right method string to use.
7062This is MULTI-METHOD, if non-nil. Otherwise, it is METHOD, if non-nil.
7063If both MULTI-METHOD and METHOD are nil, do a lookup in
7064`tramp-default-method-alist'."
7065 (or multi-method method (tramp-find-default-method user host)))
7066
7067;; HHH: Not Changed. Multi method. Will probably not handle the case where
7068;; a user name is not provided in the "file name" very well.
7069(defun tramp-dissect-multi-file-name (name)
7070 "Not implemented yet."
7071 (let ((regexp (nth 0 tramp-multi-file-name-structure))
7072 (method-index (nth 1 tramp-multi-file-name-structure))
7073 (hops-index (nth 2 tramp-multi-file-name-structure))
7074 (localname-index (nth 3 tramp-multi-file-name-structure))
7075 (hop-regexp (nth 0 tramp-multi-file-name-hop-structure))
7076 (hop-method-index (nth 1 tramp-multi-file-name-hop-structure))
7077 (hop-user-index (nth 2 tramp-multi-file-name-hop-structure))
7078 (hop-host-index (nth 3 tramp-multi-file-name-hop-structure))
7079 method hops len hop-methods hop-users hop-hosts localname)
7080 (unless (string-match (format regexp hop-regexp) name)
7081 (error "Not a multi tramp file name: %s" name))
7082 (setq method (match-string method-index name))
7083 (setq hops (match-string hops-index name))
7084 (setq len (/ (length (match-data t)) 2))
7085 (when (< localname-index 0) (setq localname-index (+ localname-index len)))
7086 (setq localname (match-string localname-index name))
7087 (let ((index 0))
7088 (while (string-match hop-regexp hops index)
7089 (setq index (match-end 0))
7090 (setq hop-methods
7091 (cons (match-string hop-method-index hops) hop-methods))
7092 (setq hop-users
7093 (cons (match-string hop-user-index hops) hop-users))
7094 (setq hop-hosts
7095 (cons (match-string hop-host-index hops) hop-hosts))))
7096 (vector
7097 method
7098 (apply 'vector (reverse hop-methods))
7099 (apply 'vector (reverse hop-users))
7100 (apply 'vector (reverse hop-hosts))
7101 localname)))
7102
7103(defun tramp-make-tramp-file-name (multi-method method user host localname)
7104 "Constructs a tramp file name from METHOD, USER, HOST and LOCALNAME."
7105 (if multi-method
7106 (tramp-make-tramp-multi-file-name multi-method method user host localname)
7107 (format-spec
7108 (concat tramp-prefix-format
7109 (when method (concat "%m" tramp-postfix-single-method-format))
7110 (when user (concat "%u" tramp-postfix-user-format))
7111 (when host (concat "%h" tramp-postfix-host-format))
7112 (when localname (concat "%p")))
7113 `((?m . ,method) (?u . ,user) (?h . ,host) (?p . ,localname)))))
7114
7115;; CCC: Henrik Holm: Not Changed. Multi Method. What should be done
7116;; with this when USER is nil?
7117(defun tramp-make-tramp-multi-file-name (multi-method method user host localname)
7118 "Constructs a tramp file name for a multi-hop method."
7119 (unless tramp-make-multi-tramp-file-format
7120 (error "`tramp-make-multi-tramp-file-format' is nil"))
7121 (let* ((prefix-format (nth 0 tramp-make-multi-tramp-file-format))
7122 (hop-format (nth 1 tramp-make-multi-tramp-file-format))
7123 (localname-format (nth 2 tramp-make-multi-tramp-file-format))
7124 (prefix (format-spec prefix-format `((?m . ,multi-method))))
7125 (hops "")
7126 (localname (format-spec localname-format `((?p . ,localname))))
7127 (i 0)
7128 (len (length method)))
7129 (while (< i len)
7130 (let ((m (aref method i)) (u (aref user i)) (h (aref host i)))
7131 (setq hops (concat hops (format-spec hop-format
7132 `((?m . ,m) (?u . ,u) (?h . ,h)))))
7133 (setq i (1+ i))))
7134 (concat prefix hops localname)))
7135
7136(defun tramp-make-copy-program-file-name (user host localname)
7137 "Create a file name suitable to be passed to `rcp' and workalikes."
7138 (if user
7139 (format "%s@%s:%s" user host localname)
7140 (format "%s:%s" host localname)))
7141 6441
7142(defun tramp-method-out-of-band-p (multi-method method user host) 6442Example:
6443
6444 (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\")
6445
6446would yield `t'. On the other hand, the following check results in nil:
6447
6448 (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")"
6449 (and (stringp (file-remote-p file1))
6450 (stringp (file-remote-p file2))
6451 (string-equal (file-remote-p file1) (file-remote-p file2))))
6452
6453(defun tramp-make-tramp-file-name (method user host localname)
6454 "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME."
6455 (concat tramp-prefix-format
6456 (when (not (zerop (length method)))
6457 (concat method tramp-postfix-method-format))
6458 (when (not (zerop (length user)))
6459 (concat user tramp-postfix-user-format))
6460 (when host host) tramp-postfix-host-format
6461 (when localname localname)))
6462
6463(defun tramp-completion-make-tramp-file-name (method user host localname)
6464 "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
6465It must not be a complete Tramp file name, but as long as there are
6466necessary only. This function will be used in file name completion."
6467 (concat tramp-prefix-format
6468 (when (not (zerop (length method)))
6469 (concat method tramp-postfix-method-format))
6470 (when (not (zerop (length user)))
6471 (concat user tramp-postfix-user-format))
6472 (when (not (zerop (length host)))
6473 (concat host tramp-postfix-host-format))
6474 (when localname localname)))
6475
6476(defun tramp-make-copy-program-file-name (vec)
6477 "Create a file name suitable to be passed to `rcp' and workalikes."
6478 (let ((user (tramp-file-name-user vec))
6479 (host (car (split-string
6480 (tramp-file-name-host vec) tramp-prefix-port-regexp)))
6481 (localname (tramp-shell-quote-argument
6482 (tramp-file-name-localname vec))))
6483 (if (not (zerop (length user)))
6484 (format "%s@%s:%s" user host localname)
6485 (format "%s:%s" host localname))))
6486
6487(defun tramp-method-out-of-band-p (vec)
7143 "Return t if this is an out-of-band method, nil otherwise." 6488 "Return t if this is an out-of-band method, nil otherwise."
7144 (tramp-get-method-parameter 6489 (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program))
7145 multi-method
7146 (tramp-find-method multi-method method user host)
7147 user host 'tramp-copy-program))
7148 6490
7149;; Variables local to connection. 6491;; Variables local to connection.
7150 6492
7151(defun tramp-get-ls-command (multi-method method user host) 6493(defun tramp-get-ls-command (vec)
7152 (or 6494 (with-connection-property vec "ls"
7153 (save-excursion 6495 (with-current-buffer (tramp-get-buffer vec)
7154 (tramp-maybe-open-connection multi-method method user host) 6496 (tramp-message vec 5 "Finding a suitable `ls' command")
7155 (set-buffer (tramp-get-buffer multi-method method user host)) 6497 (or
7156 tramp-ls-command) 6498 (catch 'ls-found
7157 (error "Couldn't find remote `ls' command"))) 6499 (dolist (cmd '("ls" "gnuls" "gls"))
7158 6500 (let ((dl tramp-remote-path)
7159(defun tramp-get-test-groks-nt (multi-method method user host) 6501 result)
7160 (save-excursion 6502 (while
7161 (tramp-maybe-open-connection multi-method method user host) 6503 (and
7162 (set-buffer (tramp-get-buffer multi-method method user host)) 6504 dl
7163 tramp-test-groks-nt)) 6505 (setq result
7164 6506 (tramp-find-executable vec cmd dl t t)))
7165(defun tramp-get-file-exists-command (multi-method method user host) 6507 ;; Check parameter.
7166 (or 6508 (when (zerop (tramp-send-command-and-check
7167 (save-excursion 6509 vec (format "%s -lnd /" result)))
7168 (tramp-maybe-open-connection multi-method method user host) 6510 (throw 'ls-found result))
7169 (set-buffer (tramp-get-buffer multi-method method user host)) 6511 ;; Remove unneeded directories from path.
7170 tramp-file-exists-command) 6512 (while
7171 (error "Couldn't find remote `test -e' command"))) 6513 (and
6514 dl
6515 (not
6516 (string-equal
6517 result (expand-file-name-as-directory cmd (car dl)))))
6518 (setq dl (cdr dl)))
6519 (setq dl (cdr dl))))))
6520 (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))))
6521
6522(defun tramp-get-test-command (vec)
6523 (with-connection-property vec "test"
6524 (with-current-buffer (tramp-get-buffer vec)
6525 (tramp-message vec 5 "Finding a suitable `test' command")
6526 (if (zerop (tramp-send-command-and-check vec "test 0"))
6527 "test"
6528 (tramp-find-executable vec "test" tramp-remote-path)))))
6529
6530(defun tramp-get-test-nt-command (vec)
6531 ;; Does `test A -nt B' work? Use abominable `find' construct if it
6532 ;; doesn't. BSD/OS 4.0 wants the parentheses around the command,
6533 ;; for otherwise the shell crashes.
6534 (with-connection-property vec "test-nt"
6535 (or
6536 (progn
6537 (tramp-send-command
6538 vec (format "( %s / -nt / )" (tramp-get-test-command vec)))
6539 (with-current-buffer (tramp-get-buffer vec)
6540 (goto-char (point-min))
6541 (when (looking-at
6542 (format "\n%s\r?\n" (regexp-quote tramp-end-of-output)))
6543 (format "%s %%s -nt %%s" (tramp-get-test-command vec)))))
6544 (progn
6545 (tramp-send-command
6546 vec
6547 (format
6548 "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}"
6549 (tramp-get-test-command vec)))
6550 "tramp_test_nt %s %s"))))
6551
6552(defun tramp-get-file-exists-command (vec)
6553 (with-connection-property vec "file-exists"
6554 (with-current-buffer (tramp-get-buffer vec)
6555 (tramp-message vec 5 "Finding command to check if file exists")
6556 (tramp-find-file-exists-command vec))))
6557
6558(defun tramp-get-remote-ln (vec)
6559 (with-connection-property vec "ln"
6560 (with-current-buffer (tramp-get-buffer vec)
6561 (tramp-message vec 5 "Finding a suitable `ln' command")
6562 (tramp-find-executable vec "ln" tramp-remote-path))))
6563
6564(defun tramp-get-remote-perl (vec)
6565 (with-connection-property vec "perl"
6566 (with-current-buffer (tramp-get-buffer vec)
6567 (tramp-message vec 5 "Finding a suitable `perl' command")
6568 (or (tramp-find-executable vec "perl5" tramp-remote-path)
6569 (tramp-find-executable vec "perl" tramp-remote-path)))))
6570
6571(defun tramp-get-remote-stat (vec)
6572 (with-connection-property vec "stat"
6573 (with-current-buffer (tramp-get-buffer vec)
6574 (tramp-message vec 5 "Finding a suitable `stat' command")
6575 (let ((result (tramp-find-executable vec "stat" tramp-remote-path))
6576 tmp)
6577 ;; Check whether stat(1) returns usable syntax.
6578 (when result
6579 (setq tmp
6580 ;; We don't want to display an error message.
6581 (with-temp-message (or (current-message) "")
6582 (condition-case nil
6583 (tramp-send-command-and-read
6584 vec (format "%s -c '(\"%%N\")' /" result))
6585 (error nil))))
6586 (unless (and (listp tmp) (stringp (car tmp))
6587 (string-match "^./.$" (car tmp)))
6588 (setq result nil)))
6589 result))))
7172 6590
7173(defun tramp-get-remote-perl (multi-method method user host) 6591(defun tramp-get-remote-id (vec)
7174 (tramp-get-connection-property "perl" nil multi-method method user host)) 6592 (with-connection-property vec "id"
6593 (with-current-buffer (tramp-get-buffer vec)
6594 (tramp-message vec 5 "Finding POSIX `id' command")
6595 (or
6596 (catch 'id-found
6597 (let ((dl tramp-remote-path)
6598 result)
6599 (while
6600 (and
6601 dl
6602 (setq result
6603 (tramp-find-executable vec "id" dl t t)))
6604 ;; Check POSIX parameter.
6605 (when (zerop (tramp-send-command-and-check
6606 vec (format "%s -u" result)))
6607 (throw 'id-found result))
6608 ;; Remove unneeded directories from path.
6609 (while
6610 (and
6611 dl
6612 (not
6613 (string-equal
6614 result
6615 (concat (file-name-as-directory (car dl)) "id"))))
6616 (setq dl (cdr dl)))
6617 (setq dl (cdr dl)))))
6618 (tramp-error vec 'file-error "Couldn't find a POSIX `id' command")))))
6619
6620(defun tramp-get-remote-uid (vec id-format)
6621 (with-connection-property vec (format "uid-%s" id-format)
6622 (let ((res (tramp-send-command-and-read
6623 vec
6624 (format "%s -u%s %s"
6625 (tramp-get-remote-id vec)
6626 (if (equal id-format 'integer) "" "n")
6627 (if (equal id-format 'integer)
6628 "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
6629 ;; The command might not always return a number.
6630 (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
6631
6632(defun tramp-get-remote-gid (vec id-format)
6633 (with-connection-property vec (format "gid-%s" id-format)
6634 (let ((res (tramp-send-command-and-read
6635 vec
6636 (format "%s -g%s %s"
6637 (tramp-get-remote-id vec)
6638 (if (equal id-format 'integer) "" "n")
6639 (if (equal id-format 'integer)
6640 "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
6641 ;; The command might not always return a number.
6642 (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
7175 6643
7176(defun tramp-get-remote-ln (multi-method method user host) 6644;; Some predefined connection properties.
6645(defun tramp-get-remote-coding (vec prop)
6646 ;; Local coding handles properties like remote coding. So we could
6647 ;; call it without pain.
6648 (let ((ret (tramp-get-local-coding vec prop)))
6649 ;; The connection property might have been cached. So we must send
6650 ;; the script - maybe.
6651 (when (not (stringp ret))
6652 (let ((name (symbol-name ret)))
6653 (while (string-match (regexp-quote "-") name)
6654 (setq name (replace-match "_" nil t name)))
6655 (tramp-maybe-send-script vec (symbol-value ret) name)
6656 (setq ret name)))
6657 ;; Return the value.
6658 ret))
6659
6660(defun tramp-get-local-coding (vec prop)
7177 (or 6661 (or
7178 (tramp-get-connection-property "ln" nil multi-method method user host) 6662 (tramp-get-connection-property vec prop nil)
7179 (error "Couldn't find remote `ln' command"))) 6663 (progn
7180 6664 (tramp-find-inline-encoding vec)
7181(defun tramp-get-remote-uid (multi-method method user host) 6665 (tramp-get-connection-property vec prop nil))))
7182 (tramp-get-connection-property "uid" nil multi-method method user host))
7183
7184(defun tramp-get-remote-gid (multi-method method user host)
7185 (tramp-get-connection-property "gid" nil multi-method method user host))
7186
7187;; Get a property of a TRAMP connection.
7188(defun tramp-get-connection-property
7189 (property default multi-method method user host)
7190 "Get the named property for the connection.
7191If the value is not set for the connection, return `default'"
7192 (tramp-maybe-open-connection multi-method method user host)
7193 (with-current-buffer (tramp-get-buffer multi-method method user host)
7194 (let (error)
7195 (condition-case nil
7196 (symbol-value (intern (concat "tramp-connection-property-" property)))
7197 (error default)))))
7198
7199;; Set a property of a TRAMP connection.
7200(defun tramp-set-connection-property
7201 (property value multi-method method user host)
7202 "Set the named property of a TRAMP connection."
7203 (tramp-maybe-open-connection multi-method method user host)
7204 (with-current-buffer (tramp-get-buffer multi-method method user host)
7205 (set (make-local-variable
7206 (intern (concat "tramp-connection-property-" property)))
7207 value)))
7208 6666
7209;; Some predefined connection properties. 6667(defun tramp-get-method-parameter (method param)
7210(defun tramp-set-remote-encoding (multi-method method user host rem-enc)
7211 (tramp-set-connection-property "remote-encoding" rem-enc
7212 multi-method method user host))
7213(defun tramp-get-remote-encoding (multi-method method user host)
7214 (tramp-get-connection-property "remote-encoding" nil
7215 multi-method method user host))
7216
7217(defun tramp-set-remote-decoding (multi-method method user host rem-dec)
7218 (tramp-set-connection-property "remote-decoding" rem-dec
7219 multi-method method user host))
7220(defun tramp-get-remote-decoding (multi-method method user host)
7221 (tramp-get-connection-property "remote-decoding" nil
7222 multi-method method user host))
7223
7224(defun tramp-set-local-encoding (multi-method method user host loc-enc)
7225 (tramp-set-connection-property "local-encoding" loc-enc
7226 multi-method method user host))
7227(defun tramp-get-local-encoding (multi-method method user host)
7228 (tramp-get-connection-property "local-encoding" nil
7229 multi-method method user host))
7230
7231(defun tramp-set-local-decoding (multi-method method user host loc-dec)
7232 (tramp-set-connection-property "local-decoding" loc-dec
7233 multi-method method user host))
7234(defun tramp-get-local-decoding (multi-method method user host)
7235 (tramp-get-connection-property "local-decoding" nil
7236 multi-method method user host))
7237
7238(defun tramp-get-method-parameter (multi-method method user host param)
7239 "Return the method parameter PARAM. 6668 "Return the method parameter PARAM.
7240If the `tramp-methods' entry does not exist, use the variable PARAM 6669If the `tramp-methods' entry does not exist, return NIL."
7241as default." 6670 (let ((entry (assoc param (assoc method tramp-methods))))
7242 (unless (boundp param) 6671 (when entry (cadr entry))))
7243 (error "Non-existing method parameter `%s'" param))
7244 (let ((entry (assoc param
7245 (assoc (tramp-find-method multi-method method user host)
7246 tramp-methods))))
7247 (if entry
7248 (cadr entry)
7249 (symbol-value param))))
7250
7251 6672
7252;; Auto saving to a special directory. 6673;; Auto saving to a special directory.
7253 6674
7254(defun tramp-exists-file-name-handler (operation &rest args) 6675(defun tramp-exists-file-name-handler (operation &rest args)
7255 (let ((buffer-file-name "/") 6676 "Checks whether OPERATION runs a file name handler."
7256 (fnha file-name-handler-alist) 6677 ;; The file name handler is determined on base of either an
7257 (check-file-name-operation operation) 6678 ;; argument, `buffer-file-name', or `default-directory'.
7258 (file-name-handler-alist 6679 (condition-case nil
7259 (list 6680 (let* ((buffer-file-name "/")
7260 (cons "/" 6681 (default-directory "/")
7261 '(lambda (operation &rest args) 6682 (fnha file-name-handler-alist)
7262 "Returns OPERATION if it is the one to be checked" 6683 (check-file-name-operation operation)
7263 (if (equal check-file-name-operation operation) 6684 (file-name-handler-alist
7264 operation 6685 (list
7265 (let ((file-name-handler-alist fnha)) 6686 (cons "/"
7266 (apply operation args)))))))) 6687 '(lambda (operation &rest args)
7267 (eq (apply operation args) operation))) 6688 "Returns OPERATION if it is the one to be checked."
6689 (if (equal check-file-name-operation operation)
6690 operation
6691 (let ((file-name-handler-alist fnha))
6692 (apply operation args))))))))
6693 (equal (apply operation args) operation))
6694 (error nil)))
7268 6695
7269(unless (tramp-exists-file-name-handler 'make-auto-save-file-name) 6696(unless (tramp-exists-file-name-handler 'make-auto-save-file-name)
7270 (defadvice make-auto-save-file-name 6697 (defadvice make-auto-save-file-name
7271 (around tramp-advice-make-auto-save-file-name () activate) 6698 (around tramp-advice-make-auto-save-file-name () activate)
7272 "Invoke `tramp-handle-make-auto-save-file-name' for tramp files." 6699 "Invoke `tramp-handle-make-auto-save-file-name' for Tramp files."
7273 (if (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))) 6700 (if (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name)))
7274 (setq ad-return-value (tramp-handle-make-auto-save-file-name)) 6701 (setq ad-return-value (tramp-handle-make-auto-save-file-name))
7275 ad-do-it)) 6702 ad-do-it))
@@ -7316,12 +6743,6 @@ ALIST is of the form ((FROM . TO) ...)."
7316 (setq alist (cdr alist)))) 6743 (setq alist (cdr alist))))
7317 string)) 6744 string))
7318 6745
7319(defun tramp-insert-with-face (face string)
7320 "Insert text with a specific face."
7321 (let ((start (point)))
7322 (insert string)
7323 (add-text-properties start (point) (list 'face face))))
7324
7325;; ------------------------------------------------------------ 6746;; ------------------------------------------------------------
7326;; -- Compatibility functions section -- 6747;; -- Compatibility functions section --
7327;; ------------------------------------------------------------ 6748;; ------------------------------------------------------------
@@ -7345,28 +6766,63 @@ this is the function `temp-directory'."
7345 "`temp-directory' is defined -- using /tmp.")) 6766 "`temp-directory' is defined -- using /tmp."))
7346 (file-name-as-directory "/tmp")))) 6767 (file-name-as-directory "/tmp"))))
7347 6768
7348(defun tramp-read-passwd (user host prompt) 6769(defun tramp-read-passwd (proc &optional prompt)
7349 "Read a password from user (compat function). 6770 "Read a password from user (compat function).
7350Invokes `password-read' if available, `read-passwd' else." 6771Invokes `password-read' if available, `read-passwd' else."
7351 (if (functionp 'password-read) 6772 (let* ((key (tramp-make-tramp-file-name
7352 (let* ((key (concat (or user (user-login-name)) "@" host)) 6773 tramp-current-method tramp-current-user
7353 (password (apply #'password-read (list prompt key)))) 6774 tramp-current-host ""))
7354 (apply #'password-cache-add (list key password)) 6775 (pw-prompt
7355 password) 6776 (or prompt
7356 (read-passwd prompt))) 6777 (with-current-buffer (process-buffer proc)
7357 6778 (tramp-check-for-regexp proc tramp-password-prompt-regexp)
7358(defun tramp-clear-passwd (&optional user host) 6779 (format "%s for %s " (capitalize (match-string 1)) key)))))
7359 "Clear password cache for connection related to current-buffer." 6780 (if (functionp 'password-read)
6781 (let ((password (apply #'password-read (list pw-prompt key))))
6782 (apply #'password-cache-add (list key password))
6783 password)
6784 (read-passwd pw-prompt))))
6785
6786(defun tramp-clear-passwd ()
6787 "Clear password cache for connection related to current-buffer.
6788If METHOD, USER or HOST is given, take then for computing the key."
7360 (interactive) 6789 (interactive)
7361 (let ((filename (or buffer-file-name list-buffers-directory ""))) 6790 (when (functionp 'password-cache-remove)
7362 (when (and (functionp 'password-cache-remove) 6791 (apply #'password-cache-remove
7363 (or (and user host) (tramp-tramp-file-p filename))) 6792 (list (tramp-make-tramp-file-name
7364 (let* ((v (when (tramp-tramp-file-p filename) 6793 tramp-current-method
7365 (tramp-dissect-file-name filename))) 6794 tramp-current-user
7366 (luser (or user (tramp-file-name-user v) (user-login-name))) 6795 tramp-current-host
7367 (lhost (or host (tramp-file-name-host v) (system-name))) 6796 "")))))
7368 (key (concat luser "@" lhost))) 6797
7369 (apply #'password-cache-remove (list key)))))) 6798;; Snarfed code from time-date.el and parse-time.el
6799
6800(defconst tramp-half-a-year '(241 17024)
6801"Evaluated by \"(days-to-time 183)\".")
6802
6803(defconst tramp-parse-time-months
6804 '(("jan" . 1) ("feb" . 2) ("mar" . 3)
6805 ("apr" . 4) ("may" . 5) ("jun" . 6)
6806 ("jul" . 7) ("aug" . 8) ("sep" . 9)
6807 ("oct" . 10) ("nov" . 11) ("dec" . 12))
6808 "Alist mapping month names to integers.")
6809
6810(defun tramp-time-less-p (t1 t2)
6811 "Say whether time value T1 is less than time value T2."
6812 (unless t1 (setq t1 '(0 0)))
6813 (unless t2 (setq t2 '(0 0)))
6814 (or (< (car t1) (car t2))
6815 (and (= (car t1) (car t2))
6816 (< (nth 1 t1) (nth 1 t2)))))
6817
6818(defun tramp-time-subtract (t1 t2)
6819 "Subtract two time values.
6820Return the difference in the format of a time value."
6821 (unless t1 (setq t1 '(0 0)))
6822 (unless t2 (setq t2 '(0 0)))
6823 (let ((borrow (< (cadr t1) (cadr t2))))
6824 (list (- (car t1) (car t2) (if borrow 1 0))
6825 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
7370 6826
7371(defun tramp-time-diff (t1 t2) 6827(defun tramp-time-diff (t1 t2)
7372 "Return the difference between the two times, in seconds. 6828 "Return the difference between the two times, in seconds.
@@ -7385,11 +6841,7 @@ T1 and T2 are time values (as returned by `current-time' for example)."
7385 (if (< (length t1) 3) (append t1 '(0)) t1) 6841 (if (< (length t1) 3) (append t1 '(0)) t1)
7386 (if (< (length t2) 3) (append t2 '(0)) t2))) 6842 (if (< (length t2) 3) (append t2 '(0)) t2)))
7387 (t 6843 (t
7388 ;; snarfed from Emacs 21 time-date.el; combining 6844 (let ((time (tramp-time-subtract t1 t2)))
7389 ;; time-to-seconds and subtract-time
7390 (let ((time (let ((borrow (< (cadr t1) (cadr t2))))
7391 (list (- (car t1) (car t2) (if borrow 1 0))
7392 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))))
7393 (+ (* (car time) 65536.0) 6845 (+ (* (car time) 65536.0)
7394 (cadr time) 6846 (cadr time)
7395 (/ (or (nth 2 time) 0) 1000000.0)))))) 6847 (/ (or (nth 2 time) 0) 1000000.0))))))
@@ -7428,11 +6880,9 @@ it does the right thing."
7428 "Specify if query is needed for process when Emacs is exited. 6880 "Specify if query is needed for process when Emacs is exited.
7429If the second argument flag is non-nil, Emacs will query the user before 6881If the second argument flag is non-nil, Emacs will query the user before
7430exiting if process is running." 6882exiting if process is running."
7431 (funcall
7432 (if (fboundp 'set-process-query-on-exit-flag) 6883 (if (fboundp 'set-process-query-on-exit-flag)
7433 (symbol-function 'set-process-query-on-exit-flag) 6884 (funcall (symbol-function 'set-process-query-on-exit-flag) process flag)
7434 (symbol-function 'process-kill-without-query)) 6885 (funcall (symbol-function 'process-kill-without-query) process flag)))
7435 process flag))
7436 6886
7437 6887
7438;; ------------------------------------------------------------ 6888;; ------------------------------------------------------------
@@ -7479,29 +6929,6 @@ Only works for Bourne-like shells."
7479 t t result))) 6929 t t result)))
7480 result)))) 6930 result))))
7481 6931
7482;; ;; EFS hooks itself into the file name handling stuff in more places
7483;; ;; than just `file-name-handler-alist'. The following tells EFS to stay
7484;; ;; away from tramp.el file names.
7485;; ;;
7486;; ;; This is needed because EFS installs (efs-dired-before-readin) into
7487;; ;; 'dired-before-readin-hook'. This prevents EFS from opening an FTP
7488;; ;; connection to help it's dired process. Not that I have any real
7489;; ;; idea *why* this is helpful to dired.
7490;; ;;
7491;; ;; Anyway, this advice fixes the problem (with a sledgehammer :)
7492;; ;;
7493;; ;; Daniel Pittman <daniel@danann.net>
7494;; ;;
7495;; ;; CCC: when the other defadvice calls have disappeared, make sure
7496;; ;; not to call defadvice unless it's necessary. How do we find out whether
7497;; ;; it is necessary? (featurep 'efs) is surely the wrong way --
7498;; ;; EFS might nicht be loaded yet.
7499;; (defadvice efs-ftp-path (around dont-match-tramp-localname activate protect)
7500;; "Cause efs-ftp-path to fail when the path is a TRAMP localname."
7501;; (if (tramp-tramp-file-p (ad-get-arg 0))
7502;; nil
7503;; ad-do-it))
7504
7505;; We currently (sometimes) use "[" and "]" in the filename format. 6932;; We currently (sometimes) use "[" and "]" in the filename format.
7506;; This means that Emacs wants to expand wildcards if 6933;; This means that Emacs wants to expand wildcards if
7507;; `find-file-wildcards' is non-nil, and then barfs because no 6934;; `find-file-wildcards' is non-nil, and then barfs because no
@@ -7552,10 +6979,6 @@ Only works for Bourne-like shells."
7552 (format "tramp (%s)" tramp-version) ; package name and version 6979 (format "tramp (%s)" tramp-version) ; package name and version
7553 (delq nil 6980 (delq nil
7554 `(;; Current state 6981 `(;; Current state
7555 tramp-ls-command
7556 tramp-test-groks-nt
7557 tramp-file-exists-command
7558 tramp-current-multi-method
7559 tramp-current-method 6982 tramp-current-method
7560 tramp-current-user 6983 tramp-current-user
7561 tramp-current-host 6984 tramp-current-host
@@ -7563,6 +6986,11 @@ Only works for Bourne-like shells."
7563 ;; System defaults 6986 ;; System defaults
7564 tramp-auto-save-directory ; vars to dump 6987 tramp-auto-save-directory ; vars to dump
7565 tramp-default-method 6988 tramp-default-method
6989 tramp-default-method-alist
6990 tramp-default-host
6991 tramp-default-proxies-alist
6992 tramp-default-user
6993 tramp-default-user-alist
7566 tramp-rsh-end-of-line 6994 tramp-rsh-end-of-line
7567 tramp-default-password-end-of-line 6995 tramp-default-password-end-of-line
7568 tramp-remote-path 6996 tramp-remote-path
@@ -7576,24 +7004,21 @@ Only works for Bourne-like shells."
7576 tramp-temp-name-prefix 7004 tramp-temp-name-prefix
7577 tramp-file-name-structure 7005 tramp-file-name-structure
7578 tramp-file-name-regexp 7006 tramp-file-name-regexp
7579 tramp-multi-file-name-structure
7580 tramp-multi-file-name-hop-structure
7581 tramp-multi-methods
7582 tramp-multi-connection-function-alist
7583 tramp-methods 7007 tramp-methods
7584 tramp-end-of-output 7008 tramp-end-of-output
7585 tramp-coding-commands 7009 tramp-local-coding-commands
7010 tramp-remote-coding-commands
7586 tramp-actions-before-shell 7011 tramp-actions-before-shell
7587 tramp-actions-copy-out-of-band 7012 tramp-actions-copy-out-of-band
7588 tramp-multi-actions
7589 tramp-terminal-type 7013 tramp-terminal-type
7590 ;; Mask non-7bit characters 7014 ;; Mask non-7bit characters
7591 (tramp-shell-prompt-pattern . tramp-reporter-dump-variable) 7015 (tramp-shell-prompt-pattern . tramp-reporter-dump-variable)
7592 tramp-chunksize
7593 ,(when (boundp 'tramp-backup-directory-alist) 7016 ,(when (boundp 'tramp-backup-directory-alist)
7594 'tramp-backup-directory-alist) 7017 'tramp-backup-directory-alist)
7595 ,(when (boundp 'tramp-bkup-backup-directory-info) 7018 ,(when (boundp 'tramp-bkup-backup-directory-info)
7596 'tramp-bkup-backup-directory-info) 7019 'tramp-bkup-backup-directory-info)
7020 ;; Dump cache.
7021 (tramp-cache-data . tramp-reporter-dump-variable)
7597 7022
7598 ;; Non-tramp variables of interest 7023 ;; Non-tramp variables of interest
7599 ;; Mask non-7bit characters 7024 ;; Mask non-7bit characters
@@ -7616,18 +7041,21 @@ Only works for Bourne-like shells."
7616 'tramp-load-report-modules ; pre-hook 7041 'tramp-load-report-modules ; pre-hook
7617 'tramp-append-tramp-buffers ; post-hook 7042 'tramp-append-tramp-buffers ; post-hook
7618 "\ 7043 "\
7619Enter your bug report in this message, including as much detail as you 7044Enter your bug report in this message, including as much detail
7620possibly can about the problem, what you did to cause it and what the 7045as you possibly can about the problem, what you did to cause it
7621local and remote machines are. 7046and what the local and remote machines are.
7047
7048If you can give a simple set of instructions to make this bug
7049happen reliably, please include those. Thank you for helping
7050kill bugs in TRAMP.
7622 7051
7623If you can give a simple set of instructions to make this bug happen 7052Another useful thing to do is to put
7624reliably, please include those. Thank you for helping kill bugs in
7625TRAMP.
7626 7053
7627Another useful thing to do is to put (setq tramp-debug-buffer t) in 7054 (setq tramp-verbose 8)
7628the ~/.emacs file and to repeat the bug. Then, include the contents 7055
7629of the *tramp/foo* buffer and the *debug tramp/foo* buffer in your bug 7056in the ~/.emacs file and to repeat the bug. Then, include the
7630report. 7057contents of the *tramp/foo* buffer and the *debug tramp/foo*
7058buffer in your bug report.
7631 7059
7632--bug report follows this line-- 7060--bug report follows this line--
7633")))) 7061"))))
@@ -7639,29 +7067,32 @@ Used for non-7bit chars in strings."
7639 (val (with-current-buffer reporter-eval-buffer 7067 (val (with-current-buffer reporter-eval-buffer
7640 (symbol-value varsym)))) 7068 (symbol-value varsym))))
7641 7069
7642 ;; There are characters to be masked. 7070 (if (hash-table-p val)
7643 (when (and (boundp 'mm-7bit-chars) 7071 ;; Pretty print the cache.
7644 (string-match 7072 (set varsym (read (format "(%s)" (tramp-cache-print val))))
7645 (concat "[^" (symbol-value 'mm-7bit-chars) "]") val)) 7073 ;; There are characters to be masked.
7646 (with-current-buffer reporter-eval-buffer 7074 (when (and (boundp 'mm-7bit-chars)
7647 (set varsym (concat "(base64-decode-string \"" 7075 (string-match
7648 (base64-encode-string val) 7076 (concat "[^" (symbol-value 'mm-7bit-chars) "]") val))
7649 "\")")))) 7077 (with-current-buffer reporter-eval-buffer
7078 (set varsym (format "(base64-decode-string \"%s\""
7079 (base64-encode-string val))))))
7650 7080
7651 ;; Dump variable. 7081 ;; Dump variable.
7652 (funcall (symbol-function 'reporter-dump-variable) varsym mailbuf) 7082 (funcall (symbol-function 'reporter-dump-variable) varsym mailbuf)
7653 7083
7654 ;; Remove string quotation. 7084 (unless (hash-table-p val)
7655 (forward-line -1) 7085 ;; Remove string quotation.
7656 (when (looking-at 7086 (forward-line -1)
7657 (concat "\\(^.*\\)" "\"" ;; \1 " 7087 (when (looking-at
7658 "\\((base64-decode-string \\)" "\\\\" ;; \2 \ 7088 (concat "\\(^.*\\)" "\"" ;; \1 "
7659 "\\(\".*\\)" "\\\\" ;; \3 \ 7089 "\\((base64-decode-string \\)" "\\\\" ;; \2 \
7660 "\\(\")\\)" "\"$")) ;; \4 " 7090 "\\(\".*\\)" "\\\\" ;; \3 \
7661 (replace-match "\\1\\2\\3\\4") 7091 "\\(\")\\)" "\"$")) ;; \4 "
7662 (beginning-of-line) 7092 (replace-match "\\1\\2\\3\\4")
7663 (insert " ;; variable encoded due to non-printable characters\n")) 7093 (beginning-of-line)
7664 (forward-line 1) 7094 (insert " ;; variable encoded due to non-printable characters\n"))
7095 (forward-line 1))
7665 7096
7666 ;; Reset VARSYM to old value. 7097 ;; Reset VARSYM to old value.
7667 (with-current-buffer reporter-eval-buffer 7098 (with-current-buffer reporter-eval-buffer
@@ -7683,8 +7114,39 @@ Used for non-7bit chars in strings."
7683 (funcall (symbol-function 'mml-mode) t))) 7114 (funcall (symbol-function 'mml-mode) t)))
7684 7115
7685(defun tramp-append-tramp-buffers () 7116(defun tramp-append-tramp-buffers ()
7686 "Append Tramp buffers into the bug report." 7117 "Append Tramp buffers and buffer local variables into the bug report."
7687 7118
7119 (goto-char (point-max))
7120
7121 ;; Dump buffer local variables.
7122 (dolist (buffer
7123 (delq nil
7124 (mapcar
7125 '(lambda (b)
7126 (when (string-match "\\*tramp/" (buffer-name b)) b))
7127 (buffer-list))))
7128 (let ((reporter-eval-buffer buffer)
7129 (buffer-name (buffer-name buffer))
7130 (elbuf (get-buffer-create " *tmp-reporter-buffer*")))
7131 (with-current-buffer elbuf
7132 (emacs-lisp-mode)
7133 (erase-buffer)
7134 (insert "\n(setq\n")
7135 (lisp-indent-line)
7136 (funcall (symbol-function 'reporter-dump-variable)
7137 'buffer-name (current-buffer))
7138 (dolist (varsym-or-cons-cell (buffer-local-variables buffer))
7139 (let ((varsym (or (car-safe varsym-or-cons-cell)
7140 varsym-or-cons-cell)))
7141 (when (string-match "tramp" (symbol-name varsym))
7142 (funcall
7143 (symbol-function 'reporter-dump-variable)
7144 varsym (current-buffer)))))
7145 (lisp-indent-line)
7146 (insert ")\n"))
7147 (insert-buffer-substring elbuf)))
7148
7149 ;; Append buffers only when we are in message mode.
7688 (when (and 7150 (when (and
7689 (eq major-mode 'message-mode) 7151 (eq major-mode 'message-mode)
7690 (boundp 'mml-mode) 7152 (boundp 'mml-mode)
@@ -7705,24 +7167,26 @@ Used for non-7bit chars in strings."
7705 (setq buffer-read-only nil) 7167 (setq buffer-read-only nil)
7706 (goto-char (point-min)) 7168 (goto-char (point-min))
7707 (while (not (eobp)) 7169 (while (not (eobp))
7708 (if (re-search-forward tramp-buf-regexp (tramp-point-at-eol) t) 7170 (if (re-search-forward tramp-buf-regexp (tramp-line-end-position) t)
7709 (forward-line 1) 7171 (forward-line 1)
7710 (forward-line 0) 7172 (forward-line 0)
7711 (let ((start (point))) 7173 (let ((start (point)))
7712 (forward-line 1) 7174 (forward-line 1)
7713 (kill-region start (point))))) 7175 (kill-region start (point)))))
7714 (insert " 7176 (insert "
7715The buffer(s) above will be appended to this message. If you don't want 7177The buffer(s) above will be appended to this message. If you
7716to append a buffer because it contains sensible data, or because the buffer 7178don't want to append a buffer because it contains sensitive data,
7717is too large, you should delete the respective buffer. The buffer(s) will 7179or because the buffer is too large, you should delete the
7718contain user and host names. Passwords will never be included there.") 7180respective buffer. The buffer(s) will contain user and host
7181names. Passwords will never be included there.")
7719 7182
7720 (when (and tramp-debug-buffer (> tramp-verbose 9)) 7183 (when (>= tramp-verbose 6)
7721 (insert "\n\n") 7184 (insert "\n\n")
7722 (let ((start (point))) 7185 (let ((start (point)))
7723 (insert "\ 7186 (insert "\
7724Please note that you have set `tramp-verbose' to a value greater than 9. 7187Please note that you have set `tramp-verbose' to a value of at
7725Therefore, the contents of files might be included in the debug buffer(s).") 7188least 6. Therefore, the contents of files might be included in
7189the debug buffer(s).")
7726 (add-text-properties start (point) (list 'face 'italic)))) 7190 (add-text-properties start (point) (list 'face 'italic))))
7727 7191
7728 (set-buffer-modified-p nil) 7192 (set-buffer-modified-p nil)
@@ -7735,7 +7199,10 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7735 (kill-buffer nil) 7199 (kill-buffer nil)
7736 (switch-to-buffer curbuf) 7200 (switch-to-buffer curbuf)
7737 (goto-char (point-max)) 7201 (goto-char (point-max))
7738 (insert "\n\n") 7202 (insert "\n\
7203This is a special notion of the `gnus/message' package. If you
7204use another mail agent (by copying the contents of this buffer)
7205please ensure that the buffers are attached to your email.\n\n")
7739 (dolist (buffer buffer-list) 7206 (dolist (buffer buffer-list)
7740 (funcall (symbol-function 'mml-insert-empty-tag) 7207 (funcall (symbol-function 'mml-insert-empty-tag)
7741 'part 'type "text/plain" 'encoding "base64" 7208 'part 'type "text/plain" 'encoding "base64"
@@ -7766,9 +7233,9 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7766 ;; ange-ftp settings must be enabled. 7233 ;; ange-ftp settings must be enabled.
7767 (when (functionp 'tramp-ftp-enable-ange-ftp) 7234 (when (functionp 'tramp-ftp-enable-ange-ftp)
7768 (funcall (symbol-function 'tramp-ftp-enable-ange-ftp))) 7235 (funcall (symbol-function 'tramp-ftp-enable-ange-ftp)))
7769 ;; `tramp-util' unloads also `tramp'. 7236 ;; Maybe its not loaded yet.
7770 (condition-case nil ;; maybe its not loaded yet. 7237 (condition-case nil
7771 (unload-feature (if (featurep 'tramp-util) 'tramp-util 'tramp) 'force) 7238 (unload-feature 'tramp 'force)
7772 (error nil))) 7239 (error nil)))
7773 7240
7774(provide 'tramp) 7241(provide 'tramp)
@@ -7776,9 +7243,9 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7776;; Make sure that we get integration with the VC package. 7243;; Make sure that we get integration with the VC package.
7777;; When it is loaded, we need to pull in the integration module. 7244;; When it is loaded, we need to pull in the integration module.
7778;; This must come after (provide 'tramp) because tramp-vc.el 7245;; This must come after (provide 'tramp) because tramp-vc.el
7779;; requires tramp. 7246;; requires tramp. Not necessary in Emacs 23.
7780(eval-after-load "vc" 7247(eval-after-load "vc"
7781 '(progn 7248 '(unless (functionp 'start-file-process)
7782 (require 'tramp-vc) 7249 (require 'tramp-vc)
7783 (add-hook 'tramp-unload-hook 7250 (add-hook 'tramp-unload-hook
7784 '(lambda () 7251 '(lambda ()
@@ -7795,6 +7262,12 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7795;; Another approach is to read a netrc file like ~/.authinfo 7262;; Another approach is to read a netrc file like ~/.authinfo
7796;; from Gnus. 7263;; from Gnus.
7797;; * Handle nonlocal exits such as C-g. 7264;; * Handle nonlocal exits such as C-g.
7265;; * But it would probably be better to use with-local-quit at the
7266;; place where it's actually needed: around any potentially
7267;; indefinitely blocking piece of code. In this case it would be
7268;; within Tramp around one of its calls to accept-process-output (or
7269;; around one of the loops that calls accept-process-output)
7270;; (Stefann Monnier).
7798;; * Autodetect if remote `ls' groks the "--dired" switch. 7271;; * Autodetect if remote `ls' groks the "--dired" switch.
7799;; * Add fallback for inline encodings. This should be used 7272;; * Add fallback for inline encodings. This should be used
7800;; if the remote end doesn't support mimencode or a similar program. 7273;; if the remote end doesn't support mimencode or a similar program.
@@ -7808,9 +7281,6 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7808;; two commands to write a null byte: 7281;; two commands to write a null byte:
7809;; dd if=/dev/zero bs=1 count=1 7282;; dd if=/dev/zero bs=1 count=1
7810;; echo | tr '\n' '\000' 7283;; echo | tr '\n' '\000'
7811;; * Separate local `tramp-coding-commands' from remote ones. Connect
7812;; the two via a format which can be `uu' or `b64'. Then we can search
7813;; for the right local commands and the right remote commands separately.
7814;; * Cooperate with PCL-CVS. It uses start-process, which doesn't 7284;; * Cooperate with PCL-CVS. It uses start-process, which doesn't
7815;; work for remote files. 7285;; work for remote files.
7816;; * Rewrite `tramp-shell-quote-argument' to abstain from using 7286;; * Rewrite `tramp-shell-quote-argument' to abstain from using
@@ -7830,43 +7300,27 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7830;; * Don't use globbing for directories with many files, as this is 7300;; * Don't use globbing for directories with many files, as this is
7831;; likely to produce long command lines, and some shells choke on 7301;; likely to produce long command lines, and some shells choke on
7832;; long command lines. 7302;; long command lines.
7833;; * Find out about the new auto-save mechanism in Emacs 21 and
7834;; do the right thing.
7835;; * `vc-directory' does not work. It never displays any files, even 7303;; * `vc-directory' does not work. It never displays any files, even
7836;; if it does show files when run locally. 7304;; if it does show files when run locally.
7837;; * Allow correction of passwords, if the remote end allows this. 7305;; * Allow correction of passwords, if the remote end allows this.
7838;; (Mark Hershberger) 7306;; (Mark Hershberger)
7839;; * How to deal with MULE in `insert-file-contents' and `write-region'? 7307;; * How to deal with MULE in `insert-file-contents' and `write-region'?
7840;; * Do asynchronous `shell-command's.
7841;; * Grok `append' parameter for `write-region'. 7308;; * Grok `append' parameter for `write-region'.
7842;; * Test remote ksh or bash for tilde expansion in `tramp-find-shell'? 7309;; * Test remote ksh or bash for tilde expansion in `tramp-find-shell'?
7843;; * abbreviate-file-name 7310;; * abbreviate-file-name
7844;; * grok ~ in tramp-remote-path (Henrik Holm <henrikh@tele.ntnu.no>) 7311;; * grok ~ in tramp-remote-path (Henrik Holm <henrikh@tele.ntnu.no>)
7845;; * Also allow to omit user names when doing multi-hop. Not sure yet
7846;; what the user names should default to, though.
7847;; * better error checking. At least whenever we see something 7312;; * better error checking. At least whenever we see something
7848;; strange when doing zerop, we should kill the process and start 7313;; strange when doing zerop, we should kill the process and start
7849;; again. (Greg Stark) 7314;; again. (Greg Stark)
7850;; * Add caching for filename completion. (Greg Stark)
7851;; Of course, this has issues with usability (stale cache bites)
7852;; -- <daniel@danann.net>
7853;; * Provide a local cache of old versions of remote files for the rsync 7315;; * Provide a local cache of old versions of remote files for the rsync
7854;; transfer method to use. (Greg Stark) 7316;; transfer method to use. (Greg Stark)
7855;; * Remove unneeded parameters from methods. 7317;; * Remove unneeded parameters from methods.
7856;; * Invoke rsync once for copying a whole directory hierarchy. 7318;; * Invoke rsync once for copying a whole directory hierarchy.
7857;; (Francesco Potort,Al(B) 7319;; (Francesco Potort,Al(B)
7858;; * Should we set PATH ourselves or should we rely on the remote end
7859;; to do it?
7860;; * Make it work for XEmacs 20, which is missing `with-timeout'.
7861;; * Make it work for different encodings, and for different file name 7320;; * Make it work for different encodings, and for different file name
7862;; encodings, too. (Daniel Pittman) 7321;; encodings, too. (Daniel Pittman)
7863;; * Change applicable functions to pass a struct tramp-file-name rather
7864;; than the individual items MULTI-METHOD, METHOD, USER, HOST, LOCALNAME.
7865;; * Implement asynchronous shell commands.
7866;; * Clean up unused *tramp/foo* buffers after a while. (Pete Forman) 7322;; * Clean up unused *tramp/foo* buffers after a while. (Pete Forman)
7867;; * Progress reports while copying files. (Michael Kifer) 7323;; * Progress reports while copying files. (Michael Kifer)
7868;; * `Smart' connection method that uses inline for small and out of
7869;; band for large files. (Michael Kifer)
7870;; * Don't search for perl5 and perl. Instead, only search for perl and 7324;; * Don't search for perl5 and perl. Instead, only search for perl and
7871;; then look if it's the right version (with `perl -v'). 7325;; then look if it's the right version (with `perl -v').
7872;; * When editing a remote CVS controlled file as a different user, VC 7326;; * When editing a remote CVS controlled file as a different user, VC
@@ -7879,19 +7333,49 @@ Therefore, the contents of files might be included in the debug buffer(s).")
7879;; about Tramp, it does not do the right thing if the target file 7333;; about Tramp, it does not do the right thing if the target file
7880;; name is a Tramp name. 7334;; name is a Tramp name.
7881;; * Username and hostname completion. 7335;; * Username and hostname completion.
7882;; ** If `partial-completion-mode' isn't loaded, "/foo:bla" tries to
7883;; connect to host "blabla" already if that host is unique. No idea
7884;; how to suppress. Maybe not an essential problem.
7885;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode'. 7336;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode'.
7886;; ** Extend `tramp-get-completion-su' for NIS and shadow passwords.
7887;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'. 7337;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'.
7888;; Code is nearly identical. 7338;; Code is nearly identical.
7889;; ** Decide whiche files to take for searching user/host names depending on
7890;; operating system (windows-nt) in `tramp-completion-function-alist'.
7891;; ** Enhance variables for debug.
7892;; ** Implement "/multi:" completion.
7893;; ** Add a learning mode for completion. Make results persistent.
7894;; * Allow out-of-band methods as _last_ multi-hop. 7339;; * Allow out-of-band methods as _last_ multi-hop.
7340;; * WIBNI if we had a command "trampclient"? If I was editing in
7341;; some shell with root priviledges, it would be nice if I could
7342;; just call
7343;; trampclient filename.c
7344;; as an editor, and the _current_ shell would connect to an Emacs
7345;; server and would be used in an existing non-priviledged Emacs
7346;; session for doing the editing in question.
7347;; That way, I need not tell Emacs my password again and be afraid
7348;; that it makes it into core dumps or other ugly stuff (I had Emacs
7349;; once display a just typed password in the context of a keyboard
7350;; sequence prompt for a question immediately following in a shell
7351;; script run within Emacs -- nasty).
7352;; And if I have some ssh session running to a different computer,
7353;; having the possibility of passing a local file there to a local
7354;; Emacs session (in case I can arrange for a connection back) would
7355;; be nice.
7356;; Likely the corresponding tramp server should not allow the
7357;; equivalent of the emacsclient -eval option in order to make this
7358;; reasonably unproblematic. And maybe trampclient should have some
7359;; way of passing credentials, like by using an SSL socket or
7360;; something. (David Kastrup)
7361;; * Could Tramp reasonably look for a prompt after ^M rather than
7362;; only after ^J ? (Stefan Monnier)
7363;; * WIBNI there was an interactive command prompting for tramp
7364;; method, hostname, username and filename and translates the user
7365;; input into the correct filename syntax (depending on the Emacs
7366;; flavor) (Reiner Steib)
7367;; * Let the user edit the connection properties interactively.
7368;; Something like `gnus-server-edit-server' in Gnus' *Server* buffer.
7369;; * Reconnect directly to a compliant shell without first going
7370;; through the user's default shell. (Pete Forman)
7371;; * It's just that when I come to Customize `tramp-default-user-alist'
7372;; I'm presented with a mismatch and raw lisp for a value. It is my
7373;; understanding that a variable declared with defcustom is a User
7374;; Option and should not be modified by the code. add-to-list is
7375;; called in several places. One way to handle that is to have a new
7376;; ordinary variable that gets its initial value from
7377;; tramp-default-user-alist and then is added to. (Pete Forman)
7378;; * Make `tramp-default-user' obsolete.
7895 7379
7896;; Functions for file-name-handler-alist: 7380;; Functions for file-name-handler-alist:
7897;; diff-latest-backup-file -- in diff.el 7381;; diff-latest-backup-file -- in diff.el
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 485c58afa65..f7961ee267d 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -11,8 +11,8 @@
11 11
12;; GNU Emacs is free software; you can redistribute it and/or modify 12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by 13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option) 14;; the Free Software Foundation; either version 3 of the License, or
15;; any later version. 15;; (at your option) any later version.
16 16
17;; GNU Emacs is distributed in the hope that it will be useful, 17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -20,22 +20,26 @@
20;; GNU General Public License for more details. 20;; GNU General Public License for more details.
21 21
22;; You should have received a copy of the GNU General Public License 22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; along with GNU Emacs; see the file COPYING. If not, see
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; <http://www.gnu.org/licenses/>.
25;; Boston, MA 02110-1301, USA.
26 25
27;;; Code: 26;;; Code:
28 27
29;; In the Tramp CVS repository, the version numer and the bug report address 28;; In the Tramp CVS repository, the version numer and the bug report address
30;; are auto-frobbed from configure.ac, so you should edit that file and run 29;; are auto-frobbed from configure.ac, so you should edit that file and run
31;; "autoconf && ./configure" to change them. 30;; "autoconf && ./configure" to change them. (X)Emacs version check is defined
31;; in macro AC_EMACS_INFO of aclocal.m4; should be changed only there.
32 32
33(defconst tramp-version "2.0.56" 33(defconst tramp-version "2.1.10-pre"
34 "This version of Tramp.") 34 "This version of Tramp.")
35 35
36(defconst tramp-bug-report-address "tramp-devel@gnu.org" 36(defconst tramp-bug-report-address "tramp-devel@gnu.org"
37 "Email address to send bug reports to.") 37 "Email address to send bug reports to.")
38 38
39;; Check for (X)Emacs version.
40(let ((x (if (or (< emacs-major-version 21) (and (featurep 'xemacs) (< emacs-minor-version 4))) (format "Tramp 2.1.10-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version)))) "ok")))
41 (unless (string-match "\\`ok\\'" x) (error x)))
42
39(provide 'trampver) 43(provide 'trampver)
40 44
41;;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1 45;;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index efb5980766d..86d930127b5 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -711,6 +711,7 @@ If PREDICATE is non-nil, it will also be used to refine the match
711If no directory information can be extracted from the completed 711If no directory information can be extracted from the completed
712component, `default-directory' is used as the basis for completion." 712component, `default-directory' is used as the basis for completion."
713 (let* ((name (substitute-env-vars pcomplete-stub)) 713 (let* ((name (substitute-env-vars pcomplete-stub))
714 (completion-ignore-case pcomplete-ignore-case)
714 (default-directory (expand-file-name 715 (default-directory (expand-file-name
715 (or (file-name-directory name) 716 (or (file-name-directory name)
716 default-directory))) 717 default-directory)))
diff --git a/lisp/pcvs-info.el b/lisp/pcvs-info.el
index 6e36b5a93e3..880972bff9d 100644
--- a/lisp/pcvs-info.el
+++ b/lisp/pcvs-info.el
@@ -85,9 +85,9 @@ to confuse some users sometimes."
85 85
86(defface cvs-unknown 86(defface cvs-unknown
87 '((((class color) (background dark)) 87 '((((class color) (background dark))
88 (:foreground "red")) 88 (:foreground "red1"))
89 (((class color) (background light)) 89 (((class color) (background light))
90 (:foreground "red")) 90 (:foreground "red1"))
91 (t (:slant italic))) 91 (t (:slant italic)))
92 "PCL-CVS face used to highlight unknown file status." 92 "PCL-CVS face used to highlight unknown file status."
93 :group 'pcl-cvs) 93 :group 'pcl-cvs)
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index a9f5f77c126..94def936fb9 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -87,13 +87,13 @@
87 87
88;;;###autoload 88;;;###autoload
89(defcustom compilation-mode-hook nil 89(defcustom compilation-mode-hook nil
90 "*List of hook functions run by `compilation-mode' (see `run-mode-hooks')." 90 "List of hook functions run by `compilation-mode' (see `run-mode-hooks')."
91 :type 'hook 91 :type 'hook
92 :group 'compilation) 92 :group 'compilation)
93 93
94;;;###autoload 94;;;###autoload
95(defcustom compilation-window-height nil 95(defcustom compilation-window-height nil
96 "*Number of lines in a compilation window. If nil, use Emacs default." 96 "Number of lines in a compilation window. If nil, use Emacs default."
97 :type '(choice (const :tag "Default" nil) 97 :type '(choice (const :tag "Default" nil)
98 integer) 98 integer)
99 :group 'compilation) 99 :group 'compilation)
@@ -442,7 +442,7 @@ Highlight entire line if t; don't highlight source lines if nil.")
442 "Overlay used to temporarily highlight compilation matches.") 442 "Overlay used to temporarily highlight compilation matches.")
443 443
444(defcustom compilation-error-screen-columns t 444(defcustom compilation-error-screen-columns t
445 "*If non-nil, column numbers in error messages are screen columns. 445 "If non-nil, column numbers in error messages are screen columns.
446Otherwise they are interpreted as character positions, with 446Otherwise they are interpreted as character positions, with
447each character occupying one column. 447each character occupying one column.
448The default is to use screen columns, which requires that the compilation 448The default is to use screen columns, which requires that the compilation
@@ -453,21 +453,21 @@ especially the TAB character."
453 :version "20.4") 453 :version "20.4")
454 454
455(defcustom compilation-read-command t 455(defcustom compilation-read-command t
456 "*Non-nil means \\[compile] reads the compilation command to use. 456 "Non-nil means \\[compile] reads the compilation command to use.
457Otherwise, \\[compile] just uses the value of `compile-command'." 457Otherwise, \\[compile] just uses the value of `compile-command'."
458 :type 'boolean 458 :type 'boolean
459 :group 'compilation) 459 :group 'compilation)
460 460
461;;;###autoload 461;;;###autoload
462(defcustom compilation-ask-about-save t 462(defcustom compilation-ask-about-save t
463 "*Non-nil means \\[compile] asks which buffers to save before compiling. 463 "Non-nil means \\[compile] asks which buffers to save before compiling.
464Otherwise, it saves all modified buffers without asking." 464Otherwise, it saves all modified buffers without asking."
465 :type 'boolean 465 :type 'boolean
466 :group 'compilation) 466 :group 'compilation)
467 467
468;;;###autoload 468;;;###autoload
469(defcustom compilation-search-path '(nil) 469(defcustom compilation-search-path '(nil)
470 "*List of directories to search for source files named in error messages. 470 "List of directories to search for source files named in error messages.
471Elements should be directory names, not file names of directories. 471Elements should be directory names, not file names of directories.
472The value nil as an element means to try the default directory." 472The value nil as an element means to try the default directory."
473 :type '(repeat (choice (const :tag "Default" nil) 473 :type '(repeat (choice (const :tag "Default" nil)
@@ -476,7 +476,7 @@ The value nil as an element means to try the default directory."
476 476
477;;;###autoload 477;;;###autoload
478(defcustom compile-command "make -k " 478(defcustom compile-command "make -k "
479 "*Last shell command used to do a compilation; default for next compilation. 479 "Last shell command used to do a compilation; default for next compilation.
480 480
481Sometimes it is useful for files to supply local values for this variable. 481Sometimes it is useful for files to supply local values for this variable.
482You might also use mode hooks to specify it in certain modes, like this: 482You might also use mode hooks to specify it in certain modes, like this:
@@ -494,7 +494,7 @@ You might also use mode hooks to specify it in certain modes, like this:
494 494
495;;;###autoload 495;;;###autoload
496(defcustom compilation-disable-input nil 496(defcustom compilation-disable-input nil
497 "*If non-nil, send end-of-file as compilation process input. 497 "If non-nil, send end-of-file as compilation process input.
498This only affects platforms that support asynchronous processes (see 498This only affects platforms that support asynchronous processes (see
499`start-process'); synchronous compilation processes never accept input." 499`start-process'); synchronous compilation processes never accept input."
500 :type 'boolean 500 :type 'boolean
@@ -605,6 +605,14 @@ Faces `compilation-error-face', `compilation-warning-face',
605(defvar compilation-error-list nil) 605(defvar compilation-error-list nil)
606(defvar compilation-old-error-list nil) 606(defvar compilation-old-error-list nil)
607 607
608(defcustom compilation-auto-jump-to-first-error nil
609 "If non-nil, automatically jump to the first error after `compile'."
610 :type 'boolean)
611
612(defvar compilation-auto-jump-to-next nil
613 "If non-nil, automatically jump to the next error encountered.")
614(make-variable-buffer-local 'compilation-auto-jump-to-next)
615
608(defun compilation-face (type) 616(defun compilation-face (type)
609 (or (and (car type) (match-end (car type)) compilation-warning-face) 617 (or (and (car type) (match-end (car type)) compilation-warning-face)
610 (and (cdr type) (match-end (cdr type)) compilation-info-face) 618 (and (cdr type) (match-end (cdr type)) compilation-info-face)
@@ -652,13 +660,18 @@ Faces `compilation-error-face', `compilation-warning-face',
652 l2 660 l2
653 (setcdr l1 (cons (list ,key) l2))))))) 661 (setcdr l1 (cons (list ,key) l2)))))))
654 662
663(defun compilation-auto-jump (buffer pos)
664 (with-current-buffer buffer
665 (goto-char pos)
666 (compile-goto-error)))
655 667
656;; This function is the central driver, called when font-locking to gather 668;; This function is the central driver, called when font-locking to gather
657;; all information needed to later jump to corresponding source code. 669;; all information needed to later jump to corresponding source code.
658;; Return a property list with all meta information on this error location. 670;; Return a property list with all meta information on this error location.
659 671
660(defun compilation-error-properties (file line end-line col end-col type fmt) 672(defun compilation-error-properties (file line end-line col end-col type fmt)
661 (unless (< (next-single-property-change (match-beginning 0) 'directory nil (point)) 673 (unless (< (next-single-property-change (match-beginning 0)
674 'directory nil (point))
662 (point)) 675 (point))
663 (if file 676 (if file
664 (if (functionp file) 677 (if (functionp file)
@@ -710,6 +723,13 @@ Faces `compilation-error-face', `compilation-warning-face',
710 (setq type (or (and (car type) (match-end (car type)) 1) 723 (setq type (or (and (car type) (match-end (car type)) 1)
711 (and (cdr type) (match-end (cdr type)) 0) 724 (and (cdr type) (match-end (cdr type)) 0)
712 2))) 725 2)))
726
727 (when (and compilation-auto-jump-to-next
728 (>= type compilation-skip-threshold))
729 (kill-local-variable 'compilation-auto-jump-to-next)
730 (run-with-timer 0 nil 'compilation-auto-jump
731 (current-buffer) (match-beginning 0)))
732
713 (compilation-internal-error-properties file line end-line col end-col type fmt))) 733 (compilation-internal-error-properties file line end-line col end-col type fmt)))
714 734
715(defun compilation-move-to-column (col screen) 735(defun compilation-move-to-column (col screen)
@@ -932,7 +952,7 @@ original use. Otherwise, recompile using `compile-command'."
932 `(,(eval compile-command)))))) 952 `(,(eval compile-command))))))
933 953
934(defcustom compilation-scroll-output nil 954(defcustom compilation-scroll-output nil
935 "*Non-nil to scroll the *compilation* buffer window as output appears. 955 "Non-nil to scroll the *compilation* buffer window as output appears.
936 956
937Setting it causes the Compilation mode commands to put point at the 957Setting it causes the Compilation mode commands to put point at the
938end of their output window so that the end of the output is always 958end of their output window so that the end of the output is always
@@ -1026,8 +1046,9 @@ Returns the compilation buffer created."
1026 ;; Clear out the compilation buffer. 1046 ;; Clear out the compilation buffer.
1027 (let ((inhibit-read-only t) 1047 (let ((inhibit-read-only t)
1028 (default-directory thisdir)) 1048 (default-directory thisdir))
1029 ;; Then evaluate a cd command if any, but don't perform it yet, else start-command 1049 ;; Then evaluate a cd command if any, but don't perform it yet, else
1030 ;; would do it again through the shell: (cd "..") AND sh -c "cd ..; make" 1050 ;; start-command would do it again through the shell: (cd "..") AND
1051 ;; sh -c "cd ..; make"
1031 (cd (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" command) 1052 (cd (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" command)
1032 (if (match-end 1) 1053 (if (match-end 1)
1033 (substitute-env-vars (match-string 1 command)) 1054 (substitute-env-vars (match-string 1 command))
@@ -1043,6 +1064,8 @@ Returns the compilation buffer created."
1043 (if highlight-regexp 1064 (if highlight-regexp
1044 (set (make-local-variable 'compilation-highlight-regexp) 1065 (set (make-local-variable 'compilation-highlight-regexp)
1045 highlight-regexp)) 1066 highlight-regexp))
1067 (if compilation-auto-jump-to-first-error
1068 (set (make-local-variable 'compilation-auto-jump-to-next) t))
1046 ;; Output a mode setter, for saving and later reloading this buffer. 1069 ;; Output a mode setter, for saving and later reloading this buffer.
1047 (insert "-*- mode: " name-of-mode 1070 (insert "-*- mode: " name-of-mode
1048 "; default-directory: " (prin1-to-string default-directory) 1071 "; default-directory: " (prin1-to-string default-directory)
@@ -1075,7 +1098,8 @@ Returns the compilation buffer created."
1075 (unless (getenv "EMACS") 1098 (unless (getenv "EMACS")
1076 (list "EMACS=t")) 1099 (list "EMACS=t"))
1077 (list "INSIDE_EMACS=t") 1100 (list "INSIDE_EMACS=t")
1078 (copy-sequence process-environment)))) 1101 (copy-sequence process-environment)))
1102 (start-process (symbol-function 'start-process)))
1079 (set (make-local-variable 'compilation-arguments) 1103 (set (make-local-variable 'compilation-arguments)
1080 (list command mode name-function highlight-regexp)) 1104 (list command mode name-function highlight-regexp))
1081 (set (make-local-variable 'revert-buffer-function) 1105 (set (make-local-variable 'revert-buffer-function)
@@ -1091,53 +1115,39 @@ Returns the compilation buffer created."
1091 (funcall compilation-process-setup-function)) 1115 (funcall compilation-process-setup-function))
1092 (compilation-set-window-height outwin) 1116 (compilation-set-window-height outwin)
1093 ;; Start the compilation. 1117 ;; Start the compilation.
1094 (if (fboundp 'start-process) 1118 (let ((proc
1095 (let ((proc (if (eq mode t) 1119 (if (eq mode t)
1096 (get-buffer-process 1120 ;; comint uses `start-file-process'.
1097 (with-no-warnings 1121 (get-buffer-process
1098 (comint-exec outbuf (downcase mode-name) 1122 (with-no-warnings
1099 shell-file-name nil `("-c" ,command)))) 1123 (comint-exec outbuf (downcase mode-name)
1100 (start-process-shell-command (downcase mode-name) 1124 shell-file-name nil `("-c" ,command))))
1101 outbuf command)))) 1125 ;; Redefine temporarily `start-process' in order to
1102 ;; Make the buffer's mode line show process state. 1126 ;; handle remote compilation.
1103 (setq mode-line-process '(":%s")) 1127 (fset 'start-process
1104 (set-process-sentinel proc 'compilation-sentinel) 1128 (lambda (name buffer program &rest program-args)
1105 (set-process-filter proc 'compilation-filter) 1129 (apply
1106 (set-marker (process-mark proc) (point) outbuf) 1130 (if (file-remote-p default-directory)
1107 (when compilation-disable-input 1131 'start-file-process
1108 (condition-case nil 1132 start-process)
1109 (process-send-eof proc) 1133 name buffer program program-args)))
1110 ;; The process may have exited already. 1134 (unwind-protect
1111 (error nil))) 1135 (start-process-shell-command (downcase mode-name)
1112 (setq compilation-in-progress 1136 outbuf command)
1113 (cons proc compilation-in-progress))) 1137 ;; Unwindform: Reset original definition of `start-process'.
1114 ;; No asynchronous processes available. 1138 (fset 'start-process start-process)))))
1115 (message "Executing `%s'..." command) 1139 ;; Make the buffer's mode line show process state.
1116 ;; Fake modeline display as if `start-process' were run. 1140 (setq mode-line-process '(":%s"))
1117 (setq mode-line-process ":run") 1141 (set-process-sentinel proc 'compilation-sentinel)
1118 (force-mode-line-update) 1142 (set-process-filter proc 'compilation-filter)
1119 (sit-for 0) ; Force redisplay 1143 (set-marker (process-mark proc) (point) outbuf)
1120 (let* ((buffer-read-only nil) ; call-process needs to modify outbuf 1144 (when compilation-disable-input
1121 (status (call-process shell-file-name nil outbuf nil "-c" 1145 (condition-case nil
1122 command))) 1146 (process-send-eof proc)
1123 (cond ((numberp status) 1147 ;; The process may have exited already.
1124 (compilation-handle-exit 'exit status 1148 (error nil)))
1125 (if (zerop status) 1149 (setq compilation-in-progress
1126 "finished\n" 1150 (cons proc compilation-in-progress))))
1127 (format "\
1128exited abnormally with code %d\n"
1129 status))))
1130 ((stringp status)
1131 (compilation-handle-exit 'signal status
1132 (concat status "\n")))
1133 (t
1134 (compilation-handle-exit 'bizarre status status))))
1135 ;; Without async subprocesses, the buffer is not yet
1136 ;; fontified, so fontify it now.
1137 (let ((font-lock-verbose nil)) ; shut up font-lock messages
1138 (font-lock-fontify-buffer))
1139 (set-buffer-modified-p nil)
1140 (message "Executing `%s'...done" command)))
1141 ;; Now finally cd to where the shell started make/grep/... 1151 ;; Now finally cd to where the shell started make/grep/...
1142 (setq default-directory thisdir)) 1152 (setq default-directory thisdir))
1143 (if (buffer-local-value 'compilation-scroll-output outbuf) 1153 (if (buffer-local-value 'compilation-scroll-output outbuf)
@@ -1258,7 +1268,7 @@ exited abnormally with code %d\n"
1258 "*If non-nil, skip multiple error messages for the same source location.") 1268 "*If non-nil, skip multiple error messages for the same source location.")
1259 1269
1260(defcustom compilation-skip-threshold 1 1270(defcustom compilation-skip-threshold 1
1261 "*Compilation motion commands skip less important messages. 1271 "Compilation motion commands skip less important messages.
1262The value can be either 2 -- skip anything less than error, 1 -- 1272The value can be either 2 -- skip anything less than error, 1 --
1263skip anything less than warning or 0 -- don't skip any messages. 1273skip anything less than warning or 0 -- don't skip any messages.
1264Note that all messages not positively identified as warning or 1274Note that all messages not positively identified as warning or
@@ -1270,7 +1280,7 @@ info, are considered errors."
1270 :version "22.1") 1280 :version "22.1")
1271 1281
1272(defcustom compilation-skip-visited nil 1282(defcustom compilation-skip-visited nil
1273 "*Compilation motion commands skip visited messages if this is t. 1283 "Compilation motion commands skip visited messages if this is t.
1274Visited messages are ones for which the file, line and column have been jumped 1284Visited messages are ones for which the file, line and column have been jumped
1275to from the current content in the current compilation buffer, even if it was 1285to from the current content in the current compilation buffer, even if it was
1276from a different message." 1286from a different message."
@@ -1371,6 +1381,8 @@ Optional argument MINOR indicates this is called from
1371 ;; with the next-error function in simple.el, and it's only 1381 ;; with the next-error function in simple.el, and it's only
1372 ;; coincidentally named similarly to compilation-next-error. 1382 ;; coincidentally named similarly to compilation-next-error.
1373 (setq next-error-function 'compilation-next-error-function) 1383 (setq next-error-function 'compilation-next-error-function)
1384 (set (make-local-variable 'comint-file-name-prefix)
1385 (or (file-remote-p default-directory) ""))
1374 (set (make-local-variable 'font-lock-extra-managed-props) 1386 (set (make-local-variable 'font-lock-extra-managed-props)
1375 '(directory message help-echo mouse-face debug)) 1387 '(directory message help-echo mouse-face debug))
1376 (set (make-local-variable 'compilation-locs) 1388 (set (make-local-variable 'compilation-locs)
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el
index 4dbc9893f61..7bc904f8319 100644
--- a/lisp/progmodes/gdb-ui.el
+++ b/lisp/progmodes/gdb-ui.el
@@ -1765,7 +1765,7 @@ static char *magick[] = {
1765 1765
1766(defface breakpoint-enabled 1766(defface breakpoint-enabled
1767 '((t 1767 '((t
1768 :foreground "red" 1768 :foreground "red1"
1769 :weight bold)) 1769 :weight bold))
1770 "Face for enabled breakpoint icon in fringe." 1770 "Face for enabled breakpoint icon in fringe."
1771 :group 'gud) 1771 :group 'gud)
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index aa382d4e185..97144fec83b 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -237,7 +237,7 @@ Used to grey out relevant toolbar icons.")
237 ([menu-bar run] menu-item 237 ([menu-bar run] menu-item
238 ,(propertize "run" 'face 'font-lock-doc-face) gud-run 238 ,(propertize "run" 'face 'font-lock-doc-face) gud-run
239 :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) 239 :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb)))
240 ([menu-bar go] menu-item 240 ([menu-bar go] menu-item
241 ,(propertize " go " 'face 'font-lock-doc-face) gud-go 241 ,(propertize " go " 'face 'font-lock-doc-face) gud-go
242 :visible (and (not gud-running) 242 :visible (and (not gud-running)
243 (eq gud-minor-mode 'gdba))) 243 (eq gud-minor-mode 'gdba)))
@@ -292,6 +292,11 @@ Used to grey out relevant toolbar icons.")
292(defun gud-file-name (f) 292(defun gud-file-name (f)
293 "Transform a relative file name to an absolute file name. 293 "Transform a relative file name to an absolute file name.
294Uses `gud-<MINOR-MODE>-directories' to find the source files." 294Uses `gud-<MINOR-MODE>-directories' to find the source files."
295 ;; When `default-directory' is a remote file name, prepend its
296 ;; remote part to f, which is the local file name. Fortunately,
297 ;; `file-remote-p' returns exactly this remote file name part (or
298 ;; nil otherwise).
299 (setq f (concat (or (file-remote-p default-directory) "") f))
295 (if (file-exists-p f) (expand-file-name f) 300 (if (file-exists-p f) (expand-file-name f)
296 (let ((directories (gud-val 'directories)) 301 (let ((directories (gud-val 'directories))
297 (result nil)) 302 (result nil))
@@ -2510,7 +2515,10 @@ comint mode, which see."
2510 (while (and w (not (eq (car w) t))) 2515 (while (and w (not (eq (car w) t)))
2511 (setq w (cdr w))) 2516 (setq w (cdr w)))
2512 (if w 2517 (if w
2513 (setcar w file))) 2518 (setcar w
2519 (if (file-remote-p default-directory)
2520 (setq file (file-name-nondirectory file))
2521 file))))
2514 (apply 'make-comint (concat "gud" filepart) program nil 2522 (apply 'make-comint (concat "gud" filepart) program nil
2515 (if massage-args (funcall massage-args file args) args)) 2523 (if massage-args (funcall massage-args file args) args))
2516 ;; Since comint clobbered the mode, we don't set it until now. 2524 ;; Since comint clobbered the mode, we don't set it until now.
@@ -3114,7 +3122,7 @@ class of the file (using s to separate nested class ids)."
3114 'syntax-table (eval-when-compile 3122 'syntax-table (eval-when-compile
3115 (string-to-syntax "> b"))) 3123 (string-to-syntax "> b")))
3116 ;; Make sure that rehighlighting the previous line won't erase our 3124 ;; Make sure that rehighlighting the previous line won't erase our
3117 ;; syntax-table property. 3125 ;; syntax-table property.
3118 (put-text-property (1- (match-beginning 0)) (match-end 0) 3126 (put-text-property (1- (match-beginning 0)) (match-end 0)
3119 'font-lock-multiline t) 3127 'font-lock-multiline t)
3120 nil))))) 3128 nil)))))
@@ -3193,8 +3201,12 @@ Treats actions as defuns."
3193 (goto-char (point-max))) 3201 (goto-char (point-max)))
3194 t) 3202 t)
3195 3203
3204;; Besides .gdbinit, gdb documents other names to be usable for init
3205;; files, cross-debuggers can use something like
3206;; .PROCESSORNAME-gdbinit so that the host and target gdbinit files
3207;; don't interfere with each other.
3196;;;###autoload 3208;;;###autoload
3197(add-to-list 'auto-mode-alist '("/\\.gdbinit" . gdb-script-mode)) 3209(add-to-list 'auto-mode-alist '("/\\.[a-z0-9-]*gdbinit" . gdb-script-mode))
3198 3210
3199;;;###autoload 3211;;;###autoload
3200(define-derived-mode gdb-script-mode nil "GDB-Script" 3212(define-derived-mode gdb-script-mode nil "GDB-Script"
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 5c117dffd5d..26fc122631d 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -996,7 +996,16 @@ don't move and return nil. Otherwise return t."
996 (throw 'done t))))))) 996 (throw 'done t)))))))
997 (setq arg (1- arg))) 997 (setq arg (1- arg)))
998 (zerop arg))) 998 (zerop arg)))
999 999
1000(defvar python-which-func-length-limit 40
1001 "Non-strict length limit for `python-which-func' output.")
1002
1003(defun python-which-func ()
1004 (let ((function-name (python-current-defun python-which-func-length-limit)))
1005 (set-text-properties 0 (length function-name) nil function-name)
1006 function-name))
1007
1008
1000;;;; Imenu. 1009;;;; Imenu.
1001 1010
1002(defvar python-recursing) 1011(defvar python-recursing)
@@ -1814,22 +1823,30 @@ of current line."
1814 (1+ (/ (current-indentation) python-indent))) 1823 (1+ (/ (current-indentation) python-indent)))
1815 1824
1816;; Fixme: Consider top-level assignments, imports, &c. 1825;; Fixme: Consider top-level assignments, imports, &c.
1817(defun python-current-defun () 1826(defun python-current-defun (&optional length-limit)
1818 "`add-log-current-defun-function' for Python." 1827 "`add-log-current-defun-function' for Python."
1819 (save-excursion 1828 (save-excursion
1820 ;; Move up the tree of nested `class' and `def' blocks until we 1829 ;; Move up the tree of nested `class' and `def' blocks until we
1821 ;; get to zero indentation, accumulating the defined names. 1830 ;; get to zero indentation, accumulating the defined names.
1822 (let ((start t) 1831 (let ((start t)
1823 accum) 1832 (accum)
1824 (while (or start (> (current-indentation) 0)) 1833 (length -1))
1834 (while (and (or start (> (current-indentation) 0))
1835 (or (null length-limit)
1836 (null (cdr accum))
1837 (< length length-limit)))
1825 (setq start nil) 1838 (setq start nil)
1826 (python-beginning-of-block) 1839 (python-beginning-of-block)
1827 (end-of-line) 1840 (end-of-line)
1828 (beginning-of-defun) 1841 (beginning-of-defun)
1829 (if (looking-at (rx (0+ space) (or "def" "class") (1+ space) 1842 (when (looking-at (rx (0+ space) (or "def" "class") (1+ space)
1830 (group (1+ (or word (syntax symbol)))))) 1843 (group (1+ (or word (syntax symbol))))))
1831 (push (match-string 1) accum))) 1844 (push (match-string 1) accum)
1832 (if accum (mapconcat 'identity accum "."))))) 1845 (setq length (+ length 1 (length (car accum))))))
1846 (when accum
1847 (when (and length-limit (> length length-limit))
1848 (setcar accum ".."))
1849 (mapconcat 'identity accum ".")))))
1833 1850
1834(defun python-mark-block () 1851(defun python-mark-block ()
1835 "Mark the block around point. 1852 "Mark the block around point.
@@ -2248,6 +2265,7 @@ with skeleton expansions for compound statement templates.
2248 (set (make-local-variable 'beginning-of-defun-function) 2265 (set (make-local-variable 'beginning-of-defun-function)
2249 'python-beginning-of-defun) 2266 'python-beginning-of-defun)
2250 (set (make-local-variable 'end-of-defun-function) 'python-end-of-defun) 2267 (set (make-local-variable 'end-of-defun-function) 'python-end-of-defun)
2268 (add-hook 'which-func-functions 'python-which-func nil t)
2251 (setq imenu-create-index-function #'python-imenu-create-index) 2269 (setq imenu-create-index-function #'python-imenu-create-index)
2252 (set (make-local-variable 'eldoc-documentation-function) 2270 (set (make-local-variable 'eldoc-documentation-function)
2253 #'python-eldoc-function) 2271 #'python-eldoc-function)
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 43c70f67dfb..5b5c13342ad 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -76,8 +76,8 @@
76 :version "20.3") 76 :version "20.3")
77 77
78(defcustom which-func-modes 78(defcustom which-func-modes
79 '(emacs-lisp-mode c-mode c++-mode perl-mode cperl-mode makefile-mode 79 '(emacs-lisp-mode c-mode c++-mode perl-mode cperl-mode python-mode
80 sh-mode fortran-mode f90-mode ada-mode) 80 makefile-mode sh-mode fortran-mode f90-mode ada-mode)
81 "List of major modes for which Which Function mode should be used. 81 "List of major modes for which Which Function mode should be used.
82For other modes it is disabled. If this is equal to t, 82For other modes it is disabled. If this is equal to t,
83then Which Function mode is enabled in any major mode that supports it." 83then Which Function mode is enabled in any major mode that supports it."
diff --git a/lisp/replace.el b/lisp/replace.el
index ed1fa9a6b59..5d4c2a2eba6 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -860,7 +860,7 @@ Compatibility function for \\[next-error] invocations."
860 860
861(defface match 861(defface match
862 '((((class color) (min-colors 88) (background light)) 862 '((((class color) (min-colors 88) (background light))
863 :background "yellow") 863 :background "yellow1")
864 (((class color) (min-colors 88) (background dark)) 864 (((class color) (min-colors 88) (background dark))
865 :background "RoyalBlue3") 865 :background "RoyalBlue3")
866 (((class color) (min-colors 8) (background light)) 866 (((class color) (min-colors 8) (background light))
diff --git a/lisp/subr.el b/lisp/subr.el
index ff43b9f9c7f..9d2dcb496b0 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -103,7 +103,7 @@ change the list."
103When COND yields non-nil, eval BODY forms sequentially and return 103When COND yields non-nil, eval BODY forms sequentially and return
104value of last one, or nil if there are none. 104value of last one, or nil if there are none.
105 105
106\(fn COND BODY ...)" 106\(fn COND BODY...)"
107 (declare (indent 1) (debug t)) 107 (declare (indent 1) (debug t))
108 (list 'if cond (cons 'progn body))) 108 (list 'if cond (cons 'progn body)))
109 109
@@ -112,7 +112,7 @@ value of last one, or nil if there are none.
112When COND yields nil, eval BODY forms sequentially and return 112When COND yields nil, eval BODY forms sequentially and return
113value of last one, or nil if there are none. 113value of last one, or nil if there are none.
114 114
115\(fn COND BODY ...)" 115\(fn COND BODY...)"
116 (declare (indent 1) (debug t)) 116 (declare (indent 1) (debug t))
117 (cons 'if (cons cond (cons nil body)))) 117 (cons 'if (cons cond (cons nil body))))
118 118
@@ -510,6 +510,7 @@ Don't call this function; it is for internal use only."
510 (if (integerp b) (< a b) 510 (if (integerp b) (< a b)
511 t) 511 t)
512 (if (integerp b) t 512 (if (integerp b) t
513 ;; string< also accepts symbols.
513 (string< a b)))))) 514 (string< a b))))))
514 (dolist (p list) 515 (dolist (p list)
515 (funcall function (car p) (cdr p)))) 516 (funcall function (car p) (cdr p))))
@@ -1219,7 +1220,8 @@ if it is empty or a duplicate."
1219Execution is delayed if `delay-mode-hooks' is non-nil. 1220Execution is delayed if `delay-mode-hooks' is non-nil.
1220If `delay-mode-hooks' is nil, run `after-change-major-mode-hook' 1221If `delay-mode-hooks' is nil, run `after-change-major-mode-hook'
1221after running the mode hooks. 1222after running the mode hooks.
1222Major mode functions should use this." 1223Major mode functions should use this instead of `run-hooks' when running their
1224FOO-mode-hook."
1223 (if delay-mode-hooks 1225 (if delay-mode-hooks
1224 ;; Delaying case. 1226 ;; Delaying case.
1225 (dolist (hook hooks) 1227 (dolist (hook hooks)
@@ -2484,6 +2486,29 @@ If BODY finishes, `while-no-input' returns whatever value BODY produced."
2484 (or (input-pending-p) 2486 (or (input-pending-p)
2485 ,@body)))))) 2487 ,@body))))))
2486 2488
2489(defmacro condition-case-no-debug (var bodyform &rest handlers)
2490 "Like `condition-case' except that it does not catch anything when debugging.
2491More specifically if `debug-on-error' is set, then it does not catch any signal."
2492 (declare (debug condition-case) (indent 2))
2493 (let ((bodysym (make-symbol "body")))
2494 `(let ((,bodysym (lambda () ,bodyform)))
2495 (if debug-on-error
2496 (funcall ,bodysym)
2497 (condition-case ,var
2498 (funcall ,bodysym)
2499 ,@handlers)))))
2500
2501(defmacro with-demoted-errors (&rest body)
2502 "Run BODY and demote any errors to simple messages.
2503If `debug-on-error' is non-nil, run BODY without catching its errors.
2504This is to be used around code which is not expected to signal an error
2505but which should be robust in the unexpected case that an error is signalled."
2506 (declare (debug t) (indent 0))
2507 (let ((err (make-symbol "err")))
2508 `(condition-case-no-debug ,err
2509 (progn ,@body)
2510 (error (message "Error: %s" ,err) nil))))
2511
2487(defmacro combine-after-change-calls (&rest body) 2512(defmacro combine-after-change-calls (&rest body)
2488 "Execute BODY, but don't call the after-change functions till the end. 2513 "Execute BODY, but don't call the after-change functions till the end.
2489If BODY makes changes in the buffer, they are recorded 2514If BODY makes changes in the buffer, they are recorded
@@ -2518,6 +2543,20 @@ The value returned is the value of the last form in BODY."
2518 2543
2519;;;; Constructing completion tables. 2544;;;; Constructing completion tables.
2520 2545
2546(defun complete-with-action (action table string pred)
2547 "Perform completion ACTION.
2548STRING is the string to complete.
2549TABLE is the completion table, which should not be a function.
2550PRED is a completion predicate.
2551ACTION can be one of nil, t or `lambda'."
2552 ;; (assert (not (functionp table)))
2553 (funcall
2554 (cond
2555 ((null action) 'try-completion)
2556 ((eq action t) 'all-completions)
2557 (t 'test-completion))
2558 string table pred))
2559
2521(defmacro dynamic-completion-table (fun) 2560(defmacro dynamic-completion-table (fun)
2522 "Use function FUN as a dynamic completion table. 2561 "Use function FUN as a dynamic completion table.
2523FUN is called with one argument, the string for which completion is required, 2562FUN is called with one argument, the string for which completion is required,
@@ -2539,10 +2578,7 @@ that can be used as the ALIST argument to `try-completion' and
2539 (with-current-buffer (let ((,win (minibuffer-selected-window))) 2578 (with-current-buffer (let ((,win (minibuffer-selected-window)))
2540 (if (window-live-p ,win) (window-buffer ,win) 2579 (if (window-live-p ,win) (window-buffer ,win)
2541 (current-buffer))) 2580 (current-buffer)))
2542 (cond 2581 (complete-with-action ,mode (,fun ,string) ,string ,predicate)))))
2543 ((eq ,mode t) (all-completions ,string (,fun ,string) ,predicate))
2544 ((not ,mode) (try-completion ,string (,fun ,string) ,predicate))
2545 (t (test-completion ,string (,fun ,string) ,predicate)))))))
2546 2582
2547(defmacro lazy-completion-table (var fun) 2583(defmacro lazy-completion-table (var fun)
2548 ;; We used to have `&rest args' where `args' were evaluated late (at the 2584 ;; We used to have `&rest args' where `args' were evaluated late (at the
@@ -2667,6 +2703,18 @@ of a match for REGEXP."
2667 (looking-at (concat "\\(?:" regexp "\\)\\'"))))) 2703 (looking-at (concat "\\(?:" regexp "\\)\\'")))))
2668 (not (null pos)))) 2704 (not (null pos))))
2669 2705
2706(defsubst looking-at-p (regexp)
2707 "\
2708Same as `looking-at' except this function does not change the match data."
2709 (let ((inhibit-changing-match-data t))
2710 (looking-at regexp)))
2711
2712(defsubst string-match-p (regexp string &optional start)
2713 "\
2714Same as `string-match' except this function does not change the match data."
2715 (let ((inhibit-changing-match-data t))
2716 (string-match regexp string start)))
2717
2670(defun subregexp-context-p (regexp pos &optional start) 2718(defun subregexp-context-p (regexp pos &optional start)
2671 "Return non-nil if POS is in a normal subregexp context in REGEXP. 2719 "Return non-nil if POS is in a normal subregexp context in REGEXP.
2672A subregexp context is one where a sub-regexp can appear. 2720A subregexp context is one where a sub-regexp can appear.
diff --git a/lisp/textmodes/org.el b/lisp/textmodes/org.el
index 244f9bb0bce..a7eb10dbb4f 100644
--- a/lisp/textmodes/org.el
+++ b/lisp/textmodes/org.el
@@ -5,7 +5,7 @@
5;; Author: Carsten Dominik <dominik at science dot uva dot nl> 5;; Author: Carsten Dominik <dominik at science dot uva dot nl>
6;; Keywords: outlines, hypermedia, calendar, wp 6;; Keywords: outlines, hypermedia, calendar, wp
7;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/ 7;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/
8;; Version: 5.01 8;; Version: 5.03b
9;; 9;;
10;; This file is part of GNU Emacs. 10;; This file is part of GNU Emacs.
11;; 11;;
@@ -83,7 +83,7 @@
83 83
84;;; Version 84;;; Version
85 85
86(defconst org-version "5.01" 86(defconst org-version "5.03b"
87 "The version number of the file org.el.") 87 "The version number of the file org.el.")
88(defun org-version () 88(defun org-version ()
89 (interactive) 89 (interactive)
@@ -489,15 +489,22 @@ the values `folded', `children', or `subtree'."
489 :tag "Org Edit Structure" 489 :tag "Org Edit Structure"
490 :group 'org-structure) 490 :group 'org-structure)
491 491
492(defcustom org-special-ctrl-a nil 492
493 "Non-nil means `C-a' behaves specially in headlines. 493(defcustom org-special-ctrl-a/e nil
494 "Non-nil means `C-a' and `C-e' behave specially in headlines.
494When set, `C-a' will bring back the cursor to the beginning of the 495When set, `C-a' will bring back the cursor to the beginning of the
495headline text, i.e. after the stars and after a possible TODO keyword. 496headline text, i.e. after the stars and after a possible TODO keyword.
496When the cursor is already at that position, another `C-a' will bring 497When the cursor is already at that position, another `C-a' will bring
497it to the beginning of the line." 498it to the beginning of the line.
499`C-e' will jump to the end of the headline, ignoring the presence of tags
500in the headline. A second `C-e' will then jump to the true end of the
501line, after any tags."
498 :group 'org-edit-structure 502 :group 'org-edit-structure
499 :type 'boolean) 503 :type 'boolean)
500 504
505(if (fboundp 'defvaralias)
506 (defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e))
507
501(defcustom org-odd-levels-only nil 508(defcustom org-odd-levels-only nil
502 "Non-nil means, skip even levels and only use odd levels for the outline. 509 "Non-nil means, skip even levels and only use odd levels for the outline.
503This has the effect that two stars are being added/taken away in 510This has the effect that two stars are being added/taken away in
@@ -1763,7 +1770,7 @@ lined-up with respect to each other."
1763 :group 'org-properties 1770 :group 'org-properties
1764 :type 'string) 1771 :type 'string)
1765 1772
1766(defcustom org-default-columns-format "%25ITEM %TODO %3PRIORITY %TAGS" 1773(defcustom org-columns-default-format "%25ITEM %TODO %3PRIORITY %TAGS"
1767 "The default column format, if no other format has been defined. 1774 "The default column format, if no other format has been defined.
1768This variable can be set on the per-file basis by inserting a line 1775This variable can be set on the per-file basis by inserting a line
1769 1776
@@ -3244,6 +3251,12 @@ color of the frame."
3244 "Face for column display of entry properties." 3251 "Face for column display of entry properties."
3245 :group 'org-faces) 3252 :group 'org-faces)
3246 3253
3254(when (fboundp 'set-face-attribute)
3255 ;; Make sure that a fixed-width face is used when we have a column table.
3256 (set-face-attribute 'org-column nil
3257 :height (face-attribute 'default :height)
3258 :family (face-attribute 'default :family)))
3259
3247(defface org-warning ;; font-lock-warning-face 3260(defface org-warning ;; font-lock-warning-face
3248 (org-compatible-face 3261 (org-compatible-face
3249 '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t)) 3262 '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
@@ -3402,8 +3415,13 @@ to the part of the headline after the DONE keyword."
3402 '(org-level-1 org-level-2 org-level-3 org-level-4 3415 '(org-level-1 org-level-2 org-level-3 org-level-4
3403 org-level-5 org-level-6 org-level-7 org-level-8 3416 org-level-5 org-level-6 org-level-7 org-level-8
3404 )) 3417 ))
3405(defconst org-n-levels (length org-level-faces))
3406 3418
3419(defcustom org-n-level-faces (length org-level-faces)
3420 "The number different faces to be used for headlines.
3421Org-mode defines 8 different headline faces, so this can be at most 8.
3422If it is less than 8, the level-1 face gets re-used for level N+1 etc."
3423 :type 'number
3424 :group 'org-faces)
3407 3425
3408;;; Variables for pre-computed regular expressions, all buffer local 3426;;; Variables for pre-computed regular expressions, all buffer local
3409 3427
@@ -3573,7 +3591,7 @@ means to push this value onto the list in the variable.")
3573 ((equal key "TAGS") 3591 ((equal key "TAGS")
3574 (setq tags (append tags (org-split-string value splitre)))) 3592 (setq tags (append tags (org-split-string value splitre))))
3575 ((equal key "COLUMNS") 3593 ((equal key "COLUMNS")
3576 (org-set-local 'org-default-columns-format value)) 3594 (org-set-local 'org-columns-default-format value))
3577 ((equal key "LINK") 3595 ((equal key "LINK")
3578 (when (string-match "^\\(\\S-+\\)[ \t]+\\(.+\\)" value) 3596 (when (string-match "^\\(\\S-+\\)[ \t]+\\(.+\\)" value)
3579 (push (cons (match-string 1 value) 3597 (push (cons (match-string 1 value)
@@ -3678,15 +3696,15 @@ means to push this value onto the list in the variable.")
3678 (mapconcat 'regexp-quote org-not-done-keywords "\\|") 3696 (mapconcat 'regexp-quote org-not-done-keywords "\\|")
3679 "\\)\\>") 3697 "\\)\\>")
3680 org-todo-line-regexp 3698 org-todo-line-regexp
3681 (concat "^\\(\\*+\\)[ \t]*\\(?:\\(" 3699 (concat "^\\(\\*+\\)[ \t]+\\(?:\\("
3682 (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") 3700 (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
3683 "\\)\\>\\)? *\\(.*\\)") 3701 "\\)\\>\\)?[ \t]*\\(.*\\)")
3684 org-nl-done-regexp 3702 org-nl-done-regexp
3685 (concat "[\r\n]\\*+[ \t]+" 3703 (concat "\n\\*+[ \t]+"
3686 "\\(?:" (mapconcat 'regexp-quote org-done-keywords "\\|") 3704 "\\(?:" (mapconcat 'regexp-quote org-done-keywords "\\|")
3687 "\\)" "\\>") 3705 "\\)" "\\>")
3688 org-todo-line-tags-regexp 3706 org-todo-line-tags-regexp
3689 (concat "^\\(\\*+\\)[ \t]*\\(?:\\(" 3707 (concat "^\\(\\*+\\)[ \t]+\\(?:\\("
3690 (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") 3708 (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
3691 (org-re 3709 (org-re
3692 "\\)\\>\\)? *\\(.*?\\([ \t]:[[:alnum:]:_@]+:[ \t]*\\)?$\\)")) 3710 "\\)\\>\\)? *\\(.*?\\([ \t]:[[:alnum:]:_@]+:[ \t]*\\)?$\\)"))
@@ -3982,7 +4000,7 @@ The following commands are available:
3982 (org-add-to-invisibility-spec '(org-cwidth)) 4000 (org-add-to-invisibility-spec '(org-cwidth))
3983 (when (featurep 'xemacs) 4001 (when (featurep 'xemacs)
3984 (org-set-local 'line-move-ignore-invisible t)) 4002 (org-set-local 'line-move-ignore-invisible t))
3985 (setq outline-regexp "\\*+") 4003 (setq outline-regexp "\\*+ ")
3986 (setq outline-level 'org-outline-level) 4004 (setq outline-level 'org-outline-level)
3987 (when (and org-ellipsis (stringp org-ellipsis) 4005 (when (and org-ellipsis (stringp org-ellipsis)
3988 (fboundp 'set-display-table-slot) (boundp 'buffer-display-table)) 4006 (fboundp 'set-display-table-slot) (boundp 'buffer-display-table))
@@ -4412,17 +4430,20 @@ between words."
4412 (looking-at outline-regexp) 4430 (looking-at outline-regexp)
4413 (if (match-beginning 1) 4431 (if (match-beginning 1)
4414 (+ (org-get-string-indentation (match-string 1)) 1000) 4432 (+ (org-get-string-indentation (match-string 1)) 1000)
4415 (- (match-end 0) (match-beginning 0))))) 4433 (1- (- (match-end 0) (match-beginning 0))))))
4416 4434
4417(defvar org-font-lock-keywords nil) 4435(defvar org-font-lock-keywords nil)
4418 4436
4437(defconst org-property-re "^[ \t]*\\(:\\([a-zA-Z_0-9]+\\):\\)[ \t]*\\(\\S-.*\\)"
4438 "Regular expression matching a property line.")
4439
4419(defun org-set-font-lock-defaults () 4440(defun org-set-font-lock-defaults ()
4420 (let* ((em org-fontify-emphasized-text) 4441 (let* ((em org-fontify-emphasized-text)
4421 (lk org-activate-links) 4442 (lk org-activate-links)
4422 (org-font-lock-extra-keywords 4443 (org-font-lock-extra-keywords
4423 ;; Headlines 4444 ;; Headlines
4424 (list 4445 (list
4425 '("^\\(\\**\\)\\(\\*\\)\\(.*\\)" (1 (org-get-level-face 1)) 4446 '("^\\(\\**\\)\\(\\* \\)\\(.*\\)" (1 (org-get-level-face 1))
4426 (2 (org-get-level-face 2)) (3 (org-get-level-face 3))) 4447 (2 (org-get-level-face 2)) (3 (org-get-level-face 3)))
4427 '("^[ \t]*\\(\\(|\\|\\+-[-+]\\).*\\S-\\)" 4448 '("^[ \t]*\\(\\(|\\|\\+-[-+]\\).*\\S-\\)"
4428 (1 'org-table)) 4449 (1 'org-table))
@@ -4436,7 +4457,7 @@ between words."
4436 '("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t)) 4457 '("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t))
4437 '(org-hide-wide-columns (0 nil append)) 4458 '(org-hide-wide-columns (0 nil append))
4438 ;; TODO lines 4459 ;; TODO lines
4439 (list (concat "^\\*+[ \t]*" org-not-done-regexp) 4460 (list (concat "^\\*+[ \t]+" org-not-done-regexp)
4440 '(1 'org-todo t)) 4461 '(1 'org-todo t))
4441 ;; Priorities 4462 ;; Priorities
4442 (list (concat "\\[#[A-Z0-9]\\]") '(0 'org-special-keyword t)) 4463 (list (concat "\\[#[A-Z0-9]\\]") '(0 'org-special-keyword t))
@@ -4452,13 +4473,13 @@ between words."
4452 '(org-do-emphasis-faces (0 nil append)) 4473 '(org-do-emphasis-faces (0 nil append))
4453 '(org-do-emphasis-faces))) 4474 '(org-do-emphasis-faces)))
4454 ;; Checkboxes, similar to Frank Ruell's org-checklet.el 4475 ;; Checkboxes, similar to Frank Ruell's org-checklet.el
4455 '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)" 4476 '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)"
4456 2 'bold prepend) 4477 2 'bold prepend)
4457 (if org-provide-checkbox-statistics 4478 (if org-provide-checkbox-statistics
4458 '("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]" 4479 '("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]"
4459 (0 (org-get-checkbox-statistics-face) t))) 4480 (0 (org-get-checkbox-statistics-face) t)))
4460 ;; COMMENT 4481 ;; COMMENT
4461 (list (concat "^\\*+[ \t]*\\<\\(" org-comment-string 4482 (list (concat "^\\*+[ \t]+\\<\\(" org-comment-string
4462 "\\|" org-quote-string "\\)\\>") 4483 "\\|" org-quote-string "\\)\\>")
4463 '(1 'org-special-keyword t)) 4484 '(1 'org-special-keyword t))
4464 '("^#.*" (0 'font-lock-comment-face t)) 4485 '("^#.*" (0 'font-lock-comment-face t))
@@ -4475,14 +4496,18 @@ between words."
4475 ;; Table stuff 4496 ;; Table stuff
4476 '("^[ \t]*\\(:.*\\)" (1 'org-table t)) 4497 '("^[ \t]*\\(:.*\\)" (1 'org-table t))
4477 '("| *\\(:?=[^|\n]*\\)" (1 'org-formula t)) 4498 '("| *\\(:?=[^|\n]*\\)" (1 'org-formula t))
4478 '("^[ \t]*| *\\([#!$*_^]\\) *|" (1 'org-formula t)) 4499; '("^[ \t]*| *\\([#!$*_^/]\\) *|" (1 'org-formula t))
4500 '("^[ \t]*| *\\([#*]\\) *|" (1 'org-formula t))
4501 '("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t))
4479 ;; Drawers 4502 ;; Drawers
4480 (list org-drawer-regexp '(0 'org-drawer t)) 4503; (list org-drawer-regexp '(0 'org-drawer t))
4481 (list "^[ \t]*:END:" '(0 'org-drawer t)) 4504; (list "^[ \t]*:END:" '(0 'org-drawer t))
4505 (list org-drawer-regexp '(0 'org-special-keyword t))
4506 (list "^[ \t]*:END:" '(0 'org-special-keyword t))
4482 ;; Properties 4507 ;; Properties
4483 '("^[ \t]*\\(:[a-zA-Z0-9]+:\\)[ \t]*\\(\\S-.*\\)" 4508 (list org-property-re
4484 (1 'org-special-keyword t) (2 'org-property-value t)) 4509 '(1 'org-special-keyword t)
4485;FIXME (1 'org-tag t) (2 'org-property-value t)) 4510 '(3 'org-property-value t))
4486 (if org-format-transports-properties-p 4511 (if org-format-transports-properties-p
4487 '("| *\\(<[0-9]+>\\) *" (1 'org-formula t))) 4512 '("| *\\(<[0-9]+>\\) *" (1 'org-formula t)))
4488 '("^\\*+ \\(.*:ARCHIVE:.*\\)" (1 'org-archived prepend)) 4513 '("^\\*+ \\(.*:ARCHIVE:.*\\)" (1 'org-archived prepend))
@@ -4499,9 +4524,9 @@ between words."
4499(defvar org-f nil) 4524(defvar org-f nil)
4500(defun org-get-level-face (n) 4525(defun org-get-level-face (n)
4501 "Get the right face for match N in font-lock matching of healdines." 4526 "Get the right face for match N in font-lock matching of healdines."
4502 (setq org-l (- (match-end 2) (match-beginning 1))) 4527 (setq org-l (- (match-end 2) (match-beginning 1) 1))
4503 (if org-odd-levels-only (setq org-l (1+ (/ org-l 2)))) 4528 (if org-odd-levels-only (setq org-l (1+ (/ org-l 2))))
4504 (setq org-f (nth (% (1- org-l) org-n-levels) org-level-faces)) 4529 (setq org-f (nth (% (1- org-l) org-n-level-faces) org-level-faces))
4505 (cond 4530 (cond
4506 ((eq n 1) (if org-hide-leading-stars 'org-hide org-f)) 4531 ((eq n 1) (if org-hide-leading-stars 'org-hide org-f))
4507 ((eq n 2) org-f) 4532 ((eq n 2) org-f)
@@ -4559,7 +4584,7 @@ between words."
4559 (interactive "P") 4584 (interactive "P")
4560 (let* ((outline-regexp 4585 (let* ((outline-regexp
4561 (if (and (org-mode-p) org-cycle-include-plain-lists) 4586 (if (and (org-mode-p) org-cycle-include-plain-lists)
4562 "\\(?:\\*+\\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) \\)" 4587 "\\(?:\\*+ \\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) \\)"
4563 outline-regexp)) 4588 outline-regexp))
4564 (bob-special (and org-cycle-global-at-bob (bobp) 4589 (bob-special (and org-cycle-global-at-bob (bobp)
4565 (not (looking-at outline-regexp)))) 4590 (not (looking-at outline-regexp))))
@@ -5175,8 +5200,8 @@ If the region is active in `transient-mark-mode', promote all headings
5175in the region." 5200in the region."
5176 (org-back-to-heading t) 5201 (org-back-to-heading t)
5177 (let* ((level (save-match-data (funcall outline-level))) 5202 (let* ((level (save-match-data (funcall outline-level)))
5178 (up-head (make-string (org-get-legal-level level -1) ?*)) 5203 (up-head (concat (make-string (org-get-legal-level level -1) ?*) " "))
5179 (diff (abs (- level (length up-head))))) 5204 (diff (abs (- level (length up-head) -1))))
5180 (if (= level 1) (error "Cannot promote to level 0. UNDO to recover if necessary")) 5205 (if (= level 1) (error "Cannot promote to level 0. UNDO to recover if necessary"))
5181 (replace-match up-head nil t) 5206 (replace-match up-head nil t)
5182 ;; Fixup tag positioning 5207 ;; Fixup tag positioning
@@ -5189,8 +5214,8 @@ If the region is active in `transient-mark-mode', demote all headings
5189in the region." 5214in the region."
5190 (org-back-to-heading t) 5215 (org-back-to-heading t)
5191 (let* ((level (save-match-data (funcall outline-level))) 5216 (let* ((level (save-match-data (funcall outline-level)))
5192 (down-head (make-string (org-get-legal-level level 1) ?*)) 5217 (down-head (concat (make-string (org-get-legal-level level 1) ?*) " "))
5193 (diff (abs (- level (length down-head))))) 5218 (diff (abs (- level (length down-head) -1))))
5194 (replace-match down-head nil t) 5219 (replace-match down-head nil t)
5195 ;; Fixup tag positioning 5220 ;; Fixup tag positioning
5196 (and org-auto-align-tags (org-set-tags nil t)) 5221 (and org-auto-align-tags (org-set-tags nil t))
@@ -5251,8 +5276,8 @@ level 5 etc."
5251 (let ((org-odd-levels-only nil) n) 5276 (let ((org-odd-levels-only nil) n)
5252 (save-excursion 5277 (save-excursion
5253 (goto-char (point-min)) 5278 (goto-char (point-min))
5254 (while (re-search-forward "^\\*\\*+" nil t) 5279 (while (re-search-forward "^\\*\\*+ " nil t)
5255 (setq n (1- (length (match-string 0)))) 5280 (setq n (- (length (match-string 0)) 2))
5256 (while (>= (setq n (1- n)) 0) 5281 (while (>= (setq n (1- n)) 0)
5257 (org-demote)) 5282 (org-demote))
5258 (end-of-line 1)))))) 5283 (end-of-line 1))))))
@@ -5266,15 +5291,15 @@ is signaled in this case."
5266 (interactive) 5291 (interactive)
5267 (goto-char (point-min)) 5292 (goto-char (point-min))
5268 ;; First check if there are no even levels 5293 ;; First check if there are no even levels
5269 (when (re-search-forward "^\\(\\*\\*\\)+[^*]" nil t) 5294 (when (re-search-forward "^\\(\\*\\*\\)+ " nil t)
5270 (org-show-context t) 5295 (org-show-context t)
5271 (error "Not all levels are odd in this file. Conversion not possible.")) 5296 (error "Not all levels are odd in this file. Conversion not possible."))
5272 (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") 5297 (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ")
5273 (let ((org-odd-levels-only nil) n) 5298 (let ((org-odd-levels-only nil) n)
5274 (save-excursion 5299 (save-excursion
5275 (goto-char (point-min)) 5300 (goto-char (point-min))
5276 (while (re-search-forward "^\\*\\*+" nil t) 5301 (while (re-search-forward "^\\*\\*+ " nil t)
5277 (setq n (/ (length (match-string 0)) 2)) 5302 (setq n (/ (length (1- (match-string 0))) 2))
5278 (while (>= (setq n (1- n)) 0) 5303 (while (>= (setq n (1- n)) 0)
5279 (org-promote)) 5304 (org-promote))
5280 (end-of-line 1)))))) 5305 (end-of-line 1))))))
@@ -5399,7 +5424,7 @@ If optional TREE is given, use this text instead of the kill ring."
5399 (^re_ (concat "\\(" outline-regexp "\\)[ \t]*")) 5424 (^re_ (concat "\\(" outline-regexp "\\)[ \t]*"))
5400 5425
5401 (old-level (if (string-match ^re txt) 5426 (old-level (if (string-match ^re txt)
5402 (- (match-end 0) (match-beginning 0)) 5427 (- (match-end 0) (match-beginning 0) 1)
5403 -1)) 5428 -1))
5404 (force-level (cond (level (prefix-numeric-value level)) 5429 (force-level (cond (level (prefix-numeric-value level))
5405 ((string-match 5430 ((string-match
@@ -5693,7 +5718,7 @@ Return t when things worked, nil when we are not in an item."
5693 (save-excursion 5718 (save-excursion
5694 (goto-char (match-end 0)) 5719 (goto-char (match-end 0))
5695 (skip-chars-forward " \t") 5720 (skip-chars-forward " \t")
5696 (looking-at "\\[[ X]\\]")))) 5721 (looking-at "\\[[- X]\\]"))))
5697 5722
5698(defun org-toggle-checkbox (&optional arg) 5723(defun org-toggle-checkbox (&optional arg)
5699 "Toggle the checkbox in the current line." 5724 "Toggle the checkbox in the current line."
@@ -5707,7 +5732,11 @@ Return t when things worked, nil when we are not in an item."
5707 (setq beg (point) end (save-excursion (outline-next-heading) (point)))) 5732 (setq beg (point) end (save-excursion (outline-next-heading) (point))))
5708 ((org-at-item-checkbox-p) 5733 ((org-at-item-checkbox-p)
5709 (save-excursion 5734 (save-excursion
5710 (replace-match (if (equal (match-string 0) "[ ]") "[X]" "[ ]") t t)) 5735 (replace-match
5736 (cond (arg "[-]")
5737 ((member (match-string 0) '("[ ]" "[-]")) "[X]")
5738 (t "[ ]"))
5739 t t))
5711 (throw 'exit t)) 5740 (throw 'exit t))
5712 (t (error "Not at a checkbox or heading, and no active region"))) 5741 (t (error "Not at a checkbox or heading, and no active region")))
5713 (save-excursion 5742 (save-excursion
@@ -5741,7 +5770,7 @@ the whole buffer."
5741 (end (move-marker (make-marker) 5770 (end (move-marker (make-marker)
5742 (progn (outline-next-heading) (point)))) 5771 (progn (outline-next-heading) (point))))
5743 (re "\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)") 5772 (re "\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)")
5744 (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)") 5773 (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)")
5745 b1 e1 f1 c-on c-off lim (cstat 0)) 5774 b1 e1 f1 c-on c-off lim (cstat 0))
5746 (when all 5775 (when all
5747 (goto-char (point-min)) 5776 (goto-char (point-min))
@@ -5761,7 +5790,7 @@ the whole buffer."
5761 (goto-char e1) 5790 (goto-char e1)
5762 (when lim 5791 (when lim
5763 (while (re-search-forward re-box lim t) 5792 (while (re-search-forward re-box lim t)
5764 (if (equal (match-string 2) "[ ]") 5793 (if (member (match-string 2) '("[ ]" "[-]"))
5765 (setq c-off (1+ c-off)) 5794 (setq c-off (1+ c-off))
5766 (setq c-on (1+ c-on)))) 5795 (setq c-on (1+ c-on))))
5767 (delete-region b1 e1) 5796 (delete-region b1 e1)
@@ -6285,6 +6314,8 @@ C-c C-c Set tags / toggle checkbox"
6285 '([(meta shift down)] org-shiftmetadown) 6314 '([(meta shift down)] org-shiftmetadown)
6286 '([(meta shift left)] org-shiftmetaleft) 6315 '([(meta shift left)] org-shiftmetaleft)
6287 '([(meta shift right)] org-shiftmetaright) 6316 '([(meta shift right)] org-shiftmetaright)
6317 '([(shift up)] org-shiftup)
6318 '([(shift down)] org-shiftdown)
6288 '("\M-q" fill-paragraph) 6319 '("\M-q" fill-paragraph)
6289 '("\C-c^" org-sort) 6320 '("\C-c^" org-sort)
6290 '("\C-c-" org-cycle-list-bullet))) 6321 '("\C-c-" org-cycle-list-bullet)))
@@ -6466,8 +6497,7 @@ this heading."
6466 (if heading 6497 (if heading
6467 (progn 6498 (progn
6468 (if (re-search-forward 6499 (if (re-search-forward
6469 (concat "\\(^\\|\r\\)" 6500 (concat "^" (regexp-quote heading)
6470 (regexp-quote heading)
6471 (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)")) 6501 (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)"))
6472 nil t) 6502 nil t)
6473 (goto-char (match-end 0)) 6503 (goto-char (match-end 0))
@@ -7131,7 +7161,7 @@ Optional argument NEW may specify text to replace the current field content."
7131 (setq n (concat new "|") org-table-may-need-update t))) 7161 (setq n (concat new "|") org-table-may-need-update t)))
7132 (or (equal n o) 7162 (or (equal n o)
7133 (let (org-table-may-need-update) 7163 (let (org-table-may-need-update)
7134 (replace-match n)))) 7164 (replace-match n t t))))
7135 (setq org-table-may-need-update t)) 7165 (setq org-table-may-need-update t))
7136 (goto-char pos)))))) 7166 (goto-char pos))))))
7137 7167
@@ -7302,7 +7332,6 @@ is always the old value."
7302 val) 7332 val)
7303 (forward-char 1) "")) 7333 (forward-char 1) ""))
7304 7334
7305
7306(defun org-table-field-info (arg) 7335(defun org-table-field-info (arg)
7307 "Show info about the current field, and highlight any reference at point." 7336 "Show info about the current field, and highlight any reference at point."
7308 (interactive "P") 7337 (interactive "P")
@@ -7723,7 +7752,7 @@ should be done in reverse order."
7723 (setq beg (point-at-bol 1))) 7752 (setq beg (point-at-bol 1)))
7724 (goto-char pos) 7753 (goto-char pos)
7725 (if (re-search-forward org-table-hline-regexp tend t) 7754 (if (re-search-forward org-table-hline-regexp tend t)
7726 (setq end (point-at-bol 0)) 7755 (setq end (point-at-bol 1))
7727 (goto-char tend) 7756 (goto-char tend)
7728 (setq end (point-at-bol)))) 7757 (setq end (point-at-bol))))
7729 (setq beg (move-marker (make-marker) beg) 7758 (setq beg (move-marker (make-marker) beg)
@@ -8709,7 +8738,7 @@ HIGHLIGHT means, just highlight the range."
8709 (goto-line r1) 8738 (goto-line r1)
8710 (while (not (looking-at org-table-dataline-regexp)) 8739 (while (not (looking-at org-table-dataline-regexp))
8711 (beginning-of-line 2)) 8740 (beginning-of-line 2))
8712 (prog1 (org-table-get-field c1) 8741 (prog1 (org-trim (org-table-get-field c1))
8713 (if highlight (org-table-highlight-rectangle (point) (point))))) 8742 (if highlight (org-table-highlight-rectangle (point) (point)))))
8714 ;; A range, return a vector 8743 ;; A range, return a vector
8715 ;; First sort the numbers to get a regular ractangle 8744 ;; First sort the numbers to get a regular ractangle
@@ -8729,7 +8758,8 @@ HIGHLIGHT means, just highlight the range."
8729 (org-table-highlight-rectangle 8758 (org-table-highlight-rectangle
8730 beg (progn (skip-chars-forward "^|\n") (point)))) 8759 beg (progn (skip-chars-forward "^|\n") (point))))
8731 ;; return string representation of calc vector 8760 ;; return string representation of calc vector
8732 (apply 'append (org-table-copy-region beg end)))))) 8761 (mapcar 'org-trim
8762 (apply 'append (org-table-copy-region beg end)))))))
8733 8763
8734(defun org-table-get-descriptor-line (desc &optional cline bline table) 8764(defun org-table-get-descriptor-line (desc &optional cline bline table)
8735 "Analyze descriptor DESC and retrieve the corresponding line number. 8765 "Analyze descriptor DESC and retrieve the corresponding line number.
@@ -9313,10 +9343,10 @@ With prefix ARG, apply the new formulas to the table."
9313 ((looking-at "[ \t]") 9343 ((looking-at "[ \t]")
9314 (goto-char pos) 9344 (goto-char pos)
9315 (call-interactively 'lisp-indent-line)) 9345 (call-interactively 'lisp-indent-line))
9316 ((looking-at "[$@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos)) 9346 ((looking-at "[$&@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos))
9317 ((not (fboundp 'pp-buffer)) 9347 ((not (fboundp 'pp-buffer))
9318 (error "Cannot pretty-print. Command `pp-buffer' is not available.")) 9348 (error "Cannot pretty-print. Command `pp-buffer' is not available."))
9319 ((looking-at "[$@0-9a-zA-Z]+ *= *'(") 9349 ((looking-at "[$&@0-9a-zA-Z]+ *= *'(")
9320 (goto-char (- (match-end 0) 2)) 9350 (goto-char (- (match-end 0) 2))
9321 (setq beg (point)) 9351 (setq beg (point))
9322 (setq ind (make-string (current-column) ?\ )) 9352 (setq ind (make-string (current-column) ?\ ))
@@ -10800,9 +10830,10 @@ With three \\[universal-argument] prefixes, negate the meaning of
10800 (setq link (org-completing-read 10830 (setq link (org-completing-read
10801 "Link: " 10831 "Link: "
10802 (append 10832 (append
10803 (mapcar (lambda (x) (concat (car x) ":")) 10833 (mapcar (lambda (x) (list (concat (car x) ":")))
10804 (append org-link-abbrev-alist-local org-link-abbrev-alist)) 10834 (append org-link-abbrev-alist-local org-link-abbrev-alist))
10805 (mapcar (lambda (x) (concat x ":")) org-link-types)) 10835 (mapcar (lambda (x) (list (concat x ":")))
10836 org-link-types))
10806 nil nil nil 10837 nil nil nil
10807 'tmphist 10838 'tmphist
10808 (or (car (car org-stored-links))))) 10839 (or (car (car org-stored-links)))))
@@ -11015,12 +11046,14 @@ optional argument IN-EMACS is non-nil, Emacs will visit the file."
11015 (switch-to-buffer-other-window 11046 (switch-to-buffer-other-window
11016 (org-get-buffer-for-internal-link (current-buffer))) 11047 (org-get-buffer-for-internal-link (current-buffer)))
11017 (org-mark-ring-push)) 11048 (org-mark-ring-push))
11018 (org-link-search 11049 (let ((cmd `(org-link-search
11019 path 11050 ,path
11020 (cond ((equal in-emacs '(4)) 'occur) 11051 ,(cond ((equal in-emacs '(4)) 'occur)
11021 ((equal in-emacs '(16)) 'org-occur) 11052 ((equal in-emacs '(16)) 'org-occur)
11022 (t nil)) 11053 (t nil))
11023 pos)) 11054 ,pos)))
11055 (condition-case nil (eval cmd)
11056 (error (progn (widen) (eval cmd))))))
11024 11057
11025 ((string= type "tree-match") 11058 ((string= type "tree-match")
11026 (org-occur (concat "\\[" (regexp-quote path) "\\]"))) 11059 (org-occur (concat "\\[" (regexp-quote path) "\\]")))
@@ -11170,7 +11203,7 @@ in all files. If AVOID-POS is given, ignore matches near that position."
11170 (let ((case-fold-search t) 11203 (let ((case-fold-search t)
11171 (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) 11204 (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " "))
11172 (markers (concat "\\(?:" (mapconcat (lambda (x) (regexp-quote (car x))) 11205 (markers (concat "\\(?:" (mapconcat (lambda (x) (regexp-quote (car x)))
11173 (append '((" ") ("\t") ("\n")) 11206 (append '(("") (" ") ("\t") ("\n"))
11174 org-emphasis-alist) 11207 org-emphasis-alist)
11175 "\\|") "\\)")) 11208 "\\|") "\\)"))
11176 (pos (point)) 11209 (pos (point))
@@ -11197,10 +11230,10 @@ in all files. If AVOID-POS is given, ignore matches near that position."
11197 ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) 11230 ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *")))
11198 (t (org-do-occur (match-string 1 s))))) 11231 (t (org-do-occur (match-string 1 s)))))
11199 (t 11232 (t
11200 ;; A normal search string 11233 ;; A normal search strings
11201 (when (equal (string-to-char s) ?*) 11234 (when (equal (string-to-char s) ?*)
11202 ;; Anchor on headlines, post may include tags. 11235 ;; Anchor on headlines, post may include tags.
11203 (setq pre "^\\*+[ \t]*\\(?:\\sw+\\)?[ \t]*" 11236 (setq pre "^\\*+[ \t]+\\(?:\\sw+\\)?[ \t]*"
11204 post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@:+]:[ \t]*\\)?$") 11237 post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@:+]:[ \t]*\\)?$")
11205 s (substring s 1))) 11238 s (substring s 1)))
11206 (remove-text-properties 11239 (remove-text-properties
@@ -11707,6 +11740,7 @@ If the file does not exist, an error is thrown."
11707 ((or (stringp cmd) 11740 ((or (stringp cmd)
11708 (eq cmd 'emacs)) 11741 (eq cmd 'emacs))
11709 (funcall (cdr (assq 'file org-link-frame-setup)) file) 11742 (funcall (cdr (assq 'file org-link-frame-setup)) file)
11743 (widen)
11710 (if line (goto-line line) 11744 (if line (goto-line line)
11711 (if search (org-link-search search)))) 11745 (if search (org-link-search search))))
11712 ((consp cmd) 11746 ((consp cmd)
@@ -11793,7 +11827,8 @@ to be run from that hook to fucntion properly."
11793 (org-startup-folded nil) 11827 (org-startup-folded nil)
11794 org-time-was-given org-end-time-was-given x prompt char time) 11828 org-time-was-given org-end-time-was-given x prompt char time)
11795 (setq org-store-link-plist 11829 (setq org-store-link-plist
11796 (append (list :annotation v-a :initial v-i))) 11830 (append (list :annotation v-a :initial v-i)
11831 org-store-link-plist))
11797 (unless tpl (setq tpl "") (message "No template") (ding)) 11832 (unless tpl (setq tpl "") (message "No template") (ding))
11798 (erase-buffer) 11833 (erase-buffer)
11799 (insert (substitute-command-keys 11834 (insert (substitute-command-keys
@@ -11842,14 +11877,18 @@ to be run from that hook to fucntion properly."
11842 (let* ((org-last-tags-completion-table 11877 (let* ((org-last-tags-completion-table
11843 (org-global-tags-completion-table 11878 (org-global-tags-completion-table
11844 (if (equal char "G") (org-agenda-files) (and file (list file))))) 11879 (if (equal char "G") (org-agenda-files) (and file (list file)))))
11880 (org-add-colon-after-tag-completion t)
11845 (ins (completing-read 11881 (ins (completing-read
11846 (if prompt (concat prompt ": ") "Tags: ") 11882 (if prompt (concat prompt ": ") "Tags: ")
11847 'org-tags-completion-function nil nil nil 11883 'org-tags-completion-function nil nil nil
11848 'org-tags-history))) 11884 'org-tags-history)))
11849 (insert (concat ":" (mapconcat 'identity 11885 (setq ins (mapconcat 'identity
11850 (org-split-string ins (org-re "[^[:alnum:]]+")) 11886 (org-split-string ins (org-re "[^[:alnum:]]+"))
11851 ":") 11887 ":"))
11852 ":")))) 11888 (when (string-match "\\S-" ins)
11889 (or (equal (char-before) ?:) (insert ":"))
11890 (insert ins)
11891 (or (equal (char-after) ?:) (insert ":")))))
11853 (char 11892 (char
11854 (setq org-time-was-given (equal (upcase char) char)) 11893 (setq org-time-was-given (equal (upcase char) char))
11855 (setq time (org-read-date (equal (upcase char) "U") t nil 11894 (setq time (org-read-date (equal (upcase char) "U") t nil
@@ -11939,7 +11978,7 @@ See also the variable `org-reverse-note-order'."
11939 (let* ((lines (split-string txt "\n")) 11978 (let* ((lines (split-string txt "\n"))
11940 first) 11979 first)
11941 (setq first (car lines) lines (cdr lines)) 11980 (setq first (car lines) lines (cdr lines))
11942 (if (string-match "^\\*+" first) 11981 (if (string-match "^\\*+ " first)
11943 ;; Is already a headline 11982 ;; Is already a headline
11944 (setq indent nil) 11983 (setq indent nil)
11945 ;; We need to add a headline: Use time and first buffer line 11984 ;; We need to add a headline: Use time and first buffer line
@@ -11990,7 +12029,7 @@ See also the variable `org-reverse-note-order'."
11990 (save-restriction 12029 (save-restriction
11991 (widen) 12030 (widen)
11992 (goto-char (point-min)) 12031 (goto-char (point-min))
11993 (re-search-forward "^\\*" nil t) 12032 (re-search-forward "^\\*+ " nil t)
11994 (beginning-of-line 1) 12033 (beginning-of-line 1)
11995 (org-paste-subtree 1 txt))) 12034 (org-paste-subtree 1 txt)))
11996 ((and (org-on-heading-p t) (not current-prefix-arg)) 12035 ((and (org-on-heading-p t) (not current-prefix-arg))
@@ -12197,7 +12236,7 @@ At all other locations, this simply calls `ispell-complete-word'."
12197 (texp 12236 (texp
12198 (setq type :tex) 12237 (setq type :tex)
12199 org-html-entities) 12238 org-html-entities)
12200 ((string-match "\\`\\*+[ \t]*\\'" 12239 ((string-match "\\`\\*+[ \t]+\\'"
12201 (buffer-substring (point-at-bol) beg)) 12240 (buffer-substring (point-at-bol) beg))
12202 (setq type :todo) 12241 (setq type :todo)
12203 (mapcar 'list org-todo-keywords-1)) 12242 (mapcar 'list org-todo-keywords-1))
@@ -12258,12 +12297,12 @@ At all other locations, this simply calls `ispell-complete-word'."
12258 (save-excursion 12297 (save-excursion
12259 (org-back-to-heading) 12298 (org-back-to-heading)
12260 (if (looking-at (concat outline-regexp 12299 (if (looking-at (concat outline-regexp
12261 "\\( +\\<" org-comment-string "\\>\\)")) 12300 "\\( *\\<" org-comment-string "\\>\\)"))
12262 (replace-match "" t t nil 1) 12301 (replace-match "" t t nil 1)
12263 (if (looking-at outline-regexp) 12302 (if (looking-at outline-regexp)
12264 (progn 12303 (progn
12265 (goto-char (match-end 0)) 12304 (goto-char (match-end 0))
12266 (insert " " org-comment-string)))))) 12305 (insert org-comment-string " "))))))
12267 12306
12268(defvar org-last-todo-state-is-todo nil 12307(defvar org-last-todo-state-is-todo nil
12269 "This is non-nil when the last TODO state change led to a TODO state. 12308 "This is non-nil when the last TODO state change led to a TODO state.
@@ -12297,7 +12336,7 @@ For calling through lisp, arg is also interpreted in the following way:
12297 (interactive "P") 12336 (interactive "P")
12298 (save-excursion 12337 (save-excursion
12299 (org-back-to-heading) 12338 (org-back-to-heading)
12300 (if (looking-at outline-regexp) (goto-char (match-end 0))) 12339 (if (looking-at outline-regexp) (goto-char (1- (match-end 0))))
12301 (or (looking-at (concat " +" org-todo-regexp " *")) 12340 (or (looking-at (concat " +" org-todo-regexp " *"))
12302 (looking-at " *")) 12341 (looking-at " *"))
12303 (let* ((this (match-string 1)) 12342 (let* ((this (match-string 1))
@@ -12490,7 +12529,7 @@ of `org-todo-keywords-1'."
12490 org-todo-keywords-1))) 12529 org-todo-keywords-1)))
12491 (t (error "Invalid prefix argument: %s" arg))))) 12530 (t (error "Invalid prefix argument: %s" arg)))))
12492 (message "%d TODO entries found" 12531 (message "%d TODO entries found"
12493 (org-occur (concat "^" outline-regexp " +" kwd-re ))))) 12532 (org-occur (concat "^" outline-regexp " *" kwd-re )))))
12494 12533
12495(defun org-deadline () 12534(defun org-deadline ()
12496 "Insert the DEADLINE: string to make a deadline. 12535 "Insert the DEADLINE: string to make a deadline.
@@ -13064,6 +13103,29 @@ also TODO lines."
13064(defvar org-tags-overlay (org-make-overlay 1 1)) 13103(defvar org-tags-overlay (org-make-overlay 1 1))
13065(org-detach-overlay org-tags-overlay) 13104(org-detach-overlay org-tags-overlay)
13066 13105
13106(defun org-align-tags-here (to-col)
13107 ;; Assumes that this is a headline
13108 (let ((pos (point)) (col (current-column)) tags)
13109 (beginning-of-line 1)
13110 (if (and (looking-at (org-re ".*?\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
13111 (< pos (match-beginning 2)))
13112 (progn
13113 (setq tags (match-string 2))
13114 (goto-char (match-beginning 1))
13115 (insert " ")
13116 (delete-region (point) (1+ (match-end 0)))
13117 (backward-char 1)
13118 (move-to-column
13119 (max (1+ (current-column))
13120 (1+ col)
13121 (if (> to-col 0)
13122 to-col
13123 (- (abs to-col) (length tags))))
13124 t)
13125 (insert tags)
13126 (move-to-column (min (current-column) col) t))
13127 (goto-char pos))))
13128
13067(defun org-set-tags (&optional arg just-align) 13129(defun org-set-tags (&optional arg just-align)
13068 "Set the tags for the current headline. 13130 "Set the tags for the current headline.
13069With prefix ARG, realign all tags in headings in the current buffer." 13131With prefix ARG, realign all tags in headings in the current buffer."
@@ -13102,30 +13164,31 @@ With prefix ARG, realign all tags in headings in the current buffer."
13102 (while (string-match "[-+&]+" tags) 13164 (while (string-match "[-+&]+" tags)
13103 ;; No boolean logic, just a list 13165 ;; No boolean logic, just a list
13104 (setq tags (replace-match ":" t t tags)))) 13166 (setq tags (replace-match ":" t t tags))))
13105 13167
13106 (if (string-match "\\`[\t ]*\\'" tags) 13168 (if (string-match "\\`[\t ]*\\'" tags)
13107 (setq tags "") 13169 (setq tags "")
13108 (unless (string-match ":$" tags) (setq tags (concat tags ":"))) 13170 (unless (string-match ":$" tags) (setq tags (concat tags ":")))
13109 (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) 13171 (unless (string-match "^:" tags) (setq tags (concat ":" tags))))
13110 13172
13111 ;; Insert new tags at the correct column 13173 ;; Insert new tags at the correct column
13112 (beginning-of-line 1) 13174 (beginning-of-line 1)
13113 (if (re-search-forward 13175 (cond
13114 (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") 13176 ((and (equal current "") (equal tags "")))
13115 (point-at-eol) t) 13177 ((re-search-forward
13116 (progn 13178 (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$")
13117 (if (equal tags "") 13179 (point-at-eol) t)
13118 (setq rpl "") 13180 (if (equal tags "")
13119 (goto-char (match-beginning 0)) 13181 (setq rpl "")
13120 (setq c0 (current-column) p0 (point) 13182 (goto-char (match-beginning 0))
13121 c1 (max (1+ c0) (if (> org-tags-column 0) 13183 (setq c0 (current-column) p0 (point)
13122 org-tags-column 13184 c1 (max (1+ c0) (if (> org-tags-column 0)
13123 (- (- org-tags-column) (length tags)))) 13185 org-tags-column
13124 rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) 13186 (- (- org-tags-column) (length tags))))
13125 (replace-match rpl t t) 13187 rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags)))
13126 (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) 13188 (replace-match rpl t t)
13127 tags) 13189 (and (not (featurep 'xemacs)) c0 (tabify p0 (point)))
13128 (error "Tags alignment failed"))))) 13190 tags)
13191 (t (error "Tags alignment failed"))))))
13129 13192
13130(defun org-tags-completion-function (string predicate &optional flag) 13193(defun org-tags-completion-function (string predicate &optional flag)
13131 (let (s1 s2 rtn (ctable org-last-tags-completion-table) 13194 (let (s1 s2 rtn (ctable org-last-tags-completion-table)
@@ -13139,11 +13202,12 @@ With prefix ARG, realign all tags in headings in the current buffer."
13139 ;; try completion 13202 ;; try completion
13140 (setq rtn (try-completion s2 ctable confirm)) 13203 (setq rtn (try-completion s2 ctable confirm))
13141 (if (stringp rtn) 13204 (if (stringp rtn)
13142 (concat s1 s2 (substring rtn (length s2)) 13205 (setq rtn
13143 (if (and org-add-colon-after-tag-completion 13206 (concat s1 s2 (substring rtn (length s2))
13144 (assoc rtn ctable)) 13207 (if (and org-add-colon-after-tag-completion
13145 ":" ""))) 13208 (assoc rtn ctable))
13146 ) 13209 ":" ""))))
13210 rtn)
13147 ((eq flag t) 13211 ((eq flag t)
13148 ;; all-completions 13212 ;; all-completions
13149 (all-completions s2 ctable confirm) 13213 (all-completions s2 ctable confirm)
@@ -13202,7 +13266,7 @@ Returns the new tags string, or nil to not change the current settings."
13202 (save-excursion 13266 (save-excursion
13203 (beginning-of-line 1) 13267 (beginning-of-line 1)
13204 (if (looking-at 13268 (if (looking-at
13205 (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*\\(\r\\|$\\)")) 13269 (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
13206 (setq ov-start (match-beginning 1) 13270 (setq ov-start (match-beginning 1)
13207 ov-end (match-end 1) 13271 ov-end (match-end 1)
13208 ov-prefix "") 13272 ov-prefix "")
@@ -13358,7 +13422,7 @@ Returns the new tags string, or nil to not change the current settings."
13358 (error "Not on a heading")) 13422 (error "Not on a heading"))
13359 (save-excursion 13423 (save-excursion
13360 (beginning-of-line 1) 13424 (beginning-of-line 1)
13361 (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*\\(\r\\|$\\)")) 13425 (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
13362 (org-match-string-no-properties 1) 13426 (org-match-string-no-properties 1)
13363 ""))) 13427 "")))
13364 13428
@@ -13393,6 +13457,32 @@ but in some other way.")
13393(defconst org-property-end-re "^[ \t]*:END:[ \t]*$" 13457(defconst org-property-end-re "^[ \t]*:END:[ \t]*$"
13394 "Regular expression matching the first line of a property drawer.") 13458 "Regular expression matching the first line of a property drawer.")
13395 13459
13460(defun org-property-action ()
13461 "Do an action on properties."
13462 (interactive)
13463 (let (c prop)
13464 (org-at-property-p)
13465 (setq prop (match-string 2))
13466 (message "Property Action: [s]et [d]elete [D]delete globally")
13467 (setq c (read-char-exclusive))
13468 (cond
13469 ((equal c ?s)
13470 (call-interactively 'org-set-property))
13471 ((equal c ?d)
13472 (call-interactively 'org-delete-property))
13473 ((equal c ?D)
13474 (call-interactively 'org-delete-property-globally))
13475 (t (error "No such property action %c" c)))))
13476
13477(defun org-at-property-p ()
13478 "Is the cursor in a property line?"
13479 ;; FIXME: Does not check if we are actually in the drawer.
13480 ;; FIXME: also returns true on any drawers.....
13481 ;; This is used by C-c C-c for property action.
13482 (save-excursion
13483 (beginning-of-line 1)
13484 (looking-at "^[ \t]*\\(:\\([a-zA-Z_0-9]+\\):\\)[ \t]*\\(.*\\)")))
13485
13396(defmacro org-with-point-at (pom &rest body) 13486(defmacro org-with-point-at (pom &rest body)
13397 "Move to buffer and point of point-or-marker POM for the duration of BODY." 13487 "Move to buffer and point of point-or-marker POM for the duration of BODY."
13398 (declare (indent 1) (debug t)) 13488 (declare (indent 1) (debug t))
@@ -13406,7 +13496,7 @@ but in some other way.")
13406 "Return the (beg . end) range of the body of the property drawer. 13496 "Return the (beg . end) range of the body of the property drawer.
13407BEG and END can be beginning and end of subtree, if not given 13497BEG and END can be beginning and end of subtree, if not given
13408they will be found. 13498they will be found.
13409If the drawer does not exist and FORCE is non-nil, greater the drawer." 13499If the drawer does not exist and FORCE is non-nil, create the drawer."
13410 (catch 'exit 13500 (catch 'exit
13411 (save-excursion 13501 (save-excursion
13412 (let* ((beg (or beg (progn (org-back-to-heading t) (point)))) 13502 (let* ((beg (or beg (progn (org-back-to-heading t) (point))))
@@ -13414,18 +13504,14 @@ If the drawer does not exist and FORCE is non-nil, greater the drawer."
13414 (goto-char beg) 13504 (goto-char beg)
13415 (if (re-search-forward org-property-start-re end t) 13505 (if (re-search-forward org-property-start-re end t)
13416 (setq beg (1+ (match-end 0))) 13506 (setq beg (1+ (match-end 0)))
13417 (or force (throw 'exit nil)) 13507 (if force
13418 (beginning-of-line 2) 13508 (save-excursion
13419 (while (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) 13509 (org-insert-property-drawer)
13420 (not (equal (match-string 1) org-clock-string))) 13510 (setq end (progn (outline-next-heading) (point))))
13421 (beginning-of-line 2)) 13511 (throw 'exit nil))
13422 (insert ":PROPERTIES:\n:END:\n") 13512 (goto-char beg)
13423 (beginning-of-line -1) 13513 (if (re-search-forward org-property-start-re end t)
13424 (org-indent-line-function) 13514 (setq beg (1+ (match-end 0)))))
13425 (setq beg (1+ (point-at-eol)) end beg)
13426 (beginning-of-line 2)
13427 (org-indent-line-function)
13428 (throw 'exit (cons beg end)))
13429 (if (re-search-forward org-property-end-re end t) 13515 (if (re-search-forward org-property-end-re end t)
13430 (setq end (match-beginning 0)) 13516 (setq end (match-beginning 0))
13431 (or force (throw 'exit nil)) 13517 (or force (throw 'exit nil))
@@ -13448,10 +13534,11 @@ If WHICH is nil or `all', get all properties. If WHICH is
13448 (org-with-point-at pom 13534 (org-with-point-at pom
13449 (let ((clockstr (substring org-clock-string 0 -1)) 13535 (let ((clockstr (substring org-clock-string 0 -1))
13450 (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY")) 13536 (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY"))
13451 beg end range props key value) 13537 beg end range props sum-props key value)
13452 (save-excursion 13538 (save-excursion
13453 (when (condition-case nil (org-back-to-heading t) (error nil)) 13539 (when (condition-case nil (org-back-to-heading t) (error nil))
13454 (setq beg (point)) 13540 (setq beg (point))
13541 (setq sum-props (get-text-property (point) 'org-summaries))
13455 (outline-next-heading) 13542 (outline-next-heading)
13456 (setq end (point)) 13543 (setq end (point))
13457 (when (memq which '(all special)) 13544 (when (memq which '(all special))
@@ -13483,18 +13570,20 @@ If WHICH is nil or `all', get all properties. If WHICH is
13483 (when range 13570 (when range
13484 (goto-char (car range)) 13571 (goto-char (car range))
13485 (while (re-search-forward 13572 (while (re-search-forward
13486 "^[ \t]*:\\([a-zA-Z][a-zA-Z0-9]*\\):[ \t]*\\(\\S-.*\\S-\\)" 13573 "^[ \t]*:\\([a-zA-Z][a-zA-Z_0-9]*\\):[ \t]*\\(\\S-.*\\)?"
13487 (cdr range) t) 13574 (cdr range) t)
13488 (setq key (org-match-string-no-properties 1) 13575 (setq key (org-match-string-no-properties 1)
13489 value (org-match-string-no-properties 2)) 13576 value (org-trim (or (org-match-string-no-properties 2) "")))
13490 (unless (member key excluded) 13577 (unless (member key excluded)
13491 (push (cons key value) props))))) 13578 (push (cons key (or value "")) props)))))
13492 (nreverse props)))))) 13579 (append sum-props (nreverse props)))))))
13493 13580
13494(defun org-entry-get (pom property &optional inherit) 13581(defun org-entry-get (pom property &optional inherit)
13495 "Get value of PROPERTY for entry at point-or-marker POM. 13582 "Get value of PROPERTY for entry at point-or-marker POM.
13496If INHERIT is non-nil and the entry does not have the property, 13583If INHERIT is non-nil and the entry does not have the property,
13497then also check higher levels of the hierarchy." 13584then also check higher levels of the hierarchy.
13585If the property is present but empty, the return value is the empty string.
13586If the property is not present at all, nil is returned."
13498 (org-with-point-at pom 13587 (org-with-point-at pom
13499 (if inherit 13588 (if inherit
13500 (org-entry-get-with-inheritance property) 13589 (org-entry-get-with-inheritance property)
@@ -13505,10 +13594,12 @@ then also check higher levels of the hierarchy."
13505 (if (and range 13594 (if (and range
13506 (goto-char (car range)) 13595 (goto-char (car range))
13507 (re-search-forward 13596 (re-search-forward
13508 (concat "^[ \t]*:" property ":[ \t]*\\(.*\\S-\\)") 13597 (concat "^[ \t]*:" property ":[ \t]*\\(.*\\S-\\)?")
13509 (cdr range) t)) 13598 (cdr range) t))
13510 ;; Found the property, return it. 13599 ;; Found the property, return it.
13511 (org-match-string-no-properties 1))))))) 13600 (if (match-end 1)
13601 (org-match-string-no-properties 1)
13602 "")))))))
13512 13603
13513(defun org-entry-delete (pom property) 13604(defun org-entry-delete (pom property)
13514 "Delete the property PROPERTY from entry at point-or-marker POM." 13605 "Delete the property PROPERTY from entry at point-or-marker POM."
@@ -13521,7 +13612,10 @@ then also check higher levels of the hierarchy."
13521 (re-search-forward 13612 (re-search-forward
13522 (concat "^[ \t]*:" property ":[ \t]*\\(.*\\S-\\)") 13613 (concat "^[ \t]*:" property ":[ \t]*\\(.*\\S-\\)")
13523 (cdr range) t)) 13614 (cdr range) t))
13524 (delete-region (match-beginning 0) (1+ (point-at-eol)))))))) 13615 (progn
13616 (delete-region (match-beginning 0) (1+ (point-at-eol)))
13617 t)
13618 nil)))))
13525 13619
13526(defvar org-entry-property-inherited-from (make-marker)) 13620(defvar org-entry-property-inherited-from (make-marker))
13527 13621
@@ -13575,7 +13669,8 @@ then also check higher levels of the hierarchy."
13575 (backward-char 1) 13669 (backward-char 1)
13576 (org-indent-line-function) 13670 (org-indent-line-function)
13577 (insert ":" property ":")) 13671 (insert ":" property ":"))
13578 (and value (insert " " value))))))) 13672 (and value (insert " " value))
13673 (org-indent-line-function))))))
13579 13674
13580(defun org-buffer-property-keys (&optional include-specials) 13675(defun org-buffer-property-keys (&optional include-specials)
13581 "Get all property keys in the current buffer." 13676 "Get all property keys in the current buffer."
@@ -13594,56 +13689,197 @@ then also check higher levels of the hierarchy."
13594 (setq rtn (append org-special-properties rtn))) 13689 (setq rtn (append org-special-properties rtn)))
13595 (sort rtn (lambda (a b) (string< (upcase a) (upcase b)))))) 13690 (sort rtn (lambda (a b) (string< (upcase a) (upcase b))))))
13596 13691
13597;; FIXME: This should automatically find the right place int he entry.
13598;; And then org-entry-put should use it.
13599(defun org-insert-property-drawer () 13692(defun org-insert-property-drawer ()
13600 "Insert a property drawer at point." 13693 "Insert a property drawer into the current entry."
13601 (interactive) 13694 (interactive)
13602 (beginning-of-line 1) 13695 (org-back-to-heading t)
13603 (insert ":PROPERTIES:\n:END:\n") 13696 (let ((beg (point))
13604 (beginning-of-line -1) 13697 (re (concat "^[ \t]*" org-keyword-time-regexp))
13605 (org-indent-line-function) 13698 end hiddenp)
13606 (beginning-of-line 2) 13699 (outline-next-heading)
13607 (org-indent-line-function) 13700 (setq end (point))
13608 (end-of-line 0)) 13701 (goto-char beg)
13609 13702 (while (re-search-forward re end t))
13610(defvar org-column-overlays nil 13703 (setq hiddenp (org-invisible-p))
13704 (end-of-line 1)
13705 (insert "\n:PROPERTIES:\n:END:")
13706 (beginning-of-line 0)
13707 (org-indent-line-function)
13708 (beginning-of-line 2)
13709 (org-indent-line-function)
13710 (beginning-of-line 0)
13711 (if hiddenp
13712 (save-excursion
13713 (org-back-to-heading t)
13714 (hide-entry))
13715 (org-flag-drawer t))))
13716
13717(defun org-set-property (property value)
13718 "In the current entry, set PROPERTY to VALUE."
13719 (interactive
13720 (let* ((prop (completing-read "Property: "
13721 (mapcar 'list (org-buffer-property-keys))))
13722 (cur (org-entry-get nil prop))
13723 (allowed (org-property-get-allowed-values nil prop 'table))
13724 (val (if allowed
13725 (completing-read "Value: " allowed nil 'req-match)
13726 (read-string
13727 (concat "Value" (if (and cur (string-match "\\S-" cur))
13728 (concat "[" cur "]") "")
13729 ": ")
13730 "" cur))))
13731 (list prop (if (equal val "") cur val))))
13732 (unless (equal (org-entry-get nil property) value)
13733 (org-entry-put nil property value)))
13734
13735(defun org-delete-property (property)
13736 "In the current entry, delete PROPERTY."
13737 (interactive
13738 (let* ((prop (completing-read
13739 "Property: " (org-entry-properties nil 'standard))))
13740 (list prop)))
13741 (message (concat "Property " property
13742 (if (org-entry-delete nil property)
13743 " deleted"
13744 " was not present in the entry"))))
13745
13746(defun org-delete-property-globally (property)
13747 "Remove PROPERTY globally, from all entries."
13748 (interactive
13749 (let* ((prop (completing-read
13750 "Globally remove property: "
13751 (mapcar 'list (org-buffer-property-keys)))))
13752 (list prop)))
13753 (save-excursion
13754 (save-restriction
13755 (widen)
13756 (goto-char (point-min))
13757 (let ((cnt 0))
13758 (while (re-search-forward
13759 (concat "^[ \t]*:" (regexp-quote property) ":.*\n?")
13760 nil t)
13761 (setq cnt (1+ cnt))
13762 (replace-match ""))
13763 (message "Property \"%s\" removed from %d entries" property cnt)))))
13764
13765(defun org-property-get-allowed-values (pom property &optional table)
13766 "Get allowed values for the property PROPERTY.
13767When TABLE is non-nil, return an alist that can directly be used for
13768completion."
13769 (let (vals)
13770 (cond
13771 ((equal property "TODO")
13772 (setq vals (org-with-point-at pom
13773 (append org-todo-keywords-1 '("")))))
13774 ((equal property "PRIORITY")
13775 (let ((n org-lowest-priority))
13776 (while (>= n org-highest-priority)
13777 (push (char-to-string n) vals)
13778 (setq n (1- n)))))
13779 ((member property org-special-properties))
13780 (t
13781 (setq vals (org-entry-get pom (concat property "_ALL") 'inherit))
13782 (when (and vals (string-match "\\S-" vals))
13783 (setq vals (car (read-from-string (concat "(" vals ")"))))
13784 (setq vals (mapcar (lambda (x)
13785 (cond ((stringp x) x)
13786 ((numberp x) (number-to-string x))
13787 ((symbolp x) (symbol-name x))
13788 (t "???")))
13789 vals)))))
13790 (if table (mapcar 'list vals) vals)))
13791
13792;;; Column View
13793
13794(defvar org-columns-overlays nil
13611 "Holds the list of current column overlays.") 13795 "Holds the list of current column overlays.")
13612 13796
13613(defvar org-current-columns-fmt nil 13797(defvar org-columns-current-fmt nil
13614 "Loval variable, holds the currently active column format.") 13798 "Local variable, holds the currently active column format.")
13615(defvar org-current-columns-maxwidths nil 13799(defvar org-columns-current-fmt-compiled nil
13800 "Local variable, holds the currently active column format.
13801This is the compiled version of the format.")
13802(defvar org-columns-current-maxwidths nil
13616 "Loval variable, holds the currently active maximum column widths.") 13803 "Loval variable, holds the currently active maximum column widths.")
13804(defvar org-columns-begin-marker (make-marker)
13805 "Points to the position where last a column creation command was called.")
13806(defvar org-columns-top-level-marker (make-marker)
13807 "Points to the position where current columns region starts.")
13617 13808
13618(defvar org-column-map (make-sparse-keymap) 13809(defvar org-columns-map (make-sparse-keymap)
13619 "The keymap valid in column display.") 13810 "The keymap valid in column display.")
13620 13811
13621(define-key org-column-map "e" 'org-column-edit) 13812(defun org-columns-content ()
13622(define-key org-column-map "v" 'org-column-show-value) 13813 "Switch to contents view while in columns view."
13623(define-key org-column-map "q" 'org-column-quit) 13814 (interactive)
13624(define-key org-column-map [left] 'backward-char) 13815 (org-overview)
13625(define-key org-column-map [right] 'forward-char) 13816 (org-content))
13626 13817
13627(easy-menu-define org-column-menu org-column-map "Org Column Menu" 13818(org-defkey org-columns-map "c" 'org-columns-content)
13819(org-defkey org-columns-map "o" 'org-overview)
13820(org-defkey org-columns-map "e" 'org-columns-edit-value)
13821(org-defkey org-columns-map "v" 'org-columns-show-value)
13822(org-defkey org-columns-map "q" 'org-columns-quit)
13823(org-defkey org-columns-map "r" 'org-columns-redo)
13824(org-defkey org-columns-map [left] 'backward-char)
13825(org-defkey org-columns-map "a" 'org-columns-edit-allowed)
13826(org-defkey org-columns-map "s" 'org-columns-edit-attributes)
13827(org-defkey org-columns-map [right] 'forward-char)
13828(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value)
13829(org-defkey org-columns-map "\C-c\C-c" 'org-columns-next-allowed-value)
13830(org-defkey org-columns-map "n" 'org-columns-next-allowed-value)
13831(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value)
13832(org-defkey org-columns-map "p" 'org-columns-previous-allowed-value)
13833(org-defkey org-columns-map "<" 'org-columns-narrow)
13834(org-defkey org-columns-map ">" 'org-columns-widen)
13835(org-defkey org-columns-map [(meta right)] 'org-columns-move-right)
13836(org-defkey org-columns-map [(meta left)] 'org-columns-move-left)
13837(org-defkey org-columns-map [(shift meta right)] 'org-columns-new)
13838(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete)
13839
13840(easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
13628 '("Column" 13841 '("Column"
13629 ["Edit property" org-column-edit t] 13842 ["Edit property" org-columns-edit-value t]
13630 ["Show full value" org-column-show-value t] 13843 ["Next allowed value" org-columns-next-allowed-value t]
13631 ["Quit" org-column-quit t])) 13844 ["Previous allowed value" org-columns-previous-allowed-value t]
13845 ["Show full value" org-columns-show-value t]
13846 ["Edit allowed" org-columns-edit-allowed t]
13847 "--"
13848 ["Edit column attributes" org-columns-edit-attributes t]
13849 ["Increase column width" org-columns-widen t]
13850 ["Decrease column width" org-columns-narrow t]
13851 "--"
13852 ["Move column right" org-columns-move-right t]
13853 ["Move column left" org-columns-move-left t]
13854 ["Add column" org-columns-new t]
13855 ["Delete column" org-columns-delete t]
13856 "--"
13857 ["CONTENTS" org-columns-content t]
13858 ["OVERVIEW" org-overview t]
13859 ["Refresh columns display" org-columns-redo t]
13860 "--"
13861 ["Quit" org-columns-quit t]))
13632 13862
13633(defun org-new-column-overlay (beg end &optional string face) 13863(defun org-columns-new-overlay (beg end &optional string face)
13634 "Create a new column overlay an add it to the list." 13864 "Create a new column overlay and add it to the list."
13635 (let ((ov (org-make-overlay beg end))) 13865 (let ((ov (org-make-overlay beg end)))
13636 (org-overlay-put ov 'face (or face 'secondary-selection)) 13866 (org-overlay-put ov 'face (or face 'secondary-selection))
13637 (org-overlay-display ov string face) 13867 (org-overlay-display ov string face)
13638 (push ov org-column-overlays) 13868 (push ov org-columns-overlays)
13639 ov)) 13869 ov))
13640 13870
13641(defun org-overlay-columns (&optional props) 13871(defun org-columns-display-here (&optional props)
13642 "Overlay the current line with column display." 13872 "Overlay the current line with column display."
13643 (interactive) 13873 (interactive)
13644 (let ((fmt (copy-sequence org-current-columns-fmt)) 13874 (let* ((fmt org-columns-current-fmt-compiled)
13645 (beg (point-at-bol)) 13875 (beg (point-at-bol))
13646 (start 0) props pom property ass width f string ov) 13876 (level-face (save-excursion
13877 (beginning-of-line 1)
13878 (looking-at "\\(\\**\\)\\(\\* \\)")
13879 (org-get-level-face 2)))
13880 (color (list :foreground
13881 (face-attribute (or level-face 'default) :foreground)))
13882 props pom property ass width f string ov column)
13647 ;; Check if the entry is in another buffer. 13883 ;; Check if the entry is in another buffer.
13648 (unless props 13884 (unless props
13649 (if (eq major-mode 'org-agenda-mode) 13885 (if (eq major-mode 'org-agenda-mode)
@@ -13651,11 +13887,9 @@ then also check higher levels of the hierarchy."
13651 (get-text-property (point) 'org-marker)) 13887 (get-text-property (point) 'org-marker))
13652 props (if pom (org-entry-properties pom) nil)) 13888 props (if pom (org-entry-properties pom) nil))
13653 (setq props (org-entry-properties nil)))) 13889 (setq props (org-entry-properties nil))))
13654 ;; Parse the format 13890 ;; Walk the format
13655 (while (string-match "%\\([0-9]+\\)?\\([a-zA-Z0-9]+\\)\\-*" 13891 (while (setq column (pop fmt))
13656 fmt start) 13892 (setq property (car column)
13657 (setq start (match-end 0)
13658 property (match-string 2 fmt)
13659 ass (if (equal property "ITEM") 13893 ass (if (equal property "ITEM")
13660 (cons "ITEM" 13894 (cons "ITEM"
13661 (save-match-data 13895 (save-match-data
@@ -13664,17 +13898,21 @@ then also check higher levels of the hierarchy."
13664 (buffer-substring-no-properties 13898 (buffer-substring-no-properties
13665 (point-at-bol) (point-at-eol)))))) 13899 (point-at-bol) (point-at-eol))))))
13666 (assoc property props)) 13900 (assoc property props))
13667 width (or (cdr (assoc property org-current-columns-maxwidths)) 13901 width (or (cdr (assoc property org-columns-current-maxwidths))
13668 (string-to-number (or (match-string 1 fmt) "10"))) 13902 (nth 2 column))
13669 f (format "%%-%d.%ds | " width width) 13903 f (format "%%-%d.%ds | " width width)
13670 string (format f (or (cdr ass) ""))) 13904 string (format f (or (cdr ass) "")))
13671 ;; Create the overlay 13905 ;; Create the overlay
13672 (org-unmodified 13906 (org-unmodified
13673 (setq ov (org-new-column-overlay 13907 (setq ov (org-columns-new-overlay
13674 beg (setq beg (1+ beg)) string 'org-column)) 13908 beg (setq beg (1+ beg)) string
13675 (org-overlay-put ov 'keymap org-column-map) 13909 (list color 'org-column)))
13676 (org-overlay-put ov 'org-column-key property) 13910;;; (list (get-text-property (point-at-bol) 'face) 'org-column)))
13677 (org-overlay-put ov 'org-column-value (cdr ass))) 13911 (org-overlay-put ov 'keymap org-columns-map)
13912 (org-overlay-put ov 'org-columns-key property)
13913 (org-overlay-put ov 'org-columns-value (cdr ass))
13914 (org-overlay-put ov 'org-columns-pom pom)
13915 (org-overlay-put ov 'org-columns-format f))
13678 (if (or (not (char-after beg)) 13916 (if (or (not (char-after beg))
13679 (equal (char-after beg) ?\n)) 13917 (equal (char-after beg) ?\n))
13680 (let ((inhibit-read-only t)) 13918 (let ((inhibit-read-only t))
@@ -13682,64 +13920,72 @@ then also check higher levels of the hierarchy."
13682 (goto-char beg) 13920 (goto-char beg)
13683 (insert " "))))) 13921 (insert " ")))))
13684 ;; Make the rest of the line disappear. 13922 ;; Make the rest of the line disappear.
13685 ;; FIXME: put the keymap also at the end of the line!
13686 (org-unmodified 13923 (org-unmodified
13687 (setq ov (org-new-column-overlay beg (point-at-eol))) 13924 (setq ov (org-columns-new-overlay beg (point-at-eol)))
13688 (org-overlay-put ov 'invisible t) 13925 (org-overlay-put ov 'invisible t)
13689 (org-overlay-put ov 'keymap 'org-column-map) 13926 (org-overlay-put ov 'keymap org-columns-map)
13690 (push ov org-column-overlays) 13927 (push ov org-columns-overlays)
13691 (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) 13928 (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
13692 (org-overlay-put ov 'keymap 'org-column-map) 13929 (org-overlay-put ov 'keymap org-columns-map)
13693 (push ov org-column-overlays) 13930 (push ov org-columns-overlays)
13694 (let ((inhibit-read-only t)) 13931 (let ((inhibit-read-only t))
13695 (put-text-property (1- (point-at-bol)) 13932 (put-text-property (1- (point-at-bol))
13696 (min (point-max) (1+ (point-at-eol))) 13933 (min (point-max) (1+ (point-at-eol)))
13697 'read-only "Type `e' to edit property"))))) 13934 'read-only "Type `e' to edit property")))))
13698 13935
13699(defun org-overlay-columns-title () 13936(defvar org-previous-header-line-format nil
13937 "The header line format before column view was turned on.")
13938(defvar org-columns-inhibit-recalculation nil
13939 "Inhibit recomputing of columns on column view startup.")
13940
13941(defvar header-line-format)
13942(defun org-columns-display-here-title ()
13700 "Overlay the newline before the current line with the table title." 13943 "Overlay the newline before the current line with the table title."
13701 (interactive) 13944 (interactive)
13702 (let ((fmt (copy-sequence org-current-columns-fmt)) 13945 (let ((fmt org-columns-current-fmt-compiled)
13703 (start 0)
13704 string (title "") 13946 string (title "")
13705 property width f ov) 13947 property width f column str)
13706 (while (string-match "%\\([0-9]+\\)?\\([a-zA-Z0-9]+\\)\\-*" 13948 (while (setq column (pop fmt))
13707 fmt start) 13949 (setq property (car column)
13708 (setq start (match-end 0) 13950 str (or (nth 1 column) property)
13709 property (match-string 2 fmt) 13951 width (or (cdr (assoc property org-columns-current-maxwidths))
13710 width (or (cdr (assoc property org-current-columns-maxwidths)) 13952 (nth 2 column))
13711 (string-to-number (or (match-string 1 fmt) "10")))
13712 f (format "%%-%d.%ds | " width width) 13953 f (format "%%-%d.%ds | " width width)
13713 string (format f property) 13954 string (format f str)
13714 title (concat title string))) 13955 title (concat title string)))
13715 (org-unmodified 13956 (setq title (concat
13716 (setq ov (org-new-column-overlay 13957 (org-add-props " " nil 'display '(space :align-to 0))
13717 (1- (point-at-bol)) (point-at-bol) 13958 (org-add-props title nil 'face '(:weight bold :underline t))))
13718 (concat "\n" (make-string (length title) ?-) "\n" 13959 (org-set-local 'org-previous-header-line-format header-line-format)
13719 title "\n" (make-string (length title) ?-) "\n") 13960 (setq header-line-format title)))
13720 'bold)) 13961
13721 (org-overlay-put ov 'keymap org-column-map)))) 13962(defun org-columns-remove-overlays ()
13722
13723(defun org-remove-column-overlays ()
13724 "Remove all currently active column overlays." 13963 "Remove all currently active column overlays."
13725 (interactive) 13964 (interactive)
13726 (org-unmodified 13965 (when (marker-buffer org-columns-begin-marker)
13727 (mapc 'org-delete-overlay org-column-overlays) 13966 (with-current-buffer (marker-buffer org-columns-begin-marker)
13728 (setq org-column-overlays nil) 13967 (when (local-variable-p 'org-previous-header-line-format)
13729 (let ((inhibit-read-only t)) 13968 (setq header-line-format org-previous-header-line-format)
13730 (remove-text-properties (point-min) (point-max) '(read-only t))))) 13969 (kill-local-variable 'org-previous-header-line-format))
13970 (move-marker org-columns-begin-marker nil)
13971 (move-marker org-columns-top-level-marker nil)
13972 (org-unmodified
13973 (mapc 'org-delete-overlay org-columns-overlays)
13974 (setq org-columns-overlays nil)
13975 (let ((inhibit-read-only t))
13976 (remove-text-properties (point-min) (point-max) '(read-only t)))))))
13731 13977
13732(defun org-column-show-value () 13978(defun org-columns-show-value ()
13733 "Show the full value of the property." 13979 "Show the full value of the property."
13734 (interactive) 13980 (interactive)
13735 (let ((value (get-char-property (point) 'org-column-value))) 13981 (let ((value (get-char-property (point) 'org-columns-value)))
13736 (message "Value is: %s" (or value "")))) 13982 (message "Value is: %s" (or value ""))))
13737 13983
13738(defun org-column-quit () 13984(defun org-columns-quit ()
13739 "Remove the column overlays and in this way exit column editing." 13985 "Remove the column overlays and in this way exit column editing."
13740 (interactive) 13986 (interactive)
13741 (org-unmodified 13987 (org-unmodified
13742 (org-remove-column-overlays) 13988 (org-columns-remove-overlays)
13743 (let ((inhibit-read-only t)) 13989 (let ((inhibit-read-only t))
13744 ;; FIXME: is this safe??? 13990 ;; FIXME: is this safe???
13745 ;; or are there other reasons why there may be a read-only property???? 13991 ;; or are there other reasons why there may be a read-only property????
@@ -13747,13 +13993,13 @@ then also check higher levels of the hierarchy."
13747 (when (eq major-mode 'org-agenda-mode) 13993 (when (eq major-mode 'org-agenda-mode)
13748 (message "Modification not yet reflected in Agenda buffer, use `r' to refresh"))) 13994 (message "Modification not yet reflected in Agenda buffer, use `r' to refresh")))
13749 13995
13750(defun org-column-edit () 13996(defun org-columns-edit-value ()
13751 "Edit the value of the property at point in column view. 13997 "Edit the value of the property at point in column view.
13752Where possible, use the standard interface for changing this line." 13998Where possible, use the standard interface for changing this line."
13753 (interactive) 13999 (interactive)
13754 (let* ((col (current-column)) 14000 (let* ((col (current-column))
13755 (key (get-char-property (point) 'org-column-key)) 14001 (key (get-char-property (point) 'org-columns-key))
13756 (value (get-char-property (point) 'org-column-value)) 14002 (value (get-char-property (point) 'org-columns-value))
13757 (bol (point-at-bol)) (eol (point-at-eol)) 14003 (bol (point-at-bol)) (eol (point-at-eol))
13758 (pom (or (get-text-property bol 'org-hd-marker) 14004 (pom (or (get-text-property bol 'org-hd-marker)
13759 (point))) ; keep despite of compiler waring 14005 (point))) ; keep despite of compiler waring
@@ -13763,8 +14009,8 @@ Where possible, use the standard interface for changing this line."
13763 (>= (overlay-start x) bol) 14009 (>= (overlay-start x) bol)
13764 (<= (overlay-start x) eol) 14010 (<= (overlay-start x) eol)
13765 x)) 14011 x))
13766 org-column-overlays))) 14012 org-columns-overlays)))
13767 nval eval) 14013 nval eval allowed)
13768 (when (equal key "ITEM") 14014 (when (equal key "ITEM")
13769 (error "Cannot edit item headline from here")) 14015 (error "Cannot edit item headline from here"))
13770 14016
@@ -13788,7 +14034,10 @@ Where possible, use the standard interface for changing this line."
13788 (setq eval '(org-with-point-at pom 14034 (setq eval '(org-with-point-at pom
13789 (call-interactively 'org-deadline)))) 14035 (call-interactively 'org-deadline))))
13790 (t 14036 (t
13791 (setq nval (read-string "Edit: " value)) 14037 (setq allowed (org-property-get-allowed-values pom key 'table))
14038 (if allowed
14039 (setq nval (completing-read "Value: " allowed nil t))
14040 (setq nval (read-string "Edit: " value)))
13792 (setq nval (org-trim nval)) 14041 (setq nval (org-trim nval))
13793 (when (not (equal nval value)) 14042 (when (not (equal nval value))
13794 (setq eval '(org-entry-put pom key nval))))) 14043 (setq eval '(org-entry-put pom key nval)))))
@@ -13797,67 +14046,272 @@ Where possible, use the standard interface for changing this line."
13797 (remove-text-properties (1- bol) eol '(read-only t)) 14046 (remove-text-properties (1- bol) eol '(read-only t))
13798 (unwind-protect 14047 (unwind-protect
13799 (progn 14048 (progn
13800 (setq org-column-overlays 14049 (setq org-columns-overlays
13801 (org-delete-all line-overlays org-column-overlays)) 14050 (org-delete-all line-overlays org-columns-overlays))
13802 (mapc 'org-delete-overlay line-overlays) 14051 (mapc 'org-delete-overlay line-overlays)
13803 (eval eval)) 14052 (org-columns-eval eval))
13804 (org-overlay-columns)))) 14053 (org-columns-display-here))))
13805 (move-to-column col))) 14054 (move-to-column col)
14055 (if (nth 3 (assoc key org-columns-current-fmt-compiled))
14056 (org-columns-update key))))
14057
14058(defun org-columns-edit-allowed ()
14059 "Edit the list of allowed values for the current property."
14060 (interactive)
14061 (let* ((col (current-column))
14062 (key (get-char-property (point) 'org-columns-key))
14063 (key1 (concat key "_ALL"))
14064 (value (get-char-property (point) 'org-columns-value))
14065 (allowed (org-entry-get (point) key1 t))
14066 nval)
14067 (setq nval (read-string "Allowed: " allowed))
14068 (org-entry-put
14069 (cond ((marker-position org-entry-property-inherited-from)
14070 org-entry-property-inherited-from)
14071 ((marker-position org-columns-top-level-marker)
14072 org-columns-top-level-marker))
14073 key1 nval)))
14074
14075(defun org-columns-eval (form)
14076 (let (hidep)
14077 (save-excursion
14078 (beginning-of-line 1)
14079 (next-line 1)
14080 (setq hidep (org-on-heading-p 1)))
14081 (eval form)
14082 (and hidep (hide-entry))))
14083
14084(defun org-columns-previous-allowed-value ()
14085 "Switch to the previous allowed value for this column."
14086 (interactive)
14087 (org-columns-next-allowed-value t))
14088
14089(defun org-columns-next-allowed-value (&optional previous)
14090 "Switch to the next allowed value for this column."
14091 (interactive)
14092 (let* ((col (current-column))
14093 (key (get-char-property (point) 'org-columns-key))
14094 (value (get-char-property (point) 'org-columns-value))
14095 (bol (point-at-bol)) (eol (point-at-eol))
14096 (pom (or (get-text-property bol 'org-hd-marker)
14097 (point))) ; keep despite of compiler waring
14098 (line-overlays
14099 (delq nil (mapcar (lambda (x)
14100 (and (eq (overlay-buffer x) (current-buffer))
14101 (>= (overlay-start x) bol)
14102 (<= (overlay-start x) eol)
14103 x))
14104 org-columns-overlays)))
14105 (allowed (or (org-property-get-allowed-values pom key)
14106 (and (equal
14107 (nth 4 (assoc key org-columns-current-fmt-compiled))
14108 'checkbox) '("[ ]" "[X]"))))
14109 nval)
14110 (when (equal key "ITEM")
14111 (error "Cannot edit item headline from here"))
14112 (unless allowed
14113 (error "Allowed values for this property have not been defined"))
14114 (if previous (setq allowed (reverse allowed)))
14115 (if (member value allowed)
14116 (setq nval (car (cdr (member value allowed)))))
14117 (setq nval (or nval (car allowed)))
14118 (if (equal nval value)
14119 (error "Only one allowed value for this property"))
14120 (let ((inhibit-read-only t))
14121 (remove-text-properties (1- bol) eol '(read-only t))
14122 (unwind-protect
14123 (progn
14124 (setq org-columns-overlays
14125 (org-delete-all line-overlays org-columns-overlays))
14126 (mapc 'org-delete-overlay line-overlays)
14127 (org-columns-eval '(org-entry-put pom key nval)))
14128 (org-columns-display-here)))
14129 (move-to-column col)
14130 (if (nth 3 (assoc key org-columns-current-fmt-compiled))
14131 (org-columns-update key))))
14132
14133(defun org-verify-version (task)
14134 (cond
14135 ((eq task 'columns)
14136 (if (or (featurep 'xemacs)
14137 (< emacs-major-version 22))
14138 (error "Emacs 22 is required for the columns feature")))))
13806 14139
13807(defun org-columns () 14140(defun org-columns ()
13808 "Turn on column view on an org-mode file." 14141 "Turn on column view on an org-mode file."
13809 (interactive) 14142 (interactive)
13810 (org-remove-column-overlays) 14143 (org-verify-version 'columns)
14144 (org-columns-remove-overlays)
14145 (move-marker org-columns-begin-marker (point))
13811 (let (beg end fmt cache maxwidths) 14146 (let (beg end fmt cache maxwidths)
13812 (move-marker org-entry-property-inherited-from nil) 14147 (when (condition-case nil (org-back-to-heading) (error nil))
13813 (setq fmt (org-entry-get nil "COLUMNS" t)) 14148 (move-marker org-entry-property-inherited-from nil)
13814 (unless fmt 14149 (setq fmt (org-entry-get nil "COLUMNS" t)))
13815 (message "No local columns format defined, using default")) 14150 (setq fmt (or fmt org-columns-default-format))
13816 (org-set-local 'org-current-columns-fmt (or fmt org-default-columns-format)) 14151 (org-set-local 'org-columns-current-fmt fmt)
13817 (org-back-to-heading) 14152 (org-columns-compile-format fmt)
13818 (save-excursion 14153 (save-excursion
13819 (if (marker-position org-entry-property-inherited-from) 14154 (if (marker-position org-entry-property-inherited-from)
13820 (goto-char org-entry-property-inherited-from)) 14155 (goto-char org-entry-property-inherited-from))
13821 (setq beg (point) 14156 (setq beg (point))
13822 end (org-end-of-subtree t t)) 14157 (move-marker org-columns-top-level-marker (point))
14158 (unless org-columns-inhibit-recalculation
14159 (org-columns-compute-all))
14160 (setq end (or (condition-case nil (org-end-of-subtree t t) (error nil))
14161 (point-max)))
13823 (goto-char beg) 14162 (goto-char beg)
13824 ;; Get and cache the properties 14163 ;; Get and cache the properties
13825 (while (re-search-forward (concat "^" outline-regexp) end t) 14164 (while (re-search-forward (concat "^" outline-regexp) end t)
13826 (push (cons (org-current-line) (org-entry-properties)) cache)) 14165 (push (cons (org-current-line) (org-entry-properties)) cache))
13827 (when cache 14166 (when cache
13828 (setq maxwidths (org-get-columns-autowidth-alist fmt cache)) 14167 (setq maxwidths (org-columns-get-autowidth-alist fmt cache))
13829 (org-set-local 'org-current-columns-maxwidths maxwidths) 14168 (org-set-local 'org-columns-current-maxwidths maxwidths)
13830 (goto-line (car (org-last cache))) 14169 (goto-line (car (org-last cache)))
13831 (org-overlay-columns-title) 14170 (org-columns-display-here-title)
13832 (mapc (lambda (x) 14171 (mapc (lambda (x)
13833 (goto-line (car x)) 14172 (goto-line (car x))
13834 (org-overlay-columns (cdr x))) 14173 (org-columns-display-here (cdr x)))
13835 cache))))) 14174 cache)))))
13836 14175
14176(defun org-columns-new (&optional prop title width op fmt)
14177 "Insert a new column, to the leeft o the current column."
14178 (interactive)
14179 (let ((editp (and prop (assoc prop org-columns-current-fmt-compiled)))
14180 cell)
14181 (setq prop (completing-read
14182 "Property: " (mapcar 'list (org-buffer-property-keys t))
14183 nil nil prop))
14184 (setq title (read-string (concat "Column title [" prop "]: ") (or title prop)))
14185 (setq width (read-string "Column width: " (if width (number-to-string width))))
14186 (if (string-match "\\S-" width)
14187 (setq width (string-to-number width))
14188 (setq width nil))
14189 (setq fmt (completing-read "Summary [none]: "
14190 '(("none") ("add_numbers") ("add_times") ("checkbox"))
14191 nil t))
14192 (if (string-match "\\S-" fmt)
14193 (setq fmt (intern fmt))
14194 (setq fmt nil))
14195 (if (eq fmt 'none) (setq fmt nil))
14196 (if editp
14197 (progn
14198 (setcar editp prop)
14199 (setcdr editp (list title width nil fmt)))
14200 (setq cell (nthcdr (1- (current-column))
14201 org-columns-current-fmt-compiled))
14202 (setcdr cell (cons (list prop title width nil fmt)
14203 (cdr cell))))
14204 (org-columns-store-format)
14205 (org-columns-redo)))
14206
14207(defun org-columns-delete ()
14208 "Delete the column at point from columns view."
14209 (interactive)
14210 (let* ((n (current-column))
14211 (title (nth 1 (nth n org-columns-current-fmt-compiled))))
14212 (when (y-or-n-p
14213 (format "Are you sure you want to remove column \"%s\"? " title))
14214 (setq org-columns-current-fmt-compiled
14215 (delq (nth n org-columns-current-fmt-compiled)
14216 org-columns-current-fmt-compiled))
14217 (org-columns-store-format)
14218 (org-columns-redo)
14219 (if (>= (current-column) (length org-columns-current-fmt-compiled))
14220 (backward-char 1)))))
14221
14222(defun org-columns-edit-attributes ()
14223 "Edit the attributes of the current column."
14224 (interactive)
14225 (let* ((n (current-column))
14226 (info (nth n org-columns-current-fmt-compiled)))
14227 (apply 'org-columns-new info)))
14228
14229(defun org-columns-widen (arg)
14230 "Make the column wider by ARG characters."
14231 (interactive "p")
14232 (let* ((n (current-column))
14233 (entry (nth n org-columns-current-fmt-compiled))
14234 (width (or (nth 2 entry)
14235 (cdr (assoc (car entry) org-columns-current-maxwidths)))))
14236 (setq width (max 1 (+ width arg)))
14237 (setcar (nthcdr 2 entry) width)
14238 (org-columns-store-format)
14239 (org-columns-redo)))
14240
14241(defun org-columns-narrow (arg)
14242 "Make the column nrrower by ARG characters."
14243 (interactive "p")
14244 (org-columns-widen (- arg)))
14245
14246(defun org-columns-move-right ()
14247 "Swap this column with the one to the right."
14248 (interactive)
14249 (let* ((n (current-column))
14250 (cell (nthcdr n org-columns-current-fmt-compiled))
14251 e)
14252 (when (>= n (1- (length org-columns-current-fmt-compiled)))
14253 (error "Cannot shift this column further to the right"))
14254 (setq e (car cell))
14255 (setcar cell (car (cdr cell)))
14256 (setcdr cell (cons e (cdr (cdr cell))))
14257 (org-columns-store-format)
14258 (org-columns-redo)
14259 (forward-char 1)))
14260
14261(defun org-columns-move-left ()
14262 "Swap this column with the one to the left."
14263 (interactive)
14264 (let* ((n (current-column)))
14265 (when (= n 0)
14266 (error "Cannot shift this column further to the left"))
14267 (backward-char 1)
14268 (org-columns-move-right)
14269 (backward-char 1)))
14270
14271(defun org-columns-store-format ()
14272 "Store the text version of the current columns format in appropriate place.
14273This is either in the COLUMNS property of the node starting the current column
14274display, or in the #+COLUMNS line of the current buffer."
14275 (let (fmt)
14276 (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled))
14277 (if (marker-position org-columns-top-level-marker)
14278 (save-excursion
14279 (goto-char org-columns-top-level-marker)
14280 (if (org-entry-get nil "COLUMNS")
14281 (org-entry-put nil "COLUMNS" fmt)
14282 (goto-char (point-min))
14283 (while (re-search-forward "^#\\+COLUMNS:.*" nil t)
14284 (replace-match (concat "#+COLUMNS: " fmt t t)))))
14285 (setq org-columns-current-fmt fmt))))
14286
13837(defvar org-overriding-columns-format nil 14287(defvar org-overriding-columns-format nil
13838 "FIXME:") 14288 "When set, overrides any other definition.")
13839(defvar org-agenda-view-columns-initially nil 14289(defvar org-agenda-view-columns-initially nil
13840 "FIXME:") 14290 "When set, switch to columns view immediately after creating the agenda.")
13841 14291
13842(defun org-agenda-columns () 14292(defun org-agenda-columns ()
13843 "Turn on column view in the agenda." 14293 "Turn on column view in the agenda."
13844 (interactive) 14294 (interactive)
13845 (let (fmt first-done cache maxwidths m) 14295 (org-verify-version 'columns)
14296 (org-columns-remove-overlays)
14297 (move-marker org-columns-begin-marker (point))
14298 (let (fmt cache maxwidths m)
13846 (cond 14299 (cond
13847 ((and (local-variable-p 'org-overriding-columns-format) 14300 ((and (local-variable-p 'org-overriding-columns-format)
13848 org-overriding-columns-format) 14301 org-overriding-columns-format)
13849 (setq fmt org-overriding-columns-format)) 14302 (setq fmt org-overriding-columns-format))
13850 ((setq m (get-text-property (point-at-bol) 'org-hd-marker)) 14303 ((setq m (get-text-property (point-at-bol) 'org-hd-marker))
13851 (setq fmt (org-entry-get m "COLUMNS" t))) 14304 (setq fmt (org-entry-get m "COLUMNS" t)))
13852 ((and (boundp 'org-current-columns-fmt) 14305 ((and (boundp 'org-columns-current-fmt)
13853 (local-variable-p 'org-current-columns-fmt) 14306 (local-variable-p 'org-columns-current-fmt)
13854 org-current-columns-fmt) 14307 org-columns-current-fmt)
13855 (setq fmt org-current-columns-fmt)) 14308 (setq fmt org-columns-current-fmt))
13856 ((setq m (next-single-property-change (point-min) 'org-hd-marker)) 14309 ((setq m (next-single-property-change (point-min) 'org-hd-marker))
13857 (setq m (get-text-property m 'org-hd-marker)) 14310 (setq m (get-text-property m 'org-hd-marker))
13858 (setq fmt (org-entry-get m "COLUMNS" t)))) 14311 (setq fmt (org-entry-get m "COLUMNS" t))))
13859 (setq fmt (or fmt org-default-columns-format)) 14312 (setq fmt (or fmt org-columns-default-format))
13860 (org-set-local 'org-current-columns-fmt fmt) 14313 (org-set-local 'org-columns-current-fmt fmt)
14314 (org-columns-compile-format fmt)
13861 (save-excursion 14315 (save-excursion
13862 ;; Get and cache the properties 14316 ;; Get and cache the properties
13863 (goto-char (point-min)) 14317 (goto-char (point-min))
@@ -13867,16 +14321,16 @@ Where possible, use the standard interface for changing this line."
13867 (push (cons (org-current-line) (org-entry-properties m)) cache)) 14321 (push (cons (org-current-line) (org-entry-properties m)) cache))
13868 (beginning-of-line 2)) 14322 (beginning-of-line 2))
13869 (when cache 14323 (when cache
13870 (setq maxwidths (org-get-columns-autowidth-alist fmt cache)) 14324 (setq maxwidths (org-columns-get-autowidth-alist fmt cache))
13871 (org-set-local 'org-current-columns-maxwidths maxwidths) 14325 (org-set-local 'org-columns-current-maxwidths maxwidths)
13872 (goto-line (car (org-last cache))) 14326 (goto-line (car (org-last cache)))
13873 (org-overlay-columns-title) 14327 (org-columns-display-here-title)
13874 (mapc (lambda (x) 14328 (mapc (lambda (x)
13875 (goto-line (car x)) 14329 (goto-line (car x))
13876 (org-overlay-columns (cdr x))) 14330 (org-columns-display-here (cdr x)))
13877 cache))))) 14331 cache)))))
13878 14332
13879(defun org-get-columns-autowidth-alist (s cache) 14333(defun org-columns-get-autowidth-alist (s cache)
13880 "Derive the maximum column widths from the format and the cache." 14334 "Derive the maximum column widths from the format and the cache."
13881 (let ((start 0) rtn) 14335 (let ((start 0) rtn)
13882 (while (string-match "%\\([a-zA-Z]\\S-*\\)" s start) 14336 (while (string-match "%\\([a-zA-Z]\\S-*\\)" s start)
@@ -13891,6 +14345,167 @@ Where possible, use the standard interface for changing this line."
13891 rtn) 14345 rtn)
13892 rtn)) 14346 rtn))
13893 14347
14348(defun org-columns-compute-all ()
14349 "Compute all columns that have operators defined."
14350 (remove-text-properties (point-min) (point-max) '(org-summaries t))
14351 (let ((columns org-columns-current-fmt-compiled) col)
14352 (while (setq col (pop columns))
14353 (when (nth 3 col)
14354 (save-excursion
14355 (org-columns-compute (car col)))))))
14356
14357(defun org-columns-update (property)
14358 "Recompute PROPERTY, and update the columns display for it."
14359 (org-columns-compute property)
14360 (let (fmt val pos)
14361 (save-excursion
14362 (mapc (lambda (ov)
14363 (when (equal (org-overlay-get ov 'org-columns-key) property)
14364 (setq pos (org-overlay-start ov))
14365 (goto-char pos)
14366 (when (setq val (cdr (assoc property
14367 (get-text-property (point-at-bol) 'org-summaries))))
14368 (setq fmt (org-overlay-get ov 'org-columns-format))
14369 (org-overlay-put ov 'display (format fmt val)))))
14370 org-columns-overlays))))
14371
14372(defun org-columns-compute (property)
14373 "Sum the values of property PROPERTY hierarchically, for the entire buffer."
14374 (interactive)
14375 (let* ((re (concat "^" outline-regexp))
14376 (lmax 30) ; Does anyone use deeper levels???
14377 (lsum (make-vector lmax 0))
14378 (level 0)
14379 (ass (assoc property org-columns-current-fmt-compiled))
14380 (format (nth 4 ass))
14381 (beg org-columns-top-level-marker)
14382 last-level val end sumpos sum-alist sum str)
14383 (save-excursion
14384 ;; Find the region to compute
14385 (goto-char beg)
14386 (setq end (condition-case nil (org-end-of-subtree t) (error (point-max))))
14387 (goto-char end)
14388 ;; Walk the tree from the back and do the computations
14389 (while (re-search-backward re beg t)
14390 (setq sumpos (match-beginning 0)
14391 last-level level
14392 level (org-outline-level)
14393 val (org-entry-get nil property))
14394 (cond
14395 ((< level last-level)
14396 ;; put the sum of lower levels here as a property
14397 (setq sum (aref lsum last-level)
14398 str (org-column-number-to-string sum format)
14399 sum-alist (get-text-property sumpos 'org-summaries))
14400 (if (assoc property sum-alist)
14401 (setcdr (assoc property sum-alist) str)
14402 (push (cons property str) sum-alist)
14403 (add-text-properties sumpos (1+ sumpos)
14404 (list 'org-summaries sum-alist)))
14405 (when val
14406 (org-entry-put nil property str))
14407 ;; add current to current level accumulator
14408 (aset lsum level (+ (aref lsum level) sum))
14409 ;; clear accumulators for deeper levels
14410 (loop for l from (1+ level) to (1- lmax) do (aset lsum l 0)))
14411 ((>= level last-level)
14412 ;; add what we have here to the accumulator for this level
14413 (aset lsum level (+ (aref lsum level)
14414 (org-column-string-to-number (or val "0") format))))
14415 (t (error "This should not happen")))))))
14416
14417(defun org-columns-redo ()
14418 "Construct the column display again."
14419 (interactive)
14420 (message "Recomputing columns...")
14421 (save-excursion
14422 (if (marker-position org-columns-begin-marker)
14423 (goto-char org-columns-begin-marker))
14424 (org-columns-remove-overlays)
14425 (if (org-mode-p)
14426 (call-interactively 'org-columns)
14427 (call-interactively 'org-agenda-columns)))
14428 (message "Recomputing columns...done"))
14429
14430(defun org-columns-not-in-agenda ()
14431 (if (eq major-mode 'org-agenda-mode)
14432 (error "This command is only allowed in Org-mode buffers")))
14433
14434
14435(defun org-string-to-number (s)
14436 "Convert string to number, and interpret hh:mm:ss."
14437 (if (not (string-match ":" s))
14438 (string-to-number s)
14439 (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
14440 (while l
14441 (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
14442 sum)))
14443
14444(defun org-column-number-to-string (n fmt)
14445 "Convert a computed column number to a string value, according to FMT."
14446 (cond
14447 ((eq fmt 'add_times)
14448 (let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h))))))
14449 (format "%d:%02d" h m)))
14450 ((eq fmt 'checkbox)
14451 (cond ((= n (floor n)) "[X]")
14452 ((> n 1.) "[-]")
14453 (t "[ ]")))
14454 (t (number-to-string n))))
14455
14456(defun org-column-string-to-number (s fmt)
14457 "Convert a column value to a number that can be used for column computing."
14458 (cond
14459 ((string-match ":" s)
14460 (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
14461 (while l
14462 (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
14463 sum))
14464 ((eq fmt 'checkbox)
14465 (if (equal s "[X]") 1. 0.000001))
14466 (t (string-to-number s))))
14467
14468(defun org-columns-uncompile-format (cfmt)
14469 "Turn the compiled columns format back into a string representation."
14470 (let ((rtn "") e s prop title op width fmt)
14471 (while (setq e (pop cfmt))
14472 (setq prop (car e)
14473 title (nth 1 e)
14474 width (nth 2 e)
14475 op (nth 3 e)
14476 fmt (nth 4 e))
14477 (cond
14478 ((eq fmt 'add_times) (setq op ":"))
14479 ((eq fmt 'checkbox) (setq op "X"))
14480 ((eq fmt 'add_numbers) (setq op "+")))
14481 (if (equal title prop) (setq title nil))
14482 (setq s (concat "%" (if width (number-to-string width))
14483 prop
14484 (if title (concat "(" title ")"))
14485 (if op (concat "{" op "}"))))
14486 (setq rtn (concat rtn " " s)))
14487 (org-trim rtn)))
14488
14489(defun org-columns-compile-format (fmt)
14490 "FIXME"
14491 (let ((start 0) width prop title op f)
14492 (setq org-columns-current-fmt-compiled nil)
14493 (while (string-match "%\\([0-9]+\\)?\\([a-zA-Z_0-9]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*"
14494 fmt start)
14495 (setq start (match-end 0)
14496 width (match-string 1 fmt)
14497 prop (match-string 2 fmt)
14498 title (or (match-string 3 fmt) prop)
14499 op (match-string 4 fmt)
14500 f nil)
14501 (if width (setq width (string-to-number width)))
14502 (cond
14503 ((equal op "+") (setq f 'add_numbers))
14504 ((equal op ":") (setq f 'add_times))
14505 ((equal op "X") (setq f 'checkbox)))
14506 (push (list prop title width op f) org-columns-current-fmt-compiled))
14507 (setq org-columns-current-fmt-compiled
14508 (nreverse org-columns-current-fmt-compiled))))
13894 14509
13895;;;; Timestamps 14510;;;; Timestamps
13896 14511
@@ -14084,7 +14699,7 @@ used to insert the time stamp into the buffer to include the time."
14084 ;; Help matching am/pm times, because `parse-time-string' does not do that. 14699 ;; Help matching am/pm times, because `parse-time-string' does not do that.
14085 ;; If there is a time with am/pm, and *no* time without it, we convert 14700 ;; If there is a time with am/pm, and *no* time without it, we convert
14086 ;; so that matching will be successful. 14701 ;; so that matching will be successful.
14087 ;; FIXME: make this replace twoce, so that we catch the end time. 14702 ;; FIXME: make this replace twice, so that we catch the end time.
14088 (when (and (not (string-match "[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans)) 14703 (when (and (not (string-match "[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans))
14089 (string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans)) 14704 (string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans))
14090 (setq hour (string-to-number (match-string 1 ans)) 14705 (setq hour (string-to-number (match-string 1 ans))
@@ -15308,8 +15923,7 @@ The following commands are available:
15308(org-defkey org-agenda-mode-map [(right)] 'org-agenda-later) 15923(org-defkey org-agenda-mode-map [(right)] 'org-agenda-later)
15309(org-defkey org-agenda-mode-map [(left)] 'org-agenda-earlier) 15924(org-defkey org-agenda-mode-map [(left)] 'org-agenda-earlier)
15310(org-defkey org-agenda-mode-map "\C-c\C-x\C-c" 'org-agenda-columns) 15925(org-defkey org-agenda-mode-map "\C-c\C-x\C-c" 'org-agenda-columns)
15311; FIXME: other key? wtah about the menu???/ 15926
15312;(org-defkey org-agenda-mode-map "\C-c\C-x\C-c" 'org-export-icalendar-combine-agenda-files)
15313(defvar org-agenda-keymap (copy-keymap org-agenda-mode-map) 15927(defvar org-agenda-keymap (copy-keymap org-agenda-mode-map)
15314 "Local keymap for agenda entries from Org-mode.") 15928 "Local keymap for agenda entries from Org-mode.")
15315 15929
@@ -16555,7 +17169,6 @@ for a keyword. A numeric prefix directly selects the Nth keyword in
16555 (mapcar 'list kwds) nil nil))) 17169 (mapcar 'list kwds) nil nil)))
16556 (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) 17170 (and (equal 0 arg) (setq org-select-this-todo-keyword nil))
16557 (org-set-local 'org-last-arg arg) 17171 (org-set-local 'org-last-arg arg)
16558;FIXME (org-set-local 'org-todo-keywords-for-agenda kwds)
16559 (setq org-agenda-redo-command 17172 (setq org-agenda-redo-command
16560 '(org-todo-list (or current-prefix-arg org-last-arg))) 17173 '(org-todo-list (or current-prefix-arg org-last-arg)))
16561 (setq files (org-agenda-files) 17174 (setq files (org-agenda-files)
@@ -16581,7 +17194,7 @@ for a keyword. A numeric prefix directly selects the Nth keyword in
16581 (mapc (lambda (x) 17194 (mapc (lambda (x)
16582 (setq s (format "(%d)%s" (setq n (1+ n)) x)) 17195 (setq s (format "(%d)%s" (setq n (1+ n)) x))
16583 (if (> (+ (current-column) (string-width s) 1) (frame-width)) 17196 (if (> (+ (current-column) (string-width s) 1) (frame-width))
16584 (insert "\n ")) 17197 (insert "\n "))
16585 (insert " " s)) 17198 (insert " " s))
16586 kwds)) 17199 kwds))
16587 (insert "\n")) 17200 (insert "\n"))
@@ -16705,8 +17318,8 @@ MATCH is being ignored."
16705 "\\)\\>")) 17318 "\\)\\>"))
16706 (tags (nth 2 org-stuck-projects)) 17319 (tags (nth 2 org-stuck-projects))
16707 (tags-re (if (member "*" tags) 17320 (tags-re (if (member "*" tags)
16708 (org-re "^\\*+.*:[[:alnum:]_@]+:[ \t]*$") 17321 (org-re "^\\*+ .*:[[:alnum:]_@]+:[ \t]*$")
16709 (concat "^\\*+.*:\\(" 17322 (concat "^\\*+ .*:\\("
16710 (mapconcat 'identity tags "\\|") 17323 (mapconcat 'identity tags "\\|")
16711 (org-re "\\):[[:alnum:]_@:]*[ \t]*$")))) 17324 (org-re "\\):[[:alnum:]_@:]*[ \t]*$"))))
16712 (gen-re (nth 3 org-stuck-projects)) 17325 (gen-re (nth 3 org-stuck-projects))
@@ -16951,7 +17564,7 @@ the documentation of `org-diary'."
16951(defun org-entry-is-done-p () 17564(defun org-entry-is-done-p ()
16952 "Is the current entry marked DONE?" 17565 "Is the current entry marked DONE?"
16953 (save-excursion 17566 (save-excursion
16954 (and (re-search-backward "[\r\n]\\*" nil t) 17567 (and (re-search-backward "[\r\n]\\* " nil t)
16955 (looking-at org-nl-done-regexp)))) 17568 (looking-at org-nl-done-regexp))))
16956 17569
16957(defun org-at-date-range-p (&optional inactive-ok) 17570(defun org-at-date-range-p (&optional inactive-ok)
@@ -16984,7 +17597,7 @@ the documentation of `org-diary'."
16984 (format "mouse-2 or RET jump to org file %s" 17597 (format "mouse-2 or RET jump to org file %s"
16985 (abbreviate-file-name buffer-file-name)))) 17598 (abbreviate-file-name buffer-file-name))))
16986 ;; FIXME: get rid of the \n at some point but watch out 17599 ;; FIXME: get rid of the \n at some point but watch out
16987 (regexp (concat "[\n\r]\\*+ *\\(" 17600 (regexp (concat "\n\\*+[ \t]+\\("
16988 (if org-select-this-todo-keyword 17601 (if org-select-this-todo-keyword
16989 (if (equal org-select-this-todo-keyword "*") 17602 (if (equal org-select-this-todo-keyword "*")
16990 org-todo-regexp 17603 org-todo-regexp
@@ -17093,12 +17706,12 @@ the documentation of `org-diary'."
17093 ;; substring should only run to end of time stamp 17706 ;; substring should only run to end of time stamp
17094 (setq timestr (substring timestr 0 (match-end 0)))) 17707 (setq timestr (substring timestr 0 (match-end 0))))
17095 (save-excursion 17708 (save-excursion
17096 (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t) 17709 (if (re-search-backward "^\\*+ " nil t)
17097 (progn 17710 (progn
17098 (goto-char (match-end 1)) 17711 (goto-char (match-beginning 0))
17099 (setq hdmarker (org-agenda-new-marker) 17712 (setq hdmarker (org-agenda-new-marker)
17100 tags (org-get-tags-at)) 17713 tags (org-get-tags-at))
17101 (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") 17714 (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
17102 (setq txt (org-format-agenda-item 17715 (setq txt (org-format-agenda-item
17103 (format "%s%s" 17716 (format "%s%s"
17104 (if deadlinep "Deadline: " "") 17717 (if deadlinep "Deadline: " "")
@@ -17202,12 +17815,12 @@ the documentation of `org-diary'."
17202 ;; substring should only run to end of time stamp 17815 ;; substring should only run to end of time stamp
17203 (setq timestr (substring timestr 0 (match-end 0)))) 17816 (setq timestr (substring timestr 0 (match-end 0))))
17204 (save-excursion 17817 (save-excursion
17205 (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t) 17818 (if (re-search-backward "^\\*+ " nil t)
17206 (progn 17819 (progn
17207 (goto-char (match-end 1)) 17820 (goto-char (match-beginning 0))
17208 (setq hdmarker (org-agenda-new-marker) 17821 (setq hdmarker (org-agenda-new-marker)
17209 tags (org-get-tags-at)) 17822 tags (org-get-tags-at))
17210 (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") 17823 (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
17211 (setq txt (org-format-agenda-item 17824 (setq txt (org-format-agenda-item
17212 (if closedp "Closed: " "Clocked: ") 17825 (if closedp "Closed: " "Clocked: ")
17213 (match-string 1) category tags timestr))) 17826 (match-string 1) category tags timestr)))
@@ -17252,10 +17865,10 @@ the documentation of `org-diary'."
17252 (if (and (< diff wdays) todayp (not (= diff 0))) 17865 (if (and (< diff wdays) todayp (not (= diff 0)))
17253 (save-excursion 17866 (save-excursion
17254 (setq category (org-get-category)) 17867 (setq category (org-get-category))
17255 (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t) 17868 (if (re-search-backward "^\\*+[ \t]+" nil t)
17256 (progn 17869 (progn
17257 (goto-char (match-end 0)) 17870 (goto-char (match-end 0))
17258 (setq pos1 (match-end 1)) 17871 (setq pos1 (match-beginning 0))
17259 (setq tags (org-get-tags-at pos1)) 17872 (setq tags (org-get-tags-at pos1))
17260 (setq head (buffer-substring-no-properties 17873 (setq head (buffer-substring-no-properties
17261 (point) 17874 (point)
@@ -17311,10 +17924,10 @@ the documentation of `org-diary'."
17311 (if (and (< diff 0) todayp) 17924 (if (and (< diff 0) todayp)
17312 (save-excursion 17925 (save-excursion
17313 (setq category (org-get-category)) 17926 (setq category (org-get-category))
17314 (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t) 17927 (if (re-search-backward "^\\*+[ \t]+" nil t)
17315 (progn 17928 (progn
17316 (goto-char (match-end 0)) 17929 (goto-char (match-end 0))
17317 (setq pos1 (match-end 1)) 17930 (setq pos1 (match-beginning 0))
17318 (setq tags (org-get-tags-at)) 17931 (setq tags (org-get-tags-at))
17319 (setq head (buffer-substring-no-properties 17932 (setq head (buffer-substring-no-properties
17320 (point) 17933 (point)
@@ -17364,12 +17977,12 @@ the documentation of `org-diary'."
17364 (save-excursion 17977 (save-excursion
17365 (setq marker (org-agenda-new-marker (point))) 17978 (setq marker (org-agenda-new-marker (point)))
17366 (setq category (org-get-category)) 17979 (setq category (org-get-category))
17367 (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t) 17980 (if (re-search-backward "^\\*+ " nil t)
17368 (progn 17981 (progn
17369 (setq hdmarker (org-agenda-new-marker (match-end 1))) 17982 (goto-char (match-beginning 0))
17370 (goto-char (match-end 1)) 17983 (setq hdmarker (org-agenda-new-marker (point)))
17371 (setq tags (org-get-tags-at)) 17984 (setq tags (org-get-tags-at))
17372 (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") 17985 (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
17373 (setq txt (org-format-agenda-item 17986 (setq txt (org-format-agenda-item
17374 (format (if (= d1 d2) "" "(%d/%d): ") 17987 (format (if (= d1 d2) "" "(%d/%d): ")
17375 (1+ (- d0 d1)) (1+ (- d2 d1))) 17988 (1+ (- d0 d1)) (1+ (- d2 d1)))
@@ -17655,8 +18268,8 @@ HH:MM."
17655 18268
17656(defsubst org-cmp-category (a b) 18269(defsubst org-cmp-category (a b)
17657 "Compare the string values of categories of strings A and B." 18270 "Compare the string values of categories of strings A and B."
17658 (let ((ca (or (get-text-property 1 'category a) "")) 18271 (let ((ca (or (get-text-property 1 'org-category a) ""))
17659 (cb (or (get-text-property 1 'category b) ""))) 18272 (cb (or (get-text-property 1 'org-category b) "")))
17660 (cond ((string-lessp ca cb) -1) 18273 (cond ((string-lessp ca cb) -1)
17661 ((string-lessp cb ca) +1) 18274 ((string-lessp cb ca) +1)
17662 (t nil)))) 18275 (t nil))))
@@ -17715,7 +18328,7 @@ If ERROR is non-nil, throw an error, otherwise just return nil."
17715 (if (not (one-window-p)) (delete-window)) 18328 (if (not (one-window-p)) (delete-window))
17716 (kill-buffer buf) 18329 (kill-buffer buf)
17717 (org-agenda-maybe-reset-markers 'force) 18330 (org-agenda-maybe-reset-markers 'force)
17718 (org-remove-column-overlays)) 18331 (org-columns-remove-overlays))
17719 ;; Maybe restore the pre-agenda window configuration. 18332 ;; Maybe restore the pre-agenda window configuration.
17720 (and org-agenda-restore-windows-after-quit 18333 (and org-agenda-restore-windows-after-quit
17721 (not (eq org-agenda-window-setup 'other-frame)) 18334 (not (eq org-agenda-window-setup 'other-frame))
@@ -17814,10 +18427,12 @@ With prefix ARG, go backward that many times the current span."
17814(defun org-agenda-day-view () 18427(defun org-agenda-day-view ()
17815 "Switch to daily view for agenda." 18428 "Switch to daily view for agenda."
17816 (interactive) 18429 (interactive)
18430 (setq org-agenda-ndays 1)
17817 (org-agenda-change-time-span 'day)) 18431 (org-agenda-change-time-span 'day))
17818(defun org-agenda-week-view () 18432(defun org-agenda-week-view ()
17819 "Switch to daily view for agenda." 18433 "Switch to daily view for agenda."
17820 (interactive) 18434 (interactive)
18435 (setq org-agenda-ndays 7)
17821 (org-agenda-change-time-span 'week)) 18436 (org-agenda-change-time-span 'week))
17822(defun org-agenda-month-view () 18437(defun org-agenda-month-view ()
17823 "Switch to daily view for agenda." 18438 "Switch to daily view for agenda."
@@ -17860,8 +18475,9 @@ so that the date SD will be in that range."
17860 ((eq span 'week) 18475 ((eq span 'week)
17861 (let* ((nt (calendar-day-of-week 18476 (let* ((nt (calendar-day-of-week
17862 (calendar-gregorian-from-absolute sd))) 18477 (calendar-gregorian-from-absolute sd)))
17863 (n1 org-agenda-start-on-weekday) 18478 (d (if org-agenda-start-on-weekday
17864 (d (- nt n1))) 18479 (- nt org-agenda-start-on-weekday)
18480 0)))
17865 (setq sd (- sd (+ (if (< d 0) 7 0) d))) 18481 (setq sd (- sd (+ (if (< d 0) 7 0) d)))
17866 (setq nd 7))) 18482 (setq nd 7)))
17867 ((eq span 'month) 18483 ((eq span 'month)
@@ -18329,7 +18945,7 @@ the tags of the current headline come last."
18329 (org-back-to-heading t) 18945 (org-back-to-heading t)
18330 (condition-case nil 18946 (condition-case nil
18331 (while t 18947 (while t
18332 (if (looking-at (org-re "[^\r\n]+?:\\([[:alnum:]_@:]+\\):[ \t]*\\([\n\r]\\|\\'\\)")) 18948 (if (looking-at (org-re "[^\r\n]+?:\\([[:alnum:]_@:]+\\):[ \t]*$"))
18333 (setq tags (append (org-split-string 18949 (setq tags (append (org-split-string
18334 (org-match-string-no-properties 1) ":") 18950 (org-match-string-no-properties 1) ":")
18335 tags))) 18951 tags)))
@@ -19463,7 +20079,8 @@ translations. There is currently no way for users to extend this.")
19463 (re-archive (concat ":" org-archive-tag ":")) 20079 (re-archive (concat ":" org-archive-tag ":"))
19464 (re-quote (concat "^\\*+[ \t]+" org-quote-string "\\>")) 20080 (re-quote (concat "^\\*+[ \t]+" org-quote-string "\\>"))
19465 (htmlp (plist-get parameters :for-html)) 20081 (htmlp (plist-get parameters :for-html))
19466 (outline-regexp "\\*+") 20082 (inhibit-read-only t)
20083 (outline-regexp "\\*+ ")
19467 a b 20084 a b
19468 rtn p) 20085 rtn p)
19469 (save-excursion 20086 (save-excursion
@@ -19739,7 +20356,7 @@ underlined headlines. The default is 3."
19739 :skip-before-1st-heading 20356 :skip-before-1st-heading
19740 (plist-get opt-plist :skip-before-1st-heading) 20357 (plist-get opt-plist :skip-before-1st-heading)
19741 :add-text (plist-get opt-plist :text)) 20358 :add-text (plist-get opt-plist :text))
19742 "[\r\n]"))) 20359 "[\r\n]"))) ;; FIXME: why \r here???/
19743 thetoc have-headings first-heading-pos 20360 thetoc have-headings first-heading-pos
19744 table-open table-buffer) 20361 table-open table-buffer)
19745 20362
@@ -19846,7 +20463,7 @@ underlined headlines. The default is 3."
19846 (when custom-times 20463 (when custom-times
19847 (setq line (org-translate-time line))) 20464 (setq line (org-translate-time line)))
19848 (cond 20465 (cond
19849 ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) 20466 ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line)
19850 ;; a Headline 20467 ;; a Headline
19851 (setq first-heading-pos (or first-heading-pos (point))) 20468 (setq first-heading-pos (or first-heading-pos (point)))
19852 (setq level (org-tr-level (- (match-end 1) (match-beginning 1))) 20469 (setq level (org-tr-level (- (match-end 1) (match-beginning 1)))
@@ -19953,7 +20570,7 @@ underlined headlines. The default is 3."
19953 ;; find the indentation of the next non-empty line 20570 ;; find the indentation of the next non-empty line
19954 (catch 'stop 20571 (catch 'stop
19955 (while lines 20572 (while lines
19956 (if (string-match "^\\*" (car lines)) (throw 'stop nil)) 20573 (if (string-match "^\\* " (car lines)) (throw 'stop nil))
19957 (if (string-match "^\\([ \t]*\\)\\S-" (car lines)) 20574 (if (string-match "^\\([ \t]*\\)\\S-" (car lines))
19958 (throw 'stop (setq ind (org-get-indentation (car lines))))) 20575 (throw 'stop (setq ind (org-get-indentation (car lines)))))
19959 (pop lines))) 20576 (pop lines)))
@@ -20145,12 +20762,12 @@ this line is also exported in fixed-width font."
20145 (save-excursion 20762 (save-excursion
20146 (org-back-to-heading) 20763 (org-back-to-heading)
20147 (if (looking-at (concat outline-regexp 20764 (if (looking-at (concat outline-regexp
20148 "\\( +\\<" org-quote-string "\\>\\)")) 20765 "\\( *\\<" org-quote-string "\\>\\)"))
20149 (replace-match "" t t nil 1) 20766 (replace-match "" t t nil 1)
20150 (if (looking-at outline-regexp) 20767 (if (looking-at outline-regexp)
20151 (progn 20768 (progn
20152 (goto-char (match-end 0)) 20769 (goto-char (match-end 0))
20153 (insert " " org-quote-string)))))))) 20770 (insert org-quote-string " "))))))))
20154 20771
20155(defun org-export-as-html-and-open (arg) 20772(defun org-export-as-html-and-open (arg)
20156 "Export the outline as HTML and immediately open it with a browser. 20773 "Export the outline as HTML and immediately open it with a browser.
@@ -20303,7 +20920,7 @@ the body tags themselves."
20303 (file-name-nondirectory buffer-file-name))) 20920 (file-name-nondirectory buffer-file-name)))
20304 "UNTITLED")) 20921 "UNTITLED"))
20305 (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) 20922 (quote-re0 (concat "^[ \t]*" org-quote-string "\\>"))
20306 (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) 20923 (quote-re (concat "^\\(\\*+\\)\\([ \t]+" org-quote-string "\\>\\)"))
20307 (inquote nil) 20924 (inquote nil)
20308 (infixed nil) 20925 (infixed nil)
20309 (in-local-list nil) 20926 (in-local-list nil)
@@ -20495,7 +21112,7 @@ lang=\"%s\" xml:lang=\"%s\">
20495 (catch 'nextline 21112 (catch 'nextline
20496 21113
20497 ;; end of quote section? 21114 ;; end of quote section?
20498 (when (and inquote (string-match "^\\*+" line)) 21115 (when (and inquote (string-match "^\\*+ " line))
20499 (insert "</pre>\n") 21116 (insert "</pre>\n")
20500 (setq inquote nil)) 21117 (setq inquote nil))
20501 ;; inside a quote section? 21118 ;; inside a quote section?
@@ -20672,7 +21289,7 @@ lang=\"%s\" xml:lang=\"%s\">
20672 t t line))))) 21289 t t line)))))
20673 21290
20674 (cond 21291 (cond
20675 ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) 21292 ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line)
20676 ;; This is a headline 21293 ;; This is a headline
20677 (setq level (org-tr-level (- (match-end 1) (match-beginning 1))) 21294 (setq level (org-tr-level (- (match-end 1) (match-beginning 1)))
20678 txt (match-string 2 line)) 21295 txt (match-string 2 line))
@@ -21595,7 +22212,7 @@ The XOXO buffer is named *xoxo-<source buffer name>*"
21595 (with-current-buffer out (erase-buffer)) 22212 (with-current-buffer out (erase-buffer))
21596 ;; Kick off the output 22213 ;; Kick off the output
21597 (org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n") 22214 (org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n")
21598 (while (re-search-forward "^\\(\\*+\\) \\(.+\\)" (point-max) 't) 22215 (while (re-search-forward "^\\(\\*+\\)[ \t]+\\(.+\\)" (point-max) 't)
21599 (let* ((hd (match-string-no-properties 1)) 22216 (let* ((hd (match-string-no-properties 1))
21600 (level (length hd)) 22217 (level (length hd))
21601 (text (concat 22218 (text (concat
@@ -21827,7 +22444,13 @@ overwritten, and the table is not marked as requiring realignment."
21827 (goto-char (match-beginning 0)) 22444 (goto-char (match-beginning 0))
21828 (self-insert-command N)) 22445 (self-insert-command N))
21829 (setq org-table-may-need-update t) 22446 (setq org-table-may-need-update t)
21830 (self-insert-command N))) 22447 (self-insert-command N)
22448 (org-fix-tags-on-the-fly)))
22449
22450(defun org-fix-tags-on-the-fly ()
22451 (when (and (equal (char-after (point-at-bol)) ?*)
22452 (org-on-heading-p))
22453 (org-align-tags-here org-tags-column)))
21831 22454
21832(defun org-delete-backward-char (N) 22455(defun org-delete-backward-char (N)
21833 "Like `delete-backward-char', insert whitespace at field end in tables. 22456 "Like `delete-backward-char', insert whitespace at field end in tables.
@@ -21850,7 +22473,8 @@ because, in this case the deletion might narrow the column."
21850 ;; noalign: if there were two spaces at the end, this field 22473 ;; noalign: if there were two spaces at the end, this field
21851 ;; does not determine the width of the column. 22474 ;; does not determine the width of the column.
21852 (if noalign (setq org-table-may-need-update c))) 22475 (if noalign (setq org-table-may-need-update c)))
21853 (backward-delete-char N))) 22476 (backward-delete-char N)
22477 (org-fix-tags-on-the-fly)))
21854 22478
21855(defun org-delete-char (N) 22479(defun org-delete-char (N)
21856 "Like `delete-char', but insert whitespace at field end in tables. 22480 "Like `delete-char', but insert whitespace at field end in tables.
@@ -21875,7 +22499,8 @@ because, in this case the deletion might narrow the column."
21875 ;; does not determine the width of the column. 22499 ;; does not determine the width of the column.
21876 (if noalign (setq org-table-may-need-update c))) 22500 (if noalign (setq org-table-may-need-update c)))
21877 (delete-char N)) 22501 (delete-char N))
21878 (delete-char N))) 22502 (delete-char N)
22503 (org-fix-tags-on-the-fly)))
21879 22504
21880;; Make `delete-selection-mode' work with org-mode and orgtbl-mode 22505;; Make `delete-selection-mode' work with org-mode and orgtbl-mode
21881(put 'org-self-insert-command 'delete-selection t) 22506(put 'org-self-insert-command 'delete-selection t)
@@ -22052,6 +22677,7 @@ depending on context. See the individual commands for more information."
22052 (cond 22677 (cond
22053 ((org-at-timestamp-p t) (call-interactively 'org-timestamp-up-day)) 22678 ((org-at-timestamp-p t) (call-interactively 'org-timestamp-up-day))
22054 ((org-on-heading-p) (org-call-with-arg 'org-todo 'right)) 22679 ((org-on-heading-p) (org-call-with-arg 'org-todo 'right))
22680 ((org-at-property-p) (call-interactively 'org-property-next-allowed-value))
22055 (t (org-shiftcursor-error)))) 22681 (t (org-shiftcursor-error))))
22056 22682
22057(defun org-shiftleft () 22683(defun org-shiftleft ()
@@ -22060,6 +22686,8 @@ depending on context. See the individual commands for more information."
22060 (cond 22686 (cond
22061 ((org-at-timestamp-p t) (call-interactively 'org-timestamp-down-day)) 22687 ((org-at-timestamp-p t) (call-interactively 'org-timestamp-down-day))
22062 ((org-on-heading-p) (org-call-with-arg 'org-todo 'left)) 22688 ((org-on-heading-p) (org-call-with-arg 'org-todo 'left))
22689 ((org-at-property-p)
22690 (call-interactively 'org-property-previous-allowed-value))
22063 (t (org-shiftcursor-error)))) 22691 (t (org-shiftcursor-error))))
22064 22692
22065(defun org-shiftcontrolright () 22693(defun org-shiftcontrolright ()
@@ -22152,6 +22780,8 @@ This command does many different things, depending on context:
22152 ((and (local-variable-p 'org-finish-function (current-buffer)) 22780 ((and (local-variable-p 'org-finish-function (current-buffer))
22153 (fboundp org-finish-function)) 22781 (fboundp org-finish-function))
22154 (funcall org-finish-function)) 22782 (funcall org-finish-function))
22783 ((org-at-property-p)
22784 (call-interactively 'org-property-action))
22155 ((org-on-target-p) (call-interactively 'org-update-radio-target-regexp)) 22785 ((org-on-target-p) (call-interactively 'org-update-radio-target-regexp))
22156 ((org-on-heading-p) (call-interactively 'org-set-tags)) 22786 ((org-on-heading-p) (call-interactively 'org-set-tags))
22157 ((org-at-table.el-p) 22787 ((org-at-table.el-p)
@@ -22306,9 +22936,9 @@ See the individual commands for more information."
22306 "--" 22936 "--"
22307 ["Jump" org-goto t] 22937 ["Jump" org-goto t]
22308 "--" 22938 "--"
22309 ["C-a finds headline start" 22939 ["C-a/e find headline start/end"
22310 (setq org-special-ctrl-a (not org-special-ctrl-a)) 22940 (setq org-special-ctrl-a/e (not org-special-ctrl-a/e))
22311 :style toggle :selected org-special-ctrl-a]) 22941 :style toggle :selected org-special-ctrl-a/e])
22312 ("Edit Structure" 22942 ("Edit Structure"
22313 ["Move Subtree Up" org-shiftmetaup (not (org-at-table-p))] 22943 ["Move Subtree Up" org-shiftmetaup (not (org-at-table-p))]
22314 ["Move Subtree Down" org-shiftmetadown (not (org-at-table-p))] 22944 ["Move Subtree Down" org-shiftmetadown (not (org-at-table-p))]
@@ -22361,17 +22991,7 @@ See the individual commands for more information."
22361 "--" 22991 "--"
22362 ["Set Priority" org-priority t] 22992 ["Set Priority" org-priority t]
22363 ["Priority Up" org-shiftup t] 22993 ["Priority Up" org-shiftup t]
22364 ["Priority Down" org-shiftdown t] 22994 ["Priority Down" org-shiftdown t])
22365 "--"
22366 ;; FIXME: why is this still here????
22367; ["Insert Checkbox" org-insert-todo-heading (org-in-item-p)]
22368; ["Toggle Checkbox" org-ctrl-c-ctrl-c (org-at-item-checkbox-p)]
22369; ["Insert [n/m] cookie" (progn (insert "[/]") (org-update-checkbox-count))
22370; (or (org-on-heading-p) (org-at-item-p))]
22371; ["Insert [%] cookie" (progn (insert "[%]") (org-update-checkbox-count))
22372; (or (org-on-heading-p) (org-at-item-p))]
22373; ["Update Statistics" org-update-checkbox-count t]
22374 )
22375 ("TAGS and Properties" 22995 ("TAGS and Properties"
22376 ["Set Tags" 'org-ctrl-c-ctrl-c (org-at-heading-p)] 22996 ["Set Tags" 'org-ctrl-c-ctrl-c (org-at-heading-p)]
22377 ["Column view of properties" org-columns t]) 22997 ["Column view of properties" org-columns t])
@@ -22811,16 +23431,16 @@ not an indirect buffer"
22811 ;; text in a line directly attached to a headline would otherwise 23431 ;; text in a line directly attached to a headline would otherwise
22812 ;; fill the headline as well. 23432 ;; fill the headline as well.
22813 (org-set-local 'comment-start-skip "^#+[ \t]*") 23433 (org-set-local 'comment-start-skip "^#+[ \t]*")
22814 (org-set-local 'paragraph-separate "\f\\|\\*\\|[ ]*$\\|[ \t]*[:|]") 23434 (org-set-local 'paragraph-separate "\f\\|\\*+ \\|[ ]*$\\|[ \t]*[:|]")
22815;; FIXME!!!!!!! (org-set-local 'paragraph-separate "\f\\|[ ]*$") 23435;; FIXME!!!!!!! (org-set-local 'paragraph-separate "\f\\|[ ]*$")
22816 ;; The paragraph starter includes hand-formatted lists. 23436 ;; The paragraph starter includes hand-formatted lists.
22817 (org-set-local 'paragraph-start 23437 (org-set-local 'paragraph-start
22818 "\f\\|[ ]*$\\|\\([*\f]+\\)\\|[ \t]*\\([-+*][ \t]+\\|[0-9]+[.)][ \t]+\\)\\|[ \t]*[:|]") 23438 "\f\\|[ ]*$\\|\\*+ \\|\f\\|[ \t]*\\([-+*][ \t]+\\|[0-9]+[.)][ \t]+\\)\\|[ \t]*[:|]")
22819 ;; Inhibit auto-fill for headers, tables and fixed-width lines. 23439 ;; Inhibit auto-fill for headers, tables and fixed-width lines.
22820 ;; But only if the user has not turned off tables or fixed-width regions 23440 ;; But only if the user has not turned off tables or fixed-width regions
22821 (org-set-local 23441 (org-set-local
22822 'auto-fill-inhibit-regexp 23442 'auto-fill-inhibit-regexp
22823 (concat "\\*\\|#\\+" 23443 (concat "\\*+ \\|#\\+"
22824 "\\|[ \t]*" org-keyword-time-regexp 23444 "\\|[ \t]*" org-keyword-time-regexp
22825 (if (or org-enable-table-editor org-enable-fixed-width-editor) 23445 (if (or org-enable-table-editor org-enable-fixed-width-editor)
22826 (concat 23446 (concat
@@ -22866,10 +23486,13 @@ work correctly."
22866 23486
22867;; C-a should go to the beginning of a *visible* line, also in the 23487;; C-a should go to the beginning of a *visible* line, also in the
22868;; new outline.el. I guess this should be patched into Emacs? 23488;; new outline.el. I guess this should be patched into Emacs?
22869(defun org-beginning-of-line () 23489(defun org-beginning-of-line (&optional arg)
22870 "Go to the beginning of the current line. If that is invisible, continue 23490 "Go to the beginning of the current line. If that is invisible, continue
22871to a visible line beginning. This makes the function of C-a more intuitive." 23491to a visible line beginning. This makes the function of C-a more intuitive.
22872 (interactive) 23492If this is a headline, and `org-special-ctrl-a/e' is set, ignore tags on the
23493first attempt, and only move to after the tags when the cursor is already
23494beyond the end of the headline."
23495 (interactive "P")
22873 (let ((pos (point))) 23496 (let ((pos (point)))
22874 (beginning-of-line 1) 23497 (beginning-of-line 1)
22875 (if (bobp) 23498 (if (bobp)
@@ -22880,14 +23503,33 @@ to a visible line beginning. This makes the function of C-a more intuitive."
22880 (backward-char 1) 23503 (backward-char 1)
22881 (beginning-of-line 1)) 23504 (beginning-of-line 1))
22882 (forward-char 1))) 23505 (forward-char 1)))
22883 (when (and org-special-ctrl-a (looking-at org-todo-line-regexp) 23506 (when (and org-special-ctrl-a/e (looking-at org-todo-line-regexp)
22884 (= (char-after (match-end 1)) ?\ )) 23507 (= (char-after (match-end 1)) ?\ ))
22885 (goto-char 23508 (goto-char
22886 (cond ((> pos (match-beginning 3)) (match-beginning 3)) 23509 (cond ((> pos (match-beginning 3)) (match-beginning 3))
22887 ((= pos (point)) (match-beginning 3)) 23510 ((= pos (point)) (match-beginning 3))
22888 (t (point))))))) 23511 (t (point)))))))
22889 23512
23513(defun org-end-of-line (&optional arg)
23514 "Go to the end of the line.
23515If this is a headline, and `org-special-ctrl-a/e' is set, ignore tags on the
23516first attempt, and only move to after the tags when the cursor is already
23517beyond the end of the headline."
23518 (interactive "P")
23519 (if (or (not org-special-ctrl-a/e)
23520 (not (org-on-heading-p)))
23521 (end-of-line arg)
23522 (let ((pos (point)))
23523 (beginning-of-line 1)
23524 (if (looking-at (org-re ".*?\\([ \t]*\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
23525 (if (or (< pos (match-beginning 1))
23526 (= pos (match-end 0)))
23527 (goto-char (match-beginning 1))
23528 (goto-char (match-end 0)))
23529 (end-of-line arg)))))
23530
22890(define-key org-mode-map "\C-a" 'org-beginning-of-line) 23531(define-key org-mode-map "\C-a" 'org-beginning-of-line)
23532(define-key org-mode-map "\C-e" 'org-end-of-line)
22891 23533
22892(defun org-invisible-p () 23534(defun org-invisible-p ()
22893 "Check if point is at a character currently not visible." 23535 "Check if point is at a character currently not visible."
@@ -23099,7 +23741,53 @@ Still experimental, may disappear in the furture."
23099 ;; make tree, check each match with the callback 23741 ;; make tree, check each match with the callback
23100 (org-occur "CLOSED: +\\[\\(.*?\\)\\]" nil callback))) 23742 (org-occur "CLOSED: +\\[\\(.*?\\)\\]" nil callback)))
23101 23743
23744(defun org-fill-paragraph-experimental (&optional justify)
23745 "Re-align a table, pass through to fill-paragraph if no table."
23746 (let ((table-p (org-at-table-p))
23747 (table.el-p (org-at-table.el-p)))
23748 (cond ((equal (char-after (point-at-bol)) ?*) t) ; skip headlines
23749 (table.el-p t) ; skip table.el tables
23750 (table-p (org-table-align) t) ; align org-mode tables
23751 ((save-excursion
23752 (let ((pos (1+ (point-at-eol))))
23753 (backward-paragraph 1)
23754 (re-search-forward "\\\\\\\\[ \t]*$" pos t)))
23755 (save-excursion
23756 (save-restriction
23757 (narrow-to-region (1+ (match-end 0)) (point-max))
23758 (fill-paragraph nil)
23759 t)))
23760 (t nil)))) ; call paragraph-fill
23761
23762(defun org-property-previous-allowed-value (&optional previous)
23763 "Switch to the next allowed value for this property."
23764 (interactive)
23765 (org-property-next-allowed-value t))
23102 23766
23767(defun org-property-next-allowed-value (&optional previous)
23768 "Switch to the next allowed value for this property."
23769 (interactive)
23770 (unless (org-at-property-p)
23771 (error "Not at a property"))
23772 (let* ((key (match-string 2))
23773 (value (match-string 3))
23774 (allowed (or (org-property-get-allowed-values (point) key)
23775 (and (member value '("[ ]" "[-]" "[X]"))
23776 '("[ ]" "[X]"))))
23777 nval)
23778 (unless allowed
23779 (error "Allowed values for this property have not been defined"))
23780 (if previous (setq allowed (reverse allowed)))
23781 (if (member value allowed)
23782 (setq nval (car (cdr (member value allowed)))))
23783 (setq nval (or nval (car allowed)))
23784 (if (equal nval value)
23785 (error "Only one allowed value for this property"))
23786 (org-at-property-p)
23787 (replace-match (concat " :" key ": " nval))
23788 (org-indent-line-function)
23789 (beginning-of-line 1)
23790 (skip-chars-forward " \t")))
23103 23791
23104;;;; Finish up 23792;;;; Finish up
23105 23793
@@ -23109,3 +23797,4 @@ Still experimental, may disappear in the furture."
23109 23797
23110;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd 23798;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd
23111;;; org.el ends here 23799;;; org.el ends here
23800
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 5757100468b..034caeee702 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -243,6 +243,21 @@ Normally set to either `plain-tex-mode' or `latex-mode'."
243 :options '("''" "\">" "\"'" ">>" "»") 243 :options '("''" "\">" "\"'" ">>" "»")
244 :group 'tex) 244 :group 'tex)
245 245
246(defcustom tex-fontify-script t
247 "If non-nil, fontify subscript and superscript strings."
248 :type 'boolean
249 :group 'tex)
250(put 'tex-fontify-script 'safe-local-variable 'booleanp)
251
252(defcustom tex-font-script-display '(-0.3 . 0.3)
253 "Display specification for subscript and superscript content.
254The car is used for subscript, the cdr is used for superscripts."
255 :group 'tex
256 :type '(cons (choice (float :tag "Subscript")
257 (const :tag "No lowering" nil))
258 (choice (float :tag "Superscript")
259 (const :tag "No raising" nil))))
260
246(defvar tex-last-temp-file nil 261(defvar tex-last-temp-file nil
247 "Latest temporary file generated by \\[tex-region] and \\[tex-buffer]. 262 "Latest temporary file generated by \\[tex-region] and \\[tex-buffer].
248Deleted when the \\[tex-region] or \\[tex-buffer] is next run, or when the 263Deleted when the \\[tex-region] or \\[tex-buffer] is next run, or when the
@@ -593,13 +608,14 @@ An alternative value is \" . \", if you use a font with a narrow period."
593 (setq pos (1- pos) odd (not odd))) 608 (setq pos (1- pos) odd (not odd)))
594 odd)) 609 odd))
595 (if (eq (char-after pos) ?_) 610 (if (eq (char-after pos) ?_)
596 '(face subscript display (raise -0.3)) 611 `(face subscript display (raise ,(car tex-font-script-display)))
597 '(face superscript display (raise +0.3))))) 612 `(face superscript display (raise ,(cdr tex-font-script-display))))))
598 613
599(defun tex-font-lock-match-suscript (limit) 614(defun tex-font-lock-match-suscript (limit)
600 "Match subscript and superscript patterns up to LIMIT." 615 "Match subscript and superscript patterns up to LIMIT."
601 (when (re-search-forward "[_^] *\\([^\n\\{}]\\|\ 616 (when (and tex-fontify-script
602\\\\\\([a-zA-Z@]+\\|[^ \t\n]\\)\\|\\({\\)\\)" limit t) 617 (re-search-forward "[_^] *\\([^\n\\{}]\\|\
618\\\\\\([a-zA-Z@]+\\|[^ \t\n]\\)\\|\\({\\)\\)" limit t))
603 (when (match-end 3) 619 (when (match-end 3)
604 (let ((beg (match-beginning 3)) 620 (let ((beg (match-beginning 3))
605 (end (save-restriction 621 (end (save-restriction
diff --git a/lisp/vc-arch.el b/lisp/vc-arch.el
index e4c13d3039a..c6aaa6c8c0b 100644
--- a/lisp/vc-arch.el
+++ b/lisp/vc-arch.el
@@ -424,13 +424,6 @@ Return non-nil if FILE is unchanged."
424 424
425;;; Completion of versions and revisions. 425;;; Completion of versions and revisions.
426 426
427(defun vc-arch-complete (table string pred action)
428 (assert (not (functionp table)))
429 (cond
430 ((null action) (try-completion string table pred))
431 ((eq action t) (all-completions string table pred))
432 (t (test-completion string table pred))))
433
434(defun vc-arch--version-completion-table (root string) 427(defun vc-arch--version-completion-table (root string)
435 (delq nil 428 (delq nil
436 (mapcar 429 (mapcar
@@ -450,10 +443,9 @@ Return non-nil if FILE is unchanged."
450 (lexical-let ((file file)) 443 (lexical-let ((file file))
451 (lambda (string pred action) 444 (lambda (string pred action)
452 ;; FIXME: complete revision patches as well. 445 ;; FIXME: complete revision patches as well.
453 (let ((root (expand-file-name "{arch}" (vc-arch-root file)))) 446 (let* ((root (expand-file-name "{arch}" (vc-arch-root file)))
454 (vc-arch-complete 447 (table (vc-arch--version-completion-table root string)))
455 (vc-arch--version-completion-table root string) 448 (complete-with-action action table string pred)))))
456 string pred action)))))
457 449
458;;; Trimming revision libraries. 450;;; Trimming revision libraries.
459 451
diff --git a/lisp/vc-cvs.el b/lisp/vc-cvs.el
index 583e02efd5d..22ed10d1286 100644
--- a/lisp/vc-cvs.el
+++ b/lisp/vc-cvs.el
@@ -29,8 +29,11 @@
29 29
30;;; Code: 30;;; Code:
31 31
32(eval-when-compile 32(eval-when-compile (require 'cl) (require 'vc))
33 (require 'vc)) 33
34;; Clear up the cache to force vc-call to check again and discover
35;; new functions when we reload this file.
36(put 'CVS 'vc-functions nil)
34 37
35;;; 38;;;
36;;; Customization options 39;;; Customization options
@@ -368,99 +371,45 @@ its parents."
368 "-p" 371 "-p"
369 (vc-switches 'CVS 'checkout))) 372 (vc-switches 'CVS 'checkout)))
370 373
371(defun vc-cvs-checkout (file &optional editable rev workfile) 374(defun vc-cvs-checkout (file &optional editable rev)
372 "Retrieve a revision of FILE into a WORKFILE. 375 "Checkout a revision of FILE into the working area.
373EDITABLE non-nil means that the file should be writable. 376EDITABLE non-nil means that the file should be writable.
374REV is the revision to check out into WORKFILE." 377REV is the revision to check out."
375 (let ((filename (or workfile file)) 378 (message "Checking out %s..." file)
376 (file-buffer (get-file-buffer file)) 379 ;; Change buffers to get local value of vc-checkout-switches.
377 switches) 380 (with-current-buffer (or (get-file-buffer file) (current-buffer))
378 (message "Checking out %s..." filename) 381 (if (and (file-exists-p file) (not rev))
379 (save-excursion 382 ;; If no revision was specified, just make the file writable
380 ;; Change buffers to get local value of vc-checkout-switches. 383 ;; if necessary (using `cvs-edit' if requested).
381 (if file-buffer (set-buffer file-buffer)) 384 (and editable (not (eq (vc-cvs-checkout-model file) 'implicit))
382 (setq switches (vc-switches 'CVS 'checkout)) 385 (if vc-cvs-use-edit
383 ;; Save this buffer's default-directory 386 (vc-cvs-command nil 0 file "edit")
384 ;; and use save-excursion to make sure it is restored 387 (set-file-modes file (logior (file-modes file) 128))
385 ;; in the same buffer it was saved in. 388 (if (equal file buffer-file-name) (toggle-read-only -1))))
386 (let ((default-directory default-directory)) 389 ;; Check out a particular version (or recreate the file).
387 (save-excursion 390 (vc-file-setprop file 'vc-workfile-version nil)
388 ;; Adjust the default-directory so that the check-out creates 391 (apply 'vc-cvs-command nil 0 file
389 ;; the file in the right place. 392 (and editable "-w")
390 (setq default-directory (file-name-directory filename)) 393 "update"
391 (if workfile 394 (when rev
392 (let ((failed t) 395 (unless (eq rev t)
393 (backup-name (if (string= file workfile) 396 ;; default for verbose checkout: clear the
394 (car (find-backup-file-name filename))))) 397 ;; sticky tag so that the actual update will
395 (when backup-name 398 ;; get the head of the trunk
396 (copy-file filename backup-name 399 (if (string= rev "")
397 'ok-if-already-exists 'keep-date) 400 "-A"
398 (unless (file-writable-p filename) 401 (concat "-r" rev))))
399 (set-file-modes filename 402 (vc-switches 'CVS 'checkout)))
400 (logior (file-modes filename) 128)))) 403 (vc-mode-line file))
401 (unwind-protect 404 (message "Checking out %s...done" file))
402 (progn
403 (let ((coding-system-for-read 'no-conversion)
404 (coding-system-for-write 'no-conversion))
405 (with-temp-file filename
406 (apply 'vc-cvs-command
407 (current-buffer) 0 file
408 "-Q" ; suppress diagnostic output
409 "update"
410 (and (stringp rev)
411 (not (string= rev ""))
412 (concat "-r" rev))
413 "-p"
414 switches)))
415 (setq failed nil))
416 (if failed
417 (if backup-name
418 (rename-file backup-name filename
419 'ok-if-already-exists)
420 (if (file-exists-p filename)
421 (delete-file filename)))
422 (and backup-name
423 (not vc-make-backup-files)
424 (delete-file backup-name)))))
425 (if (and (file-exists-p file) (not rev))
426 ;; If no revision was specified, just make the file writable
427 ;; if necessary (using `cvs-edit' if requested).
428 (and editable (not (eq (vc-cvs-checkout-model file) 'implicit))
429 (if vc-cvs-use-edit
430 (vc-cvs-command nil 0 file "edit")
431 (set-file-modes file (logior (file-modes file) 128))
432 (if file-buffer (toggle-read-only -1))))
433 ;; Check out a particular version (or recreate the file).
434 (vc-file-setprop file 'vc-workfile-version nil)
435 (apply 'vc-cvs-command nil 0 file
436 (and editable
437 (or (not (file-exists-p file))
438 (not (eq (vc-cvs-checkout-model file)
439 'implicit)))
440 "-w")
441 "update"
442 (when rev
443 (unless (eq rev t)
444 ;; default for verbose checkout: clear the
445 ;; sticky tag so that the actual update will
446 ;; get the head of the trunk
447 (if (string= rev "")
448 "-A"
449 (concat "-r" rev))))
450 switches))))
451 (vc-mode-line file)
452 (message "Checking out %s...done" filename)))))
453 405
454(defun vc-cvs-delete-file (file) 406(defun vc-cvs-delete-file (file)
455 (vc-cvs-command nil 0 file "remove" "-f") 407 (vc-cvs-command nil 0 file "remove" "-f")
456 (vc-cvs-command nil 0 file "commit" "-mRemoved.")) 408 (vc-cvs-command nil 0 file "commit" "-mRemoved."))
457 409
458(defun vc-cvs-revert (file &optional contents-done) 410(defun vc-cvs-revert (file &optional contents-done)
459 "Revert FILE to the version it was based on." 411 "Revert FILE to the version on which it was based."
460 (unless contents-done 412 (vc-default-revert 'CVS file contents-done)
461 ;; Check out via standard output (caused by the final argument
462 ;; FILE below), so that no sticky tag is set.
463 (vc-cvs-checkout file nil (vc-workfile-version file) file))
464 (unless (eq (vc-checkout-model file) 'implicit) 413 (unless (eq (vc-checkout-model file) 'implicit)
465 (if vc-cvs-use-edit 414 (if vc-cvs-use-edit
466 (vc-cvs-command nil 0 file "unedit") 415 (vc-cvs-command nil 0 file "unedit")
@@ -588,14 +537,36 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
588 (and rev2 (concat "-r" rev2)) 537 (and rev2 (concat "-r" rev2))
589 (vc-switches 'CVS 'diff)))))) 538 (vc-switches 'CVS 'diff))))))
590 539
540(defconst vc-cvs-annotate-first-line-re "^[0-9]")
541
542(defun vc-cvs-annotate-process-filter (process string)
543 (setq string (concat (process-get process 'output) string))
544 (if (not (string-match vc-cvs-annotate-first-line-re string))
545 ;; Still waiting for the first real line.
546 (process-put process 'output string)
547 (let ((vc-filter (process-get process 'vc-filter)))
548 (set-process-filter process vc-filter)
549 (funcall vc-filter process (substring string (match-beginning 0))))))
550
591(defun vc-cvs-annotate-command (file buffer &optional version) 551(defun vc-cvs-annotate-command (file buffer &optional version)
592 "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER. 552 "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER.
593Optional arg VERSION is a version to annotate from." 553Optional arg VERSION is a version to annotate from."
594 (vc-cvs-command buffer 0 file "annotate" (if version (concat "-r" version))) 554 (vc-cvs-command buffer
595 (with-current-buffer buffer 555 (if (and (vc-stay-local-p file) (fboundp 'start-process))
596 (goto-char (point-min)) 556 'async 0)
597 (re-search-forward "^[0-9]") 557 file "annotate"
598 (delete-region (point-min) (1- (point))))) 558 (if version (concat "-r" version)))
559 ;; Strip the leading few lines.
560 (let ((proc (get-buffer-process buffer)))
561 (if proc
562 ;; If running asynchronously, use a process filter.
563 (progn
564 (process-put proc 'vc-filter (process-filter proc))
565 (set-process-filter proc 'vc-cvs-annotate-process-filter))
566 (with-current-buffer buffer
567 (goto-char (point-min))
568 (re-search-forward vc-cvs-annotate-first-line-re)
569 (delete-region (point-min) (1- (point)))))))
599 570
600(defun vc-cvs-annotate-current-time () 571(defun vc-cvs-annotate-current-time ()
601 "Return the current time, based at midnight of the current day, and 572 "Return the current time, based at midnight of the current day, and
@@ -960,7 +931,34 @@ is non-nil."
960 (vc-file-setprop file 'vc-checkout-time 0) 931 (vc-file-setprop file 'vc-checkout-time 0)
961 (if set-state (vc-file-setprop file 'vc-state 'edited))))))))) 932 (if set-state (vc-file-setprop file 'vc-state 'edited)))))))))
962 933
934;; Completion of revision names.
935;; Just so I don't feel like I'm duplicating code from pcl-cvs, I'll use
936;; `cvs log' so I can list all the revision numbers rather than only
937;; tag names.
938
939(defun vc-cvs-revision-table (file)
940 (let ((default-directory (file-name-directory file))
941 (res nil))
942 (with-temp-buffer
943 (vc-cvs-command t nil file "log")
944 (goto-char (point-min))
945 (when (re-search-forward "^symbolic names:\n" nil t)
946 (while (looking-at "^ \\(.*\\): \\(.*\\)")
947 (push (cons (match-string 1) (match-string 2)) res)
948 (forward-line 1)))
949 (while (re-search-forward "^revision \\([0-9.]+\\)" nil t)
950 (push (match-string 1) res))
951 res)))
952
953(defun vc-cvs-revision-completion-table (file)
954 (lexical-let ((file file)
955 table)
956 (setq table (lazy-completion-table
957 table (lambda () (vc-cvs-revision-table file))))
958 table))
959
960
963(provide 'vc-cvs) 961(provide 'vc-cvs)
964 962
965;;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432 963;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432
966;;; vc-cvs.el ends here 964;;; vc-cvs.el ends here
diff --git a/lisp/vc-hooks.el b/lisp/vc-hooks.el
index 89d271431fa..9fbf4db3160 100644
--- a/lisp/vc-hooks.el
+++ b/lisp/vc-hooks.el
@@ -62,9 +62,9 @@ interpreted as hostnames."
62 :type 'regexp 62 :type 'regexp
63 :group 'vc) 63 :group 'vc)
64 64
65(defcustom vc-handled-backends '(RCS CVS SVN SCCS HG Arch MCVS) 65(defcustom vc-handled-backends '(RCS CVS BZR SVN SCCS HG Arch MCVS)
66 ;; Arch and MCVS come last because they are per-tree rather than per-dir. 66 ;; Arch and MCVS come last because they are per-tree rather than per-dir.
67 "*List of version control backends for which VC will be used. 67 "List of version control backends for which VC will be used.
68Entries in this list will be tried in order to determine whether a 68Entries in this list will be tried in order to determine whether a
69file is under that sort of version control. 69file is under that sort of version control.
70Removing an entry from the list prevents VC from being activated 70Removing an entry from the list prevents VC from being activated
@@ -78,19 +78,19 @@ An empty list disables VC altogether."
78 (if (file-directory-p "/usr/sccs") 78 (if (file-directory-p "/usr/sccs")
79 '("/usr/sccs") 79 '("/usr/sccs")
80 nil) 80 nil)
81 "*List of extra directories to search for version control commands." 81 "List of extra directories to search for version control commands."
82 :type '(repeat directory) 82 :type '(repeat directory)
83 :group 'vc) 83 :group 'vc)
84 84
85(defcustom vc-make-backup-files nil 85(defcustom vc-make-backup-files nil
86 "*If non-nil, backups of registered files are made as with other files. 86 "If non-nil, backups of registered files are made as with other files.
87If nil (the default), files covered by version control don't get backups." 87If nil (the default), files covered by version control don't get backups."
88 :type 'boolean 88 :type 'boolean
89 :group 'vc 89 :group 'vc
90 :group 'backup) 90 :group 'backup)
91 91
92(defcustom vc-follow-symlinks 'ask 92(defcustom vc-follow-symlinks 'ask
93 "*What to do if visiting a symbolic link to a file under version control. 93 "What to do if visiting a symbolic link to a file under version control.
94Editing such a file through the link bypasses the version control system, 94Editing such a file through the link bypasses the version control system,
95which is dangerous and probably not what you want. 95which is dangerous and probably not what you want.
96 96
@@ -104,26 +104,26 @@ visited and a warning displayed."
104 :group 'vc) 104 :group 'vc)
105 105
106(defcustom vc-display-status t 106(defcustom vc-display-status t
107 "*If non-nil, display revision number and lock status in modeline. 107 "If non-nil, display revision number and lock status in modeline.
108Otherwise, not displayed." 108Otherwise, not displayed."
109 :type 'boolean 109 :type 'boolean
110 :group 'vc) 110 :group 'vc)
111 111
112 112
113(defcustom vc-consult-headers t 113(defcustom vc-consult-headers t
114 "*If non-nil, identify work files by searching for version headers." 114 "If non-nil, identify work files by searching for version headers."
115 :type 'boolean 115 :type 'boolean
116 :group 'vc) 116 :group 'vc)
117 117
118(defcustom vc-keep-workfiles t 118(defcustom vc-keep-workfiles t
119 "*If non-nil, don't delete working files after registering changes. 119 "If non-nil, don't delete working files after registering changes.
120If the back-end is CVS, workfiles are always kept, regardless of the 120If the back-end is CVS, workfiles are always kept, regardless of the
121value of this flag." 121value of this flag."
122 :type 'boolean 122 :type 'boolean
123 :group 'vc) 123 :group 'vc)
124 124
125(defcustom vc-mistrust-permissions nil 125(defcustom vc-mistrust-permissions nil
126 "*If non-nil, don't assume permissions/ownership track version-control status. 126 "If non-nil, don't assume permissions/ownership track version-control status.
127If nil, do rely on the permissions. 127If nil, do rely on the permissions.
128See also variable `vc-consult-headers'." 128See also variable `vc-consult-headers'."
129 :type 'boolean 129 :type 'boolean
@@ -137,7 +137,7 @@ See also variable `vc-consult-headers'."
137 (vc-backend-subdirectory-name file))))) 137 (vc-backend-subdirectory-name file)))))
138 138
139(defcustom vc-stay-local t 139(defcustom vc-stay-local t
140 "*Non-nil means use local operations when possible for remote repositories. 140 "Non-nil means use local operations when possible for remote repositories.
141This avoids slow queries over the network and instead uses heuristics 141This avoids slow queries over the network and instead uses heuristics
142and past information to determine the current status of a file. 142and past information to determine the current status of a file.
143 143
@@ -742,17 +742,27 @@ Format:
742This function assumes that the file is registered." 742This function assumes that the file is registered."
743 (setq backend (symbol-name backend)) 743 (setq backend (symbol-name backend))
744 (let ((state (vc-state file)) 744 (let ((state (vc-state file))
745 (state-echo nil)
745 (rev (vc-workfile-version file))) 746 (rev (vc-workfile-version file)))
746 (cond ((or (eq state 'up-to-date) 747 (propertize
747 (eq state 'needs-patch)) 748 (cond ((or (eq state 'up-to-date)
748 (concat backend "-" rev)) 749 (eq state 'needs-patch))
749 ((stringp state) 750 (setq state-echo "Up to date file")
750 (concat backend ":" state ":" rev)) 751 (concat backend "-" rev))
751 (t 752 ((stringp state)
752 ;; Not just for the 'edited state, but also a fallback 753 (setq state-echo (concat "File locked by" state))
753 ;; for all other states. Think about different symbols 754 (concat backend ":" state ":" rev))
754 ;; for 'needs-patch and 'needs-merge. 755 (t
755 (concat backend ":" rev))))) 756 ;; Not just for the 'edited state, but also a fallback
757 ;; for all other states. Think about different symbols
758 ;; for 'needs-patch and 'needs-merge.
759 (setq state-echo "Edited file")
760 (concat backend ":" rev)))
761 'mouse-face 'mode-line-highlight
762 'local-map (let ((map (make-sparse-keymap)))
763 (define-key map [mode-line down-mouse-1] 'vc-menu-map) map)
764 'help-echo (concat state-echo " under the " backend
765 " version control system\nmouse-1: VC Menu"))))
756 766
757(defun vc-follow-link () 767(defun vc-follow-link ()
758 "If current buffer visits a symbolic link, visit the real file. 768 "If current buffer visits a symbolic link, visit the real file.
@@ -783,7 +793,7 @@ current, and kill the buffer that visits the link."
783 (when buffer-file-name 793 (when buffer-file-name
784 (vc-file-clearprops buffer-file-name) 794 (vc-file-clearprops buffer-file-name)
785 (cond 795 (cond
786 ((vc-backend buffer-file-name) 796 ((with-demoted-errors (vc-backend buffer-file-name))
787 ;; Compute the state and put it in the modeline. 797 ;; Compute the state and put it in the modeline.
788 (vc-mode-line buffer-file-name) 798 (vc-mode-line buffer-file-name)
789 (unless vc-make-backup-files 799 (unless vc-make-backup-files
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index a660deccba0..8da11029d93 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -149,14 +149,19 @@ You should set this to t when using a non-system shell.\n\n"))))
149 (if default-enable-multibyte-characters 149 (if default-enable-multibyte-characters
150 '(undecided-dos . undecided-unix) 150 '(undecided-dos . undecided-unix)
151 '(raw-text-dos . raw-text-unix))) 151 '(raw-text-dos . raw-text-unix)))
152 (or (w32-using-nt) 152 ;; Make cmdproxy default to using DOS line endings for input,
153 ;; On Windows 9x, make cmdproxy default to using DOS line endings 153 ;; because some Windows programs (including command.com) require it.
154 ;; for input, because command.com requires this. 154 (add-to-list 'process-coding-system-alist
155 (setq process-coding-system-alist 155 `("[cC][mM][dD][pP][rR][oO][xX][yY]"
156 `(("[cC][mM][dD][pP][rR][oO][xX][yY]" 156 . ,(if default-enable-multibyte-characters
157 . ,(if default-enable-multibyte-characters 157 '(undecided-dos . undecided-dos)
158 '(undecided-dos . undecided-dos) 158 '(raw-text-dos . raw-text-dos))))
159 '(raw-text-dos . raw-text-dos))))))) 159 ;; plink needs DOS input when entering the password.
160 (add-to-list 'process-coding-system-alist
161 `("[pP][lL][iI][nN][kK]"
162 . ,(if default-enable-multibyte-characters
163 '(undecided-dos . undecided-dos)
164 '(raw-text-dos . raw-text-dos)))))
160 165
161(add-hook 'before-init-hook 'set-default-process-coding-system) 166(add-hook 'before-init-hook 'set-default-process-coding-system)
162 167
diff --git a/lisp/window.el b/lisp/window.el
index 921d84d6e7d..216e89249c6 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -645,10 +645,7 @@ header-line."
645 ;; desired-height lines, constrained by MIN-HEIGHT and MAX-HEIGHT. 645 ;; desired-height lines, constrained by MIN-HEIGHT and MAX-HEIGHT.
646 (- (max (min desired-height max-height) 646 (- (max (min desired-height max-height)
647 (or min-height window-min-height)) 647 (or min-height window-min-height))
648 window-height)) 648 window-height)))
649 ;; We do our own height checking, so avoid any restrictions due to
650 ;; window-min-height.
651 (window-min-height 1))
652 649
653 ;; Don't try to redisplay with the cursor at the end 650 ;; Don't try to redisplay with the cursor at the end
654 ;; on its own line--that would force a scroll and spoil things. 651 ;; on its own line--that would force a scroll and spoil things.