|
98
|
1 ;; -*-Emacs-Lisp-*-
|
|
|
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
3 ;;
|
|
|
4 ;; File: efs-dired.el
|
|
|
5 ;; Release: $efs release: 1.15 $
|
|
118
|
6 ;; Version: #Revision: 1.32 $
|
|
98
|
7 ;; RCS:
|
|
|
8 ;; Description: Extends much of Dired to work under efs.
|
|
|
9 ;; Authors: Sebastian Kremer <sk@thp.uni-koeln.de>,
|
|
|
10 ;; Andy Norman <ange@hplb.hpl.hp.com>,
|
|
|
11 ;; Sandy Rutherford <sandy@ibm550.sissa.it>
|
|
|
12 ;; Created: Throughout the ages.
|
|
|
13 ;; Language: Emacs-Lisp
|
|
|
14 ;;
|
|
|
15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
16
|
|
|
17 ;;; Provisions and requirements
|
|
|
18
|
|
|
19 (provide 'efs-dired)
|
|
|
20 (require 'efs)
|
|
|
21 (require 'dired)
|
|
|
22 (autoload 'dired-shell-call-process "dired-shell")
|
|
|
23
|
|
|
24 (defconst efs-dired-version
|
|
|
25 (concat (substring "$efs release: 1.15 $" 14 -2)
|
|
|
26 "/"
|
|
118
|
27 (substring "#Revision: 1.32 $" 11 -2)))
|
|
98
|
28
|
|
|
29 ;;;; ----------------------------------------------------------------
|
|
|
30 ;;;; User Configuration Variables
|
|
|
31 ;;;; ----------------------------------------------------------------
|
|
|
32
|
|
|
33 (defvar efs-dired-verify-modtime-host-regexp nil
|
|
|
34 "Regular expression determining on which hosts dired modtimes are checked.")
|
|
|
35
|
|
|
36 (defvar efs-dired-verify-anonymous-modtime nil
|
|
|
37 "If non-nil, dired modtimes are checked for anonymous logins.")
|
|
|
38
|
|
|
39 ;;; Internal Variables
|
|
|
40
|
|
|
41 (make-variable-buffer-local 'dired-ls-F-marks-symlinks)
|
|
|
42
|
|
|
43 ;;;; -----------------------------------------------------------
|
|
|
44 ;;;; Inserting Directories into Buffers
|
|
|
45 ;;;; -----------------------------------------------------------
|
|
|
46
|
|
|
47 ;; The main command for inserting a directory listing in a buffer.
|
|
|
48 ;; In Emacs 19 this is in files.el, and not specifically connected to
|
|
|
49 ;; dired. Since our version of it uses some dired functions, it is
|
|
|
50 ;; included here, but there is an autoload for it in efs.el.
|
|
|
51
|
|
|
52 (defun efs-insert-directory (file switches &optional wildcard full-directory-p
|
|
|
53 nowait marker-char)
|
|
|
54 ;; Inserts a remote directory. Can do this asynch.
|
|
|
55 (let* ((parsed (efs-ftp-path file))
|
|
|
56 (mk (point-marker))
|
|
|
57 (host (car parsed))
|
|
|
58 (user (nth 1 parsed))
|
|
|
59 (path (nth 2 parsed))
|
|
|
60 (host-type (efs-host-type host))
|
|
|
61 (dumb (memq host-type efs-dumb-host-types))
|
|
|
62 (subdir (and (null (or full-directory-p wildcard))
|
|
|
63 (condition-case nil
|
|
|
64 (dired-current-directory)
|
|
|
65 (error nil))))
|
|
|
66 (case-fold-search nil) ; for testing switches
|
|
|
67 (parse (and full-directory-p (not wildcard)
|
|
|
68 (or dumb (efs-parsable-switches-p switches))))
|
|
|
69 ;; In case dired-omit-silent isn't defined.
|
|
|
70 (dired-omit-silent (and (boundp 'dired-omit-silent)
|
|
|
71 dired-omit-silent)))
|
|
|
72
|
|
|
73 ;; Insert the listing. If it's not a wild-card, and not a full-dir,
|
|
|
74 ;; then we are updating a dired-line. Do this asynch.
|
|
|
75 ;; This way of doing the listing makes sure that the dired
|
|
|
76 ;; buffer is still around after the listing is obtained.
|
|
|
77
|
|
|
78 (efs-ls
|
|
|
79 file switches t (if parse 'parse t) nil
|
|
|
80 ;; asynch, if we're inserting in a subdir. Do it nowait = 0, so
|
|
|
81 ;; updating the file line gets a high priority??
|
|
|
82 ;; Insert subdir listings NOWAIT = 0 also so 1-line
|
|
|
83 ;; updates don't toggle the mode line.
|
|
|
84 (if (and subdir nowait) 0 nowait)
|
|
|
85 (efs-cont (listing) (host user file path wildcard
|
|
|
86 nowait marker-char
|
|
|
87 mk subdir parse switches dired-omit-silent)
|
|
|
88 ;; We pass the value of dired-omit-silent from the caller to the cont.
|
|
|
89 (let ((host-type (efs-host-type host))
|
|
|
90 (listing-type (efs-listing-type host user)))
|
|
|
91 (if (marker-buffer mk)
|
|
|
92 (efs-save-buffer-excursion
|
|
|
93 (set-buffer (marker-buffer mk))
|
|
|
94 ;; parsing a listing, sometimes updates info
|
|
|
95 (if (and parse (eq major-mode 'dired-mode))
|
|
|
96 (progn
|
|
|
97 (setq efs-dired-host-type host-type
|
|
|
98 efs-dired-listing-type listing-type
|
|
|
99 efs-dired-listing-type-string
|
|
|
100 (and efs-show-host-type-in-dired
|
|
|
101 (concat " "
|
|
|
102 (symbol-name
|
|
|
103 efs-dired-listing-type))))
|
|
|
104 (if (memq host-type '(bsd-unix next-unix))
|
|
|
105 (setq dired-ls-F-marks-symlinks nil)
|
|
|
106 (if (memq host-type '(sysV-unix apollo-unix))
|
|
|
107 (setq dired-ls-F-marks-symlinks t)))))
|
|
|
108 (if subdir
|
|
|
109 ;; a 1-line re-list
|
|
|
110 (save-excursion
|
|
|
111 (efs-update-file-info
|
|
|
112 host-type file efs-data-buffer-name)
|
|
|
113 (goto-char mk)
|
|
|
114 (let ((new-subdir (condition-case nil
|
|
|
115 (dired-current-directory)
|
|
|
116 (error nil)))
|
|
|
117 buffer-read-only)
|
|
|
118 (if (and new-subdir
|
|
|
119 (string-equal subdir new-subdir))
|
|
|
120 (progn
|
|
|
121 ;; Is there an existing entry?
|
|
|
122 (if (dired-goto-file file)
|
|
|
123 (progn
|
|
|
124 (delete-region
|
|
|
125 (save-excursion
|
|
|
126 (skip-chars-backward "^\n\r")
|
|
|
127 (1- (point)))
|
|
|
128 (progn
|
|
|
129 (skip-chars-forward "^\n\r")
|
|
|
130 (point)))
|
|
|
131 (goto-char mk)))
|
|
|
132 (insert listing)
|
|
|
133 (save-restriction
|
|
|
134 (narrow-to-region mk (point))
|
|
|
135 (efs-dired-fixup-listing
|
|
|
136 listing-type file path switches wildcard)
|
|
|
137 (efs-dired-ls-trim
|
|
|
138 listing-type)
|
|
|
139 ;; save-excursion loses if fixup had to
|
|
|
140 ;; remove and re-add the region. Say for
|
|
|
141 ;; sorting.
|
|
|
142 (goto-char (point-max)))
|
|
|
143 (if (and nowait (eq major-mode 'dired-mode))
|
|
|
144 (dired-after-add-entry
|
|
|
145 (marker-position mk)
|
|
|
146 marker-char))))))
|
|
|
147 (goto-char mk)
|
|
|
148 (let (buffer-read-only)
|
|
|
149 (insert listing)
|
|
|
150 (save-restriction
|
|
|
151 (narrow-to-region mk (point))
|
|
|
152 (efs-dired-fixup-listing
|
|
|
153 listing-type file path switches wildcard)
|
|
|
154 (goto-char (point-max))))))))))
|
|
|
155 ;; Return 0 if synch, nil if asynch
|
|
|
156 (if nowait nil 0)))
|
|
|
157
|
|
|
158 ;;; Functions for cleaning listings.
|
|
|
159
|
|
|
160 (efs-defun efs-dired-ls-trim nil ()
|
|
|
161 ;; Trims dir listings, so that the listing of a single file is one line.
|
|
|
162 nil)
|
|
|
163
|
|
|
164 (efs-defun efs-dired-fixup-listing nil (file path &optional switches wildcard)
|
|
|
165 ;; FILE is in efs syntax.
|
|
|
166 ;; PATH is just the remote path.
|
|
|
167 ;; Some ftpd's put the whole directory name in front of each filename.
|
|
|
168 ;; Seems to depend in a strange way on server-client interaction.
|
|
|
169 ;; Walk down the listing generated and remove this stuff.
|
|
|
170 ;; SWITCHES is a string.
|
|
|
171 (if (memq efs-key efs-unix-host-types)
|
|
|
172 (let ((continue t)
|
|
|
173 spot bol)
|
|
|
174 (goto-char (point-min))
|
|
|
175 (while (and (not (eobp)) continue)
|
|
|
176 (and (setq bol (point)
|
|
|
177 spot (dired-manual-move-to-filename nil bol))
|
|
|
178 (setq continue (= (following-char) ?/))
|
|
|
179 (dired-manual-move-to-end-of-filename t bol)
|
|
|
180 (progn
|
|
|
181 (skip-chars-backward "^/")
|
|
|
182 (delete-region spot (point))))
|
|
|
183 (forward-line 1))
|
|
|
184 (efs-save-match-data
|
|
|
185 (if (and switches (string-match "R" switches)
|
|
|
186 (not (string-match "d" switches)))
|
|
|
187 (let ((subdir-regexp "^\\(/[^ \n\r]+\\):[\n\r]")
|
|
|
188 name)
|
|
|
189 (goto-char (point-min))
|
|
|
190 (while (re-search-forward subdir-regexp nil t)
|
|
|
191 (goto-char (match-beginning 0))
|
|
|
192 ;; There may be /./ type nonsense.
|
|
|
193 ;; expand-file-name will handle it.
|
|
|
194 (setq name (expand-file-name
|
|
|
195 (buffer-substring (point) (match-end 0))))
|
|
|
196 (delete-region (point) (match-end 0))
|
|
|
197 (insert (efs-replace-path-component file name)))))))))
|
|
|
198
|
|
|
199
|
|
|
200 ;;;; ------------------------------------------------------------
|
|
|
201 ;;;; Tree Dired support
|
|
|
202 ;;;; ------------------------------------------------------------
|
|
|
203
|
|
|
204 ;;; efs-dired keymap
|
|
|
205
|
|
|
206 (defvar efs-dired-map nil
|
|
|
207 "Keymap for efs commands in dired buffers.")
|
|
|
208
|
|
|
209 (if efs-dired-map
|
|
|
210 ()
|
|
|
211 (setq efs-dired-map (make-sparse-keymap))
|
|
|
212 (define-key efs-dired-map "c" 'efs-dired-close-ftp-process)
|
|
|
213 (define-key efs-dired-map "k" 'efs-dired-kill-ftp-process)
|
|
|
214 (define-key efs-dired-map "o" 'efs-dired-display-ftp-process-buffer)
|
|
|
215 (define-key efs-dired-map "p" 'efs-dired-ping-connection))
|
|
|
216
|
|
|
217 (fset 'efs-dired-prefix efs-dired-map)
|
|
|
218
|
|
|
219 ;;; Functions for dealing with the FTP process
|
|
|
220
|
|
|
221 (defun efs-dired-close-ftp-process ()
|
|
|
222 "Close the FTP process for the current dired buffer.
|
|
|
223 Closing causes the connection to be dropped, but efs will retain its
|
|
|
224 cached data for the connection. This will make it more efficient to
|
|
|
225 reopen the connection."
|
|
|
226 (interactive)
|
|
|
227 (or efs-dired-host-type
|
|
|
228 (error "Dired buffer is not for a remote directory."))
|
|
|
229 (efs-close-ftp-process (current-buffer))
|
|
|
230 (let ((parsed (efs-ftp-path default-directory)))
|
|
|
231 (message "Closed FTP connection for %s@%s." (nth 1 parsed) (car parsed))))
|
|
|
232
|
|
|
233 (defun efs-dired-kill-ftp-process ()
|
|
|
234 "Kills the FTP process for the current dired buffer.
|
|
|
235 Killing causes the connection to be closed, the process buffer to be killed,
|
|
|
236 and most of efs's cached data to be wiped."
|
|
|
237 (interactive)
|
|
|
238 (or efs-dired-host-type
|
|
|
239 (error "Dired buffer is not for a remote directory."))
|
|
|
240 (efs-kill-ftp-process (current-buffer))
|
|
|
241 (let ((parsed (efs-ftp-path default-directory)))
|
|
|
242 (message "Killed FTP connection for %s@%s." (nth 1 parsed) (car parsed))))
|
|
|
243
|
|
|
244 (defun efs-dired-display-ftp-process-buffer ()
|
|
|
245 "Displays in another window the FTP process buffer for a dired buffer."
|
|
|
246 (interactive)
|
|
|
247 (or efs-dired-host-type
|
|
|
248 (error "Dired buffer is not for a remote directory."))
|
|
|
249 (efs-display-ftp-process-buffer (current-buffer)))
|
|
|
250
|
|
|
251 (defun efs-dired-ping-connection ()
|
|
|
252 "Pings FTP connection associated with current dired buffer."
|
|
|
253 (interactive)
|
|
|
254 (or efs-dired-host-type
|
|
|
255 (error "Dired buffer is not for a remote directory."))
|
|
|
256 (efs-ping-ftp-connection (current-buffer)))
|
|
|
257
|
|
|
258
|
|
|
259 ;;; Reading in dired buffers.
|
|
|
260
|
|
|
261 (defun efs-dired-revert (&optional arg noconfirm)
|
|
|
262 (let ((efs-ls-uncache t))
|
|
|
263 (dired-revert arg noconfirm)))
|
|
|
264
|
|
|
265 (defun efs-dired-default-dir-function ()
|
|
|
266 (let* ((cd (dired-current-directory))
|
|
|
267 (parsed (efs-ftp-path cd)))
|
|
|
268 (if parsed
|
|
|
269 (efs-save-match-data
|
|
|
270 (let ((tail directory-abbrev-alist))
|
|
|
271 (while tail
|
|
|
272 (if (string-match (car (car tail)) cd)
|
|
|
273 (setq cd (concat (cdr (car tail))
|
|
|
274 (substring cd (match-end 0)))
|
|
|
275 parsed nil))
|
|
|
276 (setq tail (cdr tail)))
|
|
|
277 (apply 'efs-unexpand-parsed-filename
|
|
|
278 (or parsed (efs-ftp-path cd)))))
|
|
|
279 cd)))
|
|
|
280
|
|
|
281 (defun efs-dired-before-readin ()
|
|
|
282 ;; Put in the dired-before-readin-hook.
|
|
|
283 (let ((parsed (efs-ftp-path default-directory)))
|
|
|
284 (if parsed
|
|
|
285 (let ((host (car parsed))
|
|
|
286 (user (nth 1 parsed)))
|
|
|
287 (setq efs-dired-listing-type (efs-listing-type host user)
|
|
|
288 efs-dired-host-type (efs-host-type host)
|
|
|
289 efs-dired-listing-type-string
|
|
|
290 (and efs-show-host-type-in-dired
|
|
|
291 (concat " " (symbol-name efs-dired-listing-type))))
|
|
|
292 (set (make-local-variable 'revert-buffer-function)
|
|
|
293 (function efs-dired-revert))
|
|
|
294 (set (make-local-variable 'default-directory-function)
|
|
|
295 (function efs-dired-default-dir-function))
|
|
|
296 (set (make-local-variable 'dired-verify-modtimes)
|
|
|
297 (null (null (and
|
|
|
298 efs-dired-verify-modtime-host-regexp
|
|
|
299 (efs-save-match-data
|
|
|
300 (let ((case-fold-search t))
|
|
|
301 (string-match
|
|
|
302 efs-dired-verify-modtime-host-regexp host))
|
|
|
303 (or efs-dired-verify-anonymous-modtime
|
|
|
304 (not (efs-anonymous-p user))))))))
|
|
|
305 ;; The hellsoft ftp server mixes up cases.
|
|
|
306 ;; However, we may not be able to catch this until
|
|
|
307 ;; after the first directory is listed.
|
|
|
308 (if (and
|
|
|
309 (eq efs-dired-host-type 'hell)
|
|
|
310 (not (string-equal default-directory
|
|
|
311 (setq default-directory
|
|
|
312 (downcase default-directory)))))
|
|
|
313 (or (string-equal (buffer-name) (downcase (buffer-name)))
|
|
|
314 (rename-buffer (generate-new-buffer-name
|
|
|
315 (directory-file-name default-directory)))))
|
|
|
316 ;; Setup the executable and directory regexps
|
|
|
317 (let ((eentry (assq efs-dired-listing-type
|
|
|
318 efs-dired-re-exe-alist))
|
|
|
319 (dentry (assq efs-dired-listing-type
|
|
|
320 efs-dired-re-dir-alist)))
|
|
|
321 (if eentry
|
|
|
322 (set (make-local-variable 'dired-re-exe) (cdr eentry)))
|
|
|
323 (if dentry
|
|
|
324 (set (make-local-variable 'dired-re-dir) (cdr dentry))))
|
|
|
325 ;; No switches are sent to dumb hosts, so don't confuse dired.
|
|
|
326 ;; I hope that dired doesn't get excited if it doesn't see the l
|
|
|
327 ;; switch. If it does, then maybe fake things by setting this to
|
|
|
328 ;; "-Al".
|
|
|
329 (if (eq efs-dired-listing-type 'vms)
|
|
|
330 (setq dired-internal-switches
|
|
|
331 (delq ?F dired-internal-switches))
|
|
|
332 (if (memq efs-dired-host-type efs-dumb-host-types)
|
|
|
333 (setq dired-internal-switches '(?l ?A)
|
|
|
334 ;; Don't lie on the mode line
|
|
|
335 dired-sort-mode "")))
|
|
|
336 ;; If the remote file system is version-based, don't set
|
|
|
337 ;; dired-kept-versions to 0. It will flag the most recent
|
|
|
338 ;; copy of the file for deletion -- this isn't really a backup.
|
|
|
339 (if (memq efs-dired-host-type efs-version-host-types)
|
|
|
340 (set (make-local-variable 'dired-kept-versions)
|
|
|
341 (max 1 dired-kept-versions)))))))
|
|
|
342
|
|
|
343 (efs-defun efs-dired-insert-headerline (&use efs-dired-listing-type) (dir)
|
|
|
344 "Documented as original."
|
|
|
345 (efs-real-dired-insert-headerline dir))
|
|
|
346
|
|
|
347 (defun efs-dired-uncache (file dir-p)
|
|
|
348 ;; Remove FILE from cache.
|
|
|
349 (if dir-p
|
|
|
350 (efs-del-from-ls-cache file nil t)
|
|
|
351 (efs-del-from-ls-cache file t nil)))
|
|
|
352
|
|
|
353 ;;; Checking modtimes of directories.
|
|
|
354 ;;
|
|
|
355 ;; This only runs if efs-dired-verify-anonymous-modtime and
|
|
|
356 ;; efs-verify-modtime-host-regexp turn it on. Few (any?) FTP servers
|
|
|
357 ;; support getting MDTM for directories. As usual, we cache whether
|
|
|
358 ;; this works, and don't keep senselessly trying it if it doesn't.
|
|
|
359
|
|
|
360 (defun efs-dired-file-modtime (file)
|
|
|
361 ;; Returns the modtime.
|
|
|
362 (let* ((parsed (efs-ftp-path file))
|
|
|
363 (host (car parsed))
|
|
|
364 (user (nth 1 parsed))
|
|
|
365 (rpath (nth 2 parsed)))
|
|
|
366 (and (null (efs-get-host-property host 'dir-mdtm-failed))
|
|
|
367 (let ((result (efs-send-cmd host user (list 'quote 'mdtm rpath)
|
|
|
368 (and (eq efs-verbose t)
|
|
|
369 "Getting modtime")))
|
|
|
370 mp)
|
|
|
371 (if (and (null (car result))
|
|
|
372 (setq mp (efs-parse-mdtime (nth 1 result))))
|
|
|
373 (let ((ent (efs-get-file-entry file)))
|
|
|
374 (if ent
|
|
|
375 (setcdr ent (list (nth 1 ent) (nth 2 ent)
|
|
|
376 (nth 3 ent) (nth 4 ent) mp)))
|
|
|
377 parsed)
|
|
|
378 (efs-set-host-property host 'dir-mdtm-failed t)
|
|
|
379 nil)))))
|
|
|
380
|
|
|
381 (defun efs-dired-set-file-modtime (file alist)
|
|
|
382 ;; This works asynch.
|
|
|
383 (let* ((parsed (efs-ftp-path file))
|
|
|
384 (host (car parsed))
|
|
|
385 (user (nth 1 parsed))
|
|
|
386 (path (nth 2 parsed)))
|
|
|
387 (if (efs-get-host-property host 'dir-mdtm-failed)
|
|
|
388 (let ((elt (assoc file alist)))
|
|
|
389 (if elt (setcar (nthcdr 4 elt) nil)))
|
|
|
390 (efs-send-cmd
|
|
|
391 host user (list 'quote 'mdtm path) nil nil
|
|
|
392 (efs-cont (result line cont-lines) (file alist host)
|
|
|
393 (let ((elt (assoc file alist))
|
|
|
394 modtime)
|
|
|
395 (if (and (null result) (setq modtime (efs-parse-mdtime line)))
|
|
|
396 (if elt (setcar (nthcdr 4 elt) modtime))
|
|
|
397 (if elt (setcar (nthcdr 4 elt) nil))
|
|
|
398 (efs-set-host-property host 'dir-mdtm-failed t))))
|
|
|
399 0) ; Always do this NOWAIT = 0
|
|
|
400 nil))) ; return NIL
|
|
|
401
|
|
|
402 ;;; Asynch insertion of subdirs. Used when renaming subdirs.
|
|
|
403
|
|
|
404 (defun efs-dired-insert-subdir (dirname &optional noerror nowait)
|
|
|
405 (let ((buff (current-buffer))
|
|
|
406 (switches (delq ?R (copy-sequence dired-internal-switches))))
|
|
|
407 (efs-ls
|
|
|
408 dirname (dired-make-switches-string switches)
|
|
|
409 t nil noerror nowait
|
|
|
410 (efs-cont (listing) (dirname buff switches)
|
|
|
411 (if (and listing (get-buffer buff))
|
|
|
412 (save-excursion
|
|
|
413 (set-buffer buff)
|
|
|
414 (save-excursion
|
|
|
415 (let ((elt (assoc dirname dired-subdir-alist))
|
|
|
416 mark-list)
|
|
|
417 (if elt
|
|
|
418 (setq mark-list (dired-insert-subdir-del elt))
|
|
|
419 (dired-insert-subdir-newpos dirname))
|
|
|
420 (dired-insert-subdir-doupdate
|
|
|
421 dirname
|
|
|
422 (efs-dired-insert-subdir-do-insert dirname listing)
|
|
|
423 switches elt mark-list)))))))))
|
|
|
424
|
|
|
425 (defun efs-dired-insert-subdir-do-insert (dirname listing)
|
|
|
426 (let ((begin (point))
|
|
|
427 indent-tabs-mode end)
|
|
|
428 (insert listing)
|
|
|
429 (setq end (point-marker))
|
|
|
430 (indent-rigidly begin end 2)
|
|
|
431 (goto-char begin)
|
|
|
432 (dired-insert-headerline dirname)
|
|
|
433 ;; If the listing has null lines `quote' them so that "\n\n" delimits
|
|
|
434 ;; subdirs. This is OK, because we aren't inserting -R listings.
|
|
|
435 (save-excursion
|
|
|
436 (while (search-forward "\n\n" end t)
|
|
|
437 (forward-char -1)
|
|
|
438 (insert " ")))
|
|
|
439 ;; point is now like in dired-build-subdir-alist
|
|
|
440 (prog1
|
|
|
441 (list begin (marker-position end))
|
|
|
442 (set-marker end nil))))
|
|
|
443
|
|
|
444 ;;; Moving around in dired buffers.
|
|
|
445
|
|
|
446 (efs-defun efs-dired-manual-move-to-filename (&use efs-dired-listing-type)
|
|
|
447 (&optional raise-error bol eol)
|
|
|
448 "Documented as original."
|
|
|
449 (efs-real-dired-manual-move-to-filename raise-error bol eol))
|
|
|
450
|
|
|
451 (efs-defun efs-dired-manual-move-to-end-of-filename
|
|
|
452 (&use efs-dired-listing-type) (&optional no-error bol eol)
|
|
|
453 "Documented as original."
|
|
|
454 (efs-real-dired-manual-move-to-end-of-filename no-error bol eol))
|
|
|
455
|
|
|
456 (efs-defun efs-dired-make-filename-string (&use efs-dired-listing-type)
|
|
|
457 (filename &optional reverse)
|
|
|
458 "Documented as original."
|
|
|
459 ;; This translates file names from the way that they are displayed
|
|
|
460 ;; in listings to the way that the user gives them in the minibuffer.
|
|
|
461 ;; For example, in CMS this should take "FOO BAR" to "FOO.BAR".
|
|
|
462 filename)
|
|
|
463
|
|
|
464 (defun efs-dired-find-file ()
|
|
|
465 "Documented as original."
|
|
|
466 (interactive)
|
|
|
467 (find-file
|
|
|
468 (if (memq efs-dired-host-type efs-version-host-types)
|
|
|
469 (efs-internal-file-name-sans-versions
|
|
|
470 efs-dired-host-type (dired-get-filename) t)
|
|
|
471 (dired-get-filename))))
|
|
|
472
|
|
|
473 (defun efs-dired-find-file-other-window (&optional display)
|
|
|
474 "Documented as original."
|
|
|
475 (interactive "P")
|
|
|
476 (if display
|
|
|
477 (dired-display-file)
|
|
|
478 (let ((file (dired-get-filename)))
|
|
|
479 (if (memq efs-dired-host-type efs-version-host-types)
|
|
|
480 (setq file (efs-internal-file-name-sans-versions
|
|
|
481 efs-dired-host-type file t)))
|
|
|
482 (find-file-other-window file))))
|
|
|
483
|
|
|
484 (defun efs-dired-display-file ()
|
|
|
485 "Documented as original."
|
|
|
486 (interactive)
|
|
|
487 (let ((file (dired-get-filename)))
|
|
|
488 (if (memq efs-dired-host-type efs-version-host-types)
|
|
|
489 (setq file (efs-internal-file-name-sans-versions
|
|
|
490 efs-dired-host-type file t)))
|
|
|
491 (display-buffer (find-file-noselect file))))
|
|
|
492
|
|
|
493 (defun efs-dired-find-file-other-frame ()
|
|
|
494 "Documented as original."
|
|
|
495 (interactive)
|
|
|
496 (find-file-other-frame
|
|
|
497 (if (memq efs-dired-host-type efs-version-host-types)
|
|
|
498 (efs-internal-file-name-sans-versions
|
|
|
499 efs-dired-host-type (dired-get-filename) t)
|
|
|
500 (dired-get-filename))))
|
|
|
501
|
|
|
502 ;;; Creating and deleting new directories.
|
|
|
503
|
|
|
504 (defun efs-dired-recursive-delete-directory (fn)
|
|
|
505 ;; Does recursive deletion of remote directories for dired.
|
|
|
506 (or (file-exists-p fn)
|
|
|
507 (signal 'file-error
|
|
|
508 (list "Removing old file name" "no such directory" fn)))
|
|
|
509 (efs-dired-internal-recursive-delete-directory fn))
|
|
|
510
|
|
|
511 (defun efs-dired-internal-recursive-delete-directory (fn)
|
|
|
512 (if (eq (car (file-attributes fn)) t)
|
|
|
513 (let ((files (efs-directory-files fn)))
|
|
|
514 (if files
|
|
|
515 (mapcar (function
|
|
|
516 (lambda (ent)
|
|
|
517 (or (string-equal "." ent)
|
|
|
518 (string-equal ".." ent)
|
|
|
519 (efs-dired-internal-recursive-delete-directory
|
|
|
520 (expand-file-name ent fn)))))
|
|
|
521 files))
|
|
|
522 (efs-delete-directory fn))
|
|
|
523 (condition-case err
|
|
|
524 (efs-delete-file fn)
|
|
|
525 (ftp-error (if (and (nth 2 err) (stringp (nth 2 err))
|
|
|
526 (efs-save-match-data
|
|
|
527 (string-match "^FTP Error: \"550 " (nth 2 err))))
|
|
|
528 (message "File %s already deleted." fn)
|
|
|
529 (signal (car err) (cdr err)))))))
|
|
|
530
|
|
|
531 ;;; File backups and versions.
|
|
|
532
|
|
|
533 (efs-defun efs-dired-flag-backup-files
|
|
|
534 (&use efs-dired-host-type) (&optional unflag-p)
|
|
|
535 "Documented as original."
|
|
|
536 (interactive "P")
|
|
|
537 (efs-real-dired-flag-backup-files unflag-p))
|
|
|
538
|
|
|
539 (efs-defun efs-dired-collect-file-versions (&use efs-dired-host-type) ()
|
|
|
540 ;; If it looks like a file has versions, return a list of the versions.
|
|
|
541 ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...)
|
|
|
542 (efs-real-dired-collect-file-versions))
|
|
|
543
|
|
|
544 ;;; Sorting dired buffers
|
|
|
545
|
|
|
546 (defun efs-dired-file-name-lessp (name1 name2)
|
|
|
547 (if (and efs-dired-host-type
|
|
|
548 (memq efs-dired-host-type efs-case-insensitive-host-types))
|
|
|
549 (string< (downcase name1) (downcase name2))
|
|
|
550 (string< name1 name2)))
|
|
|
551
|
|
|
552 ;;; Support for async file creators.
|
|
|
553
|
|
|
554 (defun efs-dired-copy-file (from to ok-flag &optional cont nowait)
|
|
|
555 ;; Version of dired-copy-file for remote files.
|
|
|
556 ;; Assumes that filenames are already expanded.
|
|
|
557 (dired-handle-overwrite to)
|
|
|
558 (efs-copy-file-internal from (efs-ftp-path from) to (efs-ftp-path to)
|
|
|
559 ok-flag dired-copy-preserve-time 0 cont nowait))
|
|
|
560
|
|
|
561 (defun efs-dired-rename-file (from to ok-flag &optional cont nowait
|
|
|
562 insert-subdir)
|
|
|
563 ;; Version of dired-rename-file for remote files.
|
|
|
564 (dired-handle-overwrite to)
|
|
|
565 (efs-rename-file-internal
|
|
|
566 from to ok-flag nil
|
|
|
567 (efs-cont (result line cont-lines) (from to cont insert-subdir)
|
|
|
568 (if result
|
|
|
569 (if cont
|
|
|
570 (efs-call-cont cont result line cont-lines)
|
|
|
571 (signal 'ftp-error
|
|
|
572 (list "Dired Renaming"
|
|
|
573 (format "FTP Error: \"%s\"" line)
|
|
|
574 from to)))
|
|
|
575 (dired-remove-file from)
|
|
|
576 ;; Silently rename the visited file of any buffer visiting this file.
|
|
|
577 ;; We do not maintain inserted subdirs for remote
|
|
|
578 (efs-dired-rename-update-buffers from to insert-subdir)
|
|
|
579 (if cont (efs-call-cont cont result line cont-lines))))
|
|
|
580 nowait))
|
|
|
581
|
|
|
582 (defun efs-dired-rename-update-buffers (from to &optional insert-subdir)
|
|
|
583 (if (get-file-buffer from)
|
|
|
584 (save-excursion
|
|
|
585 (set-buffer (get-file-buffer from))
|
|
|
586 (let ((modflag (buffer-modified-p)))
|
|
|
587 (set-visited-file-name to) ; kills write-file-hooks
|
|
|
588 (set-buffer-modified-p modflag)))
|
|
|
589 ;; It's a directory. More work to do.
|
|
|
590 (let ((blist (buffer-list))
|
|
|
591 (from-dir (file-name-as-directory from))
|
|
|
592 (to-dir (file-name-as-directory to)))
|
|
|
593 (save-excursion
|
|
|
594 (while blist
|
|
|
595 (set-buffer (car blist))
|
|
|
596 (setq blist (cdr blist))
|
|
|
597 (cond
|
|
|
598 (buffer-file-name
|
|
|
599 (if (dired-in-this-tree buffer-file-name from-dir)
|
|
|
600 (let ((modflag (buffer-modified-p)))
|
|
|
601 (unwind-protect
|
|
|
602 (set-visited-file-name
|
|
|
603 (concat to-dir (substring buffer-file-name
|
|
|
604 (length from-dir))))
|
|
|
605 (set-buffer-modified-p modflag)))))
|
|
|
606 (dired-directory
|
|
|
607 (if (string-equal from-dir (expand-file-name default-directory))
|
|
|
608 ;; If top level directory was renamed, lots of things
|
|
|
609 ;; have to be updated.
|
|
|
610 (progn
|
|
|
611 (dired-unadvertise from-dir)
|
|
|
612 (setq default-directory to-dir
|
|
|
613 dired-directory
|
|
|
614 ;; Need to beware of wildcards.
|
|
|
615 (expand-file-name
|
|
|
616 (file-name-nondirectory dired-directory)
|
|
|
617 to-dir))
|
|
|
618 (let ((new-name (file-name-nondirectory
|
|
|
619 (directory-file-name dired-directory))))
|
|
|
620 ;; Try to rename buffer, but just leave old name if new
|
|
|
621 ;; name would already exist (don't try appending "<%d>")
|
|
|
622 ;; Why? --sandy 19-8-94
|
|
|
623 (or (get-buffer new-name)
|
|
|
624 (rename-buffer new-name)))
|
|
|
625 (dired-advertise))
|
|
|
626 (and insert-subdir
|
|
|
627 (assoc (file-name-directory (directory-file-name to))
|
|
|
628 dired-subdir-alist)
|
|
|
629 (if (efs-ftp-path to)
|
|
|
630 (efs-dired-insert-subdir to t 1)
|
|
|
631 (dired-insert-subdir to)))))))))))
|
|
|
632
|
|
|
633 (defun efs-dired-make-relative-symlink (from to ok-flag &optional cont nowait)
|
|
|
634 ;; efs version of dired-make-relative-symlink
|
|
|
635 ;; Called as a file-name-handler when dired-make-relative-symlink is
|
|
|
636 ;; called interactively.
|
|
|
637 ;; efs-dired-create-files calls it directly to supply CONT
|
|
|
638 ;; and NOWAIT args.
|
|
|
639 (setq from (directory-file-name from)
|
|
|
640 to (directory-file-name to))
|
|
|
641 (efs-make-symbolic-link-internal
|
|
|
642 (dired-make-relative from (file-name-directory to) t)
|
|
|
643 to ok-flag cont nowait))
|
|
|
644
|
|
|
645 (defun efs-dired-create-files (file-creator operation fn-list name-constructor
|
|
|
646 &optional marker-char query
|
|
|
647 implicit-to)
|
|
|
648 "Documented as original."
|
|
|
649 (if (catch 'found
|
|
|
650 (let ((list fn-list)
|
|
|
651 val)
|
|
|
652 (while list
|
|
|
653 (if (setq val (efs-ftp-path (car list)))
|
|
|
654 (throw 'found val)
|
|
|
655 (if (setq val (funcall name-constructor (car list)))
|
|
|
656 (throw 'found (efs-ftp-path val))
|
|
|
657 (setq list (cdr list)))))))
|
|
|
658 (progn
|
|
|
659 (cond ((eq file-creator 'dired-copy-file)
|
|
|
660 (setq file-creator 'efs-dired-copy-file))
|
|
|
661 ((eq file-creator 'dired-rename-file)
|
|
|
662 (setq file-creator 'efs-dired-rename-file))
|
|
|
663 ((eq file-creator 'make-symbolic-link)
|
|
|
664 (setq file-creator 'efs-make-symbolic-link-internal))
|
|
|
665 ((eq file-creator 'add-name-to-file)
|
|
|
666 (setq file-creator 'efs-add-name-to-file-internal))
|
|
|
667 ((eq file-creator 'dired-make-relative-symlink)
|
|
|
668 (setq file-creator 'efs-dired-make-relative-symlink))
|
|
|
669 ((eq file-creator 'dired-compress-file)
|
|
|
670 (setq file-creator 'efs-dired-compress-file))
|
|
|
671 ((error "Unable to perform operation %s on remote hosts."
|
|
|
672 file-creator)))
|
|
|
673 ;; use the process-filter driven routine rather than the iterative one.
|
|
|
674 (efs-dcf-1 file-creator operation fn-list name-constructor
|
|
|
675 (if (eq marker-char t)
|
|
|
676 (mapcar 'dired-file-marker fn-list)
|
|
|
677 marker-char)
|
|
|
678 query (buffer-name (current-buffer))
|
|
|
679 nil ;overwrite-query
|
|
|
680 nil ;dired-overwrite-backup-query
|
|
|
681 nil ;dired-file-creator-query
|
|
|
682 nil ;failures
|
|
|
683 nil ;skipped
|
|
|
684 0 ;success-count
|
|
|
685 (length fn-list) ;total
|
|
|
686 implicit-to
|
|
|
687 (and (eq file-creator 'efs-dired-rename-file)
|
|
|
688 (delq nil
|
|
|
689 (mapcar
|
|
|
690 (function
|
|
|
691 (lambda (x)
|
|
|
692 (and (assoc (file-name-as-directory x)
|
|
|
693 dired-subdir-alist)
|
|
|
694 x)))
|
|
|
695 fn-list)))))
|
|
|
696 ;; normal case... use the interative routine... much cheaper.
|
|
|
697 (efs-real-dired-create-files file-creator operation fn-list
|
|
|
698 name-constructor marker-char query
|
|
|
699 implicit-to)))
|
|
|
700
|
|
|
701 (defun efs-dcf-1 (file-creator operation fn-list name-constructor
|
|
|
702 markers query buffer-name overwrite-query
|
|
|
703 overwrite-backup-query file-creator-query
|
|
|
704 failures skipped success-count total
|
|
|
705 implicit-to insertions)
|
|
|
706 (if (null fn-list)
|
|
|
707 (efs-dcf-3 failures operation total skipped
|
|
|
708 success-count buffer-name)
|
|
|
709 (let* ((from (car fn-list))
|
|
|
710 ;; For dired-handle-overwrite and the file-creator-query,
|
|
|
711 ;; need to set these 2 fluid vars according to the cont data.
|
|
|
712 (dired-overwrite-backup-query overwrite-backup-query)
|
|
|
713 (dired-file-creator-query file-creator-query)
|
|
|
714 (to (funcall name-constructor from))
|
|
|
715 (marker-char (if (consp markers)
|
|
|
716 (prog1 (car markers)
|
|
|
717 (setq markers (cdr markers)))
|
|
|
718 markers))
|
|
|
719 (fn-list (cdr fn-list)))
|
|
|
720 (if to
|
|
|
721 (if (equal to from)
|
|
|
722 (progn
|
|
|
723 (dired-log buffer-name "Cannot %s to same file: %s\n"
|
|
|
724 (downcase operation) from)
|
|
|
725 (efs-dcf-1 file-creator operation fn-list name-constructor
|
|
|
726 markers query buffer-name overwrite-query
|
|
|
727 dired-overwrite-backup-query
|
|
|
728 dired-file-creator-query failures
|
|
|
729 (cons (dired-make-relative from nil t) skipped)
|
|
|
730 success-count total implicit-to insertions))
|
|
|
731 (if (or (null query)
|
|
|
732 (funcall query from to))
|
|
|
733 (let* ((overwrite (let (jka-compr-enabled)
|
|
|
734 ;; Don't let jka-compr fool us.
|
|
|
735 (file-exists-p to)))
|
|
|
736 (overwrite-confirmed ; for dired-handle-overwrite
|
|
|
737 (and overwrite
|
|
|
738 (let ((help-form '(format "\
|
|
|
739 Type SPC or `y' to overwrite file `%s',
|
|
|
740 DEL or `n' to skip to next,
|
|
|
741 ESC or `q' to not overwrite any of the remaining files,
|
|
|
742 `!' to overwrite all remaining files with no more questions." to)))
|
|
|
743 (dired-query 'overwrite-query
|
|
|
744 "Overwrite `%s'?" to)))))
|
|
|
745 (condition-case err
|
|
|
746 (let ((dired-unhandle-add-files
|
|
|
747 (cons to dired-unhandle-add-files)))
|
|
|
748 (if implicit-to
|
|
|
749 (funcall file-creator from overwrite-confirmed
|
|
|
750 (list (function efs-dcf-2)
|
|
|
751 file-creator operation fn-list
|
|
|
752 name-constructor markers
|
|
|
753 query marker-char
|
|
|
754 buffer-name to from overwrite
|
|
|
755 overwrite-confirmed overwrite-query
|
|
|
756 dired-overwrite-backup-query
|
|
|
757 dired-file-creator-query
|
|
|
758 failures skipped success-count
|
|
|
759 total implicit-to insertions)
|
|
|
760 t)
|
|
|
761 (apply file-creator from to overwrite-confirmed
|
|
|
762 (list (function efs-dcf-2)
|
|
|
763 file-creator operation fn-list
|
|
|
764 name-constructor markers
|
|
|
765 query marker-char
|
|
|
766 buffer-name to from overwrite
|
|
|
767 overwrite-confirmed overwrite-query
|
|
|
768 dired-overwrite-backup-query
|
|
|
769 dired-file-creator-query
|
|
|
770 failures skipped success-count total
|
|
|
771 implicit-to insertions)
|
|
|
772 (if insertions
|
|
|
773 (list t insertions)
|
|
|
774 '(t)))))
|
|
|
775 (error ; FILE-CREATOR aborted
|
|
|
776 (efs-dcf-2 'failed ;result
|
|
|
777 (format "%s" err) ;line
|
|
|
778 "" file-creator operation fn-list
|
|
|
779 name-constructor markers query marker-char
|
|
|
780 buffer-name to from overwrite
|
|
|
781 overwrite-confirmed overwrite-query
|
|
|
782 dired-overwrite-backup-query
|
|
|
783 dired-file-creator-query failures skipped
|
|
|
784 success-count total implicit-to insertions))))
|
|
|
785 (efs-dcf-1 file-creator operation fn-list name-constructor
|
|
|
786 markers query buffer-name overwrite-query
|
|
|
787 dired-overwrite-backup-query dired-file-creator-query
|
|
|
788 failures
|
|
|
789 (cons (dired-make-relative from nil t) skipped)
|
|
|
790 success-count total implicit-to insertions)))
|
|
|
791 (efs-dcf-1 file-creator operation fn-list name-constructor
|
|
|
792 markers query buffer-name overwrite-query
|
|
|
793 dired-overwrite-backup-query dired-file-creator-query
|
|
|
794 failures (cons (dired-make-relative from nil t) skipped)
|
|
|
795 success-count total implicit-to insertions)))))
|
|
|
796
|
|
|
797 (defun efs-dcf-2 (result line cont-lines file-creator operation fn-list
|
|
|
798 name-constructor markers query marker-char
|
|
|
799 buffer-name to from overwrite overwrite-confirmed
|
|
|
800 overwrite-query overwrite-backup-query
|
|
|
801 file-creator-query failures skipped success-count
|
|
|
802 total implicit-to insertions)
|
|
|
803 (if result
|
|
|
804 (progn
|
|
|
805 (setq failures (cons (dired-make-relative from nil t) failures))
|
|
|
806 (dired-log buffer-name "%s `%s' to `%s' failed:\n%s\n"
|
|
|
807 operation from to line))
|
|
|
808 (setq success-count (1+ success-count))
|
|
|
809 (message "%s: %d of %d" operation success-count total)
|
|
|
810 (let ((efs-ls-uncache t))
|
|
|
811 (dired-add-file to marker-char)))
|
|
|
812 ;; iterate again
|
|
|
813 (efs-dcf-1 file-creator operation fn-list name-constructor
|
|
|
814 markers query buffer-name overwrite-query overwrite-backup-query
|
|
|
815 file-creator-query failures skipped success-count total
|
|
|
816 implicit-to insertions))
|
|
|
817
|
|
|
818 (defun efs-dcf-3 (failures operation total skipped success-count buffer-name)
|
|
|
819 (cond
|
|
|
820 (failures
|
|
|
821 (dired-log-summary buffer-name (format "%s failed for %d of %d file%s"
|
|
|
822 operation (length failures) total
|
|
|
823 (dired-plural-s total)) failures))
|
|
|
824 (skipped
|
|
|
825 (dired-log-summary buffer-name (format "%s: %d of %d file%s skipped"
|
|
|
826 operation (length skipped) total
|
|
|
827 (dired-plural-s total)) skipped))
|
|
|
828 (t
|
|
|
829 (message "%s: %s file%s."
|
|
|
830 operation success-count
|
|
|
831 (dired-plural-s success-count)))))
|
|
|
832
|
|
|
833 ;;; Running remote shell commands
|
|
|
834
|
|
|
835 ;;; This support isn't very good. efs is really about a virtual file system,
|
|
|
836 ;;; and not remote processes. What is really required is low-level
|
|
|
837 ;;; support for start-process & call-process on remote hosts. This shouldn't
|
|
|
838 ;;; be part of efs, although.
|
|
|
839
|
|
|
840 (defun efs-dired-shell-unhandle-file-name (filename)
|
|
|
841 ;; Puts remote file names into a form where they can be passed to remsh.
|
|
|
842 (nth 2 (efs-ftp-path filename)))
|
|
|
843
|
|
|
844 (defun efs-dired-shell-call-process (command dir &optional in-background)
|
|
|
845 ;; Runs shell process on remote hosts.
|
|
|
846 (let* ((parsed (efs-ftp-path dir))
|
|
|
847 (host (car parsed))
|
|
|
848 (user (nth 1 parsed))
|
|
|
849 (rdir (nth 2 parsed))
|
|
|
850 (file-name-handler-alist nil))
|
|
|
851 (or (string-equal (efs-internal-directory-file-name dir)
|
|
|
852 (efs-expand-tilde "~" (efs-host-type host) host user))
|
|
|
853 (string-match "^cd " command)
|
|
|
854 (setq command (concat "cd " rdir "; " command)))
|
|
|
855 (setq command
|
|
|
856 (format "%s %s%s \"%s\"" ; remsh -l USER does not work well
|
|
|
857 ; on a hp-ux machine I tried
|
|
|
858 efs-remote-shell-file-name host
|
|
|
859 (if efs-remote-shell-takes-user
|
|
|
860 (concat " -l " user)
|
|
|
861 "")
|
|
|
862 command))
|
|
|
863 (message "Doing shell command on %s..." host)
|
|
|
864 (dired-shell-call-process
|
|
|
865 command (file-name-directory efs-tmp-name-template) in-background)))
|
|
|
866
|
|
|
867 ;;; Dired commands for running local processes on remote files.
|
|
|
868 ;;
|
|
|
869 ;; Lots of things in this section need to be re-thunk.
|
|
|
870
|
|
|
871 (defun efs-dired-call-process (program discard &rest arguments)
|
|
|
872 "Documented as original."
|
|
|
873 ;; PROGRAM is always one of those below in the cond in dired.el.
|
|
|
874 ;; The ARGUMENTS are (nearly) always files.
|
|
|
875 (if (efs-ftp-path default-directory)
|
|
|
876 ;; Can't use efs-dired-host-type here because the current
|
|
|
877 ;; buffer is *dired-check-process output*
|
|
|
878 (condition-case oops
|
|
|
879 (cond
|
|
|
880 ((string-equal "efs-call-compress" program)
|
|
|
881 (apply 'efs-call-compress arguments))
|
|
|
882 ((string-equal "chmod" program)
|
|
|
883 (efs-call-chmod arguments))
|
|
|
884 (t (error "Unknown remote command: %s" program)))
|
|
|
885 (ftp-error (dired-log (buffer-name (current-buffer))
|
|
|
886 (format "%s: %s, %s\n"
|
|
|
887 (nth 1 oops)
|
|
|
888 (nth 2 oops)
|
|
|
889 (nth 3 oops))))
|
|
|
890 (error (dired-log (buffer-name (current-buffer))
|
|
|
891 (format "%s\n" (nth 1 oops)))))
|
|
|
892 (apply 'call-process program nil (not discard) nil arguments)))
|
|
|
893
|
|
|
894 (defun efs-dired-make-compressed-filename (name &optional method)
|
|
|
895 ;; Version of dired-make-compressed-filename for efs.
|
|
|
896 ;; If NAME is in the syntax of a compressed file (according to
|
|
|
897 ;; dired-compression-method-alist), return the data (a list) from this
|
|
|
898 ;; alist on how to uncompress it. Otherwise, return a string, the
|
|
|
899 ;; uncompressed form of this file name. This is computed using the optional
|
|
|
900 ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of
|
|
|
901 ;; dired-compression-method is used.
|
|
|
902 (let* ((host-type (efs-host-type (car (efs-ftp-path name))))
|
|
|
903 (ef-alist (if (memq host-type efs-single-extension-host-types)
|
|
|
904 (mapcar
|
|
|
905 (function
|
|
|
906 (lambda (elt)
|
|
|
907 (list (car elt)
|
|
|
908 (mapconcat
|
|
|
909 (function
|
|
|
910 (lambda (char)
|
|
|
911 (if (= char ?.)
|
|
|
912 "-"
|
|
|
913 (char-to-string char))))
|
|
|
914 (nth 1 elt) "")
|
|
|
915 (nth 2 elt)
|
|
|
916 (nth 3 elt))))
|
|
|
917 dired-compression-method-alist)
|
|
|
918 dired-compression-method-alist))
|
|
|
919 (alist ef-alist)
|
|
|
920 (len (length name))
|
|
|
921 ext ext-len result)
|
|
|
922 (if (memq host-type efs-version-host-types)
|
|
|
923 (setq name (efs-internal-file-name-sans-versions host-type name)))
|
|
|
924 (if (memq host-type efs-case-insensitive-host-types)
|
|
|
925 (let ((name (downcase name)))
|
|
|
926 (while alist
|
|
|
927 (if (and (> len
|
|
|
928 (setq ext-len (length (setq ext (nth 1 (car alist))))))
|
|
|
929 (string-equal (downcase ext)
|
|
|
930 (substring name (- ext-len))))
|
|
|
931 (setq result (car alist)
|
|
|
932 alist nil)
|
|
|
933 (setq alist (cdr alist)))))
|
|
|
934 (while alist
|
|
|
935 (if (and (> len
|
|
|
936 (setq ext-len (length (setq ext (nth 1 (car alist))))))
|
|
|
937 (string-equal ext (substring name (- ext-len))))
|
|
|
938 (setq result (car alist)
|
|
|
939 alist nil)
|
|
|
940 (setq alist (cdr alist)))))
|
|
|
941 (or result
|
|
|
942 (concat name
|
|
|
943 (nth 1 (or (assq (or method dired-compression-method)
|
|
|
944 ef-alist)
|
|
|
945 (error "Unknown compression method: %s"
|
|
|
946 (or method dired-compression-method))))))))
|
|
|
947
|
|
|
948 (defun efs-dired-compress-file (file ok-flag &optional cont nowait)
|
|
|
949 ;; Version of dired-compress-file for remote files.
|
|
|
950 (let* ((compressed-fn (efs-dired-make-compressed-filename file))
|
|
|
951 (host (car (efs-ftp-path file)))
|
|
|
952 (host-type (efs-host-type host)))
|
|
|
953 (cond ((file-symlink-p file)
|
|
|
954 (if cont
|
|
|
955 (efs-call-cont
|
|
|
956 cont 'failed
|
|
|
957 (format "Cannot compress %s, a symbolic link." file) "")
|
|
|
958 (signal 'file-error (list "Compress error:" file
|
|
|
959 "a symbolic link"))))
|
|
|
960 ((listp compressed-fn)
|
|
|
961 (let ((newname (substring (if (memq host-type
|
|
|
962 efs-version-host-types)
|
|
|
963 (efs-internal-file-name-sans-versions
|
|
|
964 host-type file)
|
|
|
965 file)
|
|
|
966 0 (- (length (nth 1 compressed-fn)))))
|
|
|
967 (program (nth 3 compressed-fn)))
|
|
|
968 (if (and (memq host-type efs-unix-host-types)
|
|
|
969 (null (efs-get-host-property host 'exec-failed))
|
|
|
970 (null (eq (efs-get-host-property
|
|
|
971 host
|
|
|
972 (intern
|
|
|
973 (concat
|
|
|
974 "exec-"
|
|
|
975 (efs-compress-progname (car program)))))
|
|
|
976 'failed)))
|
|
|
977 (efs-call-remote-compress
|
|
|
978 program file newname t ok-flag
|
|
|
979 (efs-cont (result line cont-lines) (program file newname
|
|
|
980 cont nowait)
|
|
|
981 (if result
|
|
|
982 (if (eq result 'unsupported)
|
|
|
983 (efs-call-compress program file newname
|
|
|
984 t t cont nowait)
|
|
|
985 (if cont
|
|
|
986 (efs-call-cont cont result line cont-lines)
|
|
|
987 (signal 'ftp-error
|
|
|
988 (list "Uncompressing file"
|
|
|
989 (format "FTP Error: \"%s\" " line)
|
|
|
990 file))))
|
|
|
991 (if cont (efs-call-cont cont result line cont-lines))))
|
|
|
992 nowait)
|
|
|
993 (efs-call-compress
|
|
|
994 program file newname t ok-flag cont nowait)
|
|
|
995 newname)))
|
|
|
996 ((stringp compressed-fn)
|
|
|
997 (let ((program (nth 2 (assq dired-compression-method
|
|
|
998 dired-compression-method-alist))))
|
|
|
999 (if (and (memq host-type efs-unix-host-types)
|
|
|
1000 (null (efs-get-host-property host 'exec-failed))
|
|
|
1001 (null (eq (efs-get-host-property
|
|
|
1002 host
|
|
|
1003 (intern
|
|
|
1004 (concat
|
|
|
1005 "exec-"
|
|
|
1006 (efs-compress-progname (car program)))))
|
|
|
1007 'failed)))
|
|
|
1008 (efs-call-remote-compress
|
|
|
1009 program file compressed-fn nil ok-flag
|
|
|
1010 (efs-cont (result line cont-lines) (program file
|
|
|
1011 compressed-fn
|
|
|
1012 cont nowait)
|
|
|
1013 (if result
|
|
|
1014 (if (eq result 'unsupported)
|
|
|
1015 (efs-call-compress program file compressed-fn nil
|
|
|
1016 t cont nowait)
|
|
|
1017 (if cont
|
|
|
1018 (efs-call-cont cont result line cont-lines)
|
|
|
1019 (signal 'ftp-error
|
|
|
1020 (list "Compressing file"
|
|
|
1021 (format "FTP Error: \"%s\" " line)
|
|
|
1022 file))))
|
|
|
1023 (if cont (efs-call-cont cont result line cont-lines))))
|
|
|
1024 nowait)
|
|
|
1025 (efs-call-compress
|
|
|
1026 program file compressed-fn nil ok-flag cont nowait)))
|
|
|
1027 compressed-fn)
|
|
|
1028 (t (error "Strange error in efs-dired-compress-file.")))))
|
|
|
1029
|
|
|
1030 (defun efs-dired-print-file (command file)
|
|
|
1031 ;; Version of dired-print-file for remote files.
|
|
|
1032 (let ((command (dired-trans-command command (list file) "")))
|
|
|
1033 ;; Only replace the first occurence of the file name?
|
|
|
1034 (if (string-match (concat "[ ><|]\\(" (regexp-quote
|
|
|
1035 (dired-shell-quote file))
|
|
|
1036 "\\)\\($\\|[ |><&]\\)")
|
|
|
1037 command)
|
|
|
1038 (setq command (concat (substring command 0 (match-beginning 1))
|
|
|
1039 "%s"
|
|
|
1040 (substring command (match-end 1))))
|
|
|
1041 (error "efs-print-command: strange error"))
|
|
|
1042 (efs-call-lpr file command)))
|
|
|
1043
|
|
|
1044 ;;;;----------------------------------------------------------------
|
|
|
1045 ;;;; Support for `processes' run on remote files.
|
|
|
1046 ;;;; Usually (but not necessarily) these are only called from dired.
|
|
|
1047 ;;;;----------------------------------------------------------------
|
|
|
1048
|
|
|
1049 (defun efs-compress-progname (program)
|
|
|
1050 ;; Returns a canonicalized i.e. without the "un", version of a compress
|
|
|
1051 ;; program name.
|
|
|
1052 (efs-save-match-data
|
|
|
1053 (if (string-equal program "gunzip")
|
|
|
1054 "gzip"
|
|
|
1055 (if (string-match "^un" program)
|
|
|
1056 (substring program (match-end 0))
|
|
|
1057 program))))
|
|
|
1058
|
|
|
1059 (defun efs-call-remote-compress (program filename newname &optional uncompress
|
|
|
1060 ok-if-already-exists cont nowait)
|
|
|
1061 ;; Run a remote compress process using SITE EXEC.
|
|
|
1062 (if (or (not ok-if-already-exists)
|
|
|
1063 (numberp ok-if-already-exists))
|
|
|
1064 (efs-barf-or-query-if-file-exists
|
|
|
1065 newname
|
|
|
1066 (if uncompress
|
|
|
1067 "uncompress to it"
|
|
|
1068 "compress to it")
|
|
|
1069 (numberp ok-if-already-exists)))
|
|
|
1070 (let* ((filename (expand-file-name filename))
|
|
|
1071 (parsed (efs-ftp-path filename))
|
|
|
1072 (host (car parsed))
|
|
|
1073 (user (nth 1 parsed))
|
|
|
1074 (rpath (nth 2 parsed)))
|
|
|
1075 (if (efs-get-host-property host 'exec-failed)
|
|
|
1076 (if cont
|
|
|
1077 (efs-call-cont cont 'unsupported "SITE EXEC not supported" "")
|
|
|
1078 (signal 'ftp-error (list "Unable to SITE EXEC" host)))
|
|
|
1079 (let* ((progname (efs-compress-progname (car program)))
|
|
|
1080 (propsym (intern (concat "exec-" progname)))
|
|
|
1081 (prop (efs-get-host-property host propsym)))
|
|
|
1082 (cond
|
|
|
1083 ((eq prop 'failed)
|
|
|
1084 (if cont
|
|
|
1085 (efs-call-cont cont 'unsupported
|
|
|
1086 (concat progname " not in FTP exec path") "")
|
|
|
1087 (signal 'ftp-error
|
|
|
1088 (list (concat progname " not in FTP exec path") host))))
|
|
|
1089 ((eq prop 'worked)
|
|
|
1090 (efs-send-cmd
|
|
|
1091 host user
|
|
|
1092 (list 'quote 'site 'exec
|
|
|
1093 (concat (mapconcat 'identity program " ") " " rpath))
|
|
|
1094 (concat (if uncompress "Uncompressing " "Compressing ") filename)
|
|
|
1095 nil
|
|
|
1096 (efs-cont (result line cont-lines) (host user filename cont)
|
|
|
1097 (if result
|
|
|
1098 (progn
|
|
|
1099 (efs-set-host-property host 'exec-failed t)
|
|
|
1100 (efs-error host user (concat "FTP exec Error: " line)))
|
|
|
1101 (efs-save-match-data
|
|
|
1102 (if (string-match "\n200-\\([^\n]*\\)" cont-lines)
|
|
|
1103 (let ((err (substring cont-lines (match-beginning 1)
|
|
|
1104 (match-end 1))))
|
|
|
1105 (if cont
|
|
|
1106 (efs-call-cont cont 'failed err cont-lines)
|
|
|
1107 (efs-error host user (concat "FTP Error: " err))))
|
|
|
1108 ;; This function only gets called for unix hosts, so
|
|
|
1109 ;; we'll use the default version of efs-delete-file-entry
|
|
|
1110 ;; and save a host-type lookup.
|
|
|
1111 (efs-delete-file-entry nil filename)
|
|
|
1112 (dired-remove-file filename)
|
|
|
1113 (if cont (efs-call-cont cont nil line cont-lines))))))
|
|
|
1114 nowait))
|
|
|
1115 (t ; (null prop)
|
|
|
1116 (efs-send-cmd
|
|
|
1117 host user
|
|
|
1118 (list 'quote 'site 'exec (concat progname " " "-V"))
|
|
|
1119 (format "Checking for %s executable" progname)
|
|
|
1120 nil
|
|
|
1121 (efs-cont (result line cont-lines) (propsym host program filename
|
|
|
1122 newname uncompress
|
|
|
1123 cont nowait)
|
|
|
1124 (efs-save-match-data
|
|
|
1125 (if (string-match "\n200-" cont-lines)
|
|
|
1126 (efs-set-host-property host propsym 'worked)
|
|
|
1127 (efs-set-host-property host propsym 'failed)))
|
|
|
1128 (efs-call-remote-compress program filename newname uncompress
|
|
|
1129 t ; already tested for overwrite
|
|
|
1130 cont nowait))
|
|
|
1131 nowait)))))))
|
|
|
1132
|
|
|
1133 (defun efs-call-compress (program filename newname &optional uncompress
|
|
|
1134 ok-if-already-exists cont nowait)
|
|
|
1135 "Perform a compress command on a remote file.
|
|
|
1136 PROGRAM is a list of the compression program and args. Works by taking a
|
|
|
1137 copy of the file, compressing it and copying the file back. Returns 0 on
|
|
|
1138 success, 1 or 2 on failure. If UNCOMPRESS is non-nil, does this instead."
|
|
|
1139 (let* ((filename (expand-file-name filename))
|
|
|
1140 (newname (expand-file-name newname))
|
|
|
1141 (parsed (efs-ftp-path filename))
|
|
|
1142 (tmp1 (car (efs-make-tmp-name nil (car parsed))))
|
|
|
1143 (tmp2 (car (efs-make-tmp-name nil (car parsed))))
|
|
|
1144 (program (mapconcat 'identity program " ")))
|
|
|
1145 (efs-copy-file-internal
|
|
|
1146 filename parsed tmp1 nil
|
|
|
1147 t nil 2
|
|
|
1148 (efs-cont (result line cont-lines) (filename newname tmp1 tmp2 program
|
|
|
1149 uncompress ok-if-already-exists
|
|
|
1150 cont nowait)
|
|
|
1151 (if result
|
|
|
1152 (signal 'ftp-error
|
|
|
1153 (list "Opening input file"
|
|
|
1154 (format "FTP Error: \"%s\" " line) filename))
|
|
|
1155 (let ((err-buff (let ((default-major-mode 'fundamental-mode))
|
|
|
1156 (get-buffer-create
|
|
|
1157 (generate-new-buffer-name
|
|
|
1158 (format
|
|
|
1159 " efs-call-compress %s" filename))))))
|
|
|
1160 (save-excursion
|
|
|
1161 (set-buffer err-buff)
|
|
|
1162 (set (make-local-variable 'efs-call-compress-filename) filename)
|
|
|
1163 (set (make-local-variable 'efs-call-compress-newname) newname)
|
|
|
1164 (set (make-local-variable 'efs-call-compress-tmp1) tmp1)
|
|
|
1165 (set (make-local-variable 'efs-call-compress-tmp2) tmp2)
|
|
|
1166 (set (make-local-variable 'efs-call-compress-cont) cont)
|
|
|
1167 (set (make-local-variable 'efs-call-compress-nowait) nowait)
|
|
|
1168 (set (make-local-variable 'efs-call-compress-ok)
|
|
|
1169 ok-if-already-exists)
|
|
|
1170 (set (make-local-variable 'efs-call-compress-uncompress)
|
|
|
1171 uncompress)
|
|
|
1172 (set (make-local-variable 'efs-call-compress-abbr)
|
|
|
1173 (efs-relativize-filename filename))
|
|
|
1174 (if efs-verbose
|
|
|
1175 (efs-message
|
|
|
1176 (format "%s %s..."
|
|
|
1177 (if uncompress "Uncompressing" "Compressing")
|
|
|
1178 (symbol-value (make-local-variable
|
|
|
1179 'efs-call-compress-abbr)))))
|
|
|
1180 (set-process-sentinel
|
|
|
1181 (start-process (format "efs-call-compress %s" filename)
|
|
|
1182 err-buff shell-file-name
|
|
|
1183 "-c" (format "%s %s < %s > %s"
|
|
|
1184 program
|
|
|
1185 ;; Hope -c makes the compress
|
|
|
1186 ;; program write to std out.
|
|
|
1187 "-c"
|
|
|
1188 tmp1 tmp2))
|
|
|
1189 (function
|
|
|
1190 (lambda (proc str)
|
|
|
1191 (let ((buff (get-buffer (process-buffer proc))))
|
|
|
1192 (if buff
|
|
|
1193 (save-excursion
|
|
|
1194 (set-buffer buff)
|
|
|
1195 (if (/= (buffer-size) 0)
|
|
|
1196 (if cont
|
|
|
1197 (efs-call-cont
|
|
|
1198 (symbol-value
|
|
|
1199 (make-local-variable
|
|
|
1200 'efs-call-compress-cont))
|
|
|
1201 'failed
|
|
|
1202 (concat
|
|
|
1203 "failed to compress "
|
|
|
1204 (symbol-value (make-local-variable
|
|
|
1205 'efs-call-compress-filename))
|
|
|
1206 ", "
|
|
|
1207 (buffer-substring
|
|
|
1208 (point-min)
|
|
|
1209 (progn (goto-char (point-min))
|
|
|
1210 (end-of-line) (point))))))
|
|
|
1211 (efs-del-tmp-name (symbol-value
|
|
|
1212 (make-local-variable
|
|
|
1213 'efs-call-compress-tmp1)))
|
|
|
1214 (let ((tmp2 (symbol-value
|
|
|
1215 (make-local-variable
|
|
|
1216 'efs-call-compress-tmp2)))
|
|
|
1217 (newname (symbol-value
|
|
|
1218 (make-local-variable
|
|
|
1219 'efs-call-compress-newname)))
|
|
|
1220 (filename (symbol-value
|
|
|
1221 (make-local-variable
|
|
|
1222 'efs-call-compress-filename)))
|
|
|
1223 (cont (symbol-value
|
|
|
1224 (make-local-variable
|
|
|
1225 'efs-call-compress-cont)))
|
|
|
1226 (nowait (symbol-value
|
|
|
1227 (make-local-variable
|
|
|
1228 'efs-call-compress-nowait)))
|
|
|
1229 (ok (symbol-value
|
|
|
1230 (make-local-variable
|
|
|
1231 'efs-call-compress-ok)))
|
|
|
1232 (uncompress
|
|
|
1233 (symbol-value
|
|
|
1234 (make-local-variable
|
|
|
1235 'efs-call-compress-uncompress))))
|
|
|
1236 (if efs-verbose
|
|
|
1237 (efs-message
|
|
|
1238 (format "%s %s...done"
|
|
|
1239 (if uncompress
|
|
|
1240 "Uncompressing"
|
|
|
1241 "Compressing")
|
|
|
1242 (symbol-value
|
|
|
1243 (make-local-variable
|
|
|
1244 'efs-call-compress-abbr)))))
|
|
|
1245 (kill-buffer (current-buffer))
|
|
|
1246 (efs-copy-file-internal
|
|
|
1247 tmp2 nil newname (efs-ftp-path newname)
|
|
|
1248 ok nil 1
|
|
|
1249 (efs-cont (result line cont-lines) (cont
|
|
|
1250 tmp2
|
|
|
1251 filename)
|
|
|
1252 (efs-del-tmp-name tmp2)
|
|
|
1253 (or result
|
|
|
1254 (let (efs-verbose)
|
|
|
1255 (efs-delete-file filename)
|
|
|
1256 (dired-remove-file filename)))
|
|
|
1257 (if cont
|
|
|
1258 (efs-call-cont cont result line
|
|
|
1259 cont-lines)))
|
|
|
1260 nowait (if uncompress nil 'image)))))
|
|
|
1261 (error "Strange error: %s" proc))))))))))
|
|
|
1262 nowait (if uncompress 'image nil))))
|
|
|
1263
|
|
|
1264 (defun efs-update-mode-string (perms modes)
|
|
|
1265 ;; For PERMS of the form `u+w', and MODES a unix 9-character mode string,
|
|
|
1266 ;; computes the new mode string.
|
|
|
1267 ;; Doesn't call efs-save-match-data. The calling function should.
|
|
|
1268 (or (string-match "^[augo]+\\([+-]\\)[rwxst]+$" perms)
|
|
|
1269 (error "efs-update-mode-string: invalid perms %s" perms))
|
|
|
1270 (let* ((who (substring perms 0 (match-beginning 1)))
|
|
|
1271 (add (= (aref perms (match-beginning 1)) ?+))
|
|
|
1272 (what (substring perms (match-end 1)))
|
|
|
1273 (newmodes (copy-sequence modes))
|
|
|
1274 (read (string-match "r" what))
|
|
|
1275 (write (string-match "w" what))
|
|
|
1276 (execute (string-match "x" what))
|
|
|
1277 (sticky (string-match "t" what))
|
|
|
1278 (suid (string-match "s" what)))
|
|
|
1279 (if (string-match "a" who)
|
|
|
1280 (if add
|
|
|
1281 (progn
|
|
|
1282 (if read
|
|
|
1283 (progn
|
|
|
1284 (aset newmodes 0 ?r)
|
|
|
1285 (aset newmodes 3 ?r)
|
|
|
1286 (aset newmodes 6 ?r)))
|
|
|
1287 (if write
|
|
|
1288 (progn
|
|
|
1289 (aset newmodes 1 ?w)
|
|
|
1290 (aset newmodes 4 ?w)
|
|
|
1291 (aset newmodes 7 ?w)))
|
|
|
1292 (if execute
|
|
|
1293 (let ((curr (aref newmodes 2)))
|
|
|
1294 (if (= curr ?-)
|
|
|
1295 (aset newmodes 2 ?x)
|
|
|
1296 (if (= curr ?S)
|
|
|
1297 (aset newmodes 2 ?s)))
|
|
|
1298 (setq curr (aref newmodes 5))
|
|
|
1299 (if (= curr ?-)
|
|
|
1300 (aset newmodes 5 ?x)
|
|
|
1301 (if (= curr ?S)
|
|
|
1302 (aset newmodes 5 ?s)))
|
|
|
1303 (setq curr (aref newmodes 8))
|
|
|
1304 (if (= curr ?-)
|
|
|
1305 (aset newmodes 8 ?x)
|
|
|
1306 (if (= curr ?T)
|
|
|
1307 (aset newmodes 8 ?t)))))
|
|
|
1308 (if suid
|
|
|
1309 (let ((curr (aref newmodes 2)))
|
|
|
1310 (if (= curr ?-)
|
|
|
1311 (aset newmodes 2 ?S)
|
|
|
1312 (if (= curr ?x)
|
|
|
1313 (aset newmodes 2 ?s)))
|
|
|
1314 (setq curr (aref newmodes 5))
|
|
|
1315 (if (= curr ?-)
|
|
|
1316 (aset newmodes 5 ?S)
|
|
|
1317 (if (= curr ?x)
|
|
|
1318 (aset newmodes 5 ?s)))))
|
|
|
1319 (if sticky
|
|
|
1320 (let ((curr (aref newmodes 8)))
|
|
|
1321 (if (= curr ?-)
|
|
|
1322 (aset newmodes 8 ?T)
|
|
|
1323 (if (= curr ?x)
|
|
|
1324 (aset newmodes 8 ?t))))))
|
|
|
1325 (if read
|
|
|
1326 (progn
|
|
|
1327 (aset newmodes 0 ?-)
|
|
|
1328 (aset newmodes 3 ?-)
|
|
|
1329 (aset newmodes 6 ?-)))
|
|
|
1330 (if write
|
|
|
1331 (progn
|
|
|
1332 (aset newmodes 1 ?-)
|
|
|
1333 (aset newmodes 4 ?-)
|
|
|
1334 (aset newmodes 7 ?-)))
|
|
|
1335 (if execute
|
|
|
1336 (let ((curr (aref newmodes 2)))
|
|
|
1337 (if (= curr ?x)
|
|
|
1338 (aset newmodes 2 ?-)
|
|
|
1339 (if (= curr ?s)
|
|
|
1340 (aset newmodes 2 ?S)))
|
|
|
1341 (setq curr (aref newmodes 5))
|
|
|
1342 (if (= curr ?x)
|
|
|
1343 (aset newmodes 5 ?-)
|
|
|
1344 (if (= curr ?s)
|
|
|
1345 (aset newmodes 5 ?S)))
|
|
|
1346 (setq curr (aref newmodes 8))
|
|
|
1347 (if (= curr ?x)
|
|
|
1348 (aset newmodes 8 ?-)
|
|
|
1349 (if (= curr ?t)
|
|
|
1350 (aset newmodes 8 ?T)))))
|
|
|
1351 (if suid
|
|
|
1352 (let ((curr (aref newmodes 2)))
|
|
|
1353 (if (= curr ?s)
|
|
|
1354 (aset newmodes 2 ?x)
|
|
|
1355 (if (= curr ?S)
|
|
|
1356 (aset newmodes 2 ?-)))
|
|
|
1357 (setq curr (aref newmodes 5))
|
|
|
1358 (if (= curr ?s)
|
|
|
1359 (aset newmodes 5 ?x)
|
|
|
1360 (if (= curr ?S)
|
|
|
1361 (aset newmodes 5 ?-)))))
|
|
|
1362 (if sticky
|
|
|
1363 (let ((curr (aref newmodes 8)))
|
|
|
1364 (if (= curr ?t)
|
|
|
1365 (aset newmodes 8 ?x)
|
|
|
1366 (if (= curr ?T)
|
|
|
1367 (aset newmodes 8 ?-))))))
|
|
|
1368 (if (string-match "u" who)
|
|
|
1369 (if add
|
|
|
1370 (progn
|
|
|
1371 (if read
|
|
|
1372 (aset newmodes 0 ?r))
|
|
|
1373 (if write
|
|
|
1374 (aset newmodes 1 ?w))
|
|
|
1375 (if execute
|
|
|
1376 (let ((curr (aref newmodes 2)))
|
|
|
1377 (if (= curr ?-)
|
|
|
1378 (aset newmodes 2 ?x)
|
|
|
1379 (if (= curr ?S)
|
|
|
1380 (aset newmodes 2 ?s)))))
|
|
|
1381 (if suid
|
|
|
1382 (let ((curr (aref newmodes 2)))
|
|
|
1383 (if (= curr ?-)
|
|
|
1384 (aset newmodes 2 ?S)
|
|
|
1385 (if (= curr ?x)
|
|
|
1386 (aset newmodes 2 ?s))))))
|
|
|
1387 (if read
|
|
|
1388 (aset newmodes 0 ?-))
|
|
|
1389 (if write
|
|
|
1390 (aset newmodes 1 ?-))
|
|
|
1391 (if execute
|
|
|
1392 (let ((curr (aref newmodes 2)))
|
|
|
1393 (if (= curr ?x)
|
|
|
1394 (aset newmodes 2 ?-)
|
|
|
1395 (if (= curr ?s)
|
|
|
1396 (aset newmodes 2 ?S)))))
|
|
|
1397 (if suid
|
|
|
1398 (let ((curr (aref newmodes 2)))
|
|
|
1399 (if (= curr ?s)
|
|
|
1400 (aset newmodes 2 ?x)
|
|
|
1401 (if (= curr ?S)
|
|
|
1402 (aset newmodes 2 ?-)))))))
|
|
|
1403 (if (string-match "g" who)
|
|
|
1404 (if add
|
|
|
1405 (progn
|
|
|
1406 (if read
|
|
|
1407 (aset newmodes 3 ?r))
|
|
|
1408 (if write
|
|
|
1409 (aset newmodes 4 ?w))
|
|
|
1410 (if execute
|
|
|
1411 (let ((curr (aref newmodes 5)))
|
|
|
1412 (if (= curr ?-)
|
|
|
1413 (aset newmodes 5 ?x)
|
|
|
1414 (if (= curr ?S)
|
|
|
1415 (aset newmodes 5 ?s)))))
|
|
|
1416 (if suid
|
|
|
1417 (let ((curr (aref newmodes 5)))
|
|
|
1418 (if (= curr ?-)
|
|
|
1419 (aset newmodes 5 ?S)
|
|
|
1420 (if (= curr ?x)
|
|
|
1421 (aset newmodes 5 ?s))))))
|
|
|
1422 (if read
|
|
|
1423 (aset newmodes 3 ?-))
|
|
|
1424 (if write
|
|
|
1425 (aset newmodes 4 ?-))
|
|
|
1426 (if execute
|
|
|
1427 (let ((curr (aref newmodes 5)))
|
|
|
1428 (if (= curr ?x)
|
|
|
1429 (aset newmodes 5 ?-)
|
|
|
1430 (if (= curr ?s)
|
|
|
1431 (aset newmodes 5 ?S)))))
|
|
|
1432 (if suid
|
|
|
1433 (let ((curr (aref newmodes 5)))
|
|
|
1434 (if (= curr ?s)
|
|
|
1435 (aset newmodes 5 ?x)
|
|
|
1436 (if (= curr ?S)
|
|
|
1437 (aset newmodes 5 ?-)))))))
|
|
|
1438 (if (string-match "o" who)
|
|
|
1439 (if add
|
|
|
1440 (progn
|
|
|
1441 (if read
|
|
|
1442 (aset newmodes 6 ?r))
|
|
|
1443 (if write
|
|
|
1444 (aset newmodes 7 ?w))
|
|
|
1445 (if execute
|
|
|
1446 (let ((curr (aref newmodes 8)))
|
|
|
1447 (if (= curr ?-)
|
|
|
1448 (aset newmodes 8 ?x)
|
|
|
1449 (if (= curr ?T)
|
|
|
1450 (aset newmodes 8 ?t)))))
|
|
|
1451 (if sticky
|
|
|
1452 (let ((curr (aref newmodes 8)))
|
|
|
1453 (if (= curr ?-)
|
|
|
1454 (aset newmodes 8 ?T)
|
|
|
1455 (if (= curr ?x)
|
|
|
1456 (aset newmodes 5 ?t))))))
|
|
|
1457 (if read
|
|
|
1458 (aset newmodes 6 ?-))
|
|
|
1459 (if write
|
|
|
1460 (aset newmodes 7 ?-))
|
|
|
1461 (if execute
|
|
|
1462 (let ((curr (aref newmodes 8)))
|
|
|
1463 (if (= curr ?x)
|
|
|
1464 (aset newmodes 8 ?-)
|
|
|
1465 (if (= curr ?t)
|
|
|
1466 (aset newmodes 8 ?T)))))
|
|
|
1467 (if suid
|
|
|
1468 (let ((curr (aref newmodes 8)))
|
|
|
1469 (if (= curr ?t)
|
|
|
1470 (aset newmodes 8 ?x)
|
|
|
1471 (if (= curr ?T)
|
|
|
1472 (aset newmodes 8 ?-))))))))
|
|
|
1473 newmodes))
|
|
|
1474
|
|
|
1475 (defun efs-compute-chmod-arg (perms file)
|
|
|
1476 ;; Computes the octal number, represented as a string, required to
|
|
|
1477 ;; modify the permissions PERMS of FILE.
|
|
|
1478 (efs-save-match-data
|
|
|
1479 (cond
|
|
|
1480 ((string-match "^[0-7][0-7]?[0-7]?[0-7]?$" perms)
|
|
|
1481 perms)
|
|
|
1482 ((string-match "^[augo]+[-+][rwxst]+$" perms)
|
|
|
1483 (let ((curr-mode (nth 3 (efs-get-file-entry file))))
|
|
|
1484 (or (and curr-mode
|
|
|
1485 (stringp curr-mode)
|
|
|
1486 (= (length curr-mode) 10))
|
|
|
1487 (progn
|
|
|
1488 ;; Current buffer is process error buffer
|
|
|
1489 (insert "Require an octal integer to modify modes for "
|
|
|
1490 file ".\n")
|
|
|
1491 (error "Require an octal integer to modify modes for %s." file)))
|
|
|
1492 (format "%o"
|
|
|
1493 (efs-parse-mode-string
|
|
|
1494 (efs-update-mode-string perms
|
|
|
1495 (substring curr-mode 1))))))
|
|
|
1496 (t
|
|
|
1497 (insert "Don't know how to set modes " perms " for " file ".\n")
|
|
|
1498 (error "Don't know how to set modes %s" perms)))))
|
|
|
1499
|
|
|
1500 (defun efs-call-chmod (args)
|
|
|
1501 ;; Sends an FTP CHMOD command.
|
|
|
1502 (if (< (length args) 2)
|
|
|
1503 (error "efs-call-chmod: missing mode and/or filename: %s" args))
|
|
|
1504 (let ((mode (car args))
|
|
|
1505 bombed)
|
|
|
1506 (mapcar
|
|
|
1507 (function
|
|
|
1508 (lambda (file)
|
|
|
1509 (setq file (expand-file-name file))
|
|
|
1510 (let ((parsed (efs-ftp-path file)))
|
|
|
1511 (if parsed
|
|
|
1512 (condition-case nil
|
|
|
1513 (let* ((mode (efs-compute-chmod-arg mode file))
|
|
|
1514 (host (nth 0 parsed))
|
|
|
1515 (user (nth 1 parsed))
|
|
|
1516 (path (efs-quote-string
|
|
|
1517 (efs-host-type host user) (nth 2 parsed)))
|
|
|
1518 (abbr (efs-relativize-filename file))
|
|
|
1519 (result (efs-send-cmd host user
|
|
118
|
1520 (list 'quote 'site 'chmod
|
|
|
1521 mode path)
|
|
|
1522 (format "doing chmod %s"
|
|
|
1523 abbr))))
|
|
|
1524
|
|
98
|
1525 (if (car result)
|
|
118
|
1526 (efs-dired-shell-call-process
|
|
|
1527 (concat "chmod " mode " " (file-name-nondirectory file))
|
|
|
1528 (file-name-directory file)))
|
|
|
1529
|
|
|
1530 (efs-del-from-ls-cache file t))
|
|
98
|
1531 (error (setq bombed t)))))))
|
|
|
1532 (cdr args))
|
|
|
1533 (if bombed 1 0))) ; return code
|
|
|
1534
|
|
|
1535 (defun efs-call-lpr (file command-format)
|
|
|
1536 "Print remote file FILE. SWITCHES are passed to the print program."
|
|
|
1537 ;; Works asynch.
|
|
|
1538 (let* ((file (expand-file-name file))
|
|
|
1539 (parsed (efs-ftp-path file))
|
|
|
1540 (abbr (efs-relativize-filename file))
|
|
|
1541 (temp (car (efs-make-tmp-name nil (car parsed)))))
|
|
|
1542 (efs-copy-file-internal
|
|
|
1543 file parsed temp nil t nil 2
|
|
|
1544 (efs-cont (result line cont-lines) (command-format file abbr temp)
|
|
|
1545 (if result
|
|
|
1546 (signal 'ftp-error (list "Opening input file"
|
|
|
1547 (format "FTP Error: \"%s\" " line)
|
|
|
1548 file))
|
|
|
1549 (message "Spooling %s..." abbr)
|
|
|
1550 (set-process-sentinel
|
|
|
1551 (start-process (format "*print %s /// %s*" abbr temp)
|
|
|
1552 (generate-new-buffer-name " *print temp*")
|
|
|
1553 "sh" "-c" (format command-format temp))
|
|
|
1554 (function
|
|
|
1555 (lambda (proc status)
|
|
|
1556 (let ((buff (process-buffer proc))
|
|
|
1557 (name (process-name proc)))
|
|
|
1558 (if (and buff (get-buffer buff))
|
|
|
1559 (unwind-protect
|
|
|
1560 (save-excursion
|
|
|
1561 (set-buffer buff)
|
|
|
1562 (if (> (buffer-size) 0)
|
|
|
1563 (let ((log-buff (get-buffer-create
|
|
|
1564 "*Shell Command Output*")))
|
|
|
1565 (set-buffer log-buff)
|
|
|
1566 (goto-char (point-max))
|
|
|
1567 (or (bobp)
|
|
|
1568 (insert "\n"))
|
|
|
1569 (insert-buffer-substring buff)
|
|
|
1570 (goto-char (point-max))
|
|
|
1571 (display-buffer log-buff))))
|
|
|
1572 (condition-case nil (kill-buffer buff) (error nil))
|
|
|
1573 (efs-save-match-data
|
|
|
1574 (if (string-match "^\\*print \\(.*\\) /// \\(.*\\)\\*$"
|
|
|
1575 name)
|
|
|
1576 (let ((abbr (substring name (match-beginning 1)
|
|
|
1577 (match-end 1)))
|
|
|
1578 (temp (substring name (match-beginning 2)
|
|
|
1579 (match-end 2))))
|
|
|
1580 (or (= (match-beginning 2) (match-end 2))
|
|
|
1581 (efs-del-tmp-name temp))
|
|
|
1582 (message "Spooling %s...done" abbr))))))))))))
|
|
|
1583 t)))
|
|
|
1584
|
|
|
1585 ;;;; --------------------------------------------------------------
|
|
|
1586 ;;;; Attaching onto dired.
|
|
|
1587 ;;;; --------------------------------------------------------------
|
|
|
1588
|
|
|
1589 ;;; Look out for MULE
|
|
|
1590 (if (or (boundp 'MULE) (featurep 'mule)) (load "efs-dired-mule"))
|
|
|
1591
|
|
|
1592 ;;; Magic file name hooks for dired.
|
|
|
1593
|
|
|
1594 (put 'dired-print-file 'efs 'efs-dired-print-file)
|
|
|
1595 (put 'dired-make-compressed-filename 'efs 'efs-dired-make-compressed-filename)
|
|
|
1596 (put 'dired-compress-file 'efs 'efs-dired-compress-file)
|
|
|
1597 (put 'dired-recursive-delete-directory 'efs
|
|
|
1598 'efs-dired-recursive-delete-directory)
|
|
|
1599 (put 'dired-uncache 'efs 'efs-dired-uncache)
|
|
|
1600 (put 'dired-shell-call-process 'efs 'efs-dired-shell-call-process)
|
|
|
1601 (put 'dired-shell-unhandle-file-name 'efs 'efs-dired-shell-unhandle-file-name)
|
|
|
1602 (put 'dired-file-modtime 'efs 'efs-dired-file-modtime)
|
|
|
1603 (put 'dired-set-file-modtime 'efs 'efs-dired-set-file-modtime)
|
|
|
1604
|
|
|
1605 ;;; Overwriting functions
|
|
|
1606
|
|
|
1607 (efs-overwrite-fn "efs" 'dired-call-process)
|
|
|
1608 (efs-overwrite-fn "efs" 'dired-insert-headerline)
|
|
|
1609 (efs-overwrite-fn "efs" 'dired-manual-move-to-filename)
|
|
|
1610 (efs-overwrite-fn "efs" 'dired-manual-move-to-end-of-filename)
|
|
|
1611 (efs-overwrite-fn "efs" 'dired-make-filename-string)
|
|
|
1612 (efs-overwrite-fn "efs" 'dired-flag-backup-files)
|
|
|
1613 (efs-overwrite-fn "efs" 'dired-create-files)
|
|
|
1614 (efs-overwrite-fn "efs" 'dired-find-file)
|
|
|
1615 (efs-overwrite-fn "efs" 'dired-find-file-other-window)
|
|
|
1616 (efs-overwrite-fn "efs" 'dired-find-file-other-frame)
|
|
|
1617 (efs-overwrite-fn "efs" 'dired-collect-file-versions)
|
|
|
1618 (efs-overwrite-fn "efs" 'dired-file-name-lessp)
|
|
|
1619
|
|
|
1620 ;;; Hooks
|
|
|
1621
|
|
|
1622 (add-hook 'dired-before-readin-hook 'efs-dired-before-readin)
|
|
|
1623
|
|
|
1624 ;;; Handle dired-grep.el too.
|
|
|
1625
|
|
|
1626 (if (featurep 'dired-grep)
|
|
|
1627 (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file
|
|
|
1628 'efs-diff/grep-del-temp-file)
|
|
|
1629 (add-hook 'dired-grep-load-hook
|
|
|
1630 (function
|
|
|
1631 (lambda ()
|
|
|
1632 (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file
|
|
|
1633 'efs-diff/grep-del-temp-file)))))
|
|
|
1634
|
|
|
1635 ;;; end of efs-dired.el
|
