Mercurial > hg > xemacs-beta
comparison lisp/efs/efs-dired.el @ 22:8fc7fe29b841 r19-15b94
Import from CVS: tag r19-15b94
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:50:29 +0200 |
| parents | |
| children | 4103f0995bd7 |
comparison
equal
deleted
inserted
replaced
| 21:b88636d63495 | 22:8fc7fe29b841 |
|---|---|
| 1 ;; -*-Emacs-Lisp-*- | |
| 2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 3 ;; | |
| 4 ;; File: efs-dired.el | |
| 5 ;; Release: $efs release: 1.15 $ | |
| 6 ;; Version: $Revision: 1.1 $ | |
| 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 "/" | |
| 28 (substring "$Revision: 1.1 $" 11 -2))) | |
| 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 |