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