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