cgit.sxemacs.org Git - packages/blob - xemacs-packages/efs/efs-dired.el

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