Mercurial > emacs
comparison lisp/net/tramp-gvfs.el @ 103526:1d519ed4c0f4
* net/tramp-gvfs.el: New package.
author | Michael Albinus <michael.albinus@gmx.de> |
---|---|
date | Mon, 22 Jun 2009 21:04:49 +0000 |
parents | |
children | 84379ac80754 |
comparison
equal
deleted
inserted
replaced
103525:740a47edc100 | 103526:1d519ed4c0f4 |
---|---|
1 ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon | |
2 | |
3 ;; Copyright (C) 2009 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Michael Albinus <michael.albinus@gmx.de> | |
6 ;; Keywords: comm, processes | |
7 | |
8 ;; This file is free software: you can redistribute it and/or modify | |
9 ;; it under the terms of the GNU General Public License as published by | |
10 ;; the Free Software Foundation, either version 3 of the License, or | |
11 ;; (at your option) any later version. | |
12 | |
13 ;; This file is distributed in the hope that it will be useful, but | |
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
16 ;; General Public License for more details. | |
17 | |
18 ;; You should have received a copy of the GNU General Public License | |
19 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
20 | |
21 ;;; Commentary: | |
22 | |
23 ;; Access functions for the GVFS daemon from Tramp. Tested with GVFS | |
24 ;; 1.0.2 (Ubuntu 8.10, Gnome 2.24). | |
25 | |
26 ;; All actions to mount a remote location, and to retrieve mount | |
27 ;; information, are performed by D-Bus messages. File operations | |
28 ;; themselves are performed via the mounted filesystem in ~/.gvfs. | |
29 ;; Consequently, GNU Emacs 23.0.90 with enabled D-Bus bindings is a | |
30 ;; precondition. | |
31 | |
32 ;; The GVFS D-Bus interface is said to be instable. There are even no | |
33 ;; introspection data. The interface, as discovered during | |
34 ;; development time, is given in respective comments. | |
35 | |
36 ;; The customer option `tramp-gvfs-methods' contains the list of | |
37 ;; supported connection methods. Per default, these are "dav", "davs" | |
38 ;; and "obex". Note that with "obex" it might be necessary to pair | |
39 ;; with the other bluetooth device, if it hasn't been done already. | |
40 ;; There might be also some few seconds delay in discovering available | |
41 ;; bluetooth devices. | |
42 | |
43 ;; Other possible connection methods are "ftp", "sftp" and "smb". | |
44 ;; When one of these methods is added to the list, the remote access | |
45 ;; for that method is performed via GVFS instead of the native Tramp | |
46 ;; implementation. | |
47 | |
48 ;; GVFS offers even more connection methods. The complete list of | |
49 ;; connection methods of the actual GVFS implementation can be | |
50 ;; retrieved by: | |
51 ;; | |
52 ;; (message | |
53 ;; "%s" | |
54 ;; (mapcar | |
55 ;; 'car | |
56 ;; (dbus-call-method | |
57 ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker | |
58 ;; tramp-gvfs-interface-mounttracker "listMountableInfo"))) | |
59 | |
60 ;; Note that all other connection methods are not tested, beside the | |
61 ;; ones offered for customization in `tramp-gvfs-methods'. If you | |
62 ;; request an additional connection method to be supported, please | |
63 ;; drop me a note. | |
64 | |
65 ;; For hostname completion, information is retrieved either from the | |
66 ;; bluez daemon (for the "obex" method), or from the zeroconf daemon | |
67 ;; (for the "dav", "davs", and "sftp" methods). The zeroconf daemon | |
68 ;; is pre-configured to discover services in the "local" domain. If | |
69 ;; another domain shall be used for discovering services, the customer | |
70 ;; option `tramp-gvfs-zeroconf-domain' can be set accordingly. | |
71 | |
72 ;; Restrictions: | |
73 | |
74 ;; * The current GVFS implementation does not allow to write on the | |
75 ;; remote bluetooth device via OBEX. | |
76 ;; | |
77 ;; * Two shares of the same SMB server cannot be mounted in parallel. | |
78 | |
79 ;;; Code: | |
80 | |
81 ;; D-Bus support in the Emacs core can be disabled with configuration | |
82 ;; option "--without-dbus". Declare used subroutines and variables. | |
83 (declare-function dbus-call-method "dbusbind.c") | |
84 (declare-function dbus-call-method-asynchronously "dbusbind.c") | |
85 (declare-function dbus-get-unique-name "dbusbind.c") | |
86 (declare-function dbus-register-method "dbusbind.c") | |
87 (declare-function dbus-register-signal "dbusbind.c") | |
88 | |
89 ;; Pacify byte-compiler | |
90 (eval-when-compile | |
91 (require 'cl) | |
92 (require 'custom)) | |
93 | |
94 (require 'tramp) | |
95 (require 'dbus) | |
96 (require 'url-parse) | |
97 (require 'zeroconf) | |
98 | |
99 (defcustom tramp-gvfs-methods '("dav" "davs" "obex") | |
100 "*List of methods for remote files, accessed with GVFS." | |
101 :group 'tramp | |
102 :type '(repeat (choice (const "dav") | |
103 (const "davs") | |
104 (const "ftp") | |
105 (const "obex") | |
106 (const "sftp") | |
107 (const "smb")))) | |
108 | |
109 (defcustom tramp-gvfs-zeroconf-domain "local" | |
110 "*Zeroconf domain to be used for discovering services, like host names." | |
111 :group 'tramp | |
112 :type 'string) | |
113 | |
114 ;; Add the methods to `tramp-methods', in order to allow minibuffer | |
115 ;; completion. | |
116 (eval-after-load "tramp-gvfs" | |
117 '(when (featurep 'tramp-gvfs) | |
118 (dolist (elt tramp-gvfs-methods) | |
119 (unless (assoc elt tramp-methods) | |
120 (add-to-list 'tramp-methods (cons elt nil)))))) | |
121 | |
122 (defconst tramp-gvfs-mount-point | |
123 (file-name-as-directory (expand-file-name ".gvfs" "~/")) | |
124 "The directory name, fuses mounts remote ressources.") | |
125 | |
126 (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") | |
127 "The preceeding object path for own objects.") | |
128 | |
129 (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" | |
130 "The well known name of the GVFS daemon.") | |
131 | |
132 ;; Check that GVFS is available. | |
133 (unless (dbus-ping :session tramp-gvfs-service-daemon) | |
134 (message "GVFS daemon not running") | |
135 (throw 'tramp-loading nil)) | |
136 | |
137 (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" | |
138 "The object path of the GVFS daemon.") | |
139 | |
140 (defconst tramp-gvfs-interface-mounttracker "org.gtk.vfs.MountTracker" | |
141 "The mount tracking interface in the GVFS daemon.") | |
142 | |
143 ;; <interface name='org.gtk.vfs.MountTracker'> | |
144 ;; <method name='listMounts'> | |
145 ;; <arg name='mount_info_list' | |
146 ;; type='a{sosssssbay{aya{say}}}' | |
147 ;; direction='out'/> | |
148 ;; </method> | |
149 ;; <method name='mountLocation'> | |
150 ;; <arg name='mount_spec' type='{aya{say}}' direction='in'/> | |
151 ;; <arg name='dbus_id' type='s' direction='in'/> | |
152 ;; <arg name='object_path' type='o' direction='in'/> | |
153 ;; </method> | |
154 ;; <signal name='mounted'> | |
155 ;; <arg name='mount_info' | |
156 ;; type='{sosssssbay{aya{say}}}'/> | |
157 ;; </signal> | |
158 ;; <signal name='unmounted'> | |
159 ;; <arg name='mount_info' | |
160 ;; type='{sosssssbay{aya{say}}}'/> | |
161 ;; </signal> | |
162 ;; </interface> | |
163 ;; | |
164 ;; STRUCT mount_info | |
165 ;; STRING dbus_id | |
166 ;; OBJECT_PATH object_path | |
167 ;; STRING display_name | |
168 ;; STRING stable_name | |
169 ;; STRING x_content_types | |
170 ;; STRING icon | |
171 ;; STRING prefered_filename_encoding | |
172 ;; BOOLEAN user_visible | |
173 ;; ARRAY BYTE fuse_mountpoint | |
174 ;; STRUCT mount_spec | |
175 ;; ARRAY BYTE mount_prefix | |
176 ;; ARRAY | |
177 ;; STRUCT mount_spec_item | |
178 ;; STRING key (server, share, type, user, host, port) | |
179 ;; ARRAY BYTE value | |
180 | |
181 (defconst tramp-gvfs-interface-mountoperation "org.gtk.vfs.MountOperation" | |
182 "Used by the dbus-proxying implementation of GMountOperation.") | |
183 | |
184 ;; <interface name='org.gtk.vfs.MountOperation'> | |
185 ;; <method name='askPassword'> | |
186 ;; <arg name='message' type='s' direction='in'/> | |
187 ;; <arg name='default_user' type='s' direction='in'/> | |
188 ;; <arg name='default_domain' type='s' direction='in'/> | |
189 ;; <arg name='flags' type='u' direction='in'/> | |
190 ;; <arg name='handled' type='b' direction='out'/> | |
191 ;; <arg name='aborted' type='b' direction='out'/> | |
192 ;; <arg name='password' type='s' direction='out'/> | |
193 ;; <arg name='username' type='s' direction='out'/> | |
194 ;; <arg name='domain' type='s' direction='out'/> | |
195 ;; <arg name='anonymous' type='b' direction='out'/> | |
196 ;; <arg name='password_save' type='u' direction='out'/> | |
197 ;; </method> | |
198 ;; <method name='askQuestion'> | |
199 ;; <arg name='message' type='s' direction='in'/> | |
200 ;; <arg name='choices' type='as' direction='in'/> | |
201 ;; <arg name='handled' type='b' direction='out'/> | |
202 ;; <arg name='aborted' type='b' direction='out'/> | |
203 ;; <arg name='choice' type='u' direction='out'/> | |
204 ;; </method> | |
205 ;; </interface> | |
206 | |
207 ;; The following flags are used in "askPassword". They are defined in | |
208 ;; /usr/include/glib-2.0/gio/gioenums.h. | |
209 | |
210 (defconst tramp-gvfs-password-need-password 1 | |
211 "Operation requires a password.") | |
212 | |
213 (defconst tramp-gvfs-password-need-username 2 | |
214 "Operation requires a username.") | |
215 | |
216 (defconst tramp-gvfs-password-need-domain 4 | |
217 "Operation requires a domain.") | |
218 | |
219 (defconst tramp-gvfs-password-saving-supported 8 | |
220 "Operation supports saving settings.") | |
221 | |
222 (defconst tramp-gvfs-password-anonymous-supported 16 | |
223 "Operation supports anonymous users.") | |
224 | |
225 (defconst tramp-bluez-service "org.bluez" | |
226 "The well known name of the BLUEZ service.") | |
227 | |
228 (defconst tramp-bluez-interface-manager "org.bluez.Manager" | |
229 "The manager interface of the BLUEZ daemon.") | |
230 | |
231 ;; <interface name='org.bluez.Manager'> | |
232 ;; <method name='DefaultAdapter'> | |
233 ;; <arg type='o' direction='out'/> | |
234 ;; </method> | |
235 ;; <method name='FindAdapter'> | |
236 ;; <arg type='s' direction='in'/> | |
237 ;; <arg type='o' direction='out'/> | |
238 ;; </method> | |
239 ;; <method name='ListAdapters'> | |
240 ;; <arg type='ao' direction='out'/> | |
241 ;; </method> | |
242 ;; <signal name='AdapterAdded'> | |
243 ;; <arg type='o'/> | |
244 ;; </signal> | |
245 ;; <signal name='AdapterRemoved'> | |
246 ;; <arg type='o'/> | |
247 ;; </signal> | |
248 ;; <signal name='DefaultAdapterChanged'> | |
249 ;; <arg type='o'/> | |
250 ;; </signal> | |
251 ;; </interface> | |
252 | |
253 (defconst tramp-bluez-interface-adapter "org.bluez.Adapter" | |
254 "The adapter interface of the BLUEZ daemon.") | |
255 | |
256 ;; <interface name='org.bluez.Adapter'> | |
257 ;; <method name='GetProperties'> | |
258 ;; <arg type='a{sv}' direction='out'/> | |
259 ;; </method> | |
260 ;; <method name='SetProperty'> | |
261 ;; <arg type='s' direction='in'/> | |
262 ;; <arg type='v' direction='in'/> | |
263 ;; </method> | |
264 ;; <method name='RequestMode'> | |
265 ;; <arg type='s' direction='in'/> | |
266 ;; </method> | |
267 ;; <method name='ReleaseMode'/> | |
268 ;; <method name='RequestSession'/> | |
269 ;; <method name='ReleaseSession'/> | |
270 ;; <method name='StartDiscovery'/> | |
271 ;; <method name='StopDiscovery'/> | |
272 ;; <method name='ListDevices'> | |
273 ;; <arg type='ao' direction='out'/> | |
274 ;; </method> | |
275 ;; <method name='CreateDevice'> | |
276 ;; <arg type='s' direction='in'/> | |
277 ;; <arg type='o' direction='out'/> | |
278 ;; </method> | |
279 ;; <method name='CreatePairedDevice'> | |
280 ;; <arg type='s' direction='in'/> | |
281 ;; <arg type='o' direction='in'/> | |
282 ;; <arg type='s' direction='in'/> | |
283 ;; <arg type='o' direction='out'/> | |
284 ;; </method> | |
285 ;; <method name='CancelDeviceCreation'> | |
286 ;; <arg type='s' direction='in'/> | |
287 ;; </method> | |
288 ;; <method name='RemoveDevice'> | |
289 ;; <arg type='o' direction='in'/> | |
290 ;; </method> | |
291 ;; <method name='FindDevice'> | |
292 ;; <arg type='s' direction='in'/> | |
293 ;; <arg type='o' direction='out'/> | |
294 ;; </method> | |
295 ;; <method name='RegisterAgent'> | |
296 ;; <arg type='o' direction='in'/> | |
297 ;; <arg type='s' direction='in'/> | |
298 ;; </method> | |
299 ;; <method name='UnregisterAgent'> | |
300 ;; <arg type='o' direction='in'/> | |
301 ;; </method> | |
302 ;; <signal name='DeviceCreated'> | |
303 ;; <arg type='o'/> | |
304 ;; </signal> | |
305 ;; <signal name='DeviceRemoved'> | |
306 ;; <arg type='o'/> | |
307 ;; </signal> | |
308 ;; <signal name='DeviceFound'> | |
309 ;; <arg type='s'/> | |
310 ;; <arg type='a{sv}'/> | |
311 ;; </signal> | |
312 ;; <signal name='PropertyChanged'> | |
313 ;; <arg type='s'/> | |
314 ;; <arg type='v'/> | |
315 ;; </signal> | |
316 ;; <signal name='DeviceDisappeared'> | |
317 ;; <arg type='s'/> | |
318 ;; </signal> | |
319 ;; </interface> | |
320 | |
321 (defcustom tramp-bluez-discover-devices-timeout 60 | |
322 "Defines seconds since last bluetooth device discovery before rescanning. | |
323 A value of 0 would require an immediate discovery during hostname | |
324 completion, nil means to use always cached values for discovered | |
325 devices." | |
326 :group 'tramp | |
327 :type '(choice (const nil) integer)) | |
328 | |
329 (defvar tramp-bluez-discovery nil | |
330 "Indicator for a running bluetooth device discovery. | |
331 It keeps the timestamp of last discovery.") | |
332 | |
333 (defvar tramp-bluez-devices nil | |
334 "Alist of detected bluetooth devices. | |
335 Every entry is a list (NAME ADDRESS).") | |
336 | |
337 ;; New handlers should be added here. | |
338 (defconst tramp-gvfs-file-name-handler-alist | |
339 '( | |
340 (access-file . ignore) | |
341 (add-name-to-file . tramp-gvfs-handle-copy-file) | |
342 ;; `byte-compiler-base-file-name' performed by default handler | |
343 (copy-file . tramp-gvfs-handle-copy-file) | |
344 (delete-directory . tramp-gvfs-handle-delete-directory) | |
345 (delete-file . tramp-gvfs-handle-delete-file) | |
346 ;; `diff-latest-backup-file' performed by default handler | |
347 (directory-file-name . tramp-handle-directory-file-name) | |
348 (directory-files . tramp-gvfs-handle-directory-files) | |
349 (directory-files-and-attributes | |
350 . tramp-gvfs-handle-directory-files-and-attributes) | |
351 (dired-call-process . ignore) | |
352 (dired-compress-file . ignore) | |
353 (dired-uncache . tramp-handle-dired-uncache) | |
354 (expand-file-name . tramp-gvfs-handle-expand-file-name) | |
355 ;; `file-accessible-directory-p' performed by default handler | |
356 (file-attributes . tramp-gvfs-handle-file-attributes) | |
357 (file-directory-p . tramp-smb-handle-file-directory-p) | |
358 (file-executable-p . tramp-gvfs-handle-file-executable-p) | |
359 (file-exists-p . tramp-gvfs-handle-file-exists-p) | |
360 (file-local-copy . tramp-gvfs-handle-file-local-copy) | |
361 (file-remote-p . tramp-handle-file-remote-p) | |
362 ;; `file-modes' performed by default handler | |
363 (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) | |
364 (file-name-as-directory . tramp-handle-file-name-as-directory) | |
365 (file-name-completion . tramp-handle-file-name-completion) | |
366 (file-name-directory . tramp-handle-file-name-directory) | |
367 (file-name-nondirectory . tramp-handle-file-name-nondirectory) | |
368 ;; `file-name-sans-versions' performed by default handler | |
369 (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) | |
370 (file-ownership-preserved-p . ignore) | |
371 (file-readable-p . tramp-gvfs-handle-file-readable-p) | |
372 (file-regular-p . tramp-handle-file-regular-p) | |
373 (file-symlink-p . tramp-handle-file-symlink-p) | |
374 ;; `file-truename' performed by default handler | |
375 (file-writable-p . tramp-gvfs-handle-file-writable-p) | |
376 (find-backup-file-name . tramp-handle-find-backup-file-name) | |
377 ;; `find-file-noselect' performed by default handler | |
378 ;; `get-file-buffer' performed by default handler | |
379 (insert-directory . tramp-gvfs-handle-insert-directory) | |
380 (insert-file-contents . tramp-gvfs-handle-insert-file-contents) | |
381 (load . tramp-handle-load) | |
382 (make-directory . tramp-gvfs-handle-make-directory) | |
383 (make-directory-internal . ignore) | |
384 (make-symbolic-link . ignore) | |
385 (rename-file . tramp-gvfs-handle-rename-file) | |
386 (set-file-modes . tramp-gvfs-handle-set-file-modes) | |
387 (set-visited-file-modtime . tramp-gvfs-handle-set-visited-file-modtime) | |
388 (shell-command . ignore) | |
389 (substitute-in-file-name . tramp-handle-substitute-in-file-name) | |
390 (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) | |
391 (vc-registered . ignore) | |
392 (verify-visited-file-modtime | |
393 . tramp-gvfs-handle-verify-visited-file-modtime) | |
394 (write-region . tramp-gvfs-handle-write-region) | |
395 ) | |
396 "Alist of handler functions for Tramp GVFS method. | |
397 Operations not mentioned here will be handled by the default Emacs primitives.") | |
398 | |
399 (defun tramp-gvfs-file-name-p (filename) | |
400 "Check if it's a filename handled by the GVFS daemon." | |
401 (and (tramp-tramp-file-p filename) | |
402 (let ((method | |
403 (tramp-file-name-method (tramp-dissect-file-name filename)))) | |
404 (and (stringp method) (member method tramp-gvfs-methods))))) | |
405 | |
406 (defun tramp-gvfs-file-name-handler (operation &rest args) | |
407 "Invoke the GVFS related OPERATION. | |
408 First arg specifies the OPERATION, second arg is a list of arguments to | |
409 pass to the OPERATION." | |
410 (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) | |
411 (if fn | |
412 (save-match-data (apply (cdr fn) args)) | |
413 (tramp-run-real-handler operation args)))) | |
414 | |
415 ;; This might be moved to tramp.el. It shall be the first file name | |
416 ;; handler. | |
417 (add-to-list 'tramp-foreign-file-name-handler-alist | |
418 (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) | |
419 | |
420 (defmacro with-tramp-dbus-call-method | |
421 (vec synchronous bus service path interface method &rest args) | |
422 "Apply a D-Bus call on bus BUS. | |
423 | |
424 If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, | |
425 it is an asynchronous call, with `ignore' as callback function. | |
426 | |
427 The other arguments have the same meaning as with `dbus-call-method' | |
428 or `dbus-call-method-asynchronously'. Additionally, the call | |
429 will be traced by Tramp with trace level 6." | |
430 `(let ((func (if ,synchronous | |
431 'dbus-call-method 'dbus-call-method-asynchronously)) | |
432 (args (append (list ,bus ,service ,path ,interface ,method) | |
433 (if ,synchronous (list ,@args) (list 'ignore ,@args)))) | |
434 result) | |
435 (tramp-message ,vec 6 "%s %s" func args) | |
436 (setq result (apply func args)) | |
437 (tramp-message ,vec 6 "\n%s" result) | |
438 result)) | |
439 | |
440 (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) | |
441 (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) | |
442 (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) | |
443 | |
444 (defmacro with-tramp-gvfs-error-message (filename handler &rest args) | |
445 "Apply a Tramp GVFS `handler'. | |
446 In case of an error, modify the error message by replacing | |
447 `filename' with its GVFS mounted name." | |
448 `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename))) | |
449 elt) | |
450 (condition-case err | |
451 (apply ,handler (list ,@args)) | |
452 (error | |
453 (setq elt (cdr err)) | |
454 (while elt | |
455 (when (and (stringp (car elt)) | |
456 (string-match fuse-file-name (car elt))) | |
457 (setcar elt (replace-match ,filename t t (car elt)))) | |
458 (setq elt (cdr elt))) | |
459 (signal (car err) (cdr err)))))) | |
460 | |
461 (put 'with-tramp-gvfs-error-message 'lisp-indent-function 2) | |
462 (put 'with-tramp-gvfs-error-message 'edebug-form-spec '(form symbolp body)) | |
463 (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>")) | |
464 | |
465 (defvar tramp-gvfs-dbus-event-vector nil | |
466 "Current Tramp file name to be used, as vector. | |
467 It is needed when D-Bus signals or errors arrive, because there | |
468 is no information where to trace the message.") | |
469 | |
470 (defun tramp-gvfs-dbus-event-error (event err) | |
471 "Called when a D-Bus error message arrives, see `dbus-event-error-hooks'." | |
472 ; (tramp-cleanup-connection tramp-gvfs-dbus-event-vector) | |
473 (tramp-message tramp-gvfs-dbus-event-vector 1 "%S" event) | |
474 (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))) | |
475 | |
476 (add-hook 'dbus-event-error-hooks 'tramp-gvfs-dbus-event-error) | |
477 | |
478 | |
479 ;; File name primitives. | |
480 | |
481 (defun tramp-gvfs-handle-copy-file | |
482 (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) | |
483 "Like `copy-file' for Tramp files." | |
484 (copy-file | |
485 (if (tramp-gvfs-file-name-p filename) | |
486 (tramp-gvfs-fuse-file-name filename) | |
487 filename) | |
488 (if (tramp-gvfs-file-name-p newname) | |
489 (tramp-gvfs-fuse-file-name newname) | |
490 newname) | |
491 ok-if-already-exists keep-date preserve-uid-gid)) | |
492 | |
493 (defun tramp-gvfs-handle-delete-directory (directory) | |
494 "Like `delete-directory' for Tramp files." | |
495 (delete-directory (tramp-gvfs-fuse-file-name directory))) | |
496 | |
497 (defun tramp-gvfs-handle-delete-file (filename) | |
498 "Like `delete-file' for Tramp files." | |
499 (delete-file (tramp-gvfs-fuse-file-name filename))) | |
500 | |
501 (defun tramp-gvfs-handle-directory-files | |
502 (directory &optional full match nosort) | |
503 "Like `directory-files' for Tramp files." | |
504 (let ((fuse-file-name (tramp-gvfs-fuse-file-name directory))) | |
505 (mapcar | |
506 (lambda (x) | |
507 (if (string-match fuse-file-name x) | |
508 (replace-match directory t t x) | |
509 x)) | |
510 (directory-files fuse-file-name full match nosort)))) | |
511 | |
512 (defun tramp-gvfs-handle-directory-files-and-attributes | |
513 (directory &optional full match nosort id-format) | |
514 "Like `directory-files-and-attributes' for Tramp files." | |
515 (let ((fuse-file-name (tramp-gvfs-fuse-file-name directory))) | |
516 (mapcar | |
517 (lambda (x) | |
518 (when (string-match fuse-file-name (car x)) | |
519 (setcar x (replace-match directory t t (car x)))) | |
520 x) | |
521 (directory-files-and-attributes | |
522 fuse-file-name full match nosort id-format)))) | |
523 | |
524 (defun tramp-gvfs-handle-expand-file-name (name &optional dir) | |
525 "Like `expand-file-name' for Tramp files." | |
526 ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". | |
527 (setq dir (or dir default-directory "/")) | |
528 ;; Unless NAME is absolute, concat DIR and NAME. | |
529 (unless (file-name-absolute-p name) | |
530 (setq name (concat (file-name-as-directory dir) name))) | |
531 ;; If NAME is not a Tramp file, run the real handler. | |
532 (if (not (tramp-tramp-file-p name)) | |
533 (tramp-run-real-handler 'expand-file-name (list name nil)) | |
534 ;; Dissect NAME. | |
535 (with-parsed-tramp-file-name name nil | |
536 ;; Tilde expansion is not possible. | |
537 (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) | |
538 (tramp-error | |
539 v 'file-error | |
540 "Cannot expand tilde in file `%s'" name)) | |
541 (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) | |
542 (setq localname (concat "/" localname))) | |
543 ;; We do not pass "/..". | |
544 (if (string-equal "smb" method) | |
545 (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname) | |
546 (setq localname (replace-match "/" t t localname 1))) | |
547 (when (string-match "^/\\.\\./?" localname) | |
548 (setq localname (replace-match "/" t t localname)))) | |
549 ;; There might be a double slash. Remove this. | |
550 (while (string-match "//" localname) | |
551 (setq localname (replace-match "/" t t localname))) | |
552 ;; No tilde characters in file name, do normal | |
553 ;; `expand-file-name' (this does "/./" and "/../"). | |
554 (tramp-make-tramp-file-name | |
555 method user host | |
556 (tramp-run-real-handler | |
557 'expand-file-name (list localname)))))) | |
558 | |
559 (defun tramp-gvfs-handle-file-attributes (filename &optional id-format) | |
560 "Like `file-attributes' for Tramp files." | |
561 (file-attributes (tramp-gvfs-fuse-file-name filename) id-format)) | |
562 | |
563 (defun tramp-gvfs-handle-file-executable-p (filename) | |
564 "Like `file-executable-p' for Tramp files." | |
565 (file-executable-p (tramp-gvfs-fuse-file-name filename))) | |
566 | |
567 (defun tramp-gvfs-handle-file-exists-p (filename) | |
568 "Like `file-exists-p' for Tramp files." | |
569 (file-exists-p (tramp-gvfs-fuse-file-name filename))) | |
570 | |
571 (defun tramp-gvfs-handle-file-local-copy (filename) | |
572 "Like `file-local-copy' for Tramp files." | |
573 (with-parsed-tramp-file-name filename nil | |
574 (let ((tmpfile (tramp-compat-make-temp-file filename))) | |
575 (unless (file-exists-p filename) | |
576 (tramp-error | |
577 v 'file-error | |
578 "Cannot make local copy of non-existing file `%s'" filename)) | |
579 (copy-file filename tmpfile t t) | |
580 tmpfile))) | |
581 | |
582 (defun tramp-gvfs-handle-file-name-all-completions (filename directory) | |
583 "Like `file-name-all-completions' for Tramp files." | |
584 (unless (save-match-data (string-match "/" filename)) | |
585 (file-name-all-completions filename (tramp-gvfs-fuse-file-name directory)))) | |
586 | |
587 (defun tramp-gvfs-handle-file-readable-p (filename) | |
588 "Like `file-readable-p' for Tramp files." | |
589 (file-readable-p (tramp-gvfs-fuse-file-name filename))) | |
590 | |
591 (defun tramp-gvfs-handle-file-writable-p (filename) | |
592 "Like `file-writable-p' for Tramp files." | |
593 (file-writable-p (tramp-gvfs-fuse-file-name filename))) | |
594 | |
595 (defun tramp-gvfs-handle-insert-directory | |
596 (filename switches &optional wildcard full-directory-p) | |
597 "Like `insert-directory' for Tramp files." | |
598 (insert-directory | |
599 (tramp-gvfs-fuse-file-name filename) switches wildcard full-directory-p)) | |
600 | |
601 (defun tramp-gvfs-handle-insert-file-contents | |
602 (filename &optional visit beg end replace) | |
603 "Like `insert-file-contents' for Tramp files." | |
604 (unwind-protect | |
605 (let ((fuse-file-name (tramp-gvfs-fuse-file-name filename)) | |
606 (result | |
607 (insert-file-contents | |
608 (tramp-gvfs-fuse-file-name filename) visit beg end replace))) | |
609 (when (string-match fuse-file-name (car result)) | |
610 (setcar result (replace-match filename t t (car result)))) | |
611 result) | |
612 (setq buffer-file-name filename))) | |
613 | |
614 (defun tramp-gvfs-handle-make-directory (dir &optional parents) | |
615 "Like `make-directory' for Tramp files." | |
616 (condition-case err | |
617 (with-tramp-gvfs-error-message dir 'make-directory | |
618 (tramp-gvfs-fuse-file-name dir) parents) | |
619 ;; Error case. Let's try it with the GVFS utilities. | |
620 (error | |
621 (with-parsed-tramp-file-name filename nil | |
622 (tramp-message v 4 "`make-directory' failed, trying `gvfs-mkdir'") | |
623 (unless | |
624 (zerop | |
625 (tramp-local-call-process | |
626 "gvfs-mkdir" nil (tramp-get-buffer v) nil | |
627 (tramp-gvfs-url-file-name filename))) | |
628 (signal (car err) (cdr err))))))) | |
629 | |
630 (defun tramp-gvfs-handle-rename-file | |
631 (filename newname &optional ok-if-already-exists) | |
632 "Like `rename-file' for Tramp files." | |
633 (rename-file | |
634 (if (tramp-gvfs-file-name-p filename) | |
635 (tramp-gvfs-fuse-file-name filename) | |
636 filename) | |
637 (if (tramp-gvfs-file-name-p newname) | |
638 (tramp-gvfs-fuse-file-name newname) | |
639 newname) | |
640 ok-if-already-exists)) | |
641 | |
642 (defun tramp-gvfs-handle-set-file-modes (filename mode) | |
643 "Like `set-file-modes' for Tramp files." | |
644 (with-tramp-gvfs-error-message filename 'set-file-modes | |
645 (tramp-gvfs-fuse-file-name filename) mode)) | |
646 | |
647 (defun tramp-gvfs-handle-set-visited-file-modtime (&optional time-list) | |
648 "Like `set-visited-file-modtime' for Tramp files." | |
649 (let ((buffer-file-name (tramp-gvfs-fuse-file-name (buffer-file-name)))) | |
650 (set-visited-file-modtime time-list))) | |
651 | |
652 (defun tramp-gvfs-handle-verify-visited-file-modtime (buf) | |
653 "Like `verify-visited-file-modtime' for Tramp files." | |
654 (with-current-buffer buf | |
655 (let ((buffer-file-name (tramp-gvfs-fuse-file-name (buffer-file-name)))) | |
656 (verify-visited-file-modtime buf)))) | |
657 | |
658 (defun tramp-gvfs-handle-write-region | |
659 (start end filename &optional append visit lockname confirm) | |
660 "Like `write-region' for Tramp files." | |
661 (with-parsed-tramp-file-name filename nil | |
662 (condition-case err | |
663 (with-tramp-gvfs-error-message filename 'write-region | |
664 start end (tramp-gvfs-fuse-file-name filename) | |
665 append visit lockname confirm) | |
666 | |
667 ;; Error case. Let's try it with the GVFS utilities. | |
668 (error | |
669 (let ((tmpfile (tramp-compat-make-temp-file filename))) | |
670 (tramp-message v 4 "`write-region' failed, trying `gvfs-save'") | |
671 (write-region start end tmpfile) | |
672 (unwind-protect | |
673 (unless | |
674 (zerop | |
675 (tramp-local-call-process | |
676 "gvfs-save" tmpfile (tramp-get-buffer v) nil | |
677 (tramp-gvfs-url-file-name filename))) | |
678 (signal (car err) (cdr err))) | |
679 (delete-file tmpfile))))) | |
680 | |
681 ;; The end. | |
682 (when (or (eq visit t) (null visit) (stringp visit)) | |
683 (tramp-message v 0 "Wrote %s" filename)) | |
684 (run-hooks 'tramp-handle-write-region-hook))) | |
685 | |
686 | |
687 ;; File name conversions. | |
688 | |
689 (defun tramp-gvfs-url-file-name (filename) | |
690 "Return FILENAME in URL syntax." | |
691 (url-recreate-url | |
692 (if (tramp-tramp-file-p filename) | |
693 (with-parsed-tramp-file-name (file-truename filename) nil | |
694 (when (string-match tramp-user-with-domain-regexp user) | |
695 (setq user | |
696 (concat (match-string 2 user) ";" (match-string 2 user)))) | |
697 (url-parse-make-urlobj | |
698 method user nil | |
699 (tramp-file-name-real-host v) (tramp-file-name-port v) localname)) | |
700 (url-parse-make-urlobj "file" nil nil nil nil (file-truename filename))))) | |
701 | |
702 (defun tramp-gvfs-object-path (filename) | |
703 "Create a D-Bus object path from FILENAME." | |
704 (expand-file-name (dbus-escape-as-identifier filename) tramp-gvfs-path-tramp)) | |
705 | |
706 (defun tramp-gvfs-file-name (object-path) | |
707 "Retrieve file name from D-Bus OBJECT-PATH." | |
708 (dbus-unescape-from-identifier | |
709 (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) | |
710 | |
711 (defun tramp-gvfs-fuse-file-name (filename) | |
712 "Return FUSE file name, which is directly accessible." | |
713 (with-parsed-tramp-file-name (expand-file-name filename) nil | |
714 (tramp-gvfs-maybe-open-connection v) | |
715 (let ((fuse-mountpoint | |
716 (tramp-get-file-property v "/" "fuse-mountpoint" nil))) | |
717 (unless fuse-mountpoint | |
718 (tramp-error | |
719 v 'file-error "There is no FUSE mount point for `%s'" filename)) | |
720 ;; We must remove the share from the local name. | |
721 (when (and (string-equal "smb" method) (string-match "/[^/]+" localname)) | |
722 (setq localname (replace-match "" t t localname))) | |
723 (concat tramp-gvfs-mount-point fuse-mountpoint localname)))) | |
724 | |
725 (defun tramp-bluez-address (device) | |
726 "Return bluetooth device address from a given bluetooth DEVICE name." | |
727 (when (stringp device) | |
728 (if (string-match tramp-ipv6-regexp device) | |
729 (match-string 0 device) | |
730 (cadr (assoc device (tramp-bluez-list-devices)))))) | |
731 | |
732 (defun tramp-bluez-device (address) | |
733 "Return bluetooth device name from a given bluetooth device ADDRESS. | |
734 ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." | |
735 (when (stringp address) | |
736 (while (string-match "[][]" address) | |
737 (setq address (replace-match "" t t address))) | |
738 (let (result) | |
739 (dolist (item (tramp-bluez-list-devices) result) | |
740 (when (string-match address (cadr item)) | |
741 (setq result (car item))))))) | |
742 | |
743 | |
744 ;; D-Bus GVFS functions. | |
745 | |
746 (defun tramp-gvfs-handler-askpassword (message user domain flags) | |
747 "Implementation for the \"org.gtk.vfs.MountOperation.askPassword\" method." | |
748 (let* ((filename | |
749 (tramp-gvfs-file-name (dbus-event-path-name last-input-event))) | |
750 (pw-prompt | |
751 (format | |
752 "%s for %s " | |
753 (if (string-match "\\([pP]assword\\|[pP]assphrase\\)" message) | |
754 (capitalize (match-string 1 message)) | |
755 "Password") | |
756 filename)) | |
757 password) | |
758 | |
759 (condition-case nil | |
760 (with-parsed-tramp-file-name filename l | |
761 (when (and (zerop (length user)) | |
762 (not | |
763 (zerop (logand flags tramp-gvfs-password-need-username)))) | |
764 (setq user (read-string "User name: "))) | |
765 (when (and (zerop (length domain)) | |
766 (not (zerop (logand flags tramp-gvfs-password-need-domain)))) | |
767 (setq domain (read-string "Domain name: "))) | |
768 | |
769 (tramp-message l 6 "%S %S %S %d" message user domain flags) | |
770 (setq tramp-current-method l-method | |
771 tramp-current-user user | |
772 tramp-current-host l-host | |
773 password (tramp-read-passwd | |
774 (tramp-get-connection-process l) pw-prompt)) | |
775 | |
776 ;; Return result. | |
777 (if (stringp password) | |
778 (list | |
779 t ;; password handled. | |
780 nil ;; no abort of D-Bus. | |
781 password | |
782 (tramp-file-name-real-user l) | |
783 domain | |
784 nil ;; not anonymous. | |
785 0) ;; no password save. | |
786 ;; No password provided. | |
787 (list nil t "" (tramp-file-name-real-user l) domain nil 0))) | |
788 | |
789 ;; When QUIT is raised, we shall return this information to D-Bus. | |
790 (quit (list nil t "" "" "" nil 0))))) | |
791 | |
792 (defun tramp-gvfs-handler-askquestion (message choices) | |
793 "Implementation for the \"org.gtk.vfs.MountOperation.askQuestion\" method." | |
794 (save-window-excursion | |
795 (let ((enable-recursive-minibuffers t) | |
796 choice) | |
797 | |
798 (condition-case nil | |
799 (with-parsed-tramp-file-name | |
800 (tramp-gvfs-file-name (dbus-event-path-name last-input-event)) nil | |
801 (tramp-message v 6 "%S %S" message choices) | |
802 | |
803 ;; In theory, there can be several choices. Until now, | |
804 ;; there is only the question whether to accept an unknown | |
805 ;; host signature. | |
806 (with-temp-buffer | |
807 (insert message) | |
808 (pop-to-buffer (current-buffer)) | |
809 (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) | |
810 (tramp-message v 6 "%d" choice)) | |
811 | |
812 ;; When the choice is "no", we set an empty | |
813 ;; fuse-mountpoint in order to leave the timeout. | |
814 (unless (zerop choice) | |
815 (tramp-set-file-property v "/" "fuse-mountpoint" "")) | |
816 | |
817 (list | |
818 t ;; handled. | |
819 nil ;; no abort of D-Bus. | |
820 choice)) | |
821 | |
822 ;; When QUIT is raised, we shall return this information to D-Bus. | |
823 (quit (list nil t 0)))))) | |
824 | |
825 (defun tramp-gvfs-handler-mounted-unmounted (mount-info) | |
826 "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and | |
827 \"org.gtk.vfs.MountTracker.unmounted\" signals." | |
828 (ignore-errors | |
829 (let* ((signal-name (dbus-event-member-name last-input-event)) | |
830 (mount-spec (nth 1 (nth 9 mount-info))) | |
831 (method (dbus-byte-array-to-string (cadr (assoc "type" mount-spec)))) | |
832 (user (dbus-byte-array-to-string (cadr (assoc "user" mount-spec)))) | |
833 (domain (dbus-byte-array-to-string | |
834 (cadr (assoc "domain" mount-spec)))) | |
835 (host (dbus-byte-array-to-string | |
836 (cadr (or (assoc "host" mount-spec) | |
837 (assoc "server" mount-spec))))) | |
838 (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) | |
839 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))) | |
840 (when (string-match "^smb" method) | |
841 (setq method "smb")) | |
842 (when (string-equal "obex" method) | |
843 (setq host (tramp-bluez-device host))) | |
844 (when (and (string-equal "dav" method) (string-equal "true" ssl)) | |
845 (setq method "davs")) | |
846 (unless (zerop (length domain)) | |
847 (setq user (concat user tramp-prefix-domain-format domain))) | |
848 (unless (zerop (length port)) | |
849 (setq host (concat host tramp-prefix-port-format port))) | |
850 (with-parsed-tramp-file-name | |
851 (tramp-make-tramp-file-name method user host "") nil | |
852 (tramp-message v 6 "%s %s" signal-name mount-info) | |
853 (tramp-set-file-property v "/" "list-mounts" 'undef) | |
854 (if (string-equal signal-name "unmounted") | |
855 (tramp-set-file-property v "/" "fuse-mountpoint" nil) | |
856 (tramp-set-file-property | |
857 v "/" "fuse-mountpoint" | |
858 (file-name-nondirectory | |
859 (dbus-byte-array-to-string (nth 8 mount-info))))))))) | |
860 | |
861 (dbus-register-signal | |
862 :session nil tramp-gvfs-path-mounttracker | |
863 tramp-gvfs-interface-mounttracker "mounted" | |
864 'tramp-gvfs-handler-mounted-unmounted) | |
865 | |
866 (dbus-register-signal | |
867 :session nil tramp-gvfs-path-mounttracker | |
868 tramp-gvfs-interface-mounttracker "unmounted" | |
869 'tramp-gvfs-handler-mounted-unmounted) | |
870 | |
871 (defun tramp-gvfs-connection-mounted-p (vec) | |
872 "Check, whether the location is already mounted." | |
873 (catch 'mounted | |
874 (dolist | |
875 (elt | |
876 (with-file-property vec "/" "list-mounts" | |
877 (with-tramp-dbus-call-method vec t | |
878 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker | |
879 tramp-gvfs-interface-mounttracker "listMounts")) | |
880 nil) | |
881 (let* ((mount-spec (nth 1 (nth 9 elt))) | |
882 (method (dbus-byte-array-to-string | |
883 (cadr (assoc "type" mount-spec)))) | |
884 (user (dbus-byte-array-to-string | |
885 (cadr (assoc "user" mount-spec)))) | |
886 (domain (dbus-byte-array-to-string | |
887 (cadr (assoc "domain" mount-spec)))) | |
888 (host (dbus-byte-array-to-string | |
889 (cadr (or (assoc "host" mount-spec) | |
890 (assoc "server" mount-spec))))) | |
891 (port (dbus-byte-array-to-string (cadr (assoc "port" mount-spec)))) | |
892 (ssl (dbus-byte-array-to-string (cadr (assoc "ssl" mount-spec))))) | |
893 (when (string-match "^smb" method) | |
894 (setq method "smb")) | |
895 (when (string-equal "obex" method) | |
896 (setq host (tramp-bluez-device host))) | |
897 (when (and (string-equal "dav" method) (string-equal "true" ssl)) | |
898 (setq method "davs")) | |
899 (unless (zerop (length domain)) | |
900 (setq user (concat user tramp-prefix-domain-format domain))) | |
901 (unless (zerop (length port)) | |
902 (setq host (concat host tramp-prefix-port-format port))) | |
903 (when (and | |
904 (string-equal method (tramp-file-name-method vec)) | |
905 (string-equal user (or (tramp-file-name-user vec) "")) | |
906 (string-equal host (tramp-file-name-host vec))) | |
907 (tramp-set-file-property | |
908 vec "/" "fuse-mountpoint" | |
909 (file-name-nondirectory (dbus-byte-array-to-string (nth 8 elt)))) | |
910 (throw 'mounted t)))))) | |
911 | |
912 (defun tramp-gvfs-mount-spec (vec) | |
913 "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." | |
914 (let* ((method (tramp-file-name-method vec)) | |
915 (user (tramp-file-name-real-user vec)) | |
916 (domain (tramp-file-name-domain vec)) | |
917 (host (tramp-file-name-real-host vec)) | |
918 (port (tramp-file-name-port vec)) | |
919 (localname (tramp-file-name-localname vec)) | |
920 (ssl (if (string-match "^davs" method) "true" "false")) | |
921 (mount-spec `(:array))) | |
922 | |
923 (setq | |
924 mount-spec | |
925 (append | |
926 mount-spec | |
927 (cond | |
928 ((string-equal "smb" method) | |
929 (string-match "^/?\\([^/]+\\)" localname) | |
930 `((:struct "type" ,(dbus-string-to-byte-array "smb-share")) | |
931 (:struct "server" ,(dbus-string-to-byte-array host)) | |
932 (:struct "share" ,(dbus-string-to-byte-array | |
933 (match-string 1 localname))))) | |
934 ((string-equal "obex" method) | |
935 `((:struct "type" ,(dbus-string-to-byte-array method)) | |
936 (:struct "host" ,(dbus-string-to-byte-array | |
937 (concat "[" (tramp-bluez-address host) "]"))))) | |
938 ((string-match "^dav" method) | |
939 `((:struct "type" ,(dbus-string-to-byte-array "dav")) | |
940 (:struct "host" ,(dbus-string-to-byte-array host)) | |
941 (:struct "ssl" ,(dbus-string-to-byte-array ssl)))) | |
942 (t | |
943 `((:struct "type" ,(dbus-string-to-byte-array method)) | |
944 (:struct "host" ,(dbus-string-to-byte-array host))))))) | |
945 | |
946 (when user | |
947 (add-to-list | |
948 'mount-spec | |
949 `(:struct "user" ,(dbus-string-to-byte-array user)) | |
950 'append)) | |
951 | |
952 (when domain | |
953 (add-to-list | |
954 'mount-spec | |
955 `(:struct "domain" ,(dbus-string-to-byte-array domain)) | |
956 'append)) | |
957 | |
958 (when port | |
959 (add-to-list | |
960 'mount-spec | |
961 `(:struct "port" ,(dbus-string-to-byte-array (number-to-string port))) | |
962 'append)) | |
963 | |
964 ;; Return. | |
965 mount-spec)) | |
966 | |
967 | |
968 ;; Connection functions | |
969 | |
970 (defun tramp-gvfs-maybe-open-connection (vec) | |
971 "Maybe open a connection VEC. | |
972 Does not do anything if a connection is already open, but re-opens the | |
973 connection if a previous connection has died for some reason." | |
974 | |
975 ;; We set the file name, in case there are incoming D-Bus signals or | |
976 ;; D-Bus errors. | |
977 (setq tramp-gvfs-dbus-event-vector vec) | |
978 | |
979 ;; For password handling, we need a process bound to the connection | |
980 ;; buffer. Therefore, we create a dummy process. Maybe there is a | |
981 ;; better solution? | |
982 (unless (get-buffer-process (tramp-get-buffer vec)) | |
983 (let ((p (make-network-process | |
984 :name (tramp-buffer-name vec) | |
985 :buffer (tramp-get-buffer vec) | |
986 :server t :host 'local :service t))) | |
987 (tramp-set-process-query-on-exit-flag p nil))) | |
988 | |
989 (unless (tramp-gvfs-connection-mounted-p vec) | |
990 (let* ((method (tramp-file-name-method vec)) | |
991 (user (tramp-file-name-user vec)) | |
992 (host (tramp-file-name-host vec)) | |
993 (object-path | |
994 (tramp-gvfs-object-path | |
995 (tramp-make-tramp-file-name method user host "")))) | |
996 | |
997 (if (zerop (length (tramp-file-name-user vec))) | |
998 (tramp-message | |
999 vec 3 "Opening connection for %s using %s..." host method) | |
1000 (tramp-message | |
1001 vec 3 "Opening connection for %s@%s using %s..." user host method)) | |
1002 | |
1003 ;; Enable auth-sorce and password-cache. | |
1004 (tramp-set-connection-property | |
1005 (tramp-get-connection-process vec) "first-password-request" t) | |
1006 | |
1007 ;; There will be a callback of "askPassword", when a password is | |
1008 ;; needed. | |
1009 (dbus-register-method | |
1010 :session dbus-service-emacs object-path | |
1011 tramp-gvfs-interface-mountoperation "askPassword" | |
1012 'tramp-gvfs-handler-askpassword) | |
1013 | |
1014 ;; There could be a callback of "askQuestion", when adding fingerprint. | |
1015 (dbus-register-method | |
1016 :session dbus-service-emacs object-path | |
1017 tramp-gvfs-interface-mountoperation "askQuestion" | |
1018 'tramp-gvfs-handler-askquestion) | |
1019 | |
1020 ;; The call must be asynchronously, because of the "askPassword" | |
1021 ;; or "askQuestion"callbacks. | |
1022 (with-tramp-dbus-call-method vec nil | |
1023 :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker | |
1024 tramp-gvfs-interface-mounttracker "mountLocation" | |
1025 `(:struct | |
1026 ,(dbus-string-to-byte-array "/") | |
1027 ,(tramp-gvfs-mount-spec vec)) | |
1028 (dbus-get-unique-name :session) | |
1029 :object-path object-path) | |
1030 | |
1031 ;; We must wait, until the mount is applied. This will be | |
1032 ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint" | |
1033 ;; file property. | |
1034 (with-timeout | |
1035 (60 | |
1036 (if (zerop (length (tramp-file-name-user vec))) | |
1037 (tramp-error | |
1038 vec 'file-error | |
1039 "Timeout reached mounting %s using %s" host method) | |
1040 (tramp-error | |
1041 vec 'file-error | |
1042 "Timeout reached mounting %s@%s using %s" user host method))) | |
1043 (while (not (tramp-get-file-property vec "/" "fuse-mountpoint" nil)) | |
1044 (sit-for 0.1))) | |
1045 | |
1046 ;; We set the connection property "started" in order to put the | |
1047 ;; remote location into the cache, which is helpful for further | |
1048 ;; completion. | |
1049 (tramp-set-connection-property vec "started" t) | |
1050 | |
1051 (if (zerop (length (tramp-file-name-user vec))) | |
1052 (tramp-message | |
1053 vec 3 "Opening connection for %s using %s...done" host method) | |
1054 (tramp-message | |
1055 vec 3 | |
1056 "Opening connection for %s@%s using %s...done" user host method))))) | |
1057 | |
1058 | |
1059 ;; D-Bus BLUEZ functions. | |
1060 | |
1061 (defun tramp-bluez-list-devices () | |
1062 "Returns all discovered bluetooth devices as list. | |
1063 Every entry is a list (NAME ADDRESS). | |
1064 | |
1065 If `tramp-bluez-discover-devices-timeout' is an integer, and the last | |
1066 discovery happened more time before indicated there, a rescan will be | |
1067 started, which lasts some ten seconds. Otherwise, cached results will | |
1068 be used." | |
1069 ;; Reset the scanned devices list if time has passed. | |
1070 (and (integerp tramp-bluez-discover-devices-timeout) | |
1071 (integerp tramp-bluez-discovery) | |
1072 (> (tramp-time-diff (current-time) tramp-bluez-discovery) | |
1073 tramp-bluez-discover-devices-timeout) | |
1074 (setq tramp-bluez-devices nil)) | |
1075 | |
1076 ;; Rescan if needed. | |
1077 (unless tramp-bluez-devices | |
1078 (let ((object-path | |
1079 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t | |
1080 :system tramp-bluez-service "/" | |
1081 tramp-bluez-interface-manager "DefaultAdapter"))) | |
1082 (setq tramp-bluez-devices nil | |
1083 tramp-bluez-discovery t) | |
1084 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil | |
1085 :system tramp-bluez-service object-path | |
1086 tramp-bluez-interface-adapter "StartDiscovery") | |
1087 (while tramp-bluez-discovery | |
1088 (read-event nil nil 0.1)))) | |
1089 (setq tramp-bluez-discovery (current-time)) | |
1090 (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices) | |
1091 tramp-bluez-devices) | |
1092 | |
1093 (defun tramp-bluez-property-changed (property value) | |
1094 "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal." | |
1095 (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value) | |
1096 (cond | |
1097 ((string-equal property "Discovering") | |
1098 (unless (car value) | |
1099 ;; "Discovering" FALSE means discovery run has been completed. | |
1100 ;; We stop it, because we don't need another run. | |
1101 (setq tramp-bluez-discovery nil) | |
1102 (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t | |
1103 :system tramp-bluez-service (dbus-event-path-name last-input-event) | |
1104 tramp-bluez-interface-adapter "StopDiscovery"))))) | |
1105 | |
1106 (dbus-register-signal | |
1107 :system nil nil tramp-bluez-interface-adapter "PropertyChanged" | |
1108 'tramp-bluez-property-changed) | |
1109 | |
1110 (defun tramp-bluez-device-found (device args) | |
1111 "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." | |
1112 (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args) | |
1113 (let ((alias (car (cadr (assoc "Alias" args)))) | |
1114 (address (car (cadr (assoc "Address" args))))) | |
1115 ;; Maybe we shall check the device class for being a proper | |
1116 ;; device, and call also SDP in order to find the obex service. | |
1117 (add-to-list 'tramp-bluez-devices (list alias address)))) | |
1118 | |
1119 (dbus-register-signal | |
1120 :system nil nil tramp-bluez-interface-adapter "DeviceFound" | |
1121 'tramp-bluez-device-found) | |
1122 | |
1123 (defun tramp-bluez-parse-device-names (ignore) | |
1124 "Return a list of (nil host) tuples allowed to access." | |
1125 (mapcar | |
1126 (lambda (x) (list nil (car x))) | |
1127 (tramp-bluez-list-devices))) | |
1128 | |
1129 ;; Add completion function for OBEX method. | |
1130 (when (dbus-ping :system tramp-bluez-service) | |
1131 (tramp-set-completion-function | |
1132 "obex" '((tramp-bluez-parse-device-names "")))) | |
1133 | |
1134 | |
1135 ;; D-Bus zeroconf functions. | |
1136 | |
1137 (defun tramp-zeroconf-parse-workstation-device-names (ignore) | |
1138 "Return a list of (user host) tuples allowed to access." | |
1139 (mapcar | |
1140 (lambda (x) | |
1141 (list nil (zeroconf-service-host x))) | |
1142 (zeroconf-list-services "_workstation._tcp"))) | |
1143 | |
1144 (defun tramp-zeroconf-parse-webdav-device-names (ignore) | |
1145 "Return a list of (user host) tuples allowed to access." | |
1146 (mapcar | |
1147 (lambda (x) | |
1148 (let ((host (zeroconf-service-host x)) | |
1149 (port (zeroconf-service-port x)) | |
1150 (text (zeroconf-service-txt x)) | |
1151 user) | |
1152 (when port | |
1153 (setq host (format "%s%s%d" host tramp-prefix-port-regexp port))) | |
1154 ;; A user is marked in a TXT field like "u=guest". | |
1155 (while text | |
1156 (when (string-match "u=\\(.+\\)$" (car text)) | |
1157 (setq user (match-string 1 (car text)))) | |
1158 (setq text (cdr text))) | |
1159 (list user host))) | |
1160 (zeroconf-list-services "_webdav._tcp"))) | |
1161 | |
1162 ;; Add completion function for DAV and DAVS methods. | |
1163 (when (dbus-ping :system zeroconf-service-avahi) | |
1164 (zeroconf-init tramp-gvfs-zeroconf-domain) | |
1165 (tramp-set-completion-function | |
1166 "sftp" '((tramp-zeroconf-parse-workstation-device-names ""))) | |
1167 (tramp-set-completion-function | |
1168 "dav" '((tramp-zeroconf-parse-webdav-device-names ""))) | |
1169 (tramp-set-completion-function | |
1170 "davs" '((tramp-zeroconf-parse-webdav-device-names "")))) | |
1171 | |
1172 (provide 'tramp-gvfs) | |
1173 | |
1174 ;;; TODO: | |
1175 | |
1176 ;; * process-file and start-file-process on the local machine, but | |
1177 ;; with remote files. | |
1178 ;; * Host name completion via smb-server or smb-network. | |
1179 ;; * Check, how two shares of the same SMB server can be mounted in | |
1180 ;; parallel. | |
1181 ;; * Apply SDP on bluetooth devices, in order to filter out obex | |
1182 ;; capability. | |
1183 ;; * Implement obex for other serial communication but bluetooth. | |
1184 | |
1185 ;;; tramp-gvfs.el ends here |